From 7c3117139159ce81333e7da69f071b33d9aa7d50 Mon Sep 17 00:00:00 2001 From: mgkim Date: Tue, 30 Dec 2025 14:39:40 +0900 Subject: [PATCH] Tocsg.Lib --- Tocsg.Lib/VCL/CS/Tocsg.ClientBase.pas | 1493 +++ Tocsg.Lib/VCL/CS/Tocsg.Packet.pas | 600 ++ Tocsg.Lib/VCL/CS/Tocsg.PacketDefine.pas | 33 + Tocsg.Lib/VCL/CS/Tocsg.ServerBase.pas | 2872 +++++ Tocsg.Lib/VCL/CS/Tocsg.StoredPacket.pas | 1194 +++ Tocsg.Lib/VCL/EncLib/AES/!bdll.bat | 2 + Tocsg.Lib/VCL/EncLib/AES/#ca.bat | 325 + Tocsg.Lib/VCL/EncLib/AES/#ca_dll.bat | 250 + Tocsg.Lib/VCL/EncLib/AES/#times.aes | 78 + Tocsg.Lib/VCL/EncLib/AES/$d25.zip | Bin 0 -> 34131 bytes Tocsg.Lib/VCL/EncLib/AES/$log_aes.zip | Bin 0 -> 42854 bytes .../EncLib/AES/Source.zip/aes_2017-11-17.zip | Bin 0 -> 246955 bytes Tocsg.Lib/VCL/EncLib/AES/_comparm | 174 + Tocsg.Lib/VCL/EncLib/AES/aes_base.pas | 385 + Tocsg.Lib/VCL/EncLib/AES/aes_cbc.pas | 280 + Tocsg.Lib/VCL/EncLib/AES/aes_ccm.pas | 377 + Tocsg.Lib/VCL/EncLib/AES/aes_cfb.pas | 219 + Tocsg.Lib/VCL/EncLib/AES/aes_cfb8.pas | 177 + Tocsg.Lib/VCL/EncLib/AES/aes_cmac.pas | 117 + Tocsg.Lib/VCL/EncLib/AES/aes_conf.inc | 69 + Tocsg.Lib/VCL/EncLib/AES/aes_cprf.pas | 137 + Tocsg.Lib/VCL/EncLib/AES/aes_ctr.pas | 350 + Tocsg.Lib/VCL/EncLib/AES/aes_decr.pas | 191 + Tocsg.Lib/VCL/EncLib/AES/aes_dll.dpr | 168 + Tocsg.Lib/VCL/EncLib/AES/aes_dll.res | Bin 0 -> 1660 bytes Tocsg.Lib/VCL/EncLib/AES/aes_eax.pas | 362 + Tocsg.Lib/VCL/EncLib/AES/aes_ecb.pas | 250 + Tocsg.Lib/VCL/EncLib/AES/aes_encr.pas | 180 + Tocsg.Lib/VCL/EncLib/AES/aes_gcm.pas | 1017 ++ Tocsg.Lib/VCL/EncLib/AES/aes_intf.pas | 519 + Tocsg.Lib/VCL/EncLib/AES/aes_intv.pas | 534 + Tocsg.Lib/VCL/EncLib/AES/aes_ofb.pas | 170 + Tocsg.Lib/VCL/EncLib/AES/aes_omac.pas | 277 + Tocsg.Lib/VCL/EncLib/AES/aes_seek.inc | 150 + Tocsg.Lib/VCL/EncLib/AES/aes_type.pas | 119 + Tocsg.Lib/VCL/EncLib/AES/aes_xts.pas | 302 + Tocsg.Lib/VCL/EncLib/AES/btypes.pas | 199 + Tocsg.Lib/VCL/EncLib/AES/comp_speed | 25 + Tocsg.Lib/VCL/EncLib/AES/copying_we.txt | 50 + Tocsg.Lib/VCL/EncLib/AES/dec_ca16.inc | 397 + Tocsg.Lib/VCL/EncLib/AES/dec_cdat.inc | 197 + Tocsg.Lib/VCL/EncLib/AES/dec_cp16.inc | 94 + Tocsg.Lib/VCL/EncLib/AES/dec_cp32.inc | 83 + Tocsg.Lib/VCL/EncLib/AES/dec_fa16.inc | 358 + Tocsg.Lib/VCL/EncLib/AES/dec_fdat.inc | 224 + Tocsg.Lib/VCL/EncLib/AES/dec_fp16.inc | 92 + Tocsg.Lib/VCL/EncLib/AES/dec_fp32.inc | 106 + Tocsg.Lib/VCL/EncLib/AES/enc_ca16.inc | 350 + Tocsg.Lib/VCL/EncLib/AES/enc_cdat.inc | 196 + Tocsg.Lib/VCL/EncLib/AES/enc_cp16.inc | 73 + Tocsg.Lib/VCL/EncLib/AES/enc_cp32.inc | 62 + Tocsg.Lib/VCL/EncLib/AES/enc_fa16.inc | 318 + Tocsg.Lib/VCL/EncLib/AES/enc_fdat.inc | 207 + Tocsg.Lib/VCL/EncLib/AES/enc_fp16.inc | 72 + Tocsg.Lib/VCL/EncLib/AES/enc_fp32.inc | 88 + Tocsg.Lib/VCL/EncLib/AES/legal.txt | 34 + Tocsg.Lib/VCL/EncLib/AES/manifest.aes | 71 + Tocsg.Lib/VCL/EncLib/AES/mem_util.pas | 383 + Tocsg.Lib/VCL/EncLib/AES/options.zip | Bin 0 -> 4941 bytes Tocsg.Lib/VCL/EncLib/AES/ppp.pas | 338 + Tocsg.Lib/VCL/EncLib/AES/readme.aes | 108 + Tocsg.Lib/VCL/EncLib/AES/samples.zip | Bin 0 -> 3968 bytes Tocsg.Lib/VCL/EncLib/AES/std.inc | 631 ++ Tocsg.Lib/VCL/EncLib/AES/t_aes_as.pas | 190 + Tocsg.Lib/VCL/EncLib/AES/t_aes_cs.pas | 377 + Tocsg.Lib/VCL/EncLib/AES/t_aes_ws.pas | 549 + Tocsg.Lib/VCL/EncLib/AES/t_aes_xl.pas | 306 + Tocsg.Lib/VCL/EncLib/AES/t_aescbc.pas | 218 + Tocsg.Lib/VCL/EncLib/AES/t_aesccm.pas | 308 + Tocsg.Lib/VCL/EncLib/AES/t_aescf8.pas | 198 + Tocsg.Lib/VCL/EncLib/AES/t_aescfb.pas | 217 + Tocsg.Lib/VCL/EncLib/AES/t_aescrp.pas | 100 + Tocsg.Lib/VCL/EncLib/AES/t_aesctr.pas | 224 + Tocsg.Lib/VCL/EncLib/AES/t_aesecb.pas | 212 + Tocsg.Lib/VCL/EncLib/AES/t_aesgcm.pas | 957 ++ Tocsg.Lib/VCL/EncLib/AES/t_aesofb.pas | 220 + Tocsg.Lib/VCL/EncLib/AES/t_aestab.pas | 226 + Tocsg.Lib/VCL/EncLib/AES/t_cbccts.pas | 198 + Tocsg.Lib/VCL/EncLib/AES/t_cmac.pas | 138 + Tocsg.Lib/VCL/EncLib/AES/t_cprf.pas | 19 + Tocsg.Lib/VCL/EncLib/AES/t_eax2.pas | 142 + Tocsg.Lib/VCL/EncLib/AES/t_ecbcts.pas | 62 + Tocsg.Lib/VCL/EncLib/AES/t_fbmodi.pas | 153 + Tocsg.Lib/VCL/EncLib/AES/t_gsp128.pas | 218 + Tocsg.Lib/VCL/EncLib/AES/t_gspeed.pas | 215 + Tocsg.Lib/VCL/EncLib/AES/t_mcst.pas | 271 + Tocsg.Lib/VCL/EncLib/AES/t_mctful.pas | 374 + Tocsg.Lib/VCL/EncLib/AES/t_mkctab.pas | 187 + Tocsg.Lib/VCL/EncLib/AES/t_omac.pas | 155 + Tocsg.Lib/VCL/EncLib/AES/t_ppp.pas | 235 + Tocsg.Lib/VCL/EncLib/AES/t_xts.pas | 521 + Tocsg.Lib/VCL/EncLib/EM.CRC32.pas | 133 + Tocsg.Lib/VCL/EncLib/EM.MD5.pas | 393 + Tocsg.Lib/VCL/EncLib/EM.RC4.pas | 139 + Tocsg.Lib/VCL/EncLib/EM.SHA1.pas | 184 + Tocsg.Lib/VCL/EncLib/EM.Tocsg.hash.pas | 413 + Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha1.pas | 905 ++ Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha256.pas | 1051 ++ Tocsg.Lib/VCL/EncLib/EM.Tools.pas | 74 + Tocsg.Lib/VCL/EncLib/EM.WtsApi32.pas | 802 ++ Tocsg.Lib/VCL/EncLib/EM.base64.pas | 212 + Tocsg.Lib/VCL/EncLib/EM.sha256.pas | 1209 +++ Tocsg.Lib/VCL/EncLib/_EM.Tocsg.Sha1.pas | 1060 ++ Tocsg.Lib/VCL/EncLib/_EM.Tocsg.sha256.pas | 1209 +++ Tocsg.Lib/VCL/EncLib/std.inc | 631 ++ Tocsg.Lib/VCL/Other/EM.DelphiZXIngQRCode.pas | 3573 +++++++ Tocsg.Lib/VCL/Other/EM.Dnsapi.pas | 526 + Tocsg.Lib/VCL/Other/EM.DomParser.pas | 912 ++ Tocsg.Lib/VCL/Other/EM.GDIPAPI.pas | 7055 +++++++++++++ Tocsg.Lib/VCL/Other/EM.GSStorage.pas | 1045 ++ Tocsg.Lib/VCL/Other/EM.JwaBthSdpDef.pas | 192 + Tocsg.Lib/VCL/Other/EM.PdfiumCore.pas | 4121 ++++++++ Tocsg.Lib/VCL/Other/EM.PdfiumCtrl.pas | 2866 +++++ Tocsg.Lib/VCL/Other/EM.PdfiumLib.pas | 9310 +++++++++++++++++ Tocsg.Lib/VCL/Other/EM.WbemScripting_TLB.pas | 4630 ++++++++ Tocsg.Lib/VCL/Other/EM.WinOSVersion.pas | 795 ++ Tocsg.Lib/VCL/Other/EM.jwabluetoothapis.pas | 2017 ++++ Tocsg.Lib/VCL/Other/EM.jwawinnt.pas | 9307 ++++++++++++++++ Tocsg.Lib/VCL/Other/EM.jwawintype.pas | 1816 ++++ Tocsg.Lib/VCL/Other/EM.nduCType.pas | 83 + Tocsg.Lib/VCL/Other/EM.nduEapTypes.pas | 79 + Tocsg.Lib/VCL/Other/EM.nduL2cmn.pas | 75 + Tocsg.Lib/VCL/Other/EM.nduNtDDNdis.pas | 18 + Tocsg.Lib/VCL/Other/EM.nduWinDot11.pas | 54 + Tocsg.Lib/VCL/Other/EM.nduWinNT.pas | 29 + Tocsg.Lib/VCL/Other/EM.nduWlanAPI.pas | 952 ++ Tocsg.Lib/VCL/Other/EM.nduWlanTypes.pas | 87 + Tocsg.Lib/VCL/Other/EM.winioctl.pas | 866 ++ Tocsg.Lib/VCL/Other/KDL.Detours.pas | 125 + Tocsg.Lib/VCL/Other/KDL.Localizer.pas | 696 ++ Tocsg.Lib/VCL/Other/KDL.StringUtils.pas | 434 + Tocsg.Lib/VCL/Other/VirtualTrees.Filter.pas | 1316 +++ Tocsg.Lib/VCL/Other/WindowAnimator.pas | 209 + Tocsg.Lib/VCL/SQLite3/EM.Old.SQLite3.pas | 653 ++ Tocsg.Lib/VCL/SQLite3/EM.SQLite3.pas | 899 ++ Tocsg.Lib/VCL/SQLite3/EM.SQLite3Utils.pas | 95 + Tocsg.Lib/VCL/SQLite3/EM.SQLite3Wrap.pas | 480 + Tocsg.Lib/VCL/SQLite3/EM.SQLite3udf.pas | 131 + Tocsg.Lib/VCL/SQLite3/EM.SQLiteTable3.pas | 1326 +++ Tocsg.Lib/VCL/SuperObject/superobject.pas | 7808 ++++++++++++++ Tocsg.Lib/VCL/Tocsg.AIP.pas | 349 + Tocsg.Lib/VCL/Tocsg.AppInfo.pas | 357 + Tocsg.Lib/VCL/Tocsg.Binary.pas | 73 + Tocsg.Lib/VCL/Tocsg.Bluetooth.pas | 667 ++ Tocsg.Lib/VCL/Tocsg.Capture.pas | 454 + Tocsg.Lib/VCL/Tocsg.Cert.pas | 163 + Tocsg.Lib/VCL/Tocsg.Clipboard.pas | 635 ++ Tocsg.Lib/VCL/Tocsg.CommonData.pas | 132 + Tocsg.Lib/VCL/Tocsg.Controls.pas | 217 + Tocsg.Lib/VCL/Tocsg.Convert.pas | 137 + Tocsg.Lib/VCL/Tocsg.DateTime.pas | 657 ++ Tocsg.Lib/VCL/Tocsg.Delete.pas | 266 + Tocsg.Lib/VCL/Tocsg.Disk.pas | 523 + Tocsg.Lib/VCL/Tocsg.DllEntry.pas | 81 + Tocsg.Lib/VCL/Tocsg.Driver.pas | 2151 ++++ Tocsg.Lib/VCL/Tocsg.Encrypt.pas | 825 ++ Tocsg.Lib/VCL/Tocsg.Exception.pas | 74 + Tocsg.Lib/VCL/Tocsg.Export.pas | 665 ++ Tocsg.Lib/VCL/Tocsg.FileInfo.pas | 394 + Tocsg.Lib/VCL/Tocsg.Files.pas | 1665 +++ Tocsg.Lib/VCL/Tocsg.Graphic.pas | 814 ++ Tocsg.Lib/VCL/Tocsg.Hash.pas | 611 ++ Tocsg.Lib/VCL/Tocsg.Hex.pas | 270 + Tocsg.Lib/VCL/Tocsg.Html.pas | 503 + Tocsg.Lib/VCL/Tocsg.Json.pas | 112 + Tocsg.Lib/VCL/Tocsg.Kernel32.pas | 137 + Tocsg.Lib/VCL/Tocsg.Keyboard.pas | 732 ++ Tocsg.Lib/VCL/Tocsg.MSAA.pas | 681 ++ Tocsg.Lib/VCL/Tocsg.MTP.pas | 188 + Tocsg.Lib/VCL/Tocsg.NTDLL.Decompress.pas | 153 + Tocsg.Lib/VCL/Tocsg.Network.pas | 2656 +++++ Tocsg.Lib/VCL/Tocsg.Notification.pas | 52 + Tocsg.Lib/VCL/Tocsg.OLE.Stg.pas | 202 + Tocsg.Lib/VCL/Tocsg.Obj.pas | 58 + Tocsg.Lib/VCL/Tocsg.PCRE.pas | 201 + Tocsg.Lib/VCL/Tocsg.Param.pas | 78 + Tocsg.Lib/VCL/Tocsg.Path.pas | 163 + Tocsg.Lib/VCL/Tocsg.Prefetch.pas | 365 + Tocsg.Lib/VCL/Tocsg.Printer.pas | 1773 ++++ Tocsg.Lib/VCL/Tocsg.Process.IPC.pas | 1119 ++ Tocsg.Lib/VCL/Tocsg.Process.pas | 1955 ++++ Tocsg.Lib/VCL/Tocsg.Registry.pas | 610 ++ Tocsg.Lib/VCL/Tocsg.Safe.pas | 94 + Tocsg.Lib/VCL/Tocsg.Serializer.pas | 498 + Tocsg.Lib/VCL/Tocsg.Service.pas | 402 + Tocsg.Lib/VCL/Tocsg.Shell.pas | 416 + Tocsg.Lib/VCL/Tocsg.Strings.pas | 662 ++ Tocsg.Lib/VCL/Tocsg.Thread.pas | 738 ++ Tocsg.Lib/VCL/Tocsg.Trace.pas | 493 + Tocsg.Lib/VCL/Tocsg.USB.pas | 1003 ++ Tocsg.Lib/VCL/Tocsg.Url.pas | 309 + Tocsg.Lib/VCL/Tocsg.User32.pas | 70 + Tocsg.Lib/VCL/Tocsg.VTUtil.pas | 766 ++ Tocsg.Lib/VCL/Tocsg.Valid.pas | 131 + Tocsg.Lib/VCL/Tocsg.WMI.pas | 671 ++ Tocsg.Lib/VCL/Tocsg.WTS.pas | 528 + Tocsg.Lib/VCL/Tocsg.WebBrowser.pas | 182 + Tocsg.Lib/VCL/Tocsg.Win32.pas | 99 + Tocsg.Lib/VCL/Tocsg.WinInfo.pas | 259 + Tocsg.Lib/VCL/Tocsg.WndUtil.pas | 440 + 200 files changed, 129991 insertions(+) create mode 100644 Tocsg.Lib/VCL/CS/Tocsg.ClientBase.pas create mode 100644 Tocsg.Lib/VCL/CS/Tocsg.Packet.pas create mode 100644 Tocsg.Lib/VCL/CS/Tocsg.PacketDefine.pas create mode 100644 Tocsg.Lib/VCL/CS/Tocsg.ServerBase.pas create mode 100644 Tocsg.Lib/VCL/CS/Tocsg.StoredPacket.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/!bdll.bat create mode 100644 Tocsg.Lib/VCL/EncLib/AES/#ca.bat create mode 100644 Tocsg.Lib/VCL/EncLib/AES/#ca_dll.bat create mode 100644 Tocsg.Lib/VCL/EncLib/AES/#times.aes create mode 100644 Tocsg.Lib/VCL/EncLib/AES/$d25.zip create mode 100644 Tocsg.Lib/VCL/EncLib/AES/$log_aes.zip create mode 100644 Tocsg.Lib/VCL/EncLib/AES/Source.zip/aes_2017-11-17.zip create mode 100644 Tocsg.Lib/VCL/EncLib/AES/_comparm create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_base.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_cbc.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_ccm.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_cfb.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_cfb8.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_cmac.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_conf.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_cprf.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_ctr.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_decr.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_dll.dpr create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_dll.res create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_eax.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_ecb.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_encr.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_gcm.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_intf.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_intv.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_ofb.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_omac.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_seek.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_type.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/aes_xts.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/btypes.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/comp_speed create mode 100644 Tocsg.Lib/VCL/EncLib/AES/copying_we.txt create mode 100644 Tocsg.Lib/VCL/EncLib/AES/dec_ca16.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/dec_cdat.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/dec_cp16.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/dec_cp32.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/dec_fa16.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/dec_fdat.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/dec_fp16.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/dec_fp32.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/enc_ca16.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/enc_cdat.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/enc_cp16.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/enc_cp32.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/enc_fa16.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/enc_fdat.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/enc_fp16.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/enc_fp32.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/legal.txt create mode 100644 Tocsg.Lib/VCL/EncLib/AES/manifest.aes create mode 100644 Tocsg.Lib/VCL/EncLib/AES/mem_util.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/options.zip create mode 100644 Tocsg.Lib/VCL/EncLib/AES/ppp.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/readme.aes create mode 100644 Tocsg.Lib/VCL/EncLib/AES/samples.zip create mode 100644 Tocsg.Lib/VCL/EncLib/AES/std.inc create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aes_as.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aes_cs.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aes_ws.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aes_xl.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aescbc.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aesccm.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aescf8.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aescfb.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aescrp.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aesctr.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aesecb.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aesgcm.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aesofb.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_aestab.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_cbccts.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_cmac.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_cprf.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_eax2.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_ecbcts.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_fbmodi.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_gsp128.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_gspeed.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_mcst.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_mctful.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_mkctab.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_omac.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_ppp.pas create mode 100644 Tocsg.Lib/VCL/EncLib/AES/t_xts.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.CRC32.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.MD5.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.RC4.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.SHA1.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.Tocsg.hash.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha1.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha256.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.Tools.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.WtsApi32.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.base64.pas create mode 100644 Tocsg.Lib/VCL/EncLib/EM.sha256.pas create mode 100644 Tocsg.Lib/VCL/EncLib/_EM.Tocsg.Sha1.pas create mode 100644 Tocsg.Lib/VCL/EncLib/_EM.Tocsg.sha256.pas create mode 100644 Tocsg.Lib/VCL/EncLib/std.inc create mode 100644 Tocsg.Lib/VCL/Other/EM.DelphiZXIngQRCode.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.Dnsapi.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.DomParser.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.GDIPAPI.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.GSStorage.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.JwaBthSdpDef.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.PdfiumCore.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.PdfiumCtrl.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.PdfiumLib.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.WbemScripting_TLB.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.WinOSVersion.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.jwabluetoothapis.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.jwawinnt.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.jwawintype.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.nduCType.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.nduEapTypes.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.nduL2cmn.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.nduNtDDNdis.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.nduWinDot11.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.nduWinNT.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.nduWlanAPI.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.nduWlanTypes.pas create mode 100644 Tocsg.Lib/VCL/Other/EM.winioctl.pas create mode 100644 Tocsg.Lib/VCL/Other/KDL.Detours.pas create mode 100644 Tocsg.Lib/VCL/Other/KDL.Localizer.pas create mode 100644 Tocsg.Lib/VCL/Other/KDL.StringUtils.pas create mode 100644 Tocsg.Lib/VCL/Other/VirtualTrees.Filter.pas create mode 100644 Tocsg.Lib/VCL/Other/WindowAnimator.pas create mode 100644 Tocsg.Lib/VCL/SQLite3/EM.Old.SQLite3.pas create mode 100644 Tocsg.Lib/VCL/SQLite3/EM.SQLite3.pas create mode 100644 Tocsg.Lib/VCL/SQLite3/EM.SQLite3Utils.pas create mode 100644 Tocsg.Lib/VCL/SQLite3/EM.SQLite3Wrap.pas create mode 100644 Tocsg.Lib/VCL/SQLite3/EM.SQLite3udf.pas create mode 100644 Tocsg.Lib/VCL/SQLite3/EM.SQLiteTable3.pas create mode 100644 Tocsg.Lib/VCL/SuperObject/superobject.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.AIP.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.AppInfo.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Binary.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Bluetooth.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Capture.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Cert.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Clipboard.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.CommonData.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Controls.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Convert.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.DateTime.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Delete.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Disk.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.DllEntry.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Driver.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Encrypt.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Exception.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Export.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.FileInfo.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Files.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Graphic.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Hash.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Hex.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Html.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Json.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Kernel32.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Keyboard.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.MSAA.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.MTP.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.NTDLL.Decompress.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Network.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Notification.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.OLE.Stg.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Obj.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.PCRE.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Param.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Path.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Prefetch.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Printer.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Process.IPC.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Process.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Registry.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Safe.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Serializer.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Service.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Shell.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Strings.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Thread.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Trace.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.USB.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Url.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.User32.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.VTUtil.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Valid.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.WMI.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.WTS.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.WebBrowser.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.Win32.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.WinInfo.pas create mode 100644 Tocsg.Lib/VCL/Tocsg.WndUtil.pas diff --git a/Tocsg.Lib/VCL/CS/Tocsg.ClientBase.pas b/Tocsg.Lib/VCL/CS/Tocsg.ClientBase.pas new file mode 100644 index 00000000..d1fc197f --- /dev/null +++ b/Tocsg.Lib/VCL/CS/Tocsg.ClientBase.pas @@ -0,0 +1,1493 @@ +{*******************************************************} +{ } +{ Tocsg.ClientBase } +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.ClientBase; + +interface + +uses + Tocsg.Obj, System.SysUtils, System.Classes, Winapi.Windows, Winapi.Winsock2, + System.Win.ScktComp, Tocsg.Packet, Tocsg.Thread, IdTCPClient, + System.SyncObjs, Tocsg.Encrypt, System.Generics.Collections, + Tocsg.Process.IPC, Tocsg.Exception; + +const + PACKET_VERSION = 1; + +type + PClientRcvPacket = ^TClientRcvPacket; + TClientRcvPacket = record + wRank: WORD; + llId: LONGLONG; + pBuf: Pointer; + nProcPktLen, + nRemainPktLen: Integer; + end; + + ETgClient = ETgException; + TTgClientBase = class(TTgThread) + private + CS_: TCriticalSection; + sHost_: String; + nPort_: Integer; + dwPingTick_, + dwDisconnTick_: DWORD; + nPingTerm_, + nReConnTerm_: Integer; + + // 겹친 패킷 발견 시 나머지 받아놓고 나중에 재활용하는 버퍼 + _RcylBuf: TBytes; + _nRcylBufLen, + _nRcylBufPos: Integer; + + _pRcvPkt: PClientRcvPacket; + _pInitBuf: TBytes; + _DcRcvBufs: TDictionary; + + // 패킷 암호화 정보 + PktEncKind_: TTgEncKind; + PktEncPass_: String; + Enc_: TTgEncrypt; + + // 패킷 전송 정지 + bSendPause_: Boolean; + + procedure OnRcvBufNotify(Sender: TObject; const Item: PClientRcvPacket; Action: TCollectionNotification); + + procedure _ConnectedEvent(Sender: TObject); + procedure _DisconnectedEvent(Sender: TObject); + + function GetPktEncKind: TTgEncKind; + procedure SetConnected(const bVal: Boolean); + function DequeueSendPacket: ISendPacket; + protected + Client_: TIdTCPClient; + dtConn_: TDateTime; + bConnected_, + bTryReconnect_: Boolean; + nSvrPktVer_: Integer; + QSendPacket_: TQueue; + + // 프로세스 통신 + W2W_: TTgWnd2Wnd; + hIpcWnd_: HWND; + NpIpc_: TTgNpBase; // NamedPipe 통신 + + function GetConnected: Boolean; virtual; + function _ProcessRcv: Boolean; + function _ProcessSend(Send: ISendPacket): Boolean; virtual; + function _ProcessOther: Boolean; virtual; + procedure _ProcessSendFail(Send: ISendPacket); virtual; + + procedure Execute; override; + procedure SetHost(const sHost: String); + procedure SetPort(const nPort: Integer); + function GetTryReconnect: Boolean; + procedure SetTryReconnect(const bVal: Boolean); + procedure SetPacketEncryptInfo(aPktEncKind: TTgEncKind; const sPktEncPass: String); + + procedure ConnectedEvent; virtual; + procedure DisconnectedEvent; virtual; + procedure ProcessRcvPacket(aRcv: IRcvPacket); virtual; + + function GetSendPauseState: Boolean; + procedure SetSendPauseState(bVal: Boolean); + procedure OnW2WConnection(Sender: TTgObject; aState: TW2wConnState; hRcvWnd: HWND); + procedure OnNpConnected(Sender: TTgNpBase; hPipe: THandle); + procedure OnNpDisconnected(Sender: TTgNpBase; hPipe: THandle); + public + Constructor Create(const sHost: String; nPort: Integer; + nReConnTerm: Integer = 5000; nPingTerm: Integer = 60000); + Destructor Destroy; override; + + procedure Lock; + procedure Unlock; + + procedure SendPacket(Send: ISendPacket); virtual; + procedure DirectSendPacket(Send: ISendPacket); + + function Connect(const sHost: String; nPort: Integer): Boolean; overload; + function Connect: Boolean; overload; + + function GetSelfWnd: HWND; + function ActiveW2W(sClassName: String = ''; hInst: HMODULE = 0): Boolean; + procedure DeactiveW2W; + function ConnectWnd(hConnWnd: HWND): Boolean; + function ActiveNp(sPipeName: String; bNpServer: Boolean): Boolean; virtual; + function ConnectNp: Boolean; + procedure DeactiveNp; + + procedure Disconnect; + + property Host: String read sHost_ write SetHost; + property Port: Integer read nPort_ write SetPort; + property Connected: Boolean read GetConnected write SetConnected; + property TryReconnect: Boolean read bTryReconnect_ write SetTryReconnect; + property ConnDT: TDateTime read dtConn_; + end; + +implementation + +uses + IdStack, IdGlobal, IdException, IdExceptionCore, Tocsg.PacketDefine, + Tocsg.WinInfo, Tocsg.DateTime, Tocsg.Network, Tocsg.WTS, Tocsg.Process, Define; + +function PosBin(const pFind, pDestBuf: TBytes; nBeginOffset: Integer = 0): Integer; +var + i, j, lp, ld: integer; +begin + lp := Length(pFind); + ld := Length(pDestBuf); + Result := -1; + if (lp > ld) or (nBeginOffset >= ld) then + Exit; + + for i := nBeginOffset to ld-lp-1 do + begin + for j := 0 to lp -1 do + begin + if pFind[j] <> pDestBuf[i + j] then + Break; + + if j = lp-1 then + Result := i; + end; + + if Result <> -1 then + Break; + end; +end; + +{ TTgClientBase } + +Constructor TTgClientBase.Create(const sHost: String; nPort: Integer; + nReConnTerm: Integer = 5000; nPingTerm: Integer = 60000); +begin + CS_ := TCriticalSection.Create; + Inherited Create; + + PktEncKind_ := ekNone; + nSvrPktVer_ := 0; + bSendPause_ := true; + nReConnTerm_ := nReConnTerm; + if nReConnTerm_ < 1000 then + nReConnTerm_ := 1000; + nPingTerm_ := nPingTerm; +// if nPingTerm_ < 60000 then +// nPingTerm_ := 60000; + + Enc_ := nil; + W2W_ := nil; + hIpcWnd_ := 0; + NpIpc_ := nil; + + _DcRcvBufs := TDictionary.Create; + _DcRcvBufs.OnValueNotify := OnRcvBufNotify; + _pRcvPkt := nil; + + SetLength(_pInitBuf, 0); + + sHost_ := sHost; + nPort_ := nPort; + + dwPingTick_ := 0; + dwDisconnTick_ := 0; + dtConn_ := 0; + bConnected_ := false; + bTryReconnect_ := false; + + QSendPacket_ := TQueue.Create; + + if nPort <> -1 then + begin + Client_ := TIdTCPClient.Create(nil); + Client_.OnConnected := _ConnectedEvent; + Client_.OnDisconnected := _DisconnectedEvent; + Client_.ConnectTimeout := 10000; + Client_.ReadTimeout := 20000; + end else + Client_ := nil; + + StartThread; +end; + +Destructor TTgClientBase.Destroy; +begin + Inherited; + DeactiveW2W; + DeactiveNp; + if Client_ <> nil then + FreeAndNil(Client_); + FreeAndNil(QSendPacket_); + FreeAndNil(_DcRcvBufs); + if Assigned(Enc_) then + FreeAndNil(Enc_); + FreeAndNil(CS_); +end; + +procedure TTgClientBase.OnRcvBufNotify(Sender: TObject; const Item: PClientRcvPacket; Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: + begin + if Item.pBuf <> nil then + FreeMem(Item.pBuf); + Dispose(Item); + end; + cnExtracted: ; + end; +end; + +procedure TTgClientBase.Lock; +begin + CS_.Acquire; +end; + +procedure TTgClientBase.Unlock; +begin + CS_.Release; +end; + +function TTgClientBase.GetSendPauseState: Boolean; +begin + Lock; + try + Result := bSendPause_; + finally + Unlock; + end; +end; + +procedure TTgClientBase.SetSendPauseState(bVal: Boolean); +begin + Lock; + try + bSendPause_ := bVal; + finally + Unlock; + end; +end; + +procedure TTgClientBase.OnW2WConnection(Sender: TTgObject; aState: TW2wConnState; hRcvWnd: HWND); +begin + if W2W_ <> nil then + begin + try + case aState of + wcsConnect : + begin + if (hIpcWnd_ <> 0) and (hIpcWnd_ <> hRcvWnd) then + Disconnect; + + hIpcWnd_ := hRcvWnd; +// _Trace('W2W - OnW2WConnection(), hIpcWnd_=%d, PID=%d', [hIpcWnd_, GetProcessPIDFromWndHandle(hIpcWnd_)]); + if hIpcWnd_ <> 0 then + _ConnectedEvent(nil); + end; + wcsDisconnect : + begin + _DisconnectedEvent(nil); + hIpcWnd_ := 0; + W2W_.ClearQueue; + end; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. OnW2WConnection()'); + end; + end; +end; + +procedure TTgClientBase.OnNpConnected(Sender: TTgNpBase; hPipe: THandle); +begin + _ConnectedEvent(nil); +end; + +procedure TTgClientBase.OnNpDisconnected(Sender: TTgNpBase; hPipe: THandle); +begin + _DisconnectedEvent(nil); +end; + +procedure TTgClientBase._ConnectedEvent(Sender: TObject); +begin + SetPacketEncryptInfo(ekNone, ''); + dwPingTick_ := GetTickCount; + _Trace('ConnectedEvent()', 3); + + if Client_ <> nil then + SetHost(Client_.Host); + + if Client_ <> nil then + SetPort(Client_.Port); + SetConnected(true); + + ConnectedEvent; +end; + +procedure TTgClientBase._DisconnectedEvent(Sender: TObject); +begin + dwDisconnTick_ := GetTickCount; + _Trace('DisconnectedEvent()', 3); + SetConnected(false); + DisconnectedEvent; + SetPacketEncryptInfo(ekNone, ''); +end; + +function TTgClientBase.GetPktEncKind: TTgEncKind; +begin + Lock; + try + Result := PktEncKind_; + finally + Unlock; + end; +end; + +function TTgClientBase.GetConnected: Boolean; +begin + Lock; + try + Result := bConnected_; + finally + Unlock; + end; +end; + +procedure TTgClientBase.SetConnected(const bVal: Boolean); +begin + Lock; + try + if bConnected_ <> bVal then + begin + bConnected_ := bVal; + if bVal then + dtConn_ := Now + else + dtConn_ := 0; + end; + finally + Unlock; + end; +end; + +procedure TTgClientBase.SetHost(const sHost: String); +begin + if not GetConnected then + begin + if sHost_ <> sHost then + begin + sHost_ := sHost; + end; + end else + raise ETgClient.Create('접속중일 때에는 IP를 변경 할 수 없습니다.'); +end; + +procedure TTgClientBase.SetPort(const nPort: Integer); +begin + if not GetConnected then + begin + if nPort_ <> nPort then + begin + nPort_ := nPort; + end; + end else + raise ETgClient.Create('접속중일 때에는 Port를 변경 할 수 없습니다.'); +end; + +function TTgClientBase.GetTryReconnect: Boolean; +begin + Lock; + try + Result := bTryReconnect_; + finally + Unlock; + end; +end; + +procedure TTgClientBase.SetTryReconnect(const bVal: Boolean); +begin + Lock; + try + if bTryReconnect_ <> bVal then + bTryReconnect_ := bVal; + finally + Unlock; + end; +end; + +procedure TTgClientBase.SetPacketEncryptInfo(aPktEncKind: TTgEncKind; const sPktEncPass: String); +begin + Lock; + try + PktEncKind_ := aPktEncKind; + PktEncPass_ := sPktEncPass; + + if Assigned(Enc_) then + FreeAndNil(Enc_); + + if PktEncKind_ <> ekNone then + Enc_ := TTgEncrypt.Create(sPktEncPass, PktEncKind_); + finally + Unlock; + end; +end; + +procedure TTgClientBase.ConnectedEvent; +var + Send: ISendPacket; +begin + Send := TTgPacket.Create(TOC_CLIENT_INFO); + + with Send do + begin + I['Type'] := CLIENT_TYPE; + S['Ver'] := CLIENT_VER; + S['ComName'] := GetComName; + S['Account'] := WTS_GetCurrentUserName; + S['WinVer'] := GetWinVer; + D['BootDT'] := GetBootTime; + S['rIP'] := GetHostIP; + S['IpAddrs'] := GetIPAddrsToCommaStrEx; + S['MacAddr'] := GetMACAddrUsing; + S['MacAddrs'] := GetMACAddrToCommaStr; + D['CltDT'] := Now; + end; + + Sleep(500); + DirectSendPacket(Send); + _Trace('Send Client Info.', 3); +end; + +procedure TTgClientBase.DisconnectedEvent; +begin + SetSendPauseState(true); +end; + +procedure TTgClientBase.ProcessRcvPacket(aRcv: IRcvPacket); + + procedure process_QTC_CONFIRM_PACKET_ENCRYPT; + var + PktEncKind: TTgEncKind; + Send: ISendPacket; + begin + PktEncKind := TTgEncKind(aRcv.I['K']); + nSvrPktVer_ := aRcv.I['SPV']; + case PktEncKind of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : ; // 지원 + else + begin + PktEncKind := ekNone; + end; + end; + + Send := TTgPacket.Create(aRcv, pkCritical); + Send.I['K'] := LONGLONG(PktEncKind); + Send.I['CPV'] := PACKET_VERSION; + DirectSendPacket(Send); + end; + + procedure process_QTC_UPDATE_PACKET_ENCRYPT; + var + PktEncKind: TTgEncKind; + sPass: String; + bResult: Boolean; + nLen: Integer; + Send: ISendPacket; + begin +// _Trace('process_QTC_UPDATE_PACKET_ENCRYPT'); + bResult := false; + PktEncKind := TTgEncKind(aRcv.I['K']); + sPass := aRcv.S['J']; + try + case PktEncKind of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin + sPass := DecBinStrToStr(PktEncKind, ENC_PASSPASS, sPass); + nLen := Length(sPass); + if nLen > 7 then + sPass := Copy(sPass, 4, nLen - 7) + else exit; + end + else sPass := ''; + end; + bResult := true; + finally + if (sPass <> '') and bResult then + begin + // 성공했다면 서버에 통보 14_0703 16:23:49 sunk + Send := TTgPacket.Create(TOC_UPDATE_PACKET_ENCRYPT, pkCritical); // 중요 패킷 구분 14_0704 16:52:06 sunk + DirectSendPacket(Send); + SetPacketEncryptInfo(PktEncKind, sPass); + end; + + // 암호화 정보 송수신 완료전까지 다른 패킷 전송 금지 18_0117 14:45:40 sunk + SetSendPauseState(false); + end; + end; + +begin + try + case aRcv.Command of + TOC_CONFIRM_PACKET_ENCRYPT : process_QTC_CONFIRM_PACKET_ENCRYPT; + TOC_UPDATE_PACKET_ENCRYPT : process_QTC_UPDATE_PACKET_ENCRYPT; + TOC_PING : + begin + if not GetSendPauseState then + begin + // 핑 받을때까지 전송 대기라면... 패킷 암호화 설정 정보를 못 받았다고 판단.. 다시 요청한다. 22_0412 11:00:43 kku + _Trace('CRM_PING .. PauseState true?? .. Request Sv-SendPacketEncConfirm()'); + SendPacket(TTgPacket.Create(TOC_REQUEST_CONFIRM_PACKET_ENCRYPT)); + end; + end; + end; + except + on E: Exception do + ETgClient.TraceException(Self, E, 'Fail .. ProcessRcvPacket()'); + end; +end; + +procedure TTgClientBase.SendPacket(Send: ISendPacket); +begin + if GetConnected then + begin + Lock; + try + QSendPacket_.Enqueue(Send); + finally + Unlock; + end; + end else + _ProcessSendFail(Send); +end; + +function TTgClientBase.DequeueSendPacket: ISendPacket; +begin + Lock; + try + if not bSendPause_ and + (QSendPacket_.Count > 0) then + Result := QSendPacket_.Dequeue + else + Result := nil; + finally + Unlock; + end; +end; + +procedure TTgClientBase.DirectSendPacket(Send: ISendPacket); +begin + try + _ProcessSend(Send); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. DirectSendPacket()'); + end; +end; + +function TTgClientBase.Connect(const sHost: String; nPort: Integer): Boolean; +var + nOldCTO, + nOldRTO: Integer; +begin + if Client_ = nil then + begin + Result := false; + exit; + end; + + Result := true; + + if not GetConnected then + begin + _DcRcvBufs.Clear; + _pRcvPkt := nil; + SetLength(_pInitBuf, 0); + + SetLength(_RcylBuf, 0); + _nRcylBufLen := 0; + _nRcylBufPos := 0; + + with Client_ do + begin + PktEncKind_ := ekNone; + + nSvrPktVer_ := 0; + Host := sHost; + Port := nPort; + + nOldCTO := ConnectTimeout; + nOldRTO := ReadTimeout; + ConnectTimeout := 20000; + ReadTimeout := 30000; + try + try + Client_.Connect; + + Socket.RecvBufferSize := 32 * 1024; + Socket.SendBufferSize := 32 * 1024; + + Result := true; + SetConnected(true); + except + on E: EIdSocketError do + begin + if E.LastError <> 10061 then // 서버 활성화 안됐을때 접속 시도 시 이게 계속 로그에 찍혀서 제외처리 + ETgException.TraceException(Self, E, 'Fail .. Connect()'); + Result := false; + SetConnected(false); + exit; + end; + + on E: Exception do + begin + ETgClient.TraceException(Self, E, 'Fail .. Connect()'); + Result := false; + SetConnected(false); + exit; + end; + end; + finally + ReadTimeout := nOldRTO; + ConnectTimeout := nOldCTO; + end; + end; + end; +end; + +function TTgClientBase.Connect: Boolean; +begin + if (sHost_ <> '') and (nPort_ <> 0) then + Result := Connect(sHost_, nPort_) + else + Result := false; +end; + +function TTgClientBase.GetSelfWnd: HWND; +begin + if W2W_ <> nil then + Result := W2W_.RcWnd + else + Result := 0; +end; + +function TTgClientBase.ActiveW2W(sClassName: String = ''; hInst: HMODULE = 0): Boolean; +begin + if W2W_ = nil then + begin + W2W_ := TTgWnd2Wnd.Create(sClassName, hInst); + W2W_.OnW2WConnection := OnW2WConnection; + Result := true; + end else + Result := false; +end; + +procedure TTgClientBase.DeactiveW2W; +begin + if W2W_ <> nil then + begin + Disconnect; + FreeAndNil(W2W_); + end; +end; + +function TTgClientBase.ConnectWnd(hConnWnd: HWND): Boolean; +begin + Result := false; + if not GetConnected and (W2W_ <> nil) then + begin + try + if (hConnWnd <> 0) and (hConnWnd <> hIpcWnd_) then + begin + Result := SendMessage(hConnWnd, WM_WND_HANDSHAKE, NativeUInt(wcsConnect), W2W_.RcWnd) = WM_WND_HANDSHAKE; + + if Result then + begin + hIpcWnd_ := hConnWnd; + _ConnectedEvent(nil); + end + {$IFDEF DEBUG} + else + _Trace('Fail .. W2W - ConnectWnd() .. SendData()'); + {$ENDIF}; + end; + except + on E: EXception do + ETgException.TraceException(Self, E, 'Fail .. W2W - ConnectWnd()'); + end; + end; +end; + +function TTgClientBase.ActiveNp(sPipeName: String; bNpServer: Boolean): Boolean; +begin + if NpIpc_ = nil then + begin + if bNpServer then + begin + NpIpc_ := TTgNpServer.Create(sPipeName); + SetSendPauseState(false); + end else begin + NpIpc_ := TTgNpClient.Create(sPipeName); + NpIpc_.OnConnected := OnNpConnected; + NpIpc_.OnDisconnected := OnNpDisconnected; + end; + Result := true; + end else + Result := false; +end; + +function TTgClientBase.ConnectNp: Boolean; +begin + Result := false; + if not GetConnected and (NpIpc_ <> nil) then + begin + try + if NpIpc_.IsServer then + begin + Result := TTgNpServer(NpIpc_).Listen; + SetConnected(Result); + end else begin + Result := TTgNpClient(NpIpc_).Connect; + if Result then + _ConnectedEvent(nil); + end; + except + on E: EXception do + ETgException.TraceException(Self, E, 'Fail .. NpIpc - ConnectWnd()'); + end; + end; +end; + +procedure TTgClientBase.DeactiveNp; +begin + if NpIpc_ <> nil then + FreeAndNil(NpIpc_); +end; + +procedure TTgClientBase.Disconnect; +begin + try + _Trace('Disconnect()', 3); + SetConnected(false); + if W2W_ <> nil then + begin + W2W_.ClearQueue; + if hIpcWnd_ <> 0 then + begin + _DisconnectedEvent(nil); + SendMessage(hIpcWnd_, WM_WND_HANDSHAKE, NativeUInt(wcsDisconnect), W2W_.RcWnd); + hIpcWnd_ := 0; + end; + end else + if NpIpc_ <> nil then + begin + if NpIpc_.IsServer then + begin + TTgNpServer(NpIpc_).Close; + end else begin + TTgNpClient(NpIpc_).Disconnect; + _DisconnectedEvent(nil); + end; + end else begin + if Client_.Socket <> nil then + begin + Client_.Socket.InputBuffer.Clear; + Client_.Socket.CloseGracefully; + end; + Client_.Disconnect; + + _DcRcvBufs.Clear; + _pRcvPkt := nil; + + _DisconnectedEvent(Client_); + end; + except + // + end; +end; + +function TTgClientBase._ProcessRcv: Boolean; + + procedure PK_ReadBytes(var aBuffer: TBytes; nCount: Integer); + var + nLen, nRead, + nNewPktSigPos: Integer; + {$IFDEF Win64} + arrSig: TBytes; + {$ENDIF} + begin + if _nRcylBufLen > _nRcylBufPos then + begin + // 20200131TEST!! +// _Trace('PK_ReadBytes .. _RcylBuf Read~'); + nLen := Length(aBuffer); + if (_nRcylBufLen - _nRcylBufPos) > nCount then + nRead := nCount + else + nRead := _nRcylBufLen - _nRcylBufPos; + + SetLength(aBuffer, nLen + nRead); + CopyMemory(@aBuffer[nLen], @_RcylBuf[_nRcylBufPos], nRead); + Inc(_nRcylBufPos, nRead); + end else + Client_.Socket.ReadBytes(TIdBytes(aBuffer), nCount, true); + + if (_nRcylBufLen > 0) and (_nRcylBufLen <= _nRcylBufPos) then + begin + // 20200131TEST!! +// _Trace('PK_ReadBytes .. _RcylBuf Clear~~~~~'); + _nRcylBufLen := 0; + _nRcylBufPos := 0; + SetLength(_RcylBuf, 0); + end; + + // 읽은 버퍼 뒤에 새로운 패킷 시작이 있는지 확인 20_0131 15:17:22 sunk + {$IFDEF Win64} + // 64에서 이렇게 안하면 Range 오류나서 위 코드 추가 (11.1) 22_1208 09:22:00 kku + SetLength(arrSig, LEN_CTX_PACKET_SIGNATURE); + CopyMemory(arrSig, @CTX_PACKET_SIGNATURE[1], LEN_CTX_PACKET_SIGNATURE); + nNewPktSigPos := PosBin(arrSig, aBuffer, 1 {SearchBeginOffset}); + {$ELSE} + nNewPktSigPos := PosBin(TBytes(@CTX_PACKET_SIGNATURE[1]), aBuffer, 1 {SearchBeginOffset}); + {$ENDIF} + if nNewPktSigPos > 0 then + begin + // 20200131TEST!! +// _Trace('PK_ReadBytes .. Found NewPktSigPos~'); + nLen := Length(aBuffer); + if _nRcylBufLen = 0 then + begin + _nRcylBufLen := nLen - nNewPktSigPos; + SetLength(_RcylBuf, _nRcylBufLen); + CopyMemory(@_RcylBuf[0], @aBuffer[nNewPktSigPos], _nRcylBufLen); + SetLength(aBuffer, nLen - _nRcylBufLen); + end else begin + Dec(_nRcylBufPos, nLen - nNewPktSigPos); + SetLength(aBuffer, nLen - (nLen - nNewPktSigPos)); + end; + end; + end; + +var + pDecBuf, + pTempBuf: TBytes; + nInitBufLen, + nBufLen, nDecLen: Integer; + PktEncKind: TTgEncKind; + Rcv: IRcvPacket; +{$IFDEF _ENC_TEST_} + sPath, + sAlgo: String; + sData: AnsiString; + fs: TFileStream; +{$ENDIF} + pData: PWndDataEnt; +Label + LB_READ_BYTES; +begin + Result := false; + + if W2W_ <> nil then + begin + try + pData := W2W_.DeququeData; + if pData = nil then + exit; + + if pData.llSender <> hIpcWnd_ then + begin + _Trace('Change Sender HWND ..'); + hIpcWnd_ := pData.llSender; + exit; + end; + +// Rcv := TTgPacket.Create(Copy(PChar(pData.pBuf), 1, pData.dwLen)); + Rcv := TTgPacket.Create(Copy(PChar(pData.pBuf), 1, (pData.dwLen div 2) - 1)); + FreeMem(pData.pBuf, pData.dwLen); + Dispose(pData); + + ProcessRcvPacket(Rcv); + Result := true; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. W2W - _ProcessRcv()'); + end; + end else + if NpIpc_ <> nil then + begin + try + if NpIpc_.RcvData(pTempBuf) > 0 then + begin + Rcv := TTgPacket.Create(pTempBuf, true); + if NpIpc_.IsServer then + TTgPacket(Rcv).Toss := TTgNpServer(NpIpc_).LastRcvPipe; + ProcessRcvPacket(Rcv); + Result := true; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. NpIPC - _ProcessRcv()'); + end; + end else begin + if Client_ = nil then + exit; + + try + if not Client_.Socket.Readable(1) and + (Client_.Socket.InputBuffer.Size = 0) then exit; + + if (_pRcvPkt = nil) or (_pRcvPkt.llId <> -1) then + begin + // 이전 버전이랑 구분하기 위해서 만들었는 위치가 좋지 않지만 일단 이렇게 활용한다. 18_0411 16:08:51 sunk + + // 암호화 지원 확인 전까진 최신 버전도 (sServerVer_ = '') 상태이긴 한데... + // 32K 미만이면 괜찮고 암호화 지원 확인 전까진 32K 이상 패킷이 없기 때문에... + // 일단 이렇게 간다...아아아아앙앙ㅇㅇㅇ아ㅏㅏㅏㅏ 18_0411 17:40:50 sunk + // if sServerVer_ <> '' then + + // 서버에서도 패킷 버전을 통보하여 해당 정보를 통해 별도 식별 후 처리 18_0423 10:44:29 sunk + // if nSvrPktVer_ >= 4 then + begin + // 서버에서 32k 단위로 헤더 달아서 쪼개서 보내는걸 그냥 모아서 보내는걸로 수정했다. + // 따라서 클라이언트 단에서 쪼개서 받을때 무조건 헤드를 검사하면 안된다. + if (_pRcvPkt <> nil) and (_pRcvPkt.llId <> -1) then + begin + // 헤더 확인 안하고 이어서 받기 처리 추가 18_0411 15:21:28 sunk + if _DcRcvBufs.ContainsKey(_pRcvPkt.llId) then + begin + _pRcvPkt := _DcRcvBufs[_pRcvPkt.llId]; + if _pRcvPkt.nRemainPktLen > 0 then + goto LB_READ_BYTES; + end; + end; + end; + + if Length(_pInitBuf) = 0 then + PK_ReadBytes(_pInitBuf, 6) + else + PK_ReadBytes(_pInitBuf, 1); + + // 6 이 아니면... 여기서 통신 먹통되는 현상 확인 20_0131 16:30:11 sunk + // _pInitBuf 이거 재활용 하면서 6 이상이 되는 경우가 종종 발생한다. + // if Length(_pInitBuf) <> 6 then + nInitBufLen := Length(_pInitBuf); + if nInitBufLen < 6 then // 6 이하면 넘기는걸로 수정 20_0131 16:30:26 sunk + exit; + + // ------------- 주의 ---------------------------------------------------- + // 현재 서버에서 데이터를 큰 패킷단위로 쪼개서 보낼때.... + // 중간중간 작은 패킷이 중간에 껴서 오는 문제가 있다... + // 서버 워크스레드로 동시에 보내서 발생하는 문제인것 같은데... + // + // 패킷 조각이 좀 크면 그 조각 데이터 사이에 작은 별도패킷이 끼고 + // 다른 패킷 조각이 새로 새치기 되고... 등등 + // 서버에서 패킷 전송 시 하나의 스레드로 보내도록 하는 방법밖에 없을거 같긴하다. + // 일단 그냥 이대로 쓰는걸로... 20_0203 14:06:47 sunk + // ----------------------------------------------------------------------- + + if CompareMem(@_pInitBuf[0], @CTX_PACKET_SIGNATURE[1], 6) then + begin + if nInitBufLen < LEN_CTX_PACKET_HEADER then + PK_ReadBytes(_pInitBuf, LEN_CTX_PACKET_HEADER - nInitBufLen) + else + _Trace('No~~~ Don''t read CTX_PACKET_HEADER'); + + if not _DcRcvBufs.ContainsKey(PCtxPacketHeader(_pInitBuf).dwId) then + begin + New(_pRcvPkt); + ZeroMemory(_pRcvPkt, SizeOf(TClientRcvPacket)); + _pRcvPkt.wRank := PCtxPacketHeader(_pInitBuf).wRank; + _pRcvPkt.llId := PCtxPacketHeader(_pInitBuf).dwId; + _pRcvPkt.nRemainPktLen := PCtxPacketHeader(_pInitBuf).dwSize; + _pRcvPkt.pBuf := AllocMem(_pRcvPkt.nRemainPktLen); + _DcRcvBufs.Add(_pRcvPkt.llId, _pRcvPkt); + end else + _pRcvPkt := _DcRcvBufs[PCtxPacketHeader(_pInitBuf).dwId]; + + SetLength(_pInitBuf, 0); + end else begin + if _pRcvPkt = nil then + begin + _pInitBuf[0] := _pInitBuf[1]; + _pInitBuf[1] := _pInitBuf[2]; + _pInitBuf[2] := _pInitBuf[3]; + _pInitBuf[3] := _pInitBuf[4]; + _pInitBuf[4] := _pInitBuf[5]; + SetLength(_pInitBuf, 5); + Result := true; + exit; + end else + if _pRcvPkt.nRemainPktLen > 0 then + begin + nBufLen := Length(_pInitBuf); + + // SetLength(pTempBuf, nBufLen); + // CopyMemory(@pTempBuf[0], @_pInitBuf[0], nBufLen); + + CopyMemory(Pointer(NativeInt(_pRcvPkt.pBuf)+_pRcvPkt.nProcPktLen), @_pInitBuf[0], nBufLen); + Inc(_pRcvPkt.nProcPktLen, nBufLen); + Dec(_pRcvPkt.nRemainPktLen, nBufLen); + + SetLength(_pInitBuf, 0); + SetLength(pTempBuf, 0); + + goto LB_READ_BYTES; + end else begin + _DcRcvBufs.Remove(_pRcvPkt.llId); + _pRcvPkt := nil; + end; + end; + + if (_pRcvPkt = nil) or (_pRcvPkt.nRemainPktLen = 0) then + begin + exit; + end; + + SetLength(pTempBuf, 0); + + LB_READ_BYTES : + // if not Client_.Socket.Readable(1) and + // (Client_.Socket.InputBuffer.Size = 0) then exit; + + if _pRcvPkt.nRemainPktLen > BUFFER_SIZE then // TBytes 최대길이가 131071을 넘지 못해서 이렇게 잘라서 처리하도록 한다. 14_0610 17:31:00 sunk + PK_ReadBytes(pTempBuf, BUFFER_SIZE) + else + PK_ReadBytes(pTempBuf, _pRcvPkt.nRemainPktLen); + nBufLen := Length(pTempBuf); + + if nBufLen > 0 then + begin + CopyMemory(Pointer(NativeInt(_pRcvPkt.pBuf)+_pRcvPkt.nProcPktLen), @pTempBuf[0], nBufLen); + Inc(_pRcvPkt.nProcPktLen, nBufLen); + Dec(_pRcvPkt.nRemainPktLen, nBufLen); + end; + end else begin + // 기존 패킷 처리 14_0610 14:42:13 sunk + if _pRcvPkt.nRemainPktLen > BUFFER_SIZE then // TBytes 최대길이가 131071을 넘지 못해서 이렇게 잘라서 처리하도록 한다. 14_0610 17:31:00 sunk + PK_ReadBytes(pTempBuf, BUFFER_SIZE) + else + PK_ReadBytes(pTempBuf, _pRcvPkt.nRemainPktLen); + nBufLen := Length(pTempBuf); + + if nBufLen > 0 then + begin + CopyMemory(Pointer(NativeInt(_pRcvPkt.pBuf)+_pRcvPkt.nProcPktLen), @pTempBuf[0], nBufLen); + Inc(_pRcvPkt.nProcPktLen, nBufLen); + Dec(_pRcvPkt.nRemainPktLen, nBufLen); + end; + end; + + Result := true; + + // 20200131TEST!! + // if _pRcvPkt.nRemainPktLen < 0 then + // _pRcvPkt.nRemainPktLen := _pRcvPkt.nRemainPktLen + 0; + + if (_pRcvPkt <> nil) and (_pRcvPkt.nRemainPktLen = 0) then + begin + // 20200131TEST!! + // if _nRcylBufLen > 0 then + // _Trace('MakePacket ... _nRcylBufLen = %d, _nRcylBufPos = %d', [_nRcylBufLen, _nRcylBufPos]); + + // 암호화 패킷 처리 추가 14_0704 10:15:21 sunk + PktEncKind := GetPktEncKind; + if PktEncKind <> ekNone then + begin + Lock; + try + ASSERT(Enc_ <> nil, 'none.. encrypt obj ..'); + pDecBuf := Enc_.DecryptBufferEx(_pRcvPkt.pBuf, _pRcvPkt.nProcPktLen); + finally + Unlock; + end; + + case PktEncKind of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc: + begin + // 언패딩이 필요한 알고리즘의 경우, + // 언패딩 후 길이를 다시 계산. 18_0411 10:08:16 sunk + nDecLen := Length(pDecBuf); + end; + else + nDecLen := _pRcvPkt.nProcPktLen; + end; + + // if (nSvrPktVer_ < 4) and (nDecLen > 5) and + // (pDecBuf[0] <> 123) and (pDecBuf[1] <> 34) and + // (pDecBuf[4] = 123) and (pDecBuf[5] = 34) then // 올드 서버 패킷 체크 .... + // Rcv := TTgPacket.Create(@pDecBuf[4], nDecLen-4) + // else + Rcv := TTgPacket.Create(@pDecBuf[0], nDecLen); + end else begin + // if (nSvrPktVer_ < 4) and (_pRcvPkt.nProcPktLen > 5) and + // (TBytes(_pRcvPkt.pBuf)[0] <> 123) and (TBytes(_pRcvPkt.pBuf)[1] <> 34) and + // (TBytes(_pRcvPkt.pBuf)[4] = 123) and (TBytes(_pRcvPkt.pBuf)[5] = 34) then // 올드 서버 패킷 체크 .... + // begin + // // 서버 버전이 표시 되지 않는 옛날 서버의 경우 (AES 알고리즘 추가전) + // // 패킷 버전이 1,2가 이닌 3인걸 보고 데이터 퍼버 앞 4바이트에 크기 정보도 함께 보내준다. + // // 그래서 앞에 4바이트 잘라서 처리해줘야한다. 18_0411 17:14:33 sunk + // Rcv := TTgPacket.Create(Pointer(NativeInt(_pRcvPkt.pBuf)+4), _pRcvPkt.nProcPktLen-4); + // end else + Rcv := TTgPacket.Create(_pRcvPkt.pBuf, _pRcvPkt.nProcPktLen); + end; + + {$IFDEF _ENC_TEST_} + case Rcv.Command of + 1001 {QTC_CLIENT_INFO}, + 1111 {QTC_COLLECTOR_ENTER}, + 3101 {QTC_REQUEST_AGENT_LIST}, + 3406 {QTC_REQUEST_PI_DRIVELIST} : + begin + case PktEncKind of + ekNone : sAlgo := 'None'; + ekAes256cbc : sAlgo := 'AES256CBC'; + ekAes192cbc : sAlgo := 'AES192CBC'; + ekAes128cbc : sAlgo := 'AES128CBC'; + else + sAlgo := 'Unknown'; + end; + sPath := ExtractFileDrive(GetCurrentPath) + '\QT_ENCTEST\'; + if ForceDirectories(sPath) then + begin + sPath := sPath + Format('R-%s-TYP=%d-%s-Cmd=%d.pkt', [FormatDateTime('yyyymmddhhnnss', Now), CLIENT_TYPE, sAlgo, Rcv.Command]); + fs := TFileStream.Create(sPath, fmCreate); + try + if PktEncKind <> ekNone then + begin + sData := EncodeBase64(_pRcvPkt.pBuf, _pRcvPkt.nProcPktLen); + fs.Write(@sData[1], Length(sData)); + end else + fs.Write(_pRcvPkt.pBuf^, _pRcvPkt.nProcPktLen); + finally + fs.Free; + end; + end; + end; + end; + {$ENDIF} + + ProcessRcvPacket(Rcv); + + if _pRcvPkt <> nil then // ProcessRcvPacket() 처리중에 Disconnect()가 올수도 있다. + begin + _DcRcvBufs.Remove(_pRcvPkt.llId); + _pRcvPkt := nil; + end; + end; + + except + on e: EIdReadTimeout do + begin + ETgException.TraceException(Self, E, 'Fail.. _ProcessRcv()..'); + exit; + end; + + on e: ETgPacket do + begin + ETgException.TraceException(Self, E, '_ProcessRcv() .. Packet error ...'); + if _pRcvPkt <> nil then + begin + _DcRcvBufs.Remove(_pRcvPkt.llId); + _pRcvPkt := nil; + end; + ETgException.TraceException(Self, E, 'Fail.. _ProcessRcv()..'); + end; + + on e: Exception do + begin + if _pRcvPkt <> nil then + begin + _DcRcvBufs.Remove(_pRcvPkt.llId); + _pRcvPkt := nil; + end; + ETgException.TraceException(Self, E, 'Fail.. _ProcessRcv()..'); + raise; + end; + end; + end; +end; + +function TTgClientBase._ProcessSend(Send: ISendPacket): Boolean; +var + pBuf, + pSendBuf: TBytes; + nLen, nTotalLen: Integer; + CtxPacketHeader: TCtxPacketHeader; + PktEncKind: TTgEncKind; +{$IFDEF _ENC_TEST_} + sPath, + sAlgo: String; + sData: AnsiString; + fs: TFileStream; +{$ENDIF} + + procedure ProcessEncrypt; + var + pData, + pEncData: TBytes; + begin + nLen := Send.ToBytesDataOnly(pData); + if nLen > 0 then + begin + Lock; + try + {$IFDEF DEBUG} + ASSERT(Enc_ <> nil, 'none.. encrypt obj ..'); + {$ENDIF} + + pEncData := Enc_.EncryptBufferEx(@pData[0], nLen); + case PktEncKind of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc: + begin + // 패딩이 필요한 알고리즘의 경우, + // 패딩 길이도 들어가야해서 다시 계산. 18_0411 10:08:16 sunk + nLen := Length(pEncData); + end; + end; + finally + Unlock; + end; + SetLength(pBuf, nLen); + CopyMemory(@pBuf[0], @pEncData[0], nLen); + end; + end; + +begin + Result := false; + + if Send = nil then + exit; + + if W2W_ <> nil then + begin + try + if hIpcWnd_ <> 0 then + begin +// _Trace('W2W - SendData(), hIpcWnd_=%d, PID=%d', [hIpcWnd_, GetProcessPIDFromWndHandle(hIpcWnd_)]); + Result := W2W_.SendData(hIpcWnd_, Send); + if not Result then + begin + _Trace('Fail .. W2W - SendData()'); + Disconnect; + end; + end; + except + on E: EXception do + ETgException.TraceException(Self, E, 'Fail .. W2W - _ProcessSend()'); + end; + end else + if NpIpc_ <> nil then + begin + try + Result := NpIpc_.SendData(Send); + except + on E: EXception do + ETgException.TraceException(Self, E, 'Fail .. NpIPC - _ProcessSend()'); + end; + end else begin + if Client_ = nil then + exit; + + try + Lock; + try + PktEncKind := GetPktEncKind; + // _Trace('_ProcessSend() .. PktEncKind = %d', [Integer(PktEncKind)]); + if PktEncKind = ekNone then + nLen := Send.ToBytesDataOnly(pBuf) + // nLen := Send.ToBytes(pBuf) + else + ProcessEncrypt; + + {$IFDEF _ENC_TEST_} + case Send.Command of + // 1001 {QTC_CLIENT_INFO}, + // 1111 {QTC_COLLECTOR_ENTER}, + 3101 {QTC_REQUEST_AGENT_LIST}, + 3406 {QTC_REQUEST_PI_DRIVELIST} : + begin + case PktEncKind of + ekNone : sAlgo := 'None'; + ekRc4 : sAlgo := 'RC4'; + ekAes256cbc : sAlgo := 'AES256CBC'; + ekAes192cbc : sAlgo := 'AES192CBC'; + ekAes128cbc : sAlgo := 'AES128CBC'; + else + sAlgo := 'Unknown'; + end; + sPath := ExtractFileDrive(GetCurrentPath) + '\QT_ENCTEST\'; + if ForceDirectories(sPath) then + begin + sPath := sPath + Format('S-%s-TYP=%d-%s-Cmd=%d.pkt', [FormatDateTime('yyyymmddhhnnss', Now), CLIENT_TYPE, sAlgo, Send.Command]); + fs := TFileStream.Create(sPath, fmCreate); + try + if PktEncKind <> ekNone then + begin + sData := EncodeBase64(pBuf, nLen); + fs.Write(@sData[1], Length(sData)); + end else + fs.Write(pBuf[0], nLen); + finally + fs.Free; + end; + end; + end; + end; + {$ENDIF} + + if nLen > 0 then + begin + // 헤더 추가 + nTotalLen := LEN_CTX_PACKET_HEADER + nLen; + SetLength(pSendBuf, SIZE_INTEGER + nTotalLen); + CopyMemory(@pSendBuf[0], @nTotalLen, SIZE_INTEGER); + Inc(nTotalLen, SIZE_INTEGER); + + ZeroMemory(@CtxPacketHeader, SizeOf(CtxPacketHeader)); + CopyMemory(@CtxPacketHeader.sSig[0], @CTX_PACKET_SIGNATURE[1], Length(CtxPacketHeader.sSig)); + CtxPacketHeader.dwSize := nLen; + CtxPacketHeader.wRank := WORD(Send.PacketKind); + + CopyMemory(@pSendBuf[SIZE_INTEGER], @CtxPacketHeader, LEN_CTX_PACKET_HEADER); + CopyMemory(@pSendBuf[SIZE_INTEGER+LEN_CTX_PACKET_HEADER], @pBuf[0], nLen); + + Client_.Socket.Write(TIdBytes(pSendBuf), nTotalLen); + Result := true; + end; + finally + Unlock; + SetLength(pBuf, 0); + end; + except + _ProcessSendFail(Send); + raise; + end; + end; +end; + +// 전송중 연결끊김등으로 오유 났을때의 처리대비 +// 예) QatorAgent에서 수집데이터 유실방지 +procedure TTgClientBase._ProcessSendFail(Send: ISendPacket); begin end; + +function TTgClientBase._ProcessOther: Boolean; +begin + Result := false; + + if (NpIpc_ <> nil) and NpIpc_.IsServer and (NpIpc_.PipeName <> '') then + begin + if not TTgNpServer(NpIpc_).Active then + TTgNpServer(NpIpc_).Listen; + + if TTgNpServer(NpIpc_).Active then + TTgNpServer(NpIpc_).DoAcceptPipe; + end; +end; + +procedure TTgClientBase.Execute; +var + Send: ISendPacket; + bRcv, bSend, bOther: Boolean; + dwTick: DWORD; +begin + while not Terminated and not GetWorkStop do + begin + try + Send := DequeueSendPacket; + if GetConnected then + begin + bSend := _ProcessSend(Send); + bRcv := _ProcessRcv; + bOther := _ProcessOther; + if not bRcv and not bSend and not bOther then + begin + if NpIpc_ = nil then + begin + Sleep(50); + dwTick := GetTickCount; + if (dwTick - dwPingTick_) > nPingTerm_ then + begin + if W2W_ <> nil then + begin + if not IsWindow(hIpcWnd_) then + begin + Disconnect; + continue; + end; + end else + if Client_ <> nil then // 기본으로 생성되기 때문에 마지막에 넣음 + begin + if not Client_.Connected then + begin + Disconnect; + continue; + end; + end; + // _Trace('Try send ping .... nPingTerm_ = %d', [nPingTerm_]); + _ProcessSend(TTgPacket.Create(0, pkIgnore)); + dwPingTick_ := dwTick; + end; + end else Sleep(5); + end else dwPingTick_ := GetTickCount; + end else begin + // todo : 로컬 수집 추가 if Send <> nil then + Sleep(1000); + + if (NpIpc_ <> nil) and not NpIpc_.IsServer and (NpIpc_.PipeName <> '') then + begin + dwTick := GetTickCount; + if GetTryReconnect and + ((dwDisconnTick_ = 0) or ((dwTick - dwDisconnTick_) > nReConnTerm_)) then + begin + if TTgNpClient(NpIpc_).Connect then + _ConnectedEvent(nil) + else + dwDisconnTick_ := dwTick; + end; + end else + if W2W_ <> nil then + begin + // todo : 할게 있을까 23_0112 11:01:54 kku + end else begin + dwTick := GetTickCount; + if GetTryReconnect and + (sHost_ <> '') and (nPort_ <> 0) and + ((dwDisconnTick_ = 0) or ((dwTick - dwDisconnTick_) > nReConnTerm_)) then + begin + if not Connect(sHost_, nPort_) then + begin + // _Trace('재접속 주기 %d초', [(dwTick - dwDisconnTick_) div 1000]); + dwDisconnTick_ := dwTick; + end; + end; + end; + end; + except + On e: EIdSocketError do + Case e.LastError of + 10053, // 접속 비정상 종료 + 10054 : Disconnect; + else continue; + End; + + On e: EIdConnClosedGracefully do + begin + Disconnect; + end else continue; + end; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/CS/Tocsg.Packet.pas b/Tocsg.Lib/VCL/CS/Tocsg.Packet.pas new file mode 100644 index 00000000..67391e55 --- /dev/null +++ b/Tocsg.Lib/VCL/CS/Tocsg.Packet.pas @@ -0,0 +1,600 @@ +{*******************************************************} +{ } +{ Tocsg.Packet } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.Packet; + +interface + +uses + Tocsg.Obj, Tocsg.Exception, System.SysUtils, Winapi.Windows, + superobject, System.Classes; + +const + SIZE_INTEGER = SizeOf(Integer); + CTX_PACKET_SIGNATURE: AnsiString = '@OC$.G'; + LEN_CTX_PACKET_SIGNATURE = 6; + +type +// Server -> Client + PCtxPacketHeader = ^TCtxPacketHeader; + TCtxPacketHeader = packed record + sSig: array [0..5] of AnsiChar; // #SPK.$$ + wRank: WORD; + dwId, + dwSize: DWORD; + end; + + +// 종류 추가 되면 패킷 해더의 wRank 수정해야함 + TTgPacketKind = (pkNormal, pkFileQueue, pkIgnore, pkCritical); + TTgPacketHeader = record + Cmd, + Result: Integer; + Toss, + Handle, + WndMessage: LONGLONG; + ResultMsg: String; + PacketKind: TTgPacketKind; + end; + + TSnTextEncoding = System.SysUtils.TEncoding; + TSnBytes = TBytes; + + ETgPacket = class(ETgException); + ITgPacket = interface + ['{5F9E8D1B-7371-41D2-AA7A-E8DDAE3788B9}'] + function _GetPacketHeader: TTgPacketHeader; + function _GetJsonObject: ISuperObject; + + function ToJsonString: String; + function ToBytes(var SnBytes: TSnBytes): Integer; + function ToBytesDataOnly(var SnBytes: TSnBytes): Integer; + function SaveToFile(sPath: String): Boolean; + end; + + ISendPacket = interface(ITgPacket) + ['{0322E57A-C699-40BE-B0DF-64B9A69A5701}'] + function GetCommand: Integer; + procedure SetPacketKind(aPacketKind: TTgPacketKind); + function GetPacketKind: TTgPacketKind; + procedure SetHandle(llHandle: LONGLONG); + procedure SetWndMessage(llWndMessage: LONGLONG); + procedure SetToss(llToss: LONGLONG); + procedure SetResult(nResult: Integer); + procedure SetResultMsg(const sResultMsg: String); + function GetResult: Integer; + function GetResultMsg: String; + function GetSocket: TObject; + procedure SetSocket(aSocket: TObject); + + function GetO(const sPath: String): ISuperObject; + + procedure PutO(const sPath: String; const Value: ISuperObject); + procedure PutB(const sPath: String; Value: Boolean); + procedure PutI(const sPath: String; Value: SuperInt); + procedure PutC(const sPath: String; Value: Currency); + procedure PutD(const sPath: String; Value: Double); + procedure PutS(const sPath: String; const Value: String); + + property Command: Integer read GetCommand; + property Handle: LONGLONG write SetHandle; + property WndMessage: LONGLONG write SetWndMessage; + property Toss: LONGLONG write SetToss; + property Result: Integer read GetResult write SetResult; + property ResultMsg: String read GetResultMsg write SetResultMsg; + property PacketKind: TTgPacketKind read GetPacketKind write SetPacketKind; + property Socket: TObject read GetSocket write SetSocket; + + property O[const sPath: String]: ISuperObject read GetO write PutO; default; + property B[const sPath: String]: Boolean write PutB; + property I[const sPath: String]: SuperInt write PutI; + property D[const sPath: String]: Double write PutD; + property C[const sPath: String]: Currency write PutC; + property S[const sPath: String]: String write PutS; + end; + + IRcvPacket = interface(ITgPacket) + ['{C1BFCE0F-1B34-4FCC-84AC-4F24CA6D72A5}'] + function GetCommand: Integer; + function GetPacketKind: TTgPacketKind; + function GetHandle: LONGLONG; + function GetWndMessage: LONGLONG; + function GetToss: LONGLONG; + function GetResult: Integer; + function GetResultMsg: String; + function GetSocket: TObject; + function GetRcvPacketSize: DWORD; + + function ToJsonString: String; + + function GetO(const sPath: String): ISuperObject; + function GetB(const sPath: String): Boolean; + function GetI(const sPath: String): SuperInt; + function GetD(const sPath: String): Double; + function GetC(const sPath: String): Currency; + function GetS(const sPath: String): String; + function GetA(const sPath: String): TSuperArray; + + property Command: Integer read GetCommand; + property PacketKind: TTgPacketKind read GetPacketKind; + property Handle: LONGLONG read GetHandle; + property WndMessage: LONGLONG read GetWndMessage; + property Toss: LONGLONG read GetToss; + property Result: Integer read GetResult; + property ResultMsg: String read GetResultMsg; + property Socket: TObject read GetSocket; + property RcvPacketSize: DWORD read GetRcvPacketSize; + + property O[const sPath: String]: ISuperObject read GetO; default; + property B[const sPath: String]: Boolean read GetB; + property I[const sPath: String]: SuperInt read GetI; + property D[const sPath: String]: Double read GetD; + property C[const sPath: String]: Currency read GetC; + property S[const sPath: String]: String read GetS; + property A[const sPath: String]: TSuperArray read GetA; + end; + + TTgPacket = class(TInterfacedObject, ITgPacket, ISendPacket, IRcvPacket) + protected + Socket_: TObject; + PacketHeader_: TTgPacketHeader; + SuperObject_: ISuperObject; + dwRcvLen_: DWORD; + + function _GetPacketHeader: TTgPacketHeader; + function _GetJsonObject: ISuperObject; + + procedure PutO(const sPath: String; const Value: ISuperObject); + procedure PutB(const sPath: String; Value: Boolean); + procedure PutI(const sPath: String; Value: SuperInt); + procedure PutC(const sPath: String; Value: Currency); + procedure PutD(const sPath: String; Value: Double); + procedure PutS(const sPath: String; const Value: String); + + function GetO(const sPath: String): ISuperObject; + function GetB(const sPath: String): Boolean; + function GetI(const sPath: String): SuperInt; + function GetD(const sPath: String): Double; + function GetC(const sPath: String): Currency; + function GetS(const sPath: String): String; + function GetA(const sPath: String): TSuperArray; + + function GetCommand: Integer; + procedure SetPacketKind(aPacketKind: TTgPacketKind); + function GetPacketKind: TTgPacketKind; + procedure SetHandle(llHandle: LONGLONG); + function GetHandle: LONGLONG; + procedure SetWndMessage(llWndMessage: LONGLONG); + function GetWndMessage: LONGLONG; + procedure SetToss(llToss: LONGLONG); + function GetToss: LONGLONG; + procedure SetResult(nResult: Integer); + function GetResult: Integer; + procedure SetResultMsg(const sResultMsg: String); + function GetResultMsg: String; + function GetSocket: TObject; + procedure SetSocket(aSocket: TObject); + function GetRcvPacketSize: DWORD; // for IRcvPacket + public + Constructor Create; overload; + Constructor Create(const aCmd: Integer; PacketKind: TTgPacketKind = pkNormal); overload; + Constructor Create(aPacket: ITgPacket; PacketKind: TTgPacketKind = pkNormal); overload; + Constructor Create(const aRcvData: Pointer; nRcvLen: Integer); overload; + Constructor Create(const aRcvData: TSnBytes; bIncludeLen: Boolean = false; aSocket: TObject= nil{for ClientContext}); overload; + Constructor Create(aSocket: TObject{for ClientContext}; const aRcvData: Pointer; nRcvLen: Integer); overload; + Constructor Create(const sJsonData: String); overload; + function ToJsonString: String; + function ToBytes(var SnBytes: TSnBytes): Integer; + function ToBytesDataOnly(var SnBytes: TSnBytes): Integer; + function SaveToFile(sPath: String): Boolean; + + property Command: Integer read GetCommand; + property PacketKind: TTgPacketKind read GetPacketKind; + property Toss: LONGLONG read GetToss write SetToss; + property Handle: LONGLONG read GetHandle write SetHandle; + property WndMessage: LONGLONG read GetWndMessage write SetWndMessage; + property Result: Integer read GetResult write SetResult; + property ResultMsg: String read GetResultMsg write SetResultMsg; + property Socket: TObject read GetSocket write SetSocket; + + property O[const sPath: String]: ISuperObject read GetO write PutO; default; + property B[const sPath: String]: Boolean read GetB write PutB; + property I[const sPath: String]: SuperInt read GetI write PutI; + property D[const sPath: String]: Double read GetD write PutD; + property C[const sPath: String]: Currency read GetC write PutC; + property S[const sPath: String]: String read GetS write PutS; + end; + +const + LEN_CTX_PACKET_HEADER = SizeOf(TCtxPacketHeader); + BUFFER_SIZE = 32 * 1024; + MAX_BUF_LEN = BUFFER_SIZE; + +implementation + +uses + Tocsg.Safe, Tocsg.JSON; + +{ TTgPacket } + +Constructor TTgPacket.Create; +begin + Inherited Create; + ZeroMemory(@PacketHeader_, SizeOf(PacketHeader_)); + dwRcvLen_ := 0; +end; + +Constructor TTgPacket.Create(const aCmd: Integer; PacketKind: TTgPacketKind = pkNormal); +begin + Create; + PacketHeader_.Cmd := aCmd; + PacketHeader_.PacketKind := PacketKind; + SuperObject_ := TSuperObject.Create; +end; + +Constructor TTgPacket.Create(aPacket: ITgPacket; PacketKind: TTgPacketKind = pkNormal); +begin + Create; + PacketHeader_ := aPacket._GetPacketHeader; + SuperObject_ := aPacket._GetJsonObject; + PacketHeader_.PacketKind := PacketKind; +end; + +Constructor TTgPacket.Create(const aRcvData: TSnBytes; bIncludeLen: Boolean = false; aSocket: TObject = nil{for ClientContext}); + + procedure ExtractData; + var + nDataLen: Integer; + sJsonData: UTF8String; + begin + nDataLen := 0; + + if bIncludeLen then + begin + dwRcvLen_ := Length(aRcvData); + if dwRcvLen_ < 4 then + raise ETgPacket.Create('Rcv 버퍼가 손상되었습니다.'); + + CopyMemory(@nDataLen, @aRcvData[0], SIZE_INTEGER); + + if nDataLen <> (dwRcvLen_ - SIZE_INTEGER) then + begin + raise ETgPacket.CreateFmt('Rcv 데이터 크기가 잘못되었습니다. (DataLen = %d, RcvBufLen = %d', + [nDataLen, dwRcvLen_ - SIZE_INTEGER]); + end; + + SetLength(sJsonData, nDataLen); + CopyMemory(@sJsonData[1], @aRcvData[4], nDataLen); + end else begin + nDataLen := Length(aRcvData); + dwRcvLen_ := nDataLen; + SetLength(sJsonData, nDataLen); + CopyMemory(@sJsonData[1], @aRcvData[0], nDataLen); + end; + + SuperObject_ := SO(sJsonData); + + try + with SuperObject_['Header'], PacketHeader_ do + begin + Cmd := I['Cmd']; + Handle := I['Handle']; + WndMessage := I['WndMessage']; + PacketKind := TTgPacketKind(I['PacketKind']); + Result := I['Result']; + Toss := I['Toss']; + ResultMsg := S['ResultMsg']; + end; + except + raise ETgPacket.Create('Invalid packet ..'); + end; + end; + +begin + Create; + Socket_ := aSocket; + ExtractData; +end; + +Constructor TTgPacket.Create(aSocket: TObject{for ClientContext}; const aRcvData: Pointer; nRcvLen: Integer); +begin + Create(aRcvData, nRcvLen); + Socket_ := aSocket; +end; + +Constructor TTgPacket.Create(const aRcvData: Pointer; nRcvLen: Integer); + + procedure ExtractData; + var + sJsonData: UTF8String; + begin + dwRcvLen_ := nRcvLen; + SetLength(sJsonData, nRcvLen); + CopyMemory(@sJsonData[1], aRcvData, nRcvLen); + + SuperObject_ := SO(sJsonData); + + try + with SuperObject_['Header'], PacketHeader_ do + begin + Cmd := I['Cmd']; + Handle := I['Handle']; + WndMessage := I['WndMessage']; + PacketKind := TTgPacketKind(I['PacketKind']); + Result := I['Result']; + Toss := I['Toss']; + ResultMsg := S['ResultMsg']; + end; + except + raise ETgPacket.Create('Invalid packet ..'); + end; + end; + +begin + Create; + ExtractData; +end; + +Constructor TTgPacket.Create(const sJsonData: String); +begin + Inherited Create; + SuperObject_ := SO(sJsonData); + with SuperObject_['Header'], PacketHeader_ do + begin + Cmd := I['Cmd']; + Handle := I['Handle']; + WndMessage := I['WndMessage']; + PacketKind := TTgPacketKind(I['PacketKind']); + Result := I['Result']; + Toss := I['Toss']; + ResultMsg := S['ResultMsg']; + end; +end; + +function TTgPacket._GetPacketHeader: TTgPacketHeader; +begin + Result := PacketHeader_; +end; + +function TTgPacket._GetJsonObject: ISuperObject; +begin + Result := SuperObject_; +end; + +function TTgPacket.ToJsonString: String; +var + O: ISuperObject; +begin + Result := ''; + if SuperObject_ <> nil then + begin + O := SO; + with PacketHeader_, O do + begin + I['Cmd'] := Cmd; + if Handle <> 0 then + I['Handle'] := Handle; + if WndMessage <> 0 then + I['WndMessage'] := WndMessage; + if PacketKind <> pkNormal then + I['PacketKind'] := Integer(PacketKind); + if Result <> 0 then + I['Result'] := Result; + if Toss <> 0 then + I['Toss'] := Toss; + if ResultMsg <> '' then + S['ResultMsg'] := ResultMsg; + end; + SuperObject_.O['Header'] := O; + Result := SuperObject_.AsJSon; + end; +end; + +function TTgPacket.ToBytes(var SnBytes: TSnBytes): Integer; +var + sJsonData: UTF8String; + nDataLen: Integer; +begin + Result := 0; + sJsonData := UTF8Encode(ToJsonString); + if sJsonData <> '' then + begin + nDataLen := Length(sJsonData); + Result := SIZE_INTEGER + Length(sJsonData); + SetLength(SnBytes, Result); + CopyMemory(@SnBytes[0], @nDataLen, SIZE_INTEGER); + CopyMemory(@SnBytes[4], @sJsonData[1], nDataLen); +// SetLength(sJsonData, 0); + end; +end; + +function TTgPacket.ToBytesDataOnly(var SnBytes: TSnBytes): Integer; +var + sJsonData: UTF8String; +begin + Result := 0; + sJsonData := UTF8Encode(ToJsonString); + if sJsonData <> '' then + begin + Result := Length(sJsonData); + SetLength(SnBytes, Result); + CopyMemory(@SnBytes[0], @sJsonData[1], Result); + end; +end; + +function TTgPacket.SaveToFile(sPath: String): Boolean; +var + ss: TStringStream; +begin + Result := false; + try + Guard(ss, TStringStream.Create(ToJsonString, TEncoding.UTF8)); + ss.SaveToFile(sPath); + Result := true; + except + // + end; +end; + +procedure TTgPacket.PutO(const sPath: String; const Value: ISuperObject); +begin + SuperObject_.O[sPath] := Value; +end; + +procedure TTgPacket.PutB(const sPath: String; Value: Boolean); +begin + SuperObject_.B[sPath] := Value; +end; + +procedure TTgPacket.PutI(const sPath: String; Value: SuperInt); +begin + SuperObject_.I[sPath] := Value; +end; + +procedure TTgPacket.PutC(const sPath: String; Value: Currency); +begin + SuperObject_.C[sPath] := Value; +end; + +procedure TTgPacket.PutD(const sPath: String; Value: Double); +begin + SuperObject_.D[sPath] := Value; +end; + +procedure TTgPacket.PutS(const sPath: String; const Value: String); +begin + SuperObject_.S[sPath] := Value; +end; + +function TTgPacket.GetO(const sPath: String): ISuperObject; +begin + Result := SuperObject_.O[sPath]; +end; + +function TTgPacket.GetB(const sPath: String): Boolean; +begin + Result := SuperObject_.B[sPath]; +end; + +function TTgPacket.GetI(const sPath: String): SuperInt; +begin + Result := SuperObject_.I[sPath]; +end; + +function TTgPacket.GetD(const sPath: String): Double; +begin + Result := SuperObject_.D[sPath]; +end; + +function TTgPacket.GetC(const sPath: String): Currency; +begin + Result := SuperObject_.C[sPath]; +end; + +function TTgPacket.GetS(const sPath: String): String; +begin + Result := SuperObject_.S[sPath]; +end; + +function TTgPacket.GetA(const sPath: String): TSuperArray; +begin + Result := SuperObject_.A[sPath]; +end; + +function TTgPacket.GetCommand: Integer; +begin + Result := PacketHeader_.Cmd; +end; + +procedure TTgPacket.SetPacketKind(aPacketKind: TTgPacketKind); +begin + if PacketHeader_.PacketKind <> aPacketKind then + PacketHeader_.PacketKind := aPacketKind; +end; + +function TTgPacket.GetPacketKind: TTgPacketKind; +begin + Result := PacketHeader_.PacketKind; +end; + +procedure TTgPacket.SetHandle(llHandle: LONGLONG); +begin + if PacketHeader_.Handle <> llHandle then + PacketHeader_.Handle := llHandle; +end; + +function TTgPacket.GetHandle: LONGLONG; +begin + Result := PacketHeader_.Handle; +end; + +procedure TTgPacket.SetWndMessage(llWndMessage: LONGLONG); +begin + if PacketHeader_.WndMessage <> llWndMessage then + PacketHeader_.WndMessage := llWndMessage; +end; + +function TTgPacket.GetWndMessage: LONGLONG; +begin + Result := PacketHeader_.WndMessage; +end; + +procedure TTgPacket.SetToss(llToss: LONGLONG); +begin + if PacketHeader_.Toss <> llToss then + PacketHeader_.Toss := llToss; +end; + +function TTgPacket.GetToss: LONGLONG; +begin + Result := PacketHeader_.Toss; +end; + +procedure TTgPacket.SetResult(nResult: Integer); +begin + if PacketHeader_.Result <> nResult then + PacketHeader_.Result := nResult; +end; + +function TTgPacket.GetResult: Integer; +begin + Result := PacketHeader_.Result; +end; + +procedure TTgPacket.SetResultMsg(const sResultMsg: String); +begin + if PacketHeader_.ResultMsg <> sResultMsg then + PacketHeader_.ResultMsg := sResultMsg; +end; + +function TTgPacket.GetResultMsg: String; +begin + Result := PacketHeader_.ResultMsg; +end; + +function TTgPacket.GetSocket: TObject; +begin + Result := Socket_; +{$IFDEF DEBUG} + if Result = nil then + raise ETgPacket.Create('소켓이 지정 되지있지 않습니다.'); +{$ENDIF} +end; + +procedure TTgPacket.SetSocket(aSocket: TObject); +begin + if Socket_ <> aSocket then + Socket_ := aSocket; +end; + +function TTgPacket.GetRcvPacketSize: DWORD; +begin + Result := dwRcvLen_; +end; + +end. diff --git a/Tocsg.Lib/VCL/CS/Tocsg.PacketDefine.pas b/Tocsg.Lib/VCL/CS/Tocsg.PacketDefine.pas new file mode 100644 index 00000000..eac6e88c --- /dev/null +++ b/Tocsg.Lib/VCL/CS/Tocsg.PacketDefine.pas @@ -0,0 +1,33 @@ +{*******************************************************} +{ } +{ Tocsg.PacketDefine } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.PacketDefine; + +interface + +uses + Winapi.Windows; + +const + TYPE_O_AGENT = 101; + VER_O_AGENT = '1'; + ENC_PASSPASS = 'Irydk2P%a0*'; + + TOC_TEST = 9999; + TOC_PING = 10000; + TOC_CLIENT_INFO = 10001; + TOC_CONFIRM_PACKET_ENCRYPT = 10002; + TOC_UPDATE_PACKET_ENCRYPT = 10003; + TOC_REQUEST_CONFIRM_PACKET_ENCRYPT = 10004; + + TOC_PC_INFO = 11001; + TOC_INST_INFO = 11002; + +implementation + +end. diff --git a/Tocsg.Lib/VCL/CS/Tocsg.ServerBase.pas b/Tocsg.Lib/VCL/CS/Tocsg.ServerBase.pas new file mode 100644 index 00000000..7d2c9bed --- /dev/null +++ b/Tocsg.Lib/VCL/CS/Tocsg.ServerBase.pas @@ -0,0 +1,2872 @@ +{*******************************************************} +{ } +{ Tocsg.ServerBase } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.ServerBase; + +interface + +uses + System.Classes, System.SysUtils, Winapi.Messages, Winapi.Windows, + Winapi.Winsock2, System.SyncObjs, Tocsg.Packet, Tocsg.Obj, Tocsg.Thread, + Tocsg.Exception, Tocsg.Encrypt, System.Generics.Collections; + +const + DEFAULT_BUF_COUNT = 1000; + STOP_WORK = $FFFFFFFF; + PACKET_VERSION = 1; + + MAX_SEND_COUNT = DWORD(-1); + + MAX_CTX_SEND_BUFCOUNT = 30000; + + FILE_CUT_IPS = 'CutIpLst.#info'; + +type +// Server -> Client + PCtxPacketHeader = ^TCtxPacketHeader; + TCtxPacketHeader = packed record + sSig: array [0..5] of AnsiChar; // @OC$.G + wRank: WORD; + dwId, + dwSize: DWORD; + end; + + ECrmSocket = class(ETgException); + + TTgSocketBase = class(TTgObject) + private + CS_: TCriticalSection; + + sRemoteHost_, + sRemoteAddr_: String; + function GetRemoteAddr: String; + function GetRemoteHost: String; + protected + hSocket_: TSocket; + bActive_: Boolean; + DefEncoding_: TSnTextEncoding; + + PktEncKind_: TTgEncKind; + PktEncPass_: String; + Enc_: TTgEncrypt; + + procedure Lock; + procedure Unlock; + + function GetActive: Boolean; virtual; + procedure SetActive(bVal: Boolean); virtual; abstract; + procedure _Check_WSAGetLastError(nResult: Integer; const sMsg: String); + + function GetPktEncKind: TTgEncKind; + function GetPktEncPass: String; + function GetPktEncObj: TTgEncrypt; + public + Constructor Create(aSocket: TSocket); + Destructor Destroy; override; + + procedure SetPacketEncInfo(aPktEncKind: TTgEncKind; const sPktEncPass: String); virtual; + + property Handle: TSocket read hSocket_; + property Active: Boolean read GetActive write SetActive; + property RemoteAddr: String read GetRemoteAddr; + property RemoteHost: String read GetRemoteHost; + end; + + TSocketDataType = (dtRcv, dtSend); + PSocketData = ^TSocketData; + TSocketData = packed record + Overlapped: OVERLAPPED; + WSABuf: WSABuf; + SocketDataType: TSocketDataType; + AllocBuf: Pointer; +// arrBuf: array [0..MAX_BUF_LEN-1] of Byte; + end; + + PSocketBuffer = ^TSocketBuffer; + TSocketBuffer = packed record + Data: TSocketData; + bUseWSA: Boolean; + end; + + TTgServerBase = class; + TThdClientClose = class; + + TClientInfo = record + nType: Integer; + sVer, + sWinVer, + sIpAddr, + sIpRAddr, + sAccount, + sComName, + sMacAddr, + sMacAddrs: String; + BootDT, + ConnDT: TDateTime; + end; + + TTgClientCtxBase = class(TTgSocketBase) + private + _RcvBuffers: TSnBytes; + _PieceRcvBuffers: array [0..2] of Byte; // 4바이트 미만 조각 데이터 + _nTotalRcvLen, + _nRemainRcvLen, + _PieceRcvLen: Integer; // 4바이트 미만 조각 패킷 + + bRcvDec_, + bSendEnc_: Boolean; + + // 전송 실패 카운트 + nSendFailCnt_: Integer; + // 각 클라이언트에 대한 패킷 처리방식을 다르게 하기위해 버전정보를 추가 한다. + wPktVer_: WORD; + + dtLastRcv_: TDateTime; + + qSendWaitBuf_: TQueue; + nIoRefCnt_: Integer; + + pRcvBuf_: PSocketBuffer; + SendBufList_: TList; + + // SendPacket() 할때마다 카운트 되며 CtxPacketHeader의 dwId 값이 된다. + dwSendCount_: DWORD; + + procedure OnSendQNotify(Sender: TObject; const Item: PSocketBuffer; + Action: TCollectionNotification); + procedure SetActive(bVal: Boolean); override; + function GetLastRcvTime: TDateTime; + procedure UpdateLastRcvTime; + procedure SetPacketVersion(const wVal: WORD); + function GetPacketVersion: WORD; + procedure MakeRcvPacket(nBufferLen: Integer); + + procedure SetRcvDec(bVal: Boolean); + function GetRcvDec: Boolean; + procedure SetSendEnc(bVal: Boolean); + function GetSendEnc: Boolean; + + function PushSendBuf(pBuf: PSocketBuffer): Boolean; + function AddSendBuf(pBuf: PSocketBuffer): Integer; + procedure RemoveSendBuf(pBuf: PSocketBuffer); + function GetSendBufCount: Integer; + +// function Old_SendPacket_Until_1_2_3(Send: ISendPacket): Boolean; + protected + Server_: TTgServerBase; + AssocObj_: TTgObject; + ClientInfo_: TClientInfo; + // 계속 물려있는 현상 보완을 위해 추가 + dtCreate_: TDateTime; + bSendPktEncInfo_: Boolean; + public + Constructor Create(aServer: TTgServerBase; aSocket: TSocket); + Destructor Destroy; override; + procedure ClearSendBuffer; + + procedure SetPacketEncInfo(aPktEncKind: TTgEncKind; const sPktEncPass: String); override; + + procedure Close; + function ReadyRecv: Boolean; +// function ProcessSendBuf(pSendBuf: PSocketBuffer = nil): Boolean; + function ProcessSendBuf: Boolean; + + function SendPacket(Send: ISendPacket): Boolean; + + property LastRcvTime: TDateTime read GetLastRcvTime; + property AbleRcvDec: Boolean read GetRcvDec write SetRcvDec; + property AbleSendEnc: Boolean read GetSendEnc write SetSendEnc; + property OwnerSVr: TTgServerBase read Server_; + property ClientInfo: TClientInfo read ClientInfo_; + end; + + PRcvPktData = ^TRcvPktData; + TRcvPktData = record + Ctx: TTgClientCtxBase; + PacketKind: TTgPacketKind; + pData: Pointer; + nLen: Integer; + end; + + TClientEnumerator = TEnumerator; + TClientContextClass = class of TTgClientCtxBase; + + TClientNotifyEvent = procedure(Sender: TTgServerBase; aClient: TTgClientCtxBase) of object; + + TThdSocket = class; + TThdPingWorker = class; + + ECrmServer = class(ETgException); + TTgServerBase = class(TTgSocketBase) + private + dtActive_: TDateTime; + hCompPort_: THandle; + + sIPAddr_: String; + nPort_: Integer; + SockAddr_: TSockAddr; + + SenderThreadList_, + WorkThreadList_: TList; + ThdSvrAccept_, + ThdSvrLogic_: TThdSocket; + ThdClientClose_: TThdClientClose; + ThdPingWorker_: TThdPingWorker; + + evClientConnected_, + evClientDisconnected_: TClientNotifyEvent; + + nRcvBufSize_, + nSendBufSize_: Integer; + wWorkThdCnt_: WORD; + + CtxSendBufList_: TList; + + procedure _Accept; + procedure _Open; + procedure _Close; + + procedure _RegisterClient(aClient: TTgClientCtxBase); + procedure _RemoveClient(aClient: TTgClientCtxBase); + + procedure _ProcessTossPacket(aCtx: TTgClientCtxBase; RcvPacket: IRcvPacket); + + procedure OnCtxSendBufNotify(Sender: TObject; const Item: PSocketBuffer; + Action: TCollectionNotification); + procedure AddCtxSendBuf(pBuf: PSocketBuffer); + procedure RemoveCtxSendBuf(pBuf: PSocketBuffer); + procedure ClearCtxSendBuf; + protected + QueueRcvPacket_: TQUeue; + QueueSendPacket_: TQueue; + + llRcvWaitSize_: LONGLONG; +// llSendWaitSize_: LONGLONG; + + DcClient_: TDictionary; + + CutIpList_: TStringList; + sCutIpLogDir_, + sCutIpLogFName_: String; + sMakedPacketEncPass4Send_: String; // 클라이언트에 전송할 패킷 암호화 패스워드를 미리 만들어서 저장해 둔다. + + procedure _QueueRcvPacket(pRcvData: PRcvPktData); virtual; + function _DequeueRcvPacket: PRcvPktData; virtual; + procedure OnRcvDataNotify(Sender: TObject; const Item: PRcvPktData; Action: TCollectionNotification); + + function _DequeueSendPacket: ISendPacket; virtual; + + function CreateClientContext(aSocket: TSocket): TTgClientCtxBase; virtual; + procedure OnClientNotify(Sender: TObject; const Item: TTgClientCtxBase; + Action: TCollectionNotification); + procedure OnWorkThreadNotify(Sender: TObject; const Item: TThdSocket; + Action: TCollectionNotification); + + procedure SetActive(bVal: Boolean); override; + procedure SetPort(const nPort: Integer); + + procedure ClientConnectedEvent(aClient: TTgClientCtxBase); virtual; + procedure ClientDisconnectedEvent(aClient: TTgClientCtxBase); virtual; + + function GetClientEnumerator: TClientEnumerator; + function GetClientCount: Integer; + + function GetRcvWaitSize: LONGLONG; +// function GetSendWaitSize: LONGLONG; +// function IsValidBuffer(pBuf: PSocketBuffer): Boolean; + + procedure SendPacketEncConfirm(aCtx: TTgClientCtxBase); + procedure SendPacketEncInfo(aCtx: TTgClientCtxBase); + procedure ProcessTossFail(aCtx: TTgClientCtxBase; aRcv: IRcvPacket); virtual; + procedure ProcessRcvPacket(aCtx: TTgClientCtxBase; aRcv: IRcvPacket); virtual; + procedure ProcessFileQueuePacket(aCtx: TTgClientCtxBase; aRcv: IRcvPacket); overload; virtual; + procedure ProcessFileQueuePacket(aCtx: TTgClientCtxBase; pRcvBuf: Pointer; pRcvLen: Integer); overload; virtual; + + procedure ProcessClientConnection(aCtx: TTgClientCtxBase); virtual; abstract; + + procedure PushClientClose(aCtx: TTgClientCtxBase); virtual; + procedure LoadCutIpList; + public + Constructor Create(const nPort: Integer); + Destructor Destroy; override; + + procedure SetPacketEncInfo(aPktEncKind: TTgEncKind; const sPktEncPass: String); override; + procedure QueueSendPacket(SendPacket: ISendPacket); virtual; // protected에서 아래로 옮김 19_0830 16:03:47 sunk +// procedure IncSendWaitSize(llSize: LONGLONG); +// procedure DecSendWaitSize(llSize: LONGLONG); + + function IsValidClient(aClient: TTgClientCtxBase): Boolean; + procedure CloseClientCtx(aClientCtx: TTgClientCtxBase); virtual; + function CheckCutIp(sIp: String): Boolean; +// function CheckAcceptBan(sIp: String): Boolean; + + property CompletionPort: THandle read hCompPort_; + property IPAddr: String read sIPAddr_; + property Port: Integer read nPort_ write SetPort; + property CountClient: Integer read GetClientCount; + property OnClientConnected: TClientNotifyEvent write evClientConnected_; + property OnClientDisconnected: TClientNotifyEvent write evClientDisconnected_; + property ActiveDateTime: TDateTime read dtActive_; + property RcvWaitSize: LONGLONG read GetRcvWaitSize; +// property SendWaitSize: LONGLONG read GetSendWaitSize; + end; + + TThdSocket = class(TTgThread) + private + Server_: TTgServerBase; + public + Constructor Create(aServer: TTgServerBase); + end; + + TThdServerAccept = class(TThdSocket) + protected + procedure Execute; override; + end; + + TThdServerWork = class(TThdSocket) + protected + procedure Execute; override; + end; + + TThdClientClose = class(TThdSocket) + private + qCloseCtx_: TQueue; + DcCloseCtx_: TDictionary; + procedure OnQCtxNotify(Sender: TObject; const Item: TTgClientCtxBase; + Action: TCollectionNotification); + procedure OnDCtxNotify(Sender: TObject; const Item: TTgClientCtxBase; + Action: TCollectionNotification); + protected + procedure Execute; override; + public + Constructor Create(aServer: TTgServerBase); + Destructor Destroy; override; + + procedure PushCloseCtx(aCtx: TTgClientCtxBase); + end; + + TThdServerLogic = class(TThdSocket) + protected + procedure Execute; override; + public + Constructor Create(aServer: TTgServerBase); + end; + + TThdPingWorker = class(TTgThread) + private + Server_: TTgServerBase; + protected + procedure Execute; override; + public + Constructor Create(aServer: TTgServerBase); + end; + +implementation + +uses + Tocsg.Safe, System.DateUtils, Tocsg.Path, Tocsg.Trace, Tocsg.Network, Tocsg.PacketDefine, Tocsg.Hex; + +const + LEN_SOCKET_BUF = SizeOf(TSocketBuffer); + LEN_CTX_PACKET_HEADER = SizeOf(TCtxPacketHeader); + BUFFER_SIZE = 32 * 1024; + MAX_BUF_LEN = BUFFER_SIZE; + +var + _CS: TCriticalSection = nil; + _WSAData: TWSAData; + _WSACount: Integer = 0; + +{ TTgSocketBase } + + Constructor TTgSocketBase.Create(aSocket: TSocket); +begin + CS_ := TCriticalSection.Create; + Inherited Create; + +// nLockCnt_ := 0; + + sRemoteHost_ := ''; + sRemoteAddr_ := ''; + + Enc_ := nil; + PktEncPass_ := ''; + PktEncKind_ := ekNone; + + hSocket_ := aSocket; + bActive_ := hSocket_ <> INVALID_SOCKET; + + _CS.Acquire; + try + if _WSACount = 0 then + begin + // WinSock 2.2 요청 MAKEWORD(2, 2) = $0202 + if WSAStartup($0202, _WSAData) <> 0 then + begin + // WSASYSNOTREADY 네트워크 서브 시스템이 네트워크에 접속을 준비할 수 없음 + // WSAVERNOTSUPPORTED 요구한 윈속의 버전이 서포트 안됨 + // WSAEINPROGRESS 블로킹 윈도우 소켓이 실행중 + // WSAEPROCLIM 동시에 실행 가능한 최대 윈속수에 달했음 + // WSAEFAULT lpWSAData가 무효한 포인터임 + nLastError_ := GetLastError; + _Trace('TSunkSocket.Create >> %s, LastError = %d', [SysErrorMessage(nLastError_), nLastError_]); + raise ECrmSocket.CreateFmt('%s, Error = %d', [SysErrorMessage(nLastError_), nLastError_]); + end else _WSACount := 1;; + end else Inc(_WSACount); + finally + _CS.Release; + end; +end; + +Destructor TTgSocketBase.Destroy; +begin + _CS.Acquire; + try + if _WSACount > 0 then + Dec(_WSACount); + + if _WSACount = 0 then + WSACleanup; + finally + _CS.Release; + end; + + Inherited; + if Assigned(Enc_) then + FreeAndNil(Enc_); + FreeAndNil(CS_); +end; + +procedure TTgSocketBase.Lock; +begin + if Assigned(CS_) then + CS_.Acquire; +end; + +procedure TTgSocketBase.Unlock; +begin + if Assigned(CS_) then + CS_.Release; +end; + +function TTgSocketBase.GetActive: Boolean; +begin + Lock; + try + Result := bActive_; + finally + Unlock; + end; +end; + +procedure TTgSocketBase._Check_WSAGetLastError(nResult: Integer; const sMsg: String); +var + nErr: Integer; +begin + if nResult <> 0 then + begin + nErr := WSAGetLastError; + case nErr of + WSAEWOULDBLOCK, + ERROR_IO_PENDING : ; + else + begin + nLastError_ := nErr; + _Trace('_Check_WSAGetLastError("%s"), ErrorCode = %d', [sMsg, nErr]); + raise ECrmSocket.CreateFmt('Windows socket error: %s (%d), on API ''%s''', + [SysErrorMessage(nErr), nErr, sMsg]); + end; + end; + end; +end; + +function TTgSocketBase.GetPktEncKind: TTgEncKind; +begin + Lock; + try + Result := PktEncKind_; + finally + Unlock; + end; +end; + +function TTgSocketBase.GetPktEncPass: String; +begin + Lock; + try + Result := PktEncPass_; + finally + Unlock; + end; +end; + +function TTgSocketBase.GetPktEncObj: TTgEncrypt; +begin + Lock; + try + Result := Enc_; + finally + Unlock; + end; +end; + +function TTgSocketBase.GetRemoteAddr: String; +var + SockAddrIn: TSockAddr; + nSize: Integer; +begin + if sRemoteAddr_ <> '' then + begin + Result := sRemoteAddr_; + exit; + end; + + Result := ''; + + if not bActive_ or (hSocket_ = INVALID_SOCKET) then + exit; + + nSize := SizeOf(SockAddrIn); + _Check_WSAGetLastError(getpeername(hSocket_, SockAddrIn, nSize), 'getpeername'); + Result := String(inet_ntoa(TSockAddrIn(SockAddrIn).sin_addr)); + sRemoteAddr_ := Result; +end; + +function TTgSocketBase.GetRemoteHost: String; +var + SockAddrIn: TSockAddr; + nSize: Integer; + pHost: PHostEnt; +begin + if sRemoteHost_ <> '' then + begin + Result := sRemoteHost_; + exit; + end; + + Result := ''; + if not bActive_ or (hSocket_ = INVALID_SOCKET) then + exit; + + nSize := SizeOf(SockAddrIn); + _Check_WSAGetLastError(getpeername(hSocket_, SockAddrIn, nSize), 'getpeername'); + pHost := gethostbyaddr(@TSockAddrIn(SockAddrIn).sin_addr.s_addr, 4, PF_INET); + if pHost <> nil then + begin + Result := String(pHost.h_name); + sRemoteHost_ := Result; + end; +end; + +procedure TTgSocketBase.SetPacketEncInfo(aPktEncKind: TTgEncKind; const sPktEncPass: String); +begin + Lock; + try + PktEncKind_ := aPktEncKind; + PktEncPass_ := sPktEncPass; + + if Assigned(Enc_) then + FreeAndNil(Enc_); + + if PktEncKind_ <> ekNone then + Enc_ := TTgEncrypt.Create(PktEncPass_, PktEncKind_); + finally + Unlock; + end; +end; + +{ TTgClientCtxBase } + +Constructor TTgClientCtxBase.Create(aServer: TTgServerBase; aSocket: TSocket); +begin + New(pRcvBuf_); + ZeroMemory(pRcvBuf_, LEN_SOCKET_BUF); + pRcvBuf_.Data.AllocBuf := AllocMem(MAX_BUF_LEN); +// SetLength(pRcvBuf_.Data.AllocBuf, MAX_BUF_LEN); + +// New(pSendBuf_); +// ZeroMemory(pSendBuf_, LEN_SOCKET_BUF); + + Inherited Create(aSocket); + {$IFDEF DEBUG2} _Trace('Create() .. '); {$ENDIF} + + SendBufList_ := TList.Create; + SendBufList_.OnNotify := OnSendQNotify; + + nIoRefCnt_ := 0; + wPktVer_ := 0; + + bRcvDec_ := false; + bSendEnc_ := false; + + Server_ := aServer; + Server_._RegisterClient(Self); + ASSERT(Server_.wWorkThdCnt_ > 0); +// SetLength(arrSendBuf_, Server_.wWorkThdCnt_); +// ZeroMemory(arrSendBuf_, LEN_SOCKET_BUF * Server_.wWorkThdCnt_); + + qSendWaitBuf_ := TQueue.Create; + + nSendFailCnt_ := 0; + _PieceRcvLen := 0; + _nTotalRcvLen := 0; + _nRemainRcvLen := 0; + dwSendCount_ := 0; + + AssocObj_ := nil; + ZeroMemory(@ClientInfo_, SizeOf(ClientInfo_)); + dtCreate_ := Now; + bSendPktEncInfo_ := false; + + UpdateLastRcvTime; + {$IFDEF DEBUG2} _Trace('Create() .. 1'); {$ENDIF} + + if not ReadyRecv then + Server_.CloseClientCtx(Self); + {$IFDEF DEBUG2} _Trace('Create() .. 2'); {$ENDIF} +end; + +Destructor TTgClientCtxBase.Destroy; +begin + SetActive(false); + SetLength(_RcvBuffers, 0); + qSendWaitBuf_.OnNotify := OnSendQNotify; + FreeAndNil(qSendWaitBuf_); + FreeAndNil(SendBufList_); + Inherited; +// Dispose(pSendBuf_); +// SetLength(pRcvBuf_.Data.AllocBuf, 0); + FreeMem(pRcvBuf_.Data.AllocBuf, MAX_BUF_LEN); + Dispose(pRcvBuf_); +end; + +procedure TTgClientCtxBase.OnSendQNotify(Sender: TObject; const Item: PSocketBuffer; + Action: TCollectionNotification); +begin + try + case Action of + cnAdded : ; + cnRemoved : + begin +// if not Item.bUseWSA then +// begin +//// SetLength(Item.Data.AllocBuf, 0); +// if (Item.Data.AllocBuf <> nil) and (Item.Data.WSABuf.len > 0) then +// FreeMem(Item.Data.AllocBuf, Item.Data.WSABuf.len); +// Dispose(Item); +// end else +// Server_.AddCtxSendBuf(Item); + +// SetLength(Item.Data.AllocBuf, 0); + if (Item.Data.AllocBuf <> nil) and (Item.Data.WSABuf.len > 0) then + FreeMem(Item.Data.AllocBuf, Item.Data.WSABuf.len); + Dispose(Item); + end; + cnExtracted : ; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. OnSendQNotify()'); + end; +end; + +procedure TTgClientCtxBase.ClearSendBuffer; +begin + Lock; + qSendWaitBuf_.OnNotify := OnSendQNotify; + try + qSendWaitBuf_.Clear; + SendBufList_.Clear; + finally + qSendWaitBuf_.OnNotify := nil; + Unlock; + end; +end; + +procedure TTgClientCtxBase.SetPacketEncInfo(aPktEncKind: TTgEncKind; const sPktEncPass: String); +begin +// 서버가 활성화중이 아니면 무시 14_0704 09:56:49 sunk + if not Server_.Active then + exit; + + Inherited; + +// Lock; +// try +// bRcvDec_ := false; +// bSendEnc_ := false; +// finally +// Unlock; +// end; +end; + +procedure TTgClientCtxBase.Close; +begin + Active := false; +end; + +procedure TTgClientCtxBase.SetActive(bVal: Boolean); +var + li: TLinger; +begin + if bActive_ <> bVal then + begin + Lock; + try + bActive_ := bVal; + finally + Unlock; + end; + + if not bVal then + begin + ClearSendBuffer; + Lock; + try + if hSocket_ <> INVALID_SOCKET then + begin + ZeroMemory(@li, SizeOf(li)); + setsockopt(hSocket_, SOL_SOCKET, SO_LINGER, @li, SizeOf(li)); + closesocket(hSocket_); + hSocket_ := INVALID_SOCKET; + end; + finally + Unlock; + end; + end else + raise ECrmSocket.Create('클라이언트는 임의적으로 활성화 시킬 수 없습니다.'); + end; +end; + +function TTgClientCtxBase.GetLastRcvTime: TDateTime; +begin + Lock; + try + Result := dtLastRcv_; + finally + Unlock; + end; +end; + +procedure TTgClientCtxBase.UpdateLastRcvTime; +begin + Lock; + try + dtLastRcv_ := Now; + finally + Unlock; + end; +end; + +procedure TTgClientCtxBase.SetPacketVersion(const wVal: WORD); +begin + Lock; + try + if wPktVer_ <> wVal then + wPktVer_ := wVal; + finally + Unlock; + end; +end; + +function TTgClientCtxBase.GetPacketVersion: WORD; +begin + Lock; + try + Result := wPktVer_; + finally + Unlock; + end; +end; + +procedure TTgClientCtxBase.SetRcvDec(bVal: Boolean); +begin + Lock; + try + bRcvDec_ := bVal; + finally + Unlock; + end; +end; + +function TTgClientCtxBase.GetRcvDec: Boolean; +begin + Lock; + try + Result := bRcvDec_; + finally + Unlock; + end; +end; + +procedure TTgClientCtxBase.SetSendEnc(bVal: Boolean); +begin + Lock; + try + bSendEnc_ := bVal; + finally + Unlock; + end; +end; + +function TTgClientCtxBase.GetSendEnc: Boolean; +begin + Lock; + try + Result := bSendEnc_; + finally + Unlock; + end; +end; + +function TTgClientCtxBase.PushSendBuf(pBuf: PSocketBuffer): Boolean; +var + bDoProcSend: Boolean; +begin + try + Result := false; + if not Active then + exit; + + Lock; + try + bDoProcSend := qSendWaitBuf_.Count = 0; + qSendWaitBuf_.Enqueue(pBuf); + finally + Unlock; + end; + + if bDoProcSend then + begin + Result := ProcessSendBuf; + if not Result then + Close; +// Server_.CloseClientCtx(Self); + end; + + Result := true; + except + on E: Exception do + begin + Result := false; + ETgException.TraceException(Self, E, 'Fail .. PushSendBuf()'); + end; + end; +end; + +function TTgClientCtxBase.AddSendBuf(pBuf: PSocketBuffer): Integer; +begin + Lock; + try + Result := SendBufList_.Add(pBuf); + finally + Unlock; + end; +end; + +procedure TTgClientCtxBase.RemoveSendBuf(pBuf: PSocketBuffer); +var + i: Integer; +begin + try + Lock; + try + i := SendBufList_.IndexOf(pBuf); + if i <> -1 then + begin + pBuf.bUseWSA := false; + SendBufList_.Delete(i); + end; + finally + Unlock; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. RemoveSendBuf()'); + end; +end; + +function TTgClientCtxBase.GetSendBufCount: Integer; +begin + Lock; + try + Result := SendBufList_.Count; + finally + Unlock; + end; +end; + +procedure TTgClientCtxBase.MakeRcvPacket(nBufferLen: Integer); +const + OVER_SIZE_PACKET = 52428800;{50MB} +var + nReaded, + nReadLen: Integer; + pBuf: TBytes; + i: Integer; + + procedure ProcessRcvPacket; + var + Rcv: IRcvPacket; + pDecBuf: TBytes; + nDataPos: Integer; + pRcvData: PRcvPktData; + nPktVer: Integer; + begin + try + nPktVer := GetPacketVersion; + + New(pRcvData); + pRcvData.Ctx := Self; + pRcvData.PacketKind := pkNormal; + pRcvData.nLen := Length(_RcvBuffers); + + nDataPos := 0; + // 헤더 확인 및 처리 + if CompareMem(@PCtxPacketHeader(_RcvBuffers).sSig[0], @CTX_PACKET_SIGNATURE[1], 6) then + begin + // 패킷을 j-son 오브젝트로 파싱 하기 전에 파일큐에 넣기 위해 + pRcvData.PacketKind := TTgPacketKind(PCtxPacketHeader(_RcvBuffers).wRank); + nDataPos := LEN_CTX_PACKET_HEADER; + pRcvData.nLen := PCtxPacketHeader(_RcvBuffers).dwSize; + end; + + pRcvData.pData := AllocMem(pRcvData.nLen); + + // 복호화 확인 및 처리 + if AbleRcvDec then + begin + if Enc_ = nil then + begin +// {$IFDEF DEBUG} +// ASSERT(Enc_ <> nil, 'none.. encrypt obj ..'); +// {$ENDIF} + exit; + end; + + Lock; + try + pDecBuf := Enc_.DecryptBufferEx(@_RcvBuffers[nDataPos], pRcvData.nLen); + + case Enc_.EncKind of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc: + begin + // 언패딩이 필요한 알고리즘의 경우, + // 언패딩 후 길이를 다시 계산 + pRcvData.nLen := Length(pDecBuf); + end; + end; + finally + Unlock; + end; + + CopyMemory(pRcvData.pData, @pDecBuf[0], pRcvData.nLen); + end else + CopyMemory(pRcvData.pData, @_RcvBuffers[nDataPos], pRcvData.nLen); + + if pRcvData.PacketKind = pkCritical then + begin + // 패킷 버전 2부터 헤더를 확인해서 랭크를 j-son 파싱 전에 랭크 확인하고 처리 시켜주게 한다. + // 그리고 로직 스레드에서 리시브 패킷 처리 하는걸로 변경 + Rcv := TTgPacket.Create(Self, pRcvData.pData, pRcvData.nLen); + if Rcv.Toss = 0 then + Server_.ProcessRcvPacket(Self, Rcv) + else + Server_._ProcessTossPacket(Self, Rcv); + FreeMem(pRcvData.pData); + Dispose(pRcvData); + end else + Server_._QueueRcvPacket(pRcvData); + except +// on E: Exception do +// ETgException.TraceException(E, 'TTgClientCtxBase >> MakeRcvPacket()::MakeRcvPacket() .. error'); + end; + end; + +begin + try + if not Active then + exit; + + if _PieceRcvLen > 0 then + begin + SetLength(pBuf, _PieceRcvLen + nBufferLen); + CopyMemory(@pBuf[0], @_PieceRcvBuffers[0], _PieceRcvLen); + CopyMemory(@pBuf[_PieceRcvLen], pRcvBuf_.Data.AllocBuf, nBufferLen); + Inc(nBufferLen, _PieceRcvLen); + _PieceRcvLen := 0; + end else begin +// pBuf := @pRcvBuf_.Data.arrBuf; + SetLength(pBuf, MAX_BUF_LEN); + CopyMemory(@pBuf[0], pRcvBuf_.Data.AllocBuf, MAX_BUF_LEN); +// pBuf := TBytes(pRcvBuf_.Data.AllocBuf); + end; + + nReaded := 0; + if _nRemainRcvLen = 0 then + begin + if nBufferLen < 10 then + begin + // 10바이트 미만 미루기 + _PieceRcvLen := nBufferLen; + CopyMemory(@_PieceRcvBuffers[0], @pBuf[nReaded], _PieceRcvLen); + exit; + end; + + // 먼저 밀린 패킷 마구 들어온건지 검증..15_0313 18:38:37 sunk + for i := 4 to nBufferLen - 7 do + begin + if AnsiChar(pBuf[i]) = CTX_PACKET_SIGNATURE[1] then + if AnsiChar(pBuf[i+1]) = CTX_PACKET_SIGNATURE[2] then + if AnsiChar(pBuf[i+2]) = CTX_PACKET_SIGNATURE[3] then + if AnsiChar(pBuf[i+3]) = CTX_PACKET_SIGNATURE[4] then + if AnsiChar(pBuf[i+4]) = CTX_PACKET_SIGNATURE[5] then + if AnsiChar(pBuf[i+5]) = CTX_PACKET_SIGNATURE[6] then + begin + nReaded := i - 4; + break; + end; + end; + + if nBufferLen <= (i + 7) then + begin + _PieceRcvLen := 0; + _nTotalRcvLen := 0; + _nRemainRcvLen := 0; + exit; + end; + + CopyMemory(@_nTotalRcvLen, @pBuf[nReaded], SIZE_INTEGER); + + if _nTotalRcvLen + SIZE_INTEGER < nBufferLen then + begin + while nReaded < nBufferLen do + begin + if nBufferLen - nReaded < 4 then + begin + // 4바이트 미만은 패킷사이즈도 알수 없기때문에, + // 4바이트 미만은 다음 패킷까지 미룬다 + _PieceRcvLen := nBufferLen - nReaded; + CopyMemory(@_PieceRcvBuffers[0], @pBuf[nReaded], _PieceRcvLen); + exit; + end; + CopyMemory(@_nTotalRcvLen, @pBuf[nReaded], SIZE_INTEGER); + Inc(nReaded, SIZE_INTEGER); + if _nTotalRcvLen > OVER_SIZE_PACKET then + begin + // 용량이 넘 크면 문제가 있다고 판단하고 넘김 + _PieceRcvLen := 0; + _nTotalRcvLen := 0; + _nRemainRcvLen := 0; + exit; + end; + + SetLength(_RcvBuffers, _nTotalRcvLen); + + if _nTotalRcvLen > (nBufferLen - nReaded) then + begin + CopyMemory(@_RcvBuffers[0], @pBuf[nReaded], nBufferLen - nReaded); + _nRemainRcvLen := _nTotalRcvLen - (nBufferLen - nReaded); + break; + end else begin + CopyMemory(@_RcvBuffers[0], @pBuf[nReaded], _nTotalRcvLen); + + ProcessRcvPacket; + + Inc(nReaded, _nTotalRcvLen); + end; + end; + end else begin + if (_nTotalRcvLen + SIZE_INTEGER) > nBufferLen then + nReadLen := nBufferLen - SIZE_INTEGER + else + nReadLen := _nTotalRcvLen; + + if _nTotalRcvLen > OVER_SIZE_PACKET then + begin + // 용량이 넘 크면 문제가 있다고 판단하고 넘김 + _PieceRcvLen := 0; + _nTotalRcvLen := 0; + _nRemainRcvLen := 0; + exit; + end; + + SetLength(_RcvBuffers, _nTotalRcvLen); + CopyMemory(@_RcvBuffers[0], @pBuf[SIZE_INTEGER], nReadLen); + _nRemainRcvLen := _nTotalRcvLen - nReadLen; + + if _nRemainRcvLen = 0 then + ProcessRcvPacket; + end; + end else begin + if _nRemainRcvLen < nBufferLen then + begin + CopyMemory(@_RcvBuffers[_nTotalRcvLen-_nRemainRcvLen], @pBuf[0], _nRemainRcvLen); + ProcessRcvPacket; + + nReaded := _nRemainRcvLen; + _nTotalRcvLen := 0; + _nRemainRcvLen := 0; + while nReaded < nBufferLen do + begin + if nBufferLen - nReaded < 4 then + begin + // 4바이트 미만은 패킷사이즈도 알수 없기때문에, + // 4바이트 미만은 다음 패킷까지 미룬다 + _PieceRcvLen := nBufferLen - nReaded; + CopyMemory(@_PieceRcvBuffers[0], @pBuf[nReaded], _PieceRcvLen); + exit; + end; + CopyMemory(@_nTotalRcvLen, @pBuf[nReaded], SIZE_INTEGER); + Inc(nReaded, SIZE_INTEGER); + + {$IFDEF DEBUG} + if _nTotalRcvLen > OVER_SIZE_PACKET then + begin + _nTotalRcvLen := _nTotalRcvLen + 0; + end; + {$ENDIF} + if _nTotalRcvLen > OVER_SIZE_PACKET then + begin + // 용량이 넘 크면 문제가 있다고 판단하고 넘김 + _PieceRcvLen := 0; + _nTotalRcvLen := 0; + _nRemainRcvLen := 0; + exit; + end; + + SetLength(_RcvBuffers, _nTotalRcvLen); + + if _nTotalRcvLen > (nBufferLen - nReaded) then + begin + CopyMemory(@_RcvBuffers[0], @pBuf[nReaded], nBufferLen - nReaded); + _nRemainRcvLen := _nTotalRcvLen - (nBufferLen - nReaded); + break; + end else begin + CopyMemory(@_RcvBuffers[0], @pBuf[nReaded], _nTotalRcvLen); + + ProcessRcvPacket; + + Inc(nReaded, _nTotalRcvLen); + end; + end; + end else begin + CopyMemory(@_RcvBuffers[_nTotalRcvLen-_nRemainRcvLen], @pBuf[0], nBufferLen); + Dec(_nRemainRcvLen, nBufferLen); + + if _nRemainRcvLen = 0 then + ProcessRcvPacket; + end; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. MakeRcvPacket()'); + end; +end; + +function TTgClientCtxBase.ReadyRecv: Boolean; +var + dwFlags, dwRecvLen: DWORD; +begin + Result := false; + + try + if Active then + begin + ZeroMemory(pRcvBuf_.Data.AllocBuf, MAX_BUF_LEN); + pRcvBuf_.Data.WSABuf.buf := pRcvBuf_.Data.AllocBuf; + pRcvBuf_.Data.WSABuf.len := MAX_BUF_LEN; + + pRcvBuf_.Data.SocketDataType := dtRcv; + + Lock; + try + if hSocket_ <> INVALID_SOCKET then + begin + dwFlags := 0; + Result := WSARecv(hSocket_, + @pRcvBuf_.Data.WSABuf, + 1, + dwRecvLen, + dwFlags, + @pRcvBuf_.Data.Overlapped, + nil) <> SOCKET_ERROR; + end else begin + Result := false; + exit; + end; + finally + Unlock; + end; + + if not Result then + Result := (WSAGetLastError = ERROR_IO_PENDING); + end; + except + // .. + end; +end; + +//function TTgClientCtxBase.ProcessSendBuf(pSendBuf: PSocketBuffer = nil): Boolean; +function TTgClientCtxBase.ProcessSendBuf: Boolean; +var + pBuf: PSocketBuffer; + bResult: Boolean; + nError: Integer; + dwFlags, + dwSendLen: DWORD; + nRemain: Integer; +begin + Result := false; + if not Active then + exit; + + Result := true; + + Lock; + try + nRemain := qSendWaitBuf_.Count; + if nRemain > 0 then + pBuf := qSendWaitBuf_.Dequeue + else + pBuf := nil; + finally + Unlock; + end; + + if pBuf <> nil then + begin +// _Trace('ProcessSendBuf() .. Do Send.. nRemain=%d, SendLen=%d', [nRemain, pBuf.Data.WSABuf.len]); + try + pBuf.bUseWSA := true; + AddSendBuf(pBuf); + + dwFlags := 0; + Lock; + try + if hSocket_ <> INVALID_SOCKET then + begin + bResult := WSASend(hSocket_, + @pBuf.Data.WSABuf, + 1, + dwSendLen, + dwFlags, + @pBuf.Data.Overlapped, + nil) <> SOCKET_ERROR; + end else exit; + finally + Unlock; + end; + + if not bResult then + begin + nError := WSAGetLastError; + case nError of + WSA_IO_PENDING : ; + WSAENOTSOCK, + WSAENETRESET, + WSAEDISCON, + WSAEBADF, + WSAEWOULDBLOCK, + WSAECONNRESET, + WSAECONNABORTED : + begin + RemoveSendBuf(pBuf); + Result := false; + + _Trace('TTgClientCtxBase >> Fail!! ProcessSendBuf().. WSASend() ... Close .. Error=%d, IP = %s', [nError, RemoteAddr]); + // Close; + exit; + end; + else + begin + RemoveSendBuf(pBuf); + Result := false; + if nSendFailCnt_ < 5 then + begin + // 5번까지 시도해준다. + _Trace('TTgClientCtxBase >> Fail!! ProcessSendBuf().. WSASend() >> Error=%d, IP = %s, FC=%d', [nError, RemoteAddr, nSendFailCnt_]); + Inc(nSendFailCnt_); + end else begin + _Trace('TTgClientCtxBase >> Fail!! ProcessSendBuf().. WSASend() ... Close- >> IP = %s', [RemoteAddr]); + // Close; + end; + exit; + end; + end; + end; + + if nSendFailCnt_ > 0 then + nSendFailCnt_ := 0; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. ProcessSendBuf()'); + end; + end; +end; + +function TTgClientCtxBase.SendPacket(Send: ISendPacket): Boolean; +var + nLen: Integer; + pBuf: PSocketBuffer; + pEncBuf, + pSendBuf: TSnBytes; + nPacketVer, nSendPieceDataPos: Integer; + CtxPacketHeader: TCtxPacketHeader; + bAbleSendEnc: Boolean; +begin + Result := false; + try + if Active then + begin + bAbleSendEnc := AbleSendEnc; + nPacketVer := wPktVer_; + + nLen := Send.ToBytesDataOnly(pSendBuf); + if nLen = 0 then + begin + {$IFDEF DEBUG} + ASSERT(false); + {$ELSE} + _Trace('TTgClientCtxBase >> Fail!! SendPacket().. no init buffer >> IP = %s', [RemoteAddr]); + {$ENDIF} + exit; + end; + + New(pBuf); + ZeroMemory(pBuf, LEN_SOCKET_BUF); + try + +// if nPacketVer > 0 then +// begin + nSendPieceDataPos := LEN_CTX_PACKET_HEADER; +// end else begin +// bAbleSendEnc := false; +// nSendPieceDataPos := 0; +// end; + + try + if not Active then + exit; + + // 암호화 처리 + if bAbleSendEnc then + begin + if Enc_ = nil then + begin + // {$IFDEF DEBUG} + // ASSERT(Enc_ <> nil, 'none.. encrypt obj ..'); + // {$ENDIF} + exit; + end; + + Lock; + try + pEncBuf := Enc_.EncryptBufferEx(pSendBuf, nLen); + case Enc_.EncKind of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc: + begin + // 패딩이 필요한 알고리즘의 경우, + // 패딩 길이도 들어가야해서 다시 계산. 18_0411 10:08:16 sunk + nLen := Length(pEncBuf); + end; + end; + finally + Unlock; + end; + + pBuf.Data.AllocBuf := AllocMem(LEN_CTX_PACKET_HEADER + nLen); + CopyMemory(Pointer(NativeUInt(pBuf.Data.AllocBuf) + nSendPieceDataPos), pEncBuf, nLen); + end else begin + pBuf.Data.AllocBuf := AllocMem(LEN_CTX_PACKET_HEADER + nLen); + CopyMemory(Pointer(NativeUInt(pBuf.Data.AllocBuf) + nSendPieceDataPos), pSendBuf, nLen); + end; + + // 패킷 헤더는 암호화 후 넣는걸로 변경 18_0411 11:38:23 sunk +// if nPacketVer > 0 then +// begin + // 패킷 버전별 헤더 도임 14_0610 11:18:13 sunk + // 패킷 버전 1 추가 - 서버 -> 클라이언트 헤더 도입 + // 패킷 버전 2 추가 - 클라이언트 -> 서버 헤더 도입 + ZeroMemory(@CtxPacketHeader, SizeOf(CtxPacketHeader)); + CopyMemory(@CtxPacketHeader.sSig[0], @CTX_PACKET_SIGNATURE[1], Length(CtxPacketHeader.sSig)); + CtxPacketHeader.dwId := dwSendCount_; + Inc(dwSendCount_); + if dwSendCount_ >= 400000000 then + dwSendCount_ := 0; + CtxPacketHeader.dwSize := nLen; + CopyMemory(pBuf.Data.AllocBuf, @CtxPacketHeader, LEN_CTX_PACKET_HEADER); +// end; + + pBuf.Data.WSABuf.buf := pBuf.Data.AllocBuf; + pBuf.Data.WSABuf.len := nLen + nSendPieceDataPos; + pBuf.Data.SocketDataType := dtSend; + + if not PushSendBuf(pBuf) then + begin + Result := false; + exit; + end; + finally + SetLength(pSendBuf, 0); + end; + Result := true; + finally + if not Result then + begin + FreeMem(pBuf.Data.AllocBuf); + Dispose(pBuf); + end; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'TTgClientCtxBase >> SendPacket() .. exception'); + // ETgException.TraceException(Self, ...) 이런식으로 쓰면 안된다 자신이 짤려서 AV로 여기 올때 다시 자신을 참조하면 아에 뻗음 16_1013 16:22:45 sunk + end; +end; + +// AES 알고리즘을 추가 하면서 문제가 생겼다. +// 패딩 때문인데 이 패딩으로 추가되는 크기는 헤더 생성 후에 나오기 때문에 +// 32k씩 잘라서 최초 헤더를 포함한 데이터가 쏘아지게 되면 뒤늦게 변경된 패딩 추가 크기를 +// 알릴 방법이 애매하다. +// 2013년 당시에 왜 이렇게 나눠서 보내게 했는지 기억나지 않지만 일단 변경후 상황을 지켜보기로 한다 18_0411 11:26:30 sunk + +// 이전 버전의 에이전트 업데이트를 위해 남겨둔다 18_0411 15:51:52 sunk +(* +function TTgClientCtxBase.Old_SendPacket_Until_1_2_3(Send: ISendPacket): Boolean; +var + nLen, + nPieceLen: Integer; + pBuf: PSocketBuffer; + pEncBuf, + pSendBuf, pSendBufPiece: TSnBytes; + nSend, nSended, + nPacketVer, nSendPieceDataPos: Integer; + CtxPacketHeader: TCtxPacketHeader; + bAbleSendEnc: Boolean; +begin + Result := false; + try + if Active then + begin + nPacketVer := GetPacketVersion; + case nPacketVer of + // 패킷 버전 1 추가 - 서버 -> 클라이언트 헤더 도입 14_0610 11:18:13 sunk + // 패킷 버전 2 추가 - 클라이언트 -> 서버 헤더 도입 14_0708 17:08:26 sunk + 1, 2, 3 : nLen := Send.ToBytesDataOnly(pSendBuf); + else + nLen := Send.ToBytes(pSendBuf); + end; + + if nLen = 0 then + begin + {$IFDEF DEBUG} + ASSERT(false); + {$ELSE} + _Trace('TTgClientCtxBase >> Fail!! Old_SendPacket_Until_1_2_3().. no init buffer >> IP = %s', [RemoteAddr]); + {$ENDIF} + exit; + end; + + if nPacketVer > 0 then + begin + // 패킷 버전별 헤더 도임 14_0610 11:18:13 sunk + // 패킷 버전 1 추가 - 서버 -> 클라이언트 헤더 도입 14_0610 11:18:13 sunk + // 패킷 버전 2 추가 - 클라이언트 -> 서버 헤더 도입 14_0708 17:08:26 sunk + ZeroMemory(@CtxPacketHeader, SizeOf(CtxPacketHeader)); + CopyMemory(@CtxPacketHeader.sSig[0], @CTX_PACKET_SIGNATURE[1], Length(CtxPacketHeader.sSig)); + CtxPacketHeader.dwId := dwSendCount_; + Inc(dwSendCount_); + if dwSendCount_ >= 400000000 then + dwSendCount_ := 0; + CtxPacketHeader.dwSize := nLen; + + SetLength(pSendBufPiece, BUFFER_SIZE + LEN_CTX_PACKET_HEADER); + CopyMemory(@pSendBufPiece[0], @CtxPacketHeader, LEN_CTX_PACKET_HEADER); + nSendPieceDataPos := LEN_CTX_PACKET_HEADER; + + // 암호화 정보 추가 14_0704 09:35:01 sunk + bAbleSendEnc := AbleSendEnc; + end else begin + bAbleSendEnc := false; + SetLength(pSendBufPiece, BUFFER_SIZE); + nSendPieceDataPos := 0; + end; + + try + // 32kb씩 잘라서 처리해준다. 13_0516 17:21 sunk + nSended := 0; + while nSended < nLen do + begin + if not Active then + break; + + nSend := nLen - nSended; + if nSend > BUFFER_SIZE then + nSend := BUFFER_SIZE; + + // 암호화 처리 추가 14_0704 11:23:48 sunk + if bAbleSendEnc then + begin + if Enc_ = nil then // 추가 16_0712 13:08:53 sunk + begin +// {$IFDEF DEBUG} +// ASSERT(Enc_ <> nil, 'none.. encrypt obj ..'); +// {$ENDIF} + exit; + end; + + Lock; + try + case Enc_.EncKind of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc: + begin + ASSERT(false, '패킷 버전 2 이하는 올수 없는 위치 입니다.'); + end; + end; + + pEncBuf := Enc_.EncryptBufferEx(@pSendBuf[nSended], nSend); // CryptBuffer() 리셋 옵션 사용 32kb 씩 암호화 리셋 한다.. 14_0704 18:31:12 sunk + finally + Unlock; + end; + + CopyMemory(@pSendBufPiece[nSendPieceDataPos], @pEncBuf[0], nSend); + end else + CopyMemory(@pSendBufPiece[nSendPieceDataPos], @pSendBuf[nSended], nSend); + + nPieceLen := nSend + nSendPieceDataPos; //Length(pSendBufPiece); + New(pBuf); + ZeroMemory(pBuf, LEN_SOCKET_BUF); +// SetLength(pBuf.Data.AllocBuf, nPieceLen); + pBuf.Data.AllocBuf := AllocMem(nPieceLen); + CopyMemory(pBuf.Data.AllocBuf, @pSendBufPiece[0], nPieceLen); + +// pBuf.Data.WSABuf.buf := @pSendBufPiece[0]; + pBuf.Data.WSABuf.buf := pBuf.Data.AllocBuf; + pBuf.Data.WSABuf.len := nPieceLen; //nSend + nSendPieceDataPos; + pBuf.Data.SocketDataType := dtSend; + + if not PushSendBuf(pBuf) then + begin +// SetLength(pBuf.Data.AllocBuf, 0); + FreeMem(pBuf, nPieceLen); + Dispose(pBuf); + Result := false; + exit; + end; + + Inc(nSended, nSend); + end; + finally + SetLength(pSendBufPiece, 0); + SetLength(pSendBuf, 0); + end; + Result := true; + end; + except + on E: Exception do + ETgException.TraceException(E, 'TTgClientCtxBase >> Old_SendPacket_Until_1_2_3() .. exception'); + + // ETgException.TraceException(Self, ...) 이런식으로 쓰면 안된다 자신이 짤려서 AV로 여기 올때 다시 자신을 참조하면 아에 뻗음 16_1013 16:22:45 sunk + end; +end; +*) + +{ TTgServerBase } + +Constructor TTgServerBase.Create(const nPort: Integer); +begin + Inherited Create(INVALID_SOCKET); + + CtxSendBufList_ := TList.Create; + CtxSendBufList_.OnNotify := OnCtxSendBufNotify; + +// llRcvWaitSize_ := 0; +// llSendWaitSize_ := 0; + + sIPAddr_ := ''; + SetPort(nPort); + hCompPort_ := 0; + wWorkThdCnt_ := 0; + sMakedPacketEncPass4Send_ := ''; + + evClientConnected_ := nil; + evClientDisconnected_ := nil; + +// QueueRcvPacket_ := TQueue.Create; + QueueRcvPacket_ := TQUeue.Create; + QueueSendPacket_ := TQueue.Create; + + DcClient_ := TDictionary.Create; + + ThdSvrAccept_ := nil; + ThdSvrLogic_ := nil; + ThdSvrLogic_ := nil; + ThdPingWorker_ := nil; + + WorkThreadList_ := TList.Create; + WorkThreadList_.OnNotify := OnWorkThreadNotify; + + SenderThreadList_ := TList.Create; + SenderThreadList_.OnNotify := OnWorkThreadNotify; + + sCutIpLogDir_ := ''; + sCutIpLogFName_ := ''; + CutIpList_ := TStringList.Create; +end; + +Destructor TTgServerBase.Destroy; +begin + SetActive(false); + + FreeAndNil(CutIpList_); + FreeAndNil(SenderThreadList_); + FreeAndNil(WorkThreadList_); + FreeAndNil(DcClient_); + FreeAndNil(QueueSendPacket_); + QueueRcvPacket_.OnNotify := OnRcvDataNotify; + FreeAndNil(QueueRcvPacket_); + + FreeAndNil(CtxSendBufList_); + + Inherited; +end; + +procedure TTgServerBase.OnCtxSendBufNotify(Sender: TObject; const Item: PSocketBuffer; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: + begin +// SetLength(Item.Data.AllocBuf, 0); + if (Item.Data.AllocBuf <> nil) and (Item.Data.WSABuf.len > 0) then + begin + FreeMem(Item.Data.AllocBuf, Item.Data.WSABuf.len); + Dispose(Item); + end; + end; + cnExtracted: ; + end; +end; + +procedure TTgServerBase.AddCtxSendBuf(pBuf: PSocketBuffer); +begin + Lock; + try + CtxSendBufList_.Add(pBuf); + finally + Unlock; + end; +end; + +procedure TTgServerBase.RemoveCtxSendBuf(pBuf: PSocketBuffer); +var + i: Integer; +begin + Lock; + try + i := CtxSendBufList_.IndexOf(pBuf); + if i <> -1 then + CtxSendBufList_.Delete(i); + finally + Unlock; + end; +end; + +procedure TTgServerBase.ClearCtxSendBuf; +begin + Lock; + try + CtxSendBufList_.Clear; + finally + Unlock; + end; +end; + +procedure TTgServerBase.OnClientNotify(Sender: TObject; const Item: TTgClientCtxBase; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Item.Free; + cnExtracted: ; + end; +end; + +procedure TTgServerBase.OnWorkThreadNotify(Sender: TObject; const Item: TThdSocket; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Item.Free; + cnExtracted: ; + end; +end; + +//procedure TTgServerBase.IncSendWaitSize(llSize: LONGLONG); +//begin +// Lock; +// try +// Inc(llSendWaitSize_, llSize); +// finally +// Unlock; +// end; +//end; +// +//procedure TTgServerBase.DecSendWaitSize(llSize: LONGLONG); +//begin +// Lock; +// try +// Dec(llSendWaitSize_, llSize); +// if llSendWaitSize_ < 0 then +// llSendWaitSize_ := 0; +// finally +// Unlock; +// end; +//end; + +procedure TTgServerBase.CloseClientCtx(aClientCtx: TTgClientCtxBase); +begin + if IsValidClient(aClientCtx) then + begin + try + PostQueuedCompletionStatus(hCompPort_, 0, NativeInt(aClientCtx), Pointer(STOP_WORK)); +// _RemoveClient(aClientCtx); + except + // + end; + end; +end; + +function TTgServerBase.CreateClientContext(aSocket: TSocket): TTgClientCtxBase; +begin + Result := TTgClientCtxBase.Create(Self, aSocket); +end; + +//function TTgServerBase.CheckAcceptBan(sIp: String): Boolean; +//begin +// +//end; + +function TTgServerBase.CheckCutIp(sIp: String): Boolean; +var + sLog, + sLogPath: String; + dtNow: TDateTime; +begin + Result := false; + + if (CutIpList_ <> nil) and (CutIpList_.Count > 0) then + begin + Result := CutIpList_.IndexOf(sIp) <> -1; + + try + if Result and (sCutIpLogDir_ <> '') and (sCutIpLogFName_ <> '') then + begin + dtNow := Now; + sLogPath := sCutIpLogDir_ + FormatDateTime('yyyy\mm\', dtNow); + if not DirectoryExists(sLogPath) then + if not ForceDirectories(sLogPath) then exit; + sLogPath := sLogPath + FormatDateTime('yy_mmdd ', dtNow) + sCutIpLogFName_; + sLog := FormatDateTime('[yyyy-mm-dd hh:nn:ss] ', Now) + Format('Cut - %s', [sIp]); + WriteLnFileEndUTF8(sLogPath, sLog); + end; + except + exit; + end; + end; +end; + +procedure TTgServerBase.LoadCutIpList; +var + sPath: String; +begin + sCutIpLogDir_ := ''; + sCutIpLogFName_ := ''; + CutIpList_.Clear; + + sPath := GetRunExePathDir + FILE_CUT_IPS; + if FileExists(sPath) then + begin + try + CutIpList_.LoadFromFile(sPath, TEncoding.UTF8); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. LoadCutIpList()'); + end; + end; +end; + +procedure TTgServerBase.SetActive(bVal: Boolean); +begin + if bActive_ <> bVal then + begin + bActive_ := bVal; + if not bActive_ then + begin + _Close; + + QueueSendPacket_.Clear; + QueueRcvPacket_.OnNotify := OnRcvDataNotify; + try + QueueRcvPacket_.Clear; + finally + QueueRcvPacket_.OnNotify := nil; + end; + dtActive_ := 0; + sIPAddr_ := ''; + +// Lock; +// try +// llRcvWaitSize_ := 0; +// llSendWaitSize_ := 0; +// finally +// Unlock; +// end; + + sCutIpLogDir_ := ''; + sCutIpLogFName_ := ''; + CutIpList_.Clear; + + _Trace('Server Active Off.'); + end else begin + LoadCutIpList; + + sIPAddr_ := GetHostIP; + _Open; + dtActive_ := now; + + _Trace('Server Active On.'); + end; + end; +end; + +procedure TTgServerBase.SetPort(const nPort: Integer); +begin + if bActive_ then + raise ECrmServer.Create('서버가 활성화 중입니다. 포트 설정을 할 수 없습니다.'); + + if nPort_ <> nPort then + nPort_ := nPort; +end; + +procedure TTgServerBase.ClientConnectedEvent(aClient: TTgClientCtxBase); +begin + if Assigned(evClientConnected_) then + evClientConnected_(Self, aClient); +end; + +procedure TTgServerBase.ClientDisconnectedEvent(aClient: TTgClientCtxBase); +begin + if Assigned(evClientDisconnected_) then + evClientDisconnected_(Self, aClient); +end; + +function TTgServerBase.IsValidClient(aClient: TTgClientCtxBase): Boolean; +begin + Lock; + try + Result := DcClient_.ContainsKey(aClient); + finally + UnLock; + end; +end; + +function TTgServerBase.GetClientEnumerator: TClientEnumerator; +begin + Lock; + try + Result := DcClient_.Values.GetEnumerator; + finally + Unlock + end; +end; + +function TTgServerBase.GetClientCount: Integer; +begin + Lock; + try + Result := DcClient_.Count; + finally + Unlock; + end; +end; + +function TTgServerBase.GetRcvWaitSize: LONGLONG; +begin + Lock; + try + Result := llRcvWaitSize_; + finally + Unlock; + end; +end; + +//function TTgServerBase.GetSendWaitSize: LONGLONG; +//begin +// Lock; +// try +// Result := llSendWaitSize_; +// finally +// Unlock; +// end; +//end; + +procedure TTgServerBase.SetPacketEncInfo(aPktEncKind: TTgEncKind; const sPktEncPass: String); +var + enc: TTgEncrypt; + sMakePass: String; + pBuf: TBytes; +begin + try + if Active then + raise ECrmServer.Create('서버가 활성화되어 있는 상태에서는 할 수 없습니다.'); + + Inherited; + + case aPktEncKind of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin + sMakePass := 'kwa' + sPktEncPass + '!7v*' + #0; + Guard(enc, TTgEncrypt.Create(ENC_PASSPASS, aPktEncKind)); + pBuf := enc.EncryptBufferEx(@sMakePass[1], Length(sMakePass) * 2); + sMakedPacketEncPass4Send_ := ConvBinToStr(@pBuf[0], Length(pBuf)); + end + else + sMakedPacketEncPass4Send_ := ''; + end; + except + on E: Exception do + ECrmServer.TraceException(Self, E, 'Fail .. SetPacketEncInfo'); + end; +end; + +procedure TTgServerBase.SendPacketEncConfirm(aCtx: TTgClientCtxBase); +var + Send: ISendPacket; + PktEncKind: TTgEncKind; +begin + try + if IsValidClient(aCtx) then + begin + PktEncKind := GetPktEncKind; + // if PktEncKind <> ekNone then // none 이어도 해당 패킷을 보내야 전송이 활성화 된다 18_0117 14:52:51 sunk + begin + Send := TTgPacket.Create(TOC_CONFIRM_PACKET_ENCRYPT); + Send.I['K'] := NativeInt(PktEncKind); + Send.I['SPV'] := PACKET_VERSION; + + aCtx.SendPacket(Send); + end; + end; + except + on E: Exception do + ECrmServer.TraceException(Self, E, 'Fail .. SendPacketEncConfirm()'); + end; +end; + +procedure TTgServerBase.SendPacketEncInfo(aCtx: TTgClientCtxBase); +var + Send: ISendPacket; + PktEncKind: TTgEncKind; +begin + try + if IsValidClient(aCtx) then + begin + PktEncKind := GetPktEncKind; + // if PktEncKind <> ekNone then + begin + Send := TTgPacket.Create(TOC_UPDATE_PACKET_ENCRYPT); + Send.I['K'] := NativeInt(PktEncKind); + Send.S['J'] := sMakedPacketEncPass4Send_; + aCtx.SendPacket(Send); + end; + aCtx.bSendPktEncInfo_ := true; + end; + except + on E: Exception do + ECrmServer.TraceException(Self, E, 'Fail .. SendPacketEncInfo'); + end; +end; + +procedure TTgServerBase.ProcessTossFail(aCtx: TTgClientCtxBase; aRcv: IRcvPacket); +begin + // 토스 실패.. +end; + +procedure TTgServerBase.ProcessRcvPacket(aCtx: TTgClientCtxBase; aRcv: IRcvPacket); + + procedure process_TOC_CLIENT_INFO; + begin + with aCtx.ClientInfo_, aRcv do + begin + nType := I['Type']; + sVer := S['Ver']; + sComName := S['ComName']; + sAccount := S['Account']; + sWinVer := S['WinVer']; + BootDT := D['BootDT']; + sIpRAddr := S['rIP']; + sIpAddr := aCtx.RemoteAddr; + sMacAddr := S['MacAddr']; + sMacAddrs := S['MacAddrs']; + ConnDT := Now; + end; + SendPacketEncConfirm(aCtx); + ProcessClientConnection(aCtx); + end; + + procedure process_TOC_CONFIRM_PACKET_ENCRYPT; + var + EncKind: TTgEncKind; + begin + EncKind := TTgEncKind(aRcv.I['K']); + aCtx.wPktVer_ := aRcv.I['CPV']; + SendPacketEncInfo(aCtx); + if EncKind <> ekNone then + begin + // send 암호화 설정 + aCtx.AbleSendEnc := true; + aCtx.SetPacketEncInfo(EncKind, GetPktEncPass); + end; + end; + + procedure process_TOC_UPDATE_PACKET_ENCRYPT; + begin + Lock; + try + {$IFDEF DEBUG} + ASSERT(Enc_ <> nil, 'no enc obj...'); + {$ELSE} + if Enc_ = nil then + begin + // 이렇게 되면 정상이 아닌데... + // 테스트 중에 이런 현상이 있어서 아래처럼 보완 처리 14_0708 09:26:40 sunk + aCtx.AbleSendEnc := true; + aCtx.SetPacketEncInfo(GetPktEncKind, GetPktEncPass); + end; + {$ENDIF} + finally + Unlock; + end; + // rcv 복호화 설정 + aCtx.AbleRcvDec := true; + end; + + procedure process_TOC_REQUEST_CONFIRM_PACKET_ENCRYPT; + begin + SendPacketEncConfirm(aCtx); + end; + +begin + try + if not IsValidClient(aCtx) then + exit; + + case aRcv.Command of + TOC_CLIENT_INFO : process_TOC_CLIENT_INFO; + TOC_CONFIRM_PACKET_ENCRYPT : process_TOC_CONFIRM_PACKET_ENCRYPT; + TOC_UPDATE_PACKET_ENCRYPT : process_TOC_UPDATE_PACKET_ENCRYPT; + TOC_REQUEST_CONFIRM_PACKET_ENCRYPT : process_TOC_REQUEST_CONFIRM_PACKET_ENCRYPT; + end; + except + on E: Exception do + ECrmServer.TraceException(Self, E, Format('ProcessRcvPacket() .. Cmd = %d', [aRcv.Command])); + end; +end; + +procedure TTgServerBase.ProcessFileQueuePacket(aCtx: TTgClientCtxBase; aRcv: IRcvPacket); +begin + // +end; + +procedure TTgServerBase.ProcessFileQueuePacket(aCtx: TTgClientCtxBase; pRcvBuf: Pointer; pRcvLen: Integer); +begin +// +end; + +procedure TTgServerBase.PushClientClose(aCtx: TTgClientCtxBase); +begin + ThdClientClose_.PushCloseCtx(aCtx); +end; + +procedure TTgServerBase._RegisterClient(aClient: TTgClientCtxBase); +begin + {$IFDEF DEBUG2} _Trace('_RegisterClient() .. '); {$ENDIF} + if IsValidClient(aClient) then + exit; + + {$IFDEF DEBUG2} _Trace('_RegisterClient() .. 1'); {$ENDIF} + Lock; + try + DcClient_.Add(aClient, aClient); + + // 소켓을 위한 윈도우 메세지와 처리 할 네트워크 이벤트 등록 2011-09-09 sunk + + // FD_ACCEPT 클라이언트가 접속하면 윈도우 메시지를 발생시킨다. + // FD_READ 데이터 수신이 가능하면 윈도우 메시지를 발생시킨다. + // FD_WRITE 데이터 송신이 가능하면 윈도우 메시지를 발생시킨다. + // FS_CLOSE 상대가 접속을 종료하면 윈도우 메시지를 발생시킨다. + // FS_CONNECT 접속이 완료되면 윈도우 메시지를 발생시킨다. +// WSAAsyncSelect(aSocket.SocketHandle, hSocket_, WM_SOCKET_CLOSE, FD_CLOSE); + finally + Unlock; + end; + {$IFDEF DEBUG2} _Trace('_RegisterClient() .. 2'); {$ENDIF} + + ClientConnectedEvent(aClient); + {$IFDEF DEBUG2} _Trace('_RegisterClient() .. 3'); {$ENDIF} +end; + +procedure TTgServerBase._RemoveClient(aClient: TTgClientCtxBase); +begin + if not IsValidClient(aClient) then + exit; + + Lock; + try + DcClient_.Remove(aClient); + finally + UnLock; + end; + + if not Assigned(DcClient_.OnValueNotify) then + begin + ClientDisconnectedEvent(aClient); +// FreeAndNil(aClient); ThdFreeCloseCtx 에서 처리 19_0905 08:51:10 sunk + end; +end; + +procedure TTgServerBase._Open; + + procedure CreateWorkThread; + var + i: Integer; + SystemInfo: TSystemInfo; + begin + GetSystemInfo(SystemInfo); + wWorkThdCnt_ := SystemInfo.dwNumberOfProcessors * 2; + ASSERT(wWorkThdCnt_ > 0); + + ThdSvrLogic_ := TThdServerLogic.Create(Self); + + for i := 0 to wWorkThdCnt_ - 1 do + WorkThreadList_.Add(TThdServerWork.Create(Self)); + +// for i := 0 to (SystemInfo.dwNumberOfProcessors * 2) - 1 do +// SenderThreadList_.Add(TThdServerSender.Create(Self)); + + ThdPingWorker_ := TThdPingWorker.Create(Self); + end; + +var + nLen: Integer; + +begin + try + ClearCtxSendBuf; + hCompPort_ := CreateIoCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0); + if hCompPort_ = 0 then + begin + {$IFDEF DEBUG} + ASSERT(false); + {$ENDIF} + nLastError_ := GetLastError; + _Trace('TTgServerBase._Open() >> CreateIoCompletionPort() > %s, ErrorCode = %d', + [SysErrorMessage(GetLastError), nLastError_]); + raise ECrmSocket.CreateFmt('%s, Error = %d', [SysErrorMessage(GetLastError), nLastError_]); + end; + + CreateWorkThread; + + hSocket_ := WSASocket(PF_INET, SOCK_STREAM, 0, nil, 0, WSA_FLAG_OVERLAPPED); + if hSocket_ = INVALID_SOCKET then + begin + {$IFDEF DEBUG} + ASSERT(false); + {$ENDIF} + nLastError_ := GetLastError; + _Trace('TTgServerBase._Open() >> WSASocket() > %s, ErrorCode = %d', + [SysErrorMessage(GetLastError), nLastError_]); + raise ECrmSocket.CreateFmt('%s, Error = %d', [SysErrorMessage(GetLastError), nLastError_]); + end; + + nRcvBufSize_ := -1; + nSendBufSize_ := -1; + nLen := SizeOf(nRcvBufSize_); + +// nRcvBufSize_ := 32768; +// nSendBufSize_ := 32768; +// setsockopt(hSocket_, SOL_SOCKET, nSendBufSize_, @nRcvBufSize_, nLen); + + getsockopt(hSocket_, SOL_SOCKET, SO_RCVBUF, @nRcvBufSize_, nLen); + getsockopt(hSocket_, SOL_SOCKET, SO_SNDBUF, @nSendBufSize_, nLen); + + ZeroMemory(@SockAddr_, SizeOf(SockAddr_)); + with TSockAddrIn(SockAddr_) do + begin + sin_family := AF_INET; + sin_port := htons(nPort_); + sin_addr.S_addr := INADDR_ANY; + end; + _Check_WSAGetLastError(bind(hSocket_, SockAddr_, SizeOf(SockAddr_)), 'bind'); + _Check_WSAGetLastError(listen(hSocket_, SOMAXCONN), 'listen'); + + ThdClientClose_ := TThdClientClose.Create(Self); + ThdSvrAccept_ := TThdServerAccept.Create(Self); + except + _Close; + raise; + end; +end; + +procedure TTgServerBase._Close; +begin + if hCompPort_ <> 0 then + begin + PostQueuedCompletionStatus(hCompPort_, 0, 0, Pointer(STOP_WORK)); + CloseHandle(hCompPort_); + hCompPort_ := 0; + Sleep(2000); + end; + + if hSocket_ <> INVALID_SOCKET then + begin + closesocket(hSocket_); + hSocket_ := INVALID_SOCKET; + end; + + if Assigned(ThdPingWorker_) then + begin + ThdPingWorker_.StopThread; + FreeAndNil(ThdPingWorker_); + end; + + WorkThreadList_.Clear; + + if Assigned(ThdSvrLogic_) then + begin + ThdSvrLogic_.StopThread; + FreeAndNil(ThdSvrLogic_); + end; + +// if Assigned(ThdServerSendWork_) then +// begin +// ThdServerSendWork_.StopThread; +// FreeAndNil(ThdServerSendWork_); +// end; + + if Assigned(ThdSvrAccept_) then + begin + ThdSvrAccept_.StopThread; + FreeAndNil(ThdSvrAccept_); + end; + + if Assigned(ThdClientClose_) then + begin + ThdClientClose_.StopThread; + FreeAndNil(ThdClientClose_); + end; + + DcClient_.OnValueNotify := OnClientNotify; + try + DcClient_.Clear; + finally + DcClient_.OnValueNotify := nil; + end; + + ClearCtxSendBuf; +end; + +procedure TTgServerBase._Accept; +var + hClientSocket: TSocket; + SockAddr: TSockAddr; +// hClientWinSocket: TSocket; + aCtx: TTgClientCtxBase; + nSockAddrLen: Integer; + + + function CheckCut: Boolean; + var + SockAddrIn: TSockAddr; + nSize: Integer; + begin + Result := false; + + try + nSize := SizeOf(SockAddrIn); + _Check_WSAGetLastError(getpeername(hClientSocket, SockAddrIn, nSize), 'getpeername'); + // sIpAddr := String(inet_ntoa(TSockAddrIn(SockAddrIn).sin_addr)); + // if sIpAddr = '192.168.99.99' then + // Result := true; + + Result := CheckCutIp(inet_ntoa(TSockAddrIn(SockAddrIn).sin_addr)); + except + exit; + end; + end; + + procedure CloseClientContext; + begin + if Assigned(aCtx) then + begin + {$IFDEF DEBUG2} _Trace('_Accept() .. CloseClientContext()'); {$ENDIF} +// ThdServerDisconnWork_.EnqDisconnCtx(aCtx); + _RemoveClient(aCtx); + end else + if hClientSocket <> INVALID_SOCKET then + closesocket(hClientSocket); + end; + +begin + if (Handle = INVALID_SOCKET) or (hCompPort_ = 0) then + exit; + + nSockAddrLen := SizeOf(SockAddr); + hClientSocket := Winapi.Winsock2.accept(Handle, @SockAddr, @nSockAddrLen); + if hClientSocket <> INVALID_SOCKET then + begin + if not bActive_ or CheckCut then + begin + closesocket(hClientSocket); + exit; + end; + aCtx := nil; + try + {$IFDEF DEBUG2} _Trace('_Accept() .. 1'); {$ENDIF} + aCtx := CreateClientContext(hClientSocket); + {$IFDEF DEBUG2} _Trace('_Accept() .. 2'); {$ENDIF} + if CreateIoCompletionPort(hClientSocket, hCompPort_, DWORD(aCtx), 0) = 0 then + begin + CloseClientContext; + exit; + end; + {$IFDEF DEBUG2} _Trace('_Accept() .. 3'); {$ENDIF} + except + CloseClientContext; + end; + end; +end; + +procedure TTgServerBase._QueueRcvPacket(pRcvData: PRcvPktData); +begin + Lock; + try + Inc(llRcvWaitSize_, pRcvData.nLen); + QueueRcvPacket_.Enqueue(pRcvData); + finally + Unlock; + end; +end; + +function TTgServerBase._DequeueRcvPacket: PRcvPktData; +begin + Result := nil; + Lock; + try + if QueueRcvPacket_.Count > 0 then + Result := QueueRcvPacket_.Dequeue; + + if Result <> nil then + begin + if llRcvWaitSize_ >= Result.nLen then + Dec(llRcvWaitSize_, Result.nLen) + else + llRcvWaitSize_ := 0; + end else + llRcvWaitSize_ := 0; + finally + Unlock; + end; +end; + +procedure TTgServerBase.OnRcvDataNotify(Sender: TObject; const Item: PRcvPktData; Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: + begin + FreeMem(Item.pData); + Dispose(Item); + end; + cnExtracted: ; + end; +end; + +procedure TTgServerBase.QueueSendPacket(SendPacket: ISendPacket); +begin + Lock; + try + QueueSendPacket_.Enqueue(SendPacket); + finally + Unlock; + end; +end; + +function TTgServerBase._DequeueSendPacket: ISendPacket; +begin + Result := nil; + Lock; + try + if QueueSendPacket_.Count > 0 then + begin + Result := QueueSendPacket_.Dequeue; + end; + finally + Unlock; + end; +end; + +procedure TTgServerBase._ProcessTossPacket(aCtx: TTgClientCtxBase; RcvPacket: IRcvPacket); +var + SendCtx: TTgClientCtxBase; + Send: ISendPacket; +begin + SendCtx := TTgClientCtxBase(RcvPacket.Toss); + if IsValidClient(SendCtx) then + begin + Send := TTgPacket.Create(RcvPacket); + Send.Toss := LONGLONG(aCtx); +// Send.Socket := ClientContext; +// _QueueSendPacket(Send); + SendCtx.SendPacket(Send); + end else + ProcessTossFail(aCtx, RcvPacket); +end; + +{ TThdSocket } + +Constructor TThdSocket.Create(aServer: TTgServerBase); +begin + Server_ := aServer; + Inherited Create; + StartThread; +end; + +{ TThdAccept } + +procedure TThdServerAccept.Execute; +begin + while not Terminated and not bWorkStop_ do + begin + if Server_.Active then + begin + Server_._Accept; + end else + Sleep(50); + end; +end; + +{ TThdServerWork } + +procedure TThdServerWork.Execute; +var + nvClient: NativeUInt; + dwTransfered: DWORD; + pSocketBuf: PSocketBuffer; + aCtx: TTgClientCtxBase; +// RcvPacket: IRcvPacket; + bProcDisconnect: Boolean; + + procedure ProcessDisconnected(n: Integer); + begin + try + if Server_.IsValidClient(aCtx) then + Server_.PushClientClose(aCtx); + except + //.. + end; + end; + +begin + while not Terminated and not bWorkStop_ and Server_.Active do + if Server_.CompletionPort <> 0 then + begin + nvClient := 0; + if not GetQueuedCompletionStatus(Server_.CompletionPort, + dwTransfered, + nvClient, + POVERLAPPED(pSocketBuf), + INFINITE) then + begin + if (GetLastError <> $40) or (nvClient <> 0) then + begin +// aCtx := TTgClientCtxBase(nvClient); + ProcessDisconnected(1); + Server_.RemoveCtxSendBuf(pSocketBuf); + end; + continue; + end; + + aCtx := TTgClientCtxBase(nvClient); + + if DWORD(pSocketBuf) = STOP_WORK then + begin + if nvClient = 0 then + begin + // 서버 active off + break; + end else begin + // 클라이언트 접속 종료 + ProcessDisconnected(2); + continue; + end; + end; + + if not Server_.Active then + break; + + if dwTransfered = 0 then + begin + ProcessDisconnected(3); + continue; + end; + + if pSocketBuf = nil then + begin + {$IFDEF DEBUG} + if GetLastError <> $40 then + ASSERT(false); + {$ENDIF} + ProcessDisconnected(4); + continue; + end; + + bProcDisconnect := false; + try + if not Server_.IsValidClient(aCtx) then + continue; + + try + try + case pSocketBuf.Data.SocketDataType of + dtRcv : + begin + aCtx.UpdateLastRcvTime; + aCtx.MakeRcvPacket(dwTransfered); + + if not aCtx.ReadyRecv then + begin + {$IFDEF DEBUG2} _Trace('Fail .. aCtx.ReadyRecv()'); {$ENDIF} + bProcDisconnect := true; + continue; + end; + end; + dtSend : + begin + aCtx.RemoveSendBuf(pSocketBuf); + if not aCtx.ProcessSendBuf then + begin + {$IFDEF DEBUG2} _Trace('Fail .. aCtx.ProcessSendBuf()'); {$ENDIF} + bProcDisconnect := true; + continue; + end; + end; + else ASSERT(false); + end; + except + on E: Exception do + begin + bProcDisconnect := true; + continue; + end; + end; + finally + if bProcDisconnect then + begin + ProcessDisconnected(5); + end; + end; + except + continue; + end; + end else Sleep(500); +end; + +{ TThdClientClose } + +Constructor TThdClientClose.Create(aServer: TTgServerBase); +begin + Inherited Create(aServer); + DcCloseCtx_ := TDictionary.Create; + qCloseCtx_ := TQueue.Create; + qCloseCtx_.OnNotify := OnQCtxNotify; +end; + +Destructor TThdClientClose.Destroy; +begin + FreeAndNIl(qCloseCtx_); + DcCloseCtx_.OnValueNotify := OnDCtxNotify; + FreeAndNil(DcCloseCtx_); + Inherited; +end; + +procedure TThdClientClose.OnQCtxNotify(Sender: TObject; const Item: TTgClientCtxBase; + Action: TCollectionNotification); +begin + case Action of + cnAdded : + begin + if not DcCloseCtx_.ContainsKey(Item) then + DcCloseCtx_.Add(Item, Item); + end; + cnRemoved : ; + cnExtracted : ; + end; +end; + +procedure TThdClientClose.OnDCtxNotify(Sender: TObject; const Item: TTgClientCtxBase; + Action: TCollectionNotification); +begin + case Action of + cnAdded : ; + cnRemoved : Item.Free; + cnExtracted : ; + end; +end; + +procedure TThdClientClose.PushCloseCtx(aCtx: TTgClientCtxBase); +var + bAdd: Boolean; +begin + try + bAdd := false; + Lock; + try + if not DcCloseCtx_.ContainsKey(aCtx) then + begin + bAdd := true; + qCloseCtx_.Enqueue(aCtx); + end; + finally + Unlock; + end; + + if bAdd then + begin + {$IFDEF DEBUG2} _Trace('PushCloseCtx() .. Add FreeCtx., Ptr=%d', [NativeUInt(aCtx)]); {$ENDIF} + Server_._RemoveClient(aCtx); + aCtx.Close; + aCtx.UpdateLastRcvTime; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. PushCloseCtx()'); + end; +end; + +procedure TThdClientClose.Execute; +const + FREE_WAIT_SEC = 180; +var + FreeCtx: TTgClientCtxBase; + wStep: WORD; +begin + while not Terminated and not WorkStop do + begin + wStep := 0; + try + Lock; + try + if qCloseCtx_.Count > 0 then + FreeCtx := qCloseCtx_.Dequeue + else + FreeCtx := nil; + finally + Unlock; + end; + + wStep := 1; + + if FreeCtx <> nil then + begin + wStep := 2; + if SecondsBetween(FreeCtx.LastRcvTime, Now) < FREE_WAIT_SEC then + begin + wStep := 3; + Lock; + try + qCloseCtx_.Enqueue(FreeCtx); + finally + Unlock; + end; + Sleep(100); + end else begin + wStep := 4; + Lock; + try + DcCloseCtx_.Remove(FreeCtx); + finally + Unlock; + end; + wStep := 5; + + FreeAndNil(FreeCtx); + end; + end else Sleep(500); + + wStep := 6; + except + on E: Exception do + ETgException.TraceException(Self, E, Format('Fail .. Execute(), Step=%d', [wStep])); + end; + end; +end; + +{ TThdServerLogic } + +Constructor TThdServerLogic.Create(aServer: TTgServerBase); +begin + Inherited Create(aServer); + Priority := tpTimeCritical; +end; + +procedure TThdServerLogic.Execute; +var + Rcv: IRcvPacket; + pRcvData: PRcvPktData; +begin + while not Terminated and not bWorkStop_ and Server_.Active do + begin + try + pRcvData := Server_._DequeueRcvPacket; + if pRcvData <> nil then + begin + case pRcvData.PacketKind of + pkNormal : + try + Rcv := TTgPacket.Create(pRcvData.Ctx, pRcvData.pData, pRcvData.nLen); + if Rcv.Toss = 0 then + Server_.ProcessRcvPacket(pRcvData.Ctx, Rcv) + else + Server_._ProcessTossPacket(pRcvData.Ctx, Rcv); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Normal packet - fail ..'); + end; + pkFileQueue : + try + Server_.ProcessFileQueuePacket(pRcvData.Ctx, pRcvData.pData, pRcvData.nLen); + except + on E: Exception do + ETgException.TraceException(Self, E, 'FileQueue packet - fail ..'); + end; + end; + FreeMem(pRcvData.pData); + Dispose(pRcvData); + end else Sleep(10); + except + on E: Exception do + begin + ETgException.TraceException(Self, E, 'Fail .. Execute()'); + Sleep(1000); + end; + end; + end; +end; + +{ TThdPingWorker } + +Constructor TThdPingWorker.Create(aServer: TTgServerBase); +begin + Inherited Create; + Server_ := aServer; + StartThread; +end; + +procedure TThdPingWorker.Execute; +const + PING_CYCLE = 120; +var + dwTick: DWORD; + enum: TClientEnumerator; + dtNow: TDateTime; + Ctx: TTgClientCtxBase; +begin + dwTick := GetTickCount; + + while not Terminated and not WorkStop do + begin + Sleep(100); + + try + if ((GetTickCount - dwTick) div 1000) > 60 then + begin + dtNow := Now; + + Guard(enum, Server_.GetClientEnumerator); + + while enum.MoveNext do + begin + try + if not Server_.IsValidClient(enum.Current) then + break; + + if not (enum.Current is TTgClientCtxBase) then + begin + {$IFDEF DEBUG} + ASSERT(false, 'Invalid Ctx ...'); + {$ELSE} + _Trace('Execute() .. Invalid Ctx ...'); + {$ENDIF} + continue; + end; + + Ctx := TTgClientCtxBase(enum.Current); + if not Ctx.bSendPktEncInfo_ and + (SecondsBetween(Ctx.dtCreate_, dtNow) > 600) then + begin + // 패킷 전송 처리 시간 체크 후 종료 처리 + Server_.CloseClientCtx(Ctx); + _Trace('Execute() .. Close old connection .. (NoSendPktEncInfo)'); + end else + if SecondsBetween(Ctx.LastRcvTime, dtNow) > PING_CYCLE then + begin + if Server_.IsValidClient(Ctx) then + begin + if Ctx.ClientInfo_.nType = 0 then + Server_.CloseClientCtx(Ctx) + else + Ctx.SendPacket(TTgPacket.Create(TOC_PING)); + end; + end; + except + break; + end; + end; + + dwTick := GetTickCount; + end; + except + Sleep(1000); + dwTick := GetTickCount; + continue; + end; + end; +end; + +Initialization + if not Assigned(_CS) then + _CS := TCriticalSection.Create; + +Finalization + if Assigned(_CS) then + FreeAndNil(_CS); + +end. diff --git a/Tocsg.Lib/VCL/CS/Tocsg.StoredPacket.pas b/Tocsg.Lib/VCL/CS/Tocsg.StoredPacket.pas new file mode 100644 index 00000000..401527cc --- /dev/null +++ b/Tocsg.Lib/VCL/CS/Tocsg.StoredPacket.pas @@ -0,0 +1,1194 @@ +{*******************************************************} +{ } +{ Tocsg.StoredPacket } +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.StoredPacket; + +interface + +uses + SysUtils, Classes, SyncObjs, Tocsg.Encrypt, Tocsg.Obj, Tocsg.Packet, + Winapi.Windows, Tocsg.Exception, System.Generics.Collections; + +const + SIGN_KKU48 = $9748; + VER_SOTRED = 'StdPkt-v1.2'; + MAX_DATA_SIZE = 2147483648;//2 * 1024 * 1024 * 1024; + + PASS_ENC = 'QT8$4oci2!.QpdlQzd23ds9'; + + TASK_UNKNOWN = $00; + TASK_SAVE = $01; + TASK_LOAD = $02; + TASK_DESTROY = $03; + TASK_SAVE_FULL = $04; + +type + THeaderStored = packed record + sVer : array [0..19] of AnsiChar; + llMaxSize, + llTotalEntry, + llProcssOffset : LONGLONG; + dwTaskType : DWORD; + wEncType : WORD; + ucReserve : array [0..459] of Byte; + wSign : WORD; + end; + +const + OFFSET_MAX_SIZE = 20; + OFFSET_TOTAL_ENTRY = OFFSET_MAX_SIZE + SizeOf(LONGLONG); + OFFSET_PROC_OFFSET = OFFSET_TOTAL_ENTRY + SizeOf(LONGLONG); + OFFSET_TASK_TYPE = OFFSET_PROC_OFFSET + SizeOf(LONGLONG); + +type + ECrmStoredPacket = class(ETgException); + TStdPacketBase = class(TTgObject) + private + sFName_: String; + protected + Enc_: TTgEncrypt; + fs_: TFileStream; + Header_: THeaderStored; + + procedure LoadStoredHeader; + procedure SetTaskType(dwTaskType: DWORD); + function GetTaskType: DWORD; + function GetStoredSize: LONGLONG; + function GetEntryCount: LONGLONG; + + procedure IncEntry; + procedure DecEntry; + + function GetRemainSize: LONGLONG; + function GetFileSize: LONGLONG; + public + Constructor Create(const sFileName: String); + Destructor Destroy; override; + + property FileName: String read sFName_; + property FileSize: LONGLONG read GetFileSize; + property TaskType: DWORD read GetTaskType write SetTaskType; + property StoredSize: LONGLONG read GetStoredSize; + property TotalEntry: LONGLONG read GetEntryCount; + property LastError: Integer read nLastError_; + end; + + ESavePacekt = class(ECrmStoredPacket); + TSavePacket = class(TStdPacketBase) + protected + procedure InitStoredHeader(llMaxSize: LONGLONG; dwTaskType: DWORD; aEncKind: TTgEncKind; wSign: WORD); + public + Constructor Create(const sFileName: String; llMaxSize: LONGLONG = MAX_DATA_SIZE; + EncAlgorithm: TTgEncKind = ekNone; bSaveFileHideSystem: Boolean = false); + + procedure PushPacketBuf(aBuf: TBytes); overload; virtual; + procedure PushPacketBuf(aBuf: Pointer; nLen: Integer); overload; virtual; + end; + + TLoadPacket = class(TStdPacketBase) + public + Constructor Create(const sFileName: String; bInitLoad: Boolean = true); + + procedure InitLoadHeader; + + function PopPacketBuf: TBytes; virtual; + + property RemainSize: LONGLONG read GetRemainSize; + end; + + TTgStoredPacket = class(TTgObject) + private + sFNameH_, + sSaveFN_, + sLoadFN_: String; + + SavePacket_: TSavePacket; + LoadPacket_: TLoadPacket; + + bBlockMaxSize_: Boolean; // 최대 크기 이후 저장 하지 않음 + ullMaxSize_, // 최대 저장 크기 추가 + ullSegmentSize_: ULONGLONG; + EncAlgorithm_: TTgEncKind; + bSaveFileHideSystem_: Boolean; // 파일 저장 시 숨김, 시스템 속성 추가 22_0124 14:58:09 sunk + + function _CreateStoredSave: TSavePacket; + function _CreateStoredLoad: TLoadPacket; + + procedure SetSavePacketTaskType(dwTaskType: DWORD); + procedure SetMaxSize(ullMaxSize: ULONGLONG); + procedure SetSegmentSize(ullSegmentSize: ULONGLONG); + function GetStoredSavePath: String; + function GetStoredLoadPath: String; + public + Constructor Create(const sSaveFN: String; EncAlgorithm: TTgEncKind = ekNone); + Destructor Destroy; override; + + procedure PushPacket(aPacket: ITgPacket); overload; + procedure PushPacket(pPktBuf: TBytes); overload; + procedure PushPacket(pPktBuf: Pointer; nLen: Integer); overload; + procedure PushPacket(sPacket: UTF8String); overload; + function PopPacketStr: String; + function PopPacket: ITgPacket; + + function GetFirstStoredPath: String; + + procedure SafeFreeSaveStored(const sPath: String; dwTaskType: DWORD); + + property MaxSize: ULONGLONG read ullMaxSize_ write SetMaxSize; + property SegSize: ULONGLONG read ullSegmentSize_ write SetSegmentSize; + property SavePacketTaskType: DWORD write SetSavePacketTaskType; + property StoredSavePath: String read GetStoredSavePath; + property StoredLoadPath: String read GetStoredLoadPath; + property SaveFileAttrHideSystem: Boolean write bSaveFileHideSystem_; + property IsBlockMaxSize: Boolean write bBlockMaxSize_; + end; + +// 미러링 기능 추가 때문에 작성 + PSpmEnt = ^TSpmEnt; + TSpmEnt = record + sSaveFN: String; + SavePacket: TSavePacket; + end; + TSpmEntList = TList; + + TTgStoredPacketMirror = class(TTgObject) + private + SpmEntList_: TSpmEntList; + + ullSegmentSize_: ULONGLONG; + EncAlgorithm_: TTgEncKind; + bSaveFileHideSystem_: Boolean; // 파일 저장 시 숨김, 시스템 속성 추가 + + procedure OnSpmEntNotify(Sender: TObject; const Item: PSpmEnt; Action: TCollectionNotification); + function _CreateStoredSave(sSaveFN: String): TSavePacket; + procedure SetSegmentSize(ullSegmentSize: ULONGLONG); + function GetSegmentSize: ULONGLONG; + public + Constructor Create(sPaths, sFName: String; EncAlgorithm: TTgEncKind = ekNone); + Destructor Destroy; override; + + procedure PushPacket(aPacket: ITgPacket); overload; + procedure PushPacket(pPktBuf: TBytes); overload; + procedure PushPacket(pPktBuf: Pointer; nLen: Integer); overload; + + property SegmentSize: ULONGLONG read GetSegmentSize write SetSegmentSize; + property SaveFileAttrHideSystem: Boolean write bSaveFileHideSystem_; + end; + +implementation + +uses + Tocsg.Safe, Tocsg.Strings, Tocsg.Files, System.Math; + +{ TStdPacketBase } + +Constructor TStdPacketBase.Create(const sFileName: String); +begin + Inherited Create; + + Enc_ := TTgEncrypt.Create(PASS_ENC, ekNone); + + ZeroMemory(@Header_, SizeOf(Header_)); + + nLastError_ := 0; + sFName_ := sFileName; + fs_ := nil; +end; + +Destructor TStdPacketBase.Destroy; +begin + if Assigned(fs_) then + FreeAndNil(fs_); + + if Header_.dwTaskType = TASK_DESTROY then + DeleteFile(PChar(sFName_)); + + FreeAndNil(Enc_); + + Inherited; +end; + +procedure TStdPacketBase.LoadStoredHeader; +begin + try + if Assigned(fs_) then + begin + ZeroMemory(@Header_, SizeOf(Header_)); + fs_.Position := 0; + fs_.Read(Header_, SizeOf(Header_)); + + Enc_.EncKind := TTgEncKind(Header_.wEncType); + end; + except + on E: Exception do + ESavePacekt.TraceException(Self, E, 'Fail .. LoadStoredHeader()'); + end; +end; + +procedure TStdPacketBase.SetTaskType(dwTaskType: DWORD); +var + ll: LONGLONG; +begin + try + if Assigned(fs_) and (Header_.dwTaskType <> dwTaskType) then + begin + ll := fs_.Position; + fs_.Position := OFFSET_TASK_TYPE; + try + Header_.dwTaskType := dwTaskType; + fs_.Write(Header_.dwTaskType, SizeOf(Header_.dwTaskType)); + // FlushFileBuffers(fs_.Handle); + finally + fs_.Position := ll; + end; + end; + except + on E: Exception do + ESavePacekt.TraceException(Self, E, 'Fail .. SetTaskType()'); + end; +end; + +function TStdPacketBase.GetTaskType: DWORD; +var + ll: LONGLONG; +begin + try + Result := TASK_UNKNOWN; + if Assigned(fs_) then + begin + ll := fs_.Position; + fs_.Position := OFFSET_TASK_TYPE; + try + fs_.Read(Header_.dwTaskType, SizeOf(Header_.dwTaskType)); + finally + fs_.Position := ll; + end; + Result := Header_.dwTaskType; + end; + except + on E: Exception do + ESavePacekt.TraceException(Self, E, 'Fail .. GetTaskType()'); + end; +end; + +function TStdPacketBase.GetStoredSize: LONGLONG; +begin + Result := 0; + if Assigned(fs_) then + Result := fs_.Size; +end; + +function TStdPacketBase.GetEntryCount: LONGLONG; +begin + Result := 0; + if Assigned(fs_) then + Result := Header_.llTotalEntry; +end; + +procedure TStdPacketBase.IncEntry; +var + ll: LONGLONG; +begin + try + if Assigned(fs_) then + begin + ll := fs_.Position; + fs_.Position := OFFSET_TOTAL_ENTRY; + try + Inc(Header_.llTotalEntry); + fs_.Write(Header_.llTotalEntry, SizeOf(Header_.llTotalEntry)); + finally + fs_.Position := ll; + end; + end; + except + on E: Exception do + ESavePacekt.TraceException(Self, E, 'Fail .. IncEntry()'); + end; +end; + +procedure TStdPacketBase.DecEntry; +begin + try + if Assigned(fs_) then + begin + Header_.llProcssOffset := fs_.Position; + try + fs_.Position := OFFSET_TOTAL_ENTRY; + Dec(Header_.llTotalEntry); + fs_.Write(Header_.llTotalEntry, SizeOf(Header_.llTotalEntry)); + fs_.Write(Header_.llProcssOffset, SizeOf(Header_.llProcssOffset)); + finally + fs_.Position := Header_.llProcssOffset; + end; + end; + except + on E: Exception do + ESavePacekt.TraceException(Self, E, 'Fail .. DecEntry()'); + end; +end; + +function TStdPacketBase.GetRemainSize: LONGLONG; +begin + Result := -1; + if Assigned(fs_) then + Result := fs_.Size - fs_.Position; +end; + +function TStdPacketBase.GetFileSize: LONGLONG; +begin + Result := 0; + if Assigned(fs_) then + Result := fs_.Size; +end; + +{ TSavePacket } + +Constructor TSavePacket.Create(const sFileName: String; llMaxSize: LONGLONG = MAX_DATA_SIZE; + EncAlgorithm: TTgEncKind = ekNone; bSaveFileHideSystem: Boolean = false); + + procedure InitSavePacket; + begin + try + if not FileExists(sFileName) then + begin + InitStoredHeader(llMaxSize, TASK_SAVE, EncAlgorithm, SIGN_KKU48); + if bSaveFileHideSystem then // 숨김, 시스템 속성 추가 22_0124 16:03:37 sunk + begin + fs_ := TFileStream.Create(sFileName, fmCreate or fmOpenReadWrite or fmShareDenyNone); + fs_.Free; + SetFileAttributes(PChar(sFileName), FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_SYSTEM); + fs_ := TFileStream.Create(sFileName, fmOpenReadWrite or fmShareDenyNone); + end else + fs_ := TFileStream.Create(sFileName, fmCreate or fmOpenReadWrite or fmShareDenyNone); + fs_.Write(Header_, SizeOf(Header_)); + end else begin + fs_ := TFileStream.Create(sFileName, fmOpenReadWrite or fmShareDenyNone); + LoadStoredHeader; + fs_.Seek(0, soEnd); + end; + except + // 예외나면 씹지말고 위로 올리도록 수정 + raise ESavePacekt.Create('Fail .. Create()'); + end; + end; + +begin + Inherited Create(sFileName); + +// if bInit then + InitSavePacket; +end; + +procedure TSavePacket.InitStoredHeader(llMaxSize: LONGLONG; dwTaskType: DWORD; aEncKind: TTgEncKind; wSign: WORD); +begin + ZeroMemory(@Header_, SizeOf(Header_)); + StrCopy(Header_.sVer, VER_SOTRED); + Header_.llMaxSize := llMaxSize; + Header_.dwTaskType := TASK_SAVE; + Header_.wEncType := WORD(aEncKind); + Header_.wSign := SIGN_KKU48; + + Enc_.EncKind := aEncKind; +end; + +procedure TSavePacket.PushPacketBuf(aBuf: TBytes); +begin + try + PushPacketBuf(@aBuf[0], Length(aBuf)); + except + on E: Exception do + ESavePacekt.TraceException(Self, E, 'Fail .. PushPacketBuf() .. 1'); + end; +end; + +procedure TSavePacket.PushPacketBuf(aBuf: Pointer; nLen: Integer); +var + pBuf: TBytes; + nEncLen: Integer; +begin + try + if fs_ <> nil then + begin + pBuf := Enc_.EncryptBufferEx(aBuf, nLen); + nEncLen := Length(pBuf); + if nEncLen >= nLen then // 패딩때문에 암호화 결과가 더 커질 수 있음 23_0516 09:40:07 kku + begin + fs_.Write(nEncLen, SIZE_INTEGER); + fs_.Write(pBuf[0], nEncLen); + IncEntry; + end; + end; + except + on E: Exception do + ESavePacekt.TraceException(Self, E, 'Fail .. PushPacketBuf() .. 2'); + end; +end; + +{ TLoadPacket } + +Constructor TLoadPacket.Create(const sFileName: String; bInitLoad: Boolean = true); + + procedure InitLoadPacket; + begin + if FileExists(sFileName) then + begin + try + fs_ := TFileStream.Create(sFileName, fmOpenReadWrite or fmShareDenyNone); + except + nLastError_ := ERROR_ACCESS_DENIED; + exit; + end; + LoadStoredHeader; + + if bInitLoad then + InitLoadHeader; + end else + nLastError_ := ERROR_FILE_NOT_FOUND; + end; + +begin + Inherited Create(sFileName); + + nLastError_ := ERROR_SUCCESS; + + InitLoadPacket; +end; + +procedure TLoadPacket.InitLoadHeader; +begin + TaskType := TASK_LOAD; + + if Header_.llProcssOffset > fs_.Position then + fs_.Position := Header_.llProcssOffset; +end; + +function TLoadPacket.PopPacketBuf: TBytes; +var + pSrcBuf, pDecBuf: TBytes; + nLen: Integer; +begin + Result := nil; + if Assigned(fs_) then + begin + if SIZE_INTEGER > RemainSize then + exit; + + if fs_.Read(nLen, SIZE_INTEGER) <> SIZE_INTEGER then + exit; + + if nLen > RemainSize then + exit; + + SetLength(pSrcBuf, nLen); + if fs_.Read(pSrcBuf[0], nLen) <> nLen then + exit; + + DecEntry; + + Result := Enc_.DecryptBufferEx(pSrcBuf, nLen); + end; +end; + +{ TTgStoredPacket } + +Constructor TTgStoredPacket.Create(const sSaveFN: String; EncAlgorithm: TTgEncKind = ekNone); +begin + Inherited Create; + + bBlockMaxSize_ := false; + bSaveFileHideSystem_ := false; + EncAlgorithm_ := EncAlgorithm; + + SavePacket_ := nil; + LoadPacket_ := nil; + + ullMaxSize_ := 0; + ullSegmentSize_ := 50*1024*1024; +// ullLimitSize_ := 2*1024*1024; + sSaveFN_ := sSaveFN; + sFNameH_ := ExtractFileName(sSaveFN_); +end; + +Destructor TTgStoredPacket.Destroy; +begin + if Assigned(LoadPacket_) then + FreeAndNil(LoadPacket_); + + if Assigned(SavePacket_) then + FreeAndNil(SavePacket_); + + Inherited; +end; + +procedure TTgStoredPacket.SetSavePacketTaskType(dwTaskType: DWORD); +begin + if Assigned(SavePacket_) then + SavePacket_.TaskType := dwTaskType; +end; + +procedure TTgStoredPacket.SetMaxSize(ullMaxSize: ULONGLONG); +begin + if ullMaxSize_ <> ullMaxSize then + ullMaxSize_ := ullMaxSize; +end; + +procedure TTgStoredPacket.SetSegmentSize(ullSegmentSize: ULONGLONG); +begin + if ullSegmentSize_ <> ullSegmentSize then + ullSegmentSize_ := ullSegmentSize; +end; + +function TTgStoredPacket.GetStoredSavePath: String; +begin + Result := ''; + if Assigned(SavePacket_) then + Result := SavePacket_.sFName_; +end; + +function TTgStoredPacket.GetStoredLoadPath: String; +begin + Result := ''; + if Assigned(LoadPacket_) then + Result := LoadPacket_.sFName_; +end; + + + +function TTgStoredPacket.GetFirstStoredPath: String; +var + wfd: TWin32FindData; + hSc: THandle; + sDir, + sPath: String; +// ullTotalSize: ULONGLONG; + PkFileList: TStringList; + i: Integer; +begin + Result := ''; + try +// ullTotalSize := 0; + sDir := ExtractFilePath(sSaveFN_); + if not ForceDirectories(sDir) then + exit; + + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + Guard(PkFileList, TStringList.Create); + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0) then + begin + if Pos(sFNameH_, wfd.cFileName) > 0 then + begin +// Inc(ullTotalSize, GetFileSize_path(sDir + wfd.cFileName)); + PkFileList.Add(sDir + wfd.cFileName); + end; + end; + Until not FindNextFile(hSc, wfd); + finally + FindClose(hSc); + end; + + if PkFileList.Count > 0 then + begin + PkFileList.CustomSort(StringListCompareFileCreateDate); + Result := PkFileList[0]; + end; + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. ReduceOldStoredData()'); + end; +end; + +function TTgStoredPacket._CreateStoredSave: TSavePacket; + + function ReduceOldStoredData: Boolean; + var + wfd: TWin32FindData; + hSc: THandle; + sDir, + sPath: String; + ullTotalSize: ULONGLONG; + PkFileList: TStringList; + i: Integer; + begin + Result := true; + try + ullTotalSize := 0; + sDir := ExtractFilePath(sSaveFN_); + if not ForceDirectories(sDir) then + Exit(false); + + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + Exit(false); + + Guard(PkFileList, TStringList.Create); + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0) then + begin + if Pos(sFNameH_, wfd.cFileName) > 0 then + begin + Inc(ullTotalSize, GetFileSize_path(sDir + wfd.cFileName)); + PkFileList.Add(sDir + wfd.cFileName); + end; + end; + Until not FindNextFile(hSc, wfd); + finally + FindClose(hSc); + end; + + if ullMaxSize_ <= ullTotalSize then + begin + if bBlockMaxSize_ then + Exit(false); + + PkFileList.CustomSort(StringListCompareFileCreateDate); + for i := 0 to PkFileList.Count - 1 do + begin + Dec(ullTotalSize, GetFileSize_path(PkFileList[i])); + DeleteFile(PChar(PkFileList[i])); + if ullMaxSize_ > ullTotalSize then + break; + end; + end; + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. ReduceOldStoredData()'); + end; + end; + +var + i, c: Integer; + sPath, sLoad: String; +begin + Result := nil; + + try + if ullMaxSize_ > 0 then + begin + // 최대 저장 크기 체크해서 넘으면 오래된 덩어리 지워주기 + if not ReduceOldStoredData then + exit; + end; + + c := -1; + sLoad := ''; + + if Assigned(LoadPacket_) then + sLoad := LoadPacket_.FileName; + + for i := 1 to High(Integer) do + begin + sPath := Format('%s.%.4d.dat', [sSaveFN_, i]); + if sLoad <> sPath then + begin + if FileExists(sPath) then + begin + try + if not ForceDirectories(ExtractFilePath(sPath)) then + begin + _Trace('Fail CreateDir .. Path = "%s"', [ExtractFilePath(sPath)]); + exit; + end; + + Result := TSavePacket.Create(sPath, ullSegmentSize_, EncAlgorithm_, bSaveFileHideSystem_); + // 용량 꽉찬건지도 다시 확인 12_1206 09:16 sunk + if Result.GetStoredSize > ullSegmentSize_ then + Result.TaskType := TASK_SAVE_FULL; + + case Result.Header_.dwTaskType of + TASK_SAVE : exit; + TASK_LOAD, + TASK_SAVE_FULL : FreeAndNil(Result); + TASK_DESTROY : + begin + FreeAndNil(Result); + DeleteFile(PChar(sPath)); + c := i; + break; + end; + else + begin + {$IFDEF DEBUG} + ASSERT(false); + {$ELSE} + FreeAndNil(Result); + DeleteFile(PChar(sPath)); + c := i; + break; + {$ENDIF} + end; + end; + except + if Assigned(Result) then + FreeAndNil(Result); + continue; + end; + end else begin + c := i; + break; + end; + end; + end; + + if Result = nil then + begin + if c > -1 then + begin + if not ForceDirectories(ExtractFilePath(sSaveFN_)) then + begin + _Trace('Fail CreateDir .... Path = "%s"', [ExtractFilePath(sSaveFN_)]); + exit; + end; + + Result := TSavePacket.Create(Format('%s.%.4d.dat', [sSaveFN_, c]), ullSegmentSize_, EncAlgorithm_, bSaveFileHideSystem_) + end else + // 여기까지 왔다면 파일 생성이 불가능한 상황으로 판단 17_0515 16:22:35 sunk + _Trace('Exception .. _CreateStoredSave() .. Files can no longer be created. LastPath = [%s]', [sPath]); + +// Result := TSavePacket.Create(Format('%s.%.4d.dat', [sSaveFN_, c]), ullSegmentSize_, EncAlgorithm_, bSaveFileHideSystem_); + // _Trace('_CreateStoredSave() - Path = %s', [Result.sFileName_]); + end; + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. _CreateStoredSave()'); + end; +end; + +function TTgStoredPacket._CreateStoredLoad: TLoadPacket; +var + i: Integer; + hSc: THandle; + sDir, + sPath, sSave: String; + wfd: TWin32FindData; +begin + Result := nil; + + try + sSave := ''; + if Assigned(SavePacket_) then + sSave := SavePacket_.FileName; + + sDir := IncludeTrailingBackslash(ExtractFilePath(sSaveFN_)); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + + end else begin + if Pos(sFNameH_ + '.', wfd.cFileName) > 0 then + begin + sPath := sDir + wfd.cFileName; + if (sSave <> sPath) and FileExists(sPath) then + begin + Result := TLoadPacket.Create(sPath); + case Result.Header_.dwTaskType of + TASK_LOAD : exit; + TASK_SAVE, + TASK_SAVE_FULL : + begin + Result.SetTaskType(TASK_LOAD); + exit; + end; + // TASK_DESTROY : + else + begin + FreeAndNil(Result); + DeleteFile(PChar(sPath)); + end; + // else ASSERT(false); + end; + end; + end; + end; + Until not FindNextFile(hSc, wfd); + finally + Winapi.Windows.FindClose(hSc); + end; + + if (Result = nil) and Assigned(SavePacket_) then + begin + FreeAndNil(SavePacket_); + Result := TLoadPacket.Create(sSave); // todo : LastError 체크해서 후 처리 + Result.SetTaskType(TASK_LOAD); + end; + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. _CreateStoredLoad()'); + end; +end; + +procedure TTgStoredPacket.PushPacket(aPacket: ITgPacket); +var + pBuf: TBytes; +begin + try + if aPacket.ToBytesDataOnly(pBuf) > 0 then + PushPacket(pBuf); + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. PushPacket() .... 0'); + end; +end; + +procedure TTgStoredPacket.PushPacket(pPktBuf: TBytes); +begin + try + PushPacket(@pPktBuf[0], Length(pPktBuf)); + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. PushPacket() .... 1'); + end; +end; + +procedure TTgStoredPacket.PushPacket(pPktBuf: Pointer; nLen: Integer); +begin + try + if Assigned(SavePacket_) then + if SavePacket_.GetStoredSize > ullSegmentSize_ then + begin + SavePacket_.TaskType := TASK_SAVE_FULL; + FreeAndNil(SavePacket_); + end else + if SavePacket_.TaskType <> TASK_SAVE then + FreeAndNil(SavePacket_); + + if not Assigned(SavePacket_) then + SavePacket_ := _CreateStoredSave; + + if Assigned(SavePacket_) then + SavePacket_.PushPacketBuf(pPktBuf, nLen); + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. PushPacket() .... 2'); + end; +end; + +procedure TTgStoredPacket.PushPacket(sPacket: UTF8String); +begin + PushPacket(@sPacket[1], Length(sPacket)); +end; + +function TTgStoredPacket.PopPacketStr: String; +var + bCreate: Boolean; + sPath: String; + pBuf: TBytes; + bPopSuccess: Boolean; +Label + LB_DoPopPacket; +begin + Result := ''; + + try + bCreate := false; + if not Assigned(LoadPacket_) then + begin + LoadPacket_ := _CreateStoredLoad; + if not Assigned(LoadPacket_) then + exit; + bCreate := true; + end; + + LB_DoPopPacket : + bPopSuccess := false; + try + pBuf := LoadPacket_.PopPacketBuf; + bPopSuccess := pBuf <> nil; + except + Result := ''; + end; + + if bPopSuccess then + begin + try + Result := TEncoding.UTF8.GetString(pBuf); // UTF8ToWideString(PAnsiChar(pBuf)); + + // Result := TTgPacket.Create(pBuf, true); + except + _Trace('Conv .. Fail! TTgPacketCreate. '); +// raise; + Result := ''; + end; + end; + + if not bPopSuccess then + begin + sPath := LoadPacket_.FileName; + LoadPacket_.SetTaskType(TASK_DESTROY); + FreeAndNil(LoadPacket_); + DeleteFile(PChar(sPath)); + + if not bCreate then + Result := PopPacketStr; + end else + if Result = '' then + begin + // TEncoding.UTF8.GetString() 에서 디코딩 실패 시 수집 데이터 전체 지우지 말고 + // 넘기고 다시 시도 하도록 보완 20_0804 12:44:27 sunk + goto LB_DoPopPacket; + end; + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. PopPacketStr() .... 1'); + end; +end; + +function TTgStoredPacket.PopPacket: ITgPacket; +begin + Result := nil; + try + Result := TTgPacket.Create(PopPacketStr); + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. PopPacketStr() .... 2'); + end; +end; + +procedure TTgStoredPacket.SafeFreeSaveStored(const sPath: String; dwTaskType: DWORD); +begin + try + // 외부에서 해당 조건(Path)의 SaveStored가 사용중이라면 dwTaskType값으로 바꿔주고 해제해 준다. 14_0709 14:18:56 sunk + if Assigned(SavePacket_) and (SavePacket_.sFName_ = sPath) then + begin + SavePacket_.SetTaskType(dwTaskType); + FreeAndNil(SavePacket_); + end; + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. SafeFreeSaveStored'); + end; +end; + +{ TTgStoredMirrorPacket } + +Constructor TTgStoredPacketMirror.Create(sPaths, sFName: String; EncAlgorithm: TTgEncKind = ekNone); + + procedure InitEnt; + var + PathList: TStringList; + i: Integer; + pEnt: PSpmEnt; + begin + if sPaths <> '' then + begin + Guard(PathList, TStringList.Create); + SplitString('|', sPaths, PathList); + for i := 0 to PathList.Count - 1 do + if ForceDirectories(PathList[i]) then + begin + New(pEnt); + pEnt.sSaveFN := IncludeTrailingBackslash(PathList[i]) + sFName; + pENt.SavePacket := nil; + SpmEntList_.Add(pEnt); + end else + _Trace('Fail .. make dir .. Path="%s"', [PathList[i]]); + end; + end; + +begin + Inherited Create; + + EncAlgorithm_ := EncAlgorithm; + ullSegmentSize_ := 50*1024*1024; + bSaveFileHideSystem_ := false; + + SpmEntList_ := TSpmEntList.Create; + SpmEntList_.OnNotify := OnSpmEntNotify; + InitEnt; +end; + +Destructor TTgStoredPacketMirror.Destroy; +begin + FreeAndNil(SpmEntList_); + Inherited; +end; + +procedure TTgStoredPacketMirror.OnSpmEntNotify(Sender: TObject; const Item: PSpmEnt; Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: + begin + if Item.SavePacket <> nil then + FreeAndNil(Item.SavePacket); + Dispose(Item); + end; + cnExtracted: ; + end; +end; + +procedure TTgStoredPacketMirror.SetSegmentSize(ullSegmentSize: ULONGLONG); +begin + if ullSegmentSize_ <> ullSegmentSize then + ullSegmentSize_ := ullSegmentSize; +end; + +function TTgStoredPacketMirror.GetSegmentSize: ULONGLONG; +begin + Result := ullSegmentSize_; +end; + +function TTgStoredPacketMirror._CreateStoredSave(sSaveFN: String): TSavePacket; +var + i, c: Integer; + sPath, sLoad: String; +begin + Result := nil; + + try + c := -1; + sLoad := ''; + + for i := 1 to High(Integer) - 1 do + begin + sPath := Format('%s.%.4d.dat', [sSaveFN, i]); + if sLoad <> sPath then + begin + if FileExists(sPath) then + begin + try + if not ForceDirectories(ExtractFilePath(sPath)) then + begin + _Trace('Fail CreateDir .. Path = "%s"', [ExtractFilePath(sPath)]); + exit; + end; + + Result := TSavePacket.Create(sPath, ullSegmentSize_, EncAlgorithm_, bSaveFileHideSystem_); + // 용량 꽉찬건지도 다시 확인 12_1206 09:16 sunk + if Result.GetStoredSize > ullSegmentSize_ then + Result.TaskType := TASK_SAVE_FULL; + + case Result.Header_.dwTaskType of + TASK_SAVE : exit; + TASK_LOAD, + TASK_SAVE_FULL : FreeAndNil(Result); + TASK_DESTROY : + begin + FreeAndNil(Result); + DeleteFile(PChar(sPath)); + c := i; + break; + end; + else + begin + {$IFDEF DEBUG} + ASSERT(false); + {$ELSE} + FreeAndNil(Result); + DeleteFile(PChar(sPath)); + c := i; + break; + {$ENDIF} + end; + end; + except + if Assigned(Result) then + FreeAndNil(Result); + continue; + end; + end else begin + c := i; + break; + end; + end; + end; + + if Result = nil then + begin + if c > -1 then + begin + if not ForceDirectories(ExtractFilePath(sSaveFN)) then + begin + _Trace('Fail CreateDir .... Path = "%s"', [ExtractFilePath(sSaveFN)]); + exit; + end; + + Result := TSavePacket.Create(Format('%s.%.4d.dat', [sSaveFN, c]), ullSegmentSize_, EncAlgorithm_, bSaveFileHideSystem_) + end else + // 여기까지 왔다면 파일 생성이 불가능한 상황으로 판단 17_0515 16:22:35 sunk + _Trace('Exception .. _CreateStoredSave() .. Files can no longer be created. LastPath = [%s]', [sPath]); + end; + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. _CreateStoredSave()'); + end; +end; + +procedure TTgStoredPacketMirror.PushPacket(aPacket: ITgPacket); +var + pBuf: TBytes; +begin + try + if (SpmEntList_.Count > 0) and (aPacket.ToBytesDataOnly(pBuf) > 0) then + PushPacket(pBuf); + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. PushPacket() .... 0'); + end; +end; + +procedure TTgStoredPacketMirror.PushPacket(pPktBuf: TBytes); +begin + try + if SpmEntList_.Count > 0 then + PushPacket(@pPktBuf[0], Length(pPktBuf)); + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. PushPacket() .... 1'); + end; +end; + +procedure TTgStoredPacketMirror.PushPacket(pPktBuf: Pointer; nLen: Integer); +var + i: Integer; +begin + try + for i := 0 to SpmEntList_.Count - 1 do + begin + if Assigned(SpmEntList_[i].SavePacket) then + if SpmEntList_[i].SavePacket.GetStoredSize > ullSegmentSize_ then + begin + SpmEntList_[i].SavePacket.TaskType := TASK_SAVE_FULL; + FreeAndNil(SpmEntList_[i].SavePacket); + end else + if SpmEntList_[i].SavePacket.TaskType <> TASK_SAVE then + FreeAndNil(SpmEntList_[i].SavePacket); + + if not Assigned(SpmEntList_[i].SavePacket) then + SpmEntList_[i].SavePacket := _CreateStoredSave(SpmEntList_[i].sSaveFN); + + if Assigned(SpmEntList_[i].SavePacket) then + SpmEntList_[i].SavePacket.PushPacketBuf(pPktBuf, nLen); + end; + except + on E: Exception do + ECrmStoredPacket.TraceException(Self, E, 'Fail .. PushPacket() .... 2'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/!bdll.bat b/Tocsg.Lib/VCL/EncLib/AES/!bdll.bat new file mode 100644 index 00000000..03e68252 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/!bdll.bat @@ -0,0 +1,2 @@ +::call b3 -b -dDLL AES_DLL.DPR +call b10 -b -dDLL AES_DLL.DPR \ No newline at end of file diff --git a/Tocsg.Lib/VCL/EncLib/AES/#ca.bat b/Tocsg.Lib/VCL/EncLib/AES/#ca.bat new file mode 100644 index 00000000..c263587b --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/#ca.bat @@ -0,0 +1,325 @@ +@echo off + +rem generic compile batch file for most console compilers +rem pause after each compiler if %1 not empty +rem call self on low env space condition +rem (c) 2003-2008 W.Ehrhardt + +rem test file +rem ========= + +::set SRC=T_GSpeed +::set SRC=T_AESCRP +::set SRC=T_CYCCNT +::set SRC=T_FBMODI +set SRC=T_AES_WS +::set SRC=T_EAX2 +::set SRC=t_cprf +::set SRC=T_XTS + +rem log file (may be con or nul) +rem ============================ +::set LOG=nul +set LOG=%SRC%.LOG + + +rem parameters for test file +rem ======================== +set PARA=test + +rem build options +rem ======================== +::set OPT=-ddebug + + +rem test whether enough space in environment +rem ========================================= +set PCB=A_rather_long_environment_string_for_testing +if (%PCB%)==(A_rather_long_environment_string_for_testing) goto OK + + +rem call self with 4096 byte env +rem ============================ +set PCB= +%COMSPEC% /E:4096 /C %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto ende + + +:OK + +echo Test %SRC% for most console compilers >%LOG% +ver >>%LOG% + +set PCB=bpc -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=bpc -CP -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc1 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc2 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc22 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc222 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc224 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc240 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc242 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc244 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc260 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc262 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc264d -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc264 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc300 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc302 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc311 -B +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + + +set PCB=call vpc -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call p5 -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call p55 -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call p6 -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M2\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M3\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M4\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M5\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M6\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M7\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M9\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +call wdosx %SRC%.exe +echo. >>%LOG% +echo Results for WDOSX >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M10\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M12\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M17\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M18\DCC32.EXE -b +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +echo. +echo **** Log file: %LOG% + +:ende + +set PCB= +set SRC= +set LOG= +set PARA= +set OPT= + diff --git a/Tocsg.Lib/VCL/EncLib/AES/#ca_dll.bat b/Tocsg.Lib/VCL/EncLib/AES/#ca_dll.bat new file mode 100644 index 00000000..bd6dc6af --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/#ca_dll.bat @@ -0,0 +1,250 @@ +@echo off + +rem Tests with AES_DLL. Compile batch file for most console compilers +rem pause after each compiler if %1 not empty +rem call self on low env space condition +rem (c) 2003-2008 W.Ehrhardt + +if exist aes_dll.dll goto dll_found +echo AES_DLL.DLL not found +goto ende + +:dll_found + +set SRC=T_AES_WS +::set SRC=T_CMAC +::set SRC=T_CBCCTS +::set SRC=T_XTS +::set SRC=T_AESCCM + +rem log file (may be con or nul) +rem ============================ +::set LOG=nul +set LOG=%SRC%.LOD + +rem parameters for test file +rem ======================== +set PARA=test + + +rem test whether enough space in environment +rem ======================================== +set PCB=A_rather_long_environment_string_for_testing +if (%PCB%)==(A_rather_long_environment_string_for_testing) goto OK + + +rem call self with 4096 byte env +rem ============================ +set PCB= +%COMSPEC% /E:4096 /C %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto ende + + +:OK + +echo Test %SRC% for all win32 compilers >%LOG% +ver >>%LOG% + +set PCB=call fpc2 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc22 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc222 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc224 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc240 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc242 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc244 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc260 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc264 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc300 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc302 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call fpc311 -B -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=call vpc -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M2\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M3\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M4\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M5\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M6\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M7\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M9\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M10\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M12\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M17\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +set PCB=D:\DMX\M18\DCC32.EXE -b -dUSEDLL +del %SRC%.exe >nul +%PCB% %OPT% %SRC%.pas +if not (%1%)==() pause +echo. >>%LOG% +echo Results for %PCB% >>%LOG% +%SRC%.exe %PARA% >>%LOG% + +echo. +echo **** Log file: %LOG% + +:ende + +set PCB= +set SRC= +set LOG= +set PARA= + + diff --git a/Tocsg.Lib/VCL/EncLib/AES/#times.aes b/Tocsg.Lib/VCL/EncLib/AES/#times.aes new file mode 100644 index 00000000..6904152f --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/#times.aes @@ -0,0 +1,78 @@ +Times in [s] for 512 MB: 128 bit key, 1.8 GHz P4, Win98 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Package/Compiler CTR CFB OFB ECB CBC OMAC + LibTom117/VC6 13.0 16.3 16.4 12.9 13.9 15.6 + LTC117/GCC4.2.1 10.1 14.5 10.6 9.0 9.3 14.2 + dcpcrypt2/D6 28.8 32.7 28.6 - 32.7 - + DEC5.1/D6 - 13.9 10.9 10.2 11.8 - + StrSecII/D6 9.0 11.5 9.1 7.7 9.3 - + WE/D3 9.0 8.1 8.1 7.7 9.1 9.1 + WE/D6 9.0 8.0 8.0 7.7 8.4 9.1 + WE/FPC 2.0.2 12.5 12.5 12.4 11.3 14.1 13.1 + WE/FPC 2.2 -O3 9.9 9.1 9.1 9.0 11.2 9.0 + WE/VPC 2.1 10.4 10.2 10.3 9.3 13.9 12.0 + WE/BP7 47.1 41.4 41.4 34.3 51.0 45.3 + + +Cycles (Fun=enc/dec, Bit=key size) compared to Gladman (ASM/C++) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Func/Bit ASM C++ D6 VPC FPC2 BP7 + Enc/128 295 385 370 425 542 1490 + Dec/128 293 376 382 405 549 1545 + Enc/192 352 439 434 532 643 1768 + Dec/192 346 443 451 476 648 1723 + Enc/256 403 497 498 580 745 1948 + Dec/256 407 507 518 549 749 1971 + + +Cycles for encrypt/decrypt and key setup +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +D3 + KeyBit EncCyc DecCyc EK-Cyc DK-Cyc MB/s (Enc) + 256 516 515 883 1668 55.6 + 192 448 446 743 1364 64.0 + 128 380 379 740 1260 75.5 + +D6 +KeyBit EncCyc DecCyc EK-Cyc DK-Cyc MB/s (Enc) + 256 498 518 918 1648 57.6 + 192 434 451 732 1457 66.1 + 128 370 382 802 1338 77.5 + + +D10 +KeyBit EncCyc DecCyc EK-Cyc DK-Cyc MB/s (Enc) + 256 516 510 1029 1772 55.6 + 192 448 442 770 1398 64.0 + 128 380 377 814 1367 75.5 + +VP +KeyBit EncCyc DecCyc EK-Cyc DK-Cyc MB/s (Enc) + 256 580 549 1356 2134 49.5 + 192 532 476 1144 1812 53.9 + 128 425 405 1013 1569 67.5 + +FPC 1.1.10 DOS +KeyBit EncCyc DecCyc EK-Cyc DK-Cyc MB/s (Enc) + 256 745 749 1015 2609 38.5 + 192 643 648 828 2162 44.7 + 128 542 549 935 1971 53.0 + +FPC 2.0.2 +KeyBit EncCyc DecCyc EK-Cyc DK-Cyc MB/s (Enc) + 256 751 755 1001 2673 38.2 + 192 648 653 843 2225 44.3 + 128 546 551 790 1986 52.5 + +FPC 2.2 -O3 +KeyBit EncCyc DecCyc EK-Cyc DK-Cyc MB/s (Enc) + 256 572 589 1228 1914 50.1 + 192 493 506 867 1507 58.2 + 128 416 428 778 1353 69.0 + +BP7 +KeyBit EncCyc DecCyc EK-Cyc DK-Cyc MB/s (Enc) + 256 1948 1971 5172 7410 14.7 + 192 1768 1723 4356 6274 16.2 + 128 1490 1545 4300 5909 19.3 + diff --git a/Tocsg.Lib/VCL/EncLib/AES/$d25.zip b/Tocsg.Lib/VCL/EncLib/AES/$d25.zip new file mode 100644 index 0000000000000000000000000000000000000000..2595337f31f67adc16e7984e1676c1b924ee99b8 GIT binary patch literal 34131 zcmc$`Wl+|A`0Yz~cL_);Al=;|NJ>j1-QCjNNJ%K5fYObWG}0iQ(%p@O=XV3vE z$jnBsujkM<()+ko5D9F~J!3aoS_m2u2L~s^U15(5u6DNj(y%5^i$z8;-`d(dzL{)x zy64&BSF#OMjY|_K(8RBa&HSd%%#@vmSMY22ns7eu`rnuLb>CXJ1{*=3PhUUw^KPSP za)3|KzpVLO##@#?Kk3T~^U(tHn2E|Qc~*3YMHV$2qIO&BDt<9Pg*Lu8S?-+PGk(P&fWti=-w5cJf17vs3p`;urF!fN%K7rYqRLzC_}g6Vdqs5 zS%0XY2OE5i&$z8AXU!?yu3MjUu!Sjq^TmMyUmSaosr2Ri5p)3*7+3)v7#J$>#X0Ec zJ-4SfwzGD$v9Yr@D^KjVN)bd0+KvB)^4YnJ$&rkQEFm;Q0p&dz+o=gYOpw!eQ)knX z5B%z=o^Kn3Ehj|ZQpT6C5IHC9R$Y_?&7bz`?5B;qM)w$y%$Oco8+5ntO!AX>IUP_6 zk(WmA38zsC@hNiv=20Ad5v@Y;+Sb;L$^OZcVpsND%if}*g2G-W+wbN0V~)yn4gF;g zYLloYT->hpnA43q?NWO(mpS>ON*_Ei-d#NmBVpP+D)$)0Mf>XVl7X^jPTVIKv5w#z zHgab^1rf3AeTBQ1ndIOb8hN3BNJpuBv3tI&o(aadR%c9PNI#kxAB4l$tEc@|ag&C~)kh z>K8nbb}QLWOiY`7+%s?U_j8}U8!5A-m_#TH-9srD3JvQj!hM)fhtp7tBb%9YTsIXo zxjIvXT$=u^;qnyTUHCOgc@>`#LmGX|0Q8T;4Om(`E;>je4ho(w^! zp+8uI6Q*{5H1q2D%QKtjLj(9ezLBI3rK&>(Ll5?od$KcFAfWFFtr-?&^H_<8MA@+; z|M(fc8JBnGK2{ht=a4f{4oXAY-4AT%KL7Ru?$%kY`&21`eQ;O~P#JOc2|Fe24{VdV ze*Kkq?ivhq5>*xi+~o2D=>D=N8a0W>GB)x*|JiA6*$(WdFB_uXO|UwMzj;Frm$v2T zuU|^Yt8BT1t)Q6I>Q@}xEUe7%_ zK)Qn#m#I2G{^NDgp2qxpuirkYrj=af7qA$5QxC;WC^T1|xL%zsxz1l;F*E>t0{rJe zpTJ73^AlSB{)r>-NyyJn0=3^M?`(yE0^3%}3%q$lavSeJYGRY?oHDXLc zJjCB3FKp4t`Yt@nVlK+-$)GumPr_*}lXI{eOniEhau6k@{(elfX~9w9QWnpY%t^N{ zin#m;hVTov>175x({k{OK1 z$t3cn74=*UMwe4!eW$xeN$a9P8=mf$XOmiyS1#{|j!#_8i7zfu(CoRT{+Vti@c5IEDpScu*~)`whT3P64Zb-dokwFM z%2^hrJ*m5wuUTGrTpWz3*_^DC=zu%x z(=R;dM#^5YTKmm3$G*yRwr;Qy^~2+0lNWvJMA@S7Z`u0{`q=~=-50g{H&Av{k$3s( z>__XJ-ByKmhih1Btkay_(qfMH@-HR^SeVt7`-3GcaqMAxOr8jG5=tP3FgidRPDqG) ze_UX~<3_QMZd)6jV%zIJCW{&rDs#M8611p-@l(k&rEh{IlRpvcdt3zfRS0UQnR+l` zUoc5agaN$_qlNL=wg{s_qAowp6L|IXht%M8#+L<9E8%3C=_-92h;tA#9JQ$BN+SK3 z_FM0j0)nHK40;&&+;ESHIy)ve+7=RMwO@Bp92dYWB2!Q=I&CJDE7LuFi{QvtM&0IZ z$XWoCQCJ$W)GD8swr}zXpY~EwcO#8#>6K}%CK?JWGr9yl+xIM{1SML{r_XV>3v03U zB;Cw3BflfAb`*y=tB>W;kgns8eOI2{ba%E;-wgRk>9ydKiZy78lZG=$jnF2Ao@PAg zie6Ect0ig-KH(GoafoY^f}}HdO&vT%9_g68dYzb=+Go-bxgMe~WHEsyOS96ei)g`b zVtcyn9+O1A;R^_NJqY|cFjNA3Wq-&oLF0YeBMXxbm`d=j$uTLStR>|36Sc>%bmVGcr$=Y0smWH7^ zSs1s{vEp@G_a$jK84X)*TMVgqrH*UgYoC;{3U%-*R}!4Y>#eC(78MN=AGPiFveK-{ zrc%%|ilc8qNM@XIopF8!ILlBh4?kHZU@%S`xGyzhPt+T6%<{V$Md|nV)BBz1SPz<& zsh&P!-r|HeTJ&jwK=wtRM|rg*llN3@XY1RDXH|7g(O0~UVVcucyh>tddoEXQ{7KCG z_hgy1W{L?dWt97ouoO&&3!|!H3|*aS6mj*a>^-<gzO1qmw#;0RGKmyAhMjGv(dha7X zrS#xo22)lfNiCzvEWZNoRV70GCAWM_O_fhNTa3t34d=9yK7Fky7ipdjb9i^#OExA4 zBAO#ytA}nA8~xv2niSYQWDCj?FnmyNIU4x&3UQwNr8U~|QL;y{H^LIuM=-ooc*hE8 zo2Cc*^(NNDkJBhkweppr&EvC&pB;b=(e7c<2WnNm=fqMiWH28HAcvF8>s<4kXDE{WA{HUM6f{mPN(>?Y?DP%QN!zw19 z)X%Qjl;EMNwwx@B-djvmGz|^k^Cs#~u%uYHXLUKPQJ+M&J<(R@dHxJchiL`zk!V2t z&Xp9TDQRFK!r{GNVyFj*;d;=gthv9$(7^JC7_M6l38Gy`wetAGJ?ur@s!pYhe3z>H z=B)xzBuRW`1fLZ0NnwS#2;@TNSrhp_LO4g{D0KjY?^83U)f9K5B9IuS+MnR0=GtPP zJw1ArsDQ;k;yC|ISkNEG1;yCclB`$HXQ$bHPaW&h6XG>1OXATLqlIX;g?L2KJd7RvoCFPgG`2%`gR@6SM4V%`(nqHd*ERg)RY9$U zyMFD+W`)KRb8vn%pHg=_6*s9f95S0#{t)(X*k)##deNT8M=drV5u1dye9v=PDGgnz zQla*I_MI`3m_jXFHMsJMyb&F~GN+q#WT#WFj4S0Jpp$$KO44yZ;@{wkMy(hLYkQp5X(NQMf};^1Rum9uw^!#rZ2 z*@ldGsEJGr??*l}yOuDZ%TcM!?V_L5!vCd(62*~Ke`+BsQDOUN;8_T)ouVkUx`U$V zYg#O7F^2>(W3l1BOegd-7(+zn71>oG>T^kPv3`VcfBjsNrYEP-`0&G2<{Q{HvP4y> z4`+%;@a=<969zv<@#sgYbzT!WL7cXdQaB{$ZaGq?qmr|B)yo@cV|+m_Fg8hBD&l#E zZu9uE{xiNsh=AdIr2AC&gER&%kQSz`IrgLfs}`bC`z6)zOFAj_bL)J-Ee($5)Sci# z7aH)yJexre3BII$0AE|AH&cO+vO~N~F`1p7VyrB8Ph7S0ej*axR$I(WgPQwMGqgb6 zk;-A)dD*@V*S++9)_%S0bj;7@nPkwpXEE8y5wCI?k5gMC66IX83gqtD#SCoju;k9m zP|2a7sK3PQd3#x@{8e9!>mGY)B$;Vx=^4rcVrmH&Cl*B}xN8Zu}8A~tR zLzUG3++0u;s{JyqM3TxKH$RzS7)BEu=iTWNw1qdMBWVdavZ~0Z#F9l4V+&T|I^L^u zk2C{!*y{Q`8|;G5?g&_%A&rs2hqAMBVr~tiZv;>r2!u%Cxp?eY9w%h3iWoe;C*YJZ zR_Fef{+lJX+qvVLKu2pxK6A35&yFRZa$27`h1dzId@{sK45KvH-{5?@#xSjTR66qd z_~D?&vZ5J^#EZ}JZd3WlU(bGMA-;~7AhccRGqCUr|C&jnYTcJ-+T~>@@A_g{A?SC`ALX5GwrDiJubKB2?BPL0Uvis-1?9Ml+$EkC z&!LIO@tV-kt1ag!$ZM9;1Mz{EMMoM!(814!hMx*nNUrEs#)c+-{?NVgsw)-d{-OeT zn|tq37i%N!Q1nL|1dtY<-fAJSjw>04M8Rg8#&)*0b-BRnsBhg~7y9{;`-tyZ#b8_n zBeTQUG4@e7+_;`K5HM`5pXYn-D}w1T|E`7Ee{11;BJ$>izqHVZ^M@90f{fv{^#Ttm zlis-=VyX7SC*DpRYh4(j8&OX_4-k)=@eK7~X|eJr3wTiIG!11Kx;Z+IJV>EqS>-vk zUumym(22k|wr+|bRMit~d*h1VF{q@4yF=+OYLc;QM>Wnp`V41-xGu9u=8<1|zZ)FU{ zsfCjnrd0EOtR$SU>K}*3&v-2hp(GyjNRHO{7~95YCuOE%((|V^L|qc;De{~Y;e$QM zsB|l-UJf10VV3gDYjT0??5v)tA-BXv#Lg3*>Df|XBE^4_CzP9GLC(cAY-Y@>@wgq~ z6IPO24%|m04QnHR$cQJcG19%?O~RLlyKs~z#A>^(#PDL%CleOGH@hOLOg$Mr{(vCq z)_(jV{`A{yMf>7A%R;GW7gB1mBZ{zetijbAYiKlRitbpNt0YQ&f5IDN4R`LWVGzg~ zx&YRYGUJyu%rLLyHK2!Y+;VcOCSM7T-|E++wvj_37j_Qm68heX+9;eg9c8#ed4FaA zMynw1@|cw#)54l)P59$iSg`b3q z4-}x8gdZ%%4JNpOOFD_%$zgD{E;kRl$oLCP7|*a)kTn#&8Y|x5L4tLT`e6;J>9e|T ztzqVJIfDv+{T^vB{nfIC*L4pu1J&Z;`<2?B0ecA7Cr{skVGDd=b(F`%4or`$-amL~ zU4HytgdXGk$`ghywR5Sn>3*1utncPCI{C!!f`b zT5!Tsk2XHffSC`q!F^(vtxQAb>~yuUgROenODK}2v7BD4yRF2ydXmiNVDX1D4EnoS| z;=xzajdcT^wmUV1^>>>@0@M)7tB&OqP{VTi(GR{AkCn{mUA@<_T@Y|v=%=0%h0=~C zvYChwgFhK*?`>YJQjr2zTry8%35^vbiA zHo_cYJ4A+9Zt<6T0aH@s)&XU`2FO31A#<6C+ut$SNdI5d5Zr4VVl(ZF|0axXf=beZhz;5BE-0nE}R-31>%+E6msb zflq6@=@R!!j_In@=~7b`_34gt&5-*kwIA#$%#6b7>>})pM3ls$1S(Zald*_g=Ue4^ zQu+$DR!hbfHgG*_4h=#73|i7&ehP>l?5M^8+aw?HaH|D1nkX&TSJ45-U2B+d&38oRlkO>|mR%;}kBwsb=`UNTrTD-gbkK zt=(KQvZJ8=o++(Pt~|&Zrkn#YIf5V~5{Sv;@>%f*KunefV)8;7nc-bbX1$BaI6q=C z4XihS5?H%fi5ydhR}vs==<1LzzUn&sI7@{% z?c5NSdBy3%i{~1!hH{8%H`Y+C;bCmln#K-pUiz-6N8Z1c9S-1b=i{>5T=1a(Vdj=<|8dkbrlDrfA%%w<>EQk>hS3k-lM#4AYmoGujs&++nc*BhH|v&oU)PmRWSos2i8pOn0;V~iaGch zZjk%q*5`>2U=5EE18qMhl~M&piUeFYKN4fmxKe+uU+|osa>eE-2#K<)w`-5*#eEO| zQsm5Z{rCXM*w1k=YoZK#a(P;zq~<6QgLWDp+fdq$weSEs{~6Ew3J{5?Fs z4t;o;wq8*loNR~{8(aQSEO%0G^#XM1M(KxaW+Sgg7d7cUFTRh=$opNa`Y5Ro^BS@J zEev3p>9d8@s)cZ3Ww!NdS;}L15hyre`?_oNMWs|I$(?T0p!JCexa$f0!nj5mRtgLfV)TeitgcG6HN7WF?L1T*{$mp&rERyAnpw}L&Dv6w9x8sd zQW%9O#dDsl@-KLtfuWqM!{V-pA}Ky(b$@|&N)RV-GA&htuv2X@5rSnGD`P;W_6mbZ z1_RM%PVrEHz<{lyR7}~aX(wA1Gw`i(o+SyuRI5++g4duDdt(DKJB3?4$zlc8%PV#seV56KzxbxX=Gp-X=@}SK`ZlN zY_z3GR{AXVixw^^M)C)|p}bA*Sd*;$#k${VI#Xyd zFos>?jRkOS@Jrhh6qH`Ul(nWyX$-5+iudqb$L&ygn+EruW1-x8NqQcIiG`{&w>|KV zvD#BHdM!y@FI|=I^ua{1h%6G_npns7Gb>2D^+iT6Y>R}vFbO4hzA6SBw>gEO2XI(y z=;`48FXV=rp`ZAthzl)LCCD9$Ya$U<%M&3*;ScLk#Zkkm0%G|2?WL2cxHlk%AyGx0 zI}A>X+i^KN6v)k&%xjm&I0YQ;o?jta(lbnU!g&eSIVZ_he5AyWH3CNZth8sY4mPfj z+vRgqDyWI-5aB9ShNy>1cmiJ0kX7eVDRXgZ`a9DJH%CKj>fEcRqc(_<*||UYB{~ne z5{6Eiq?5L;1ql-sk*C=P^2i;Z=gO-+b$w~#JZg0lVv@&qTPq;X;w5FxrkfPpC|ROM_b@^;q-Z1ru})i zL1i}Uk{c3&`OHNeOsSxZ2=)r$pU$v5jECj#oa|utml)pWzDEp!13o5FGWpFX=af5bG28V*1yUfFrfFdY-+1Z)%x zGsB~Sjp^F2Wi_WeBmx^V?uJv;r?SMac{%Y<^83~lcFQu14NE_0qrK*~=+!Ee?AE3g1@zf&#@*B%I)r~q37FUBtE&G zk{nrVGX7{(rcWp9O#kE6Q0@1tA>Yrdq2g~>LpK(3A`=U;e_RcnXq%&thAWA_fOF{xZ&l(9J4cna>tqiz?_DGh+$vqa4qYgY^JdA%}Ga<8&@<^p{HGM?jlIGe0Rb%bxbbN!mum8=iRr~Q2HO%P!q6*7zN7o?{2K&yQ<#Fy;_hp zJOEk46J?~Qq&c6V8(jo*b9%iI#iiytcnH9*;#T)-cMIbrxIzMYtj6?jv)}9F=LSD>@)W2+@swB~5%zz%0?uQK__VcTxK$S0oAm?ap8Uhf z@wj2#U5#3HR?>!WSpE`yTf9T{E@&dN zsB7q_Y2iW!gugD!6g%dBq#NdQK?M)<-po*=1kQ#*^|K07b?!Le$I3vVgb(Wd-wP`U0w7~+o|IQT`XR(AA!sv;(}5T zUVfoF~F#YCgnC_jiSPT|{uXT}vi@qX-{0V1nZafr-JEKrGA>ifRLcPSBZIINi8e3XTNt1+@=;)@PNs z%J$z7ss&ejuS1+n*2MIE`0PJm?WWg7omI$1$@iz%73FKwTUN~WhR9%kHD#I=w&UJ$ z+L6*+W^Vf+Q^n#g5Auel=o=5GBxR8uYq+8kVoTZ?pp9l93TMQRrf|&*8erNk-FZV? zG(q}W6X%H{c#$tGQ+Ag+oD8a}v&S{S(XbD6G+g<4G;|}Se(n$}LH+zlo!C?5)+MI# zZoC{cm1HM1*g1}LU+)+|JgV~+c@X#wz0LwPIY!>HBv2a?x7D^g`3svSzcJ`&cp7OV zL5F5O@w!Q6E*($Y-%2UIr3pA1Ld@F9N`1q3n=gQPc!#C#@>WX^AJUqbH)sY>9QRYZrRBtqY-P zop+zNoh!N5B}MidzuILMVF0|LLJauROUa=gp(juA+=LcJyK`y=*>g}nN-m)~;Sbw@ zyx|317rc?87Y`k|Zt3#rXFtMH_in4Y7kkb4lwQ#~Ff%|&948+dv4Ffs;e;PwUV#;dQ&8LD4l%*KzH2M(zafS_FK z{XL)uAX;5P=@KBvl~|i1!e4SrQnu8P%fCP)^hvCPV+t} z+9S(e{2W~qv2r$!R0vQ*){kBe)9lo>GX_yNLAiXHuwFqPJoBeD>@8ow27+>SHgmRK ztIKrPo*qvvbHrX3s}XT3_`F6!{|pe6)4mpNo9nbLyswN( zU!F=VYELbzniGxKY|P30S{ItR_r4Hu72yY6gLzBW_}$PoqaeDbMRv8?bhduzmacJb z|3TO219VNAtoUf$VCTNyJozT*ei#=A>o>o)@7HI@?BU_&Ho2af>cM^#E~5gdp+ZXA zG&qX}I+`Z+fG`=77P$J!eRN%VSERtm79v)Cheb=mvt_rK4wFw4H80AkD>bjY@k)uBvUtO6a1%s)Dm zyk8y4IaB_kmKHHt9c5Bq?Hx50g-Yx%*G>cjMzL*5ob?bGYL z8~?;>$bZ9Y-Vs)E8>8$uZ8=5SO7x)9PP}fB1?14*e+MJ}YPR)I52<-x`@xMl9Nh(( zLyo&jnG2|t^+A<#-mgmel>XoGnkcH4n@agdhXPc}lb}l39rLW7>9$gK2P)+QLEeQ zk-Jv1o@q6~xB76tOWXGL(Y@t~ejq7N@ig8fWwBY7H;qzIPNJ#K z2VOK^4l7`;Y~KvQK}da`h)Gc>#o{9&P}(>vLA+YI`ge0kxl$_q60-CgWlQxl8FfsN zjtt=!^9h-W1=smjiuRn}L;}A|8Cjmqd_v`^UX=j7*4Ypx=}NZ zW4A27a}QoMl*z;d?skTEU$F2Oz`4@tCnZ~Xrq7m5&bu_mhr-k^4&H$^81~?51S8Ob zlJXZpBrWU}o?l5Bq=v_6@^Ai9L+f81%0K8De>*Hd4d)QhlDt+b4@ zoEoq1)X;h-x&8puqV!E@+GMsX&nXRBYl|zK0WFF>JUF_>92d}{gs=ud*C6gT8Q-_z zL)#ob)VlJ@v7ctO{%SS{t4yg@&a+I1qLc}xNSITy`s#K5e2bnjBiF~%z5TeIdf3y~ zNV~{2sOi)0b_e4d;j)piS#kTuBK@BYffj|hLcQl6V-_~JgJnU0C|(Uj>6Qpt<3PbHoQx69Igbn=|pX~_$ zf(_xR!98>@)1Zv*U_;s)*pT|4jWVBGxEsonh~=@qZ8vt2-1FFPDt`Mgv2nJwjuMkJ zI5dg@HOUiM`hv`_RQ%*sC&caab4U7I%45T^y&f_i%c9%$mQVD-!xAJ1lPA9VK8V-- zKK{{%(l960nNUUwzKTa3-vbT})H^dL?IvkckuxH?HNZ1VV8Hz(xbP~8hr($+IGJecq;n;oy8xk!> zCXuU@3IwG!@-YFhAtlX4eFy*>`nUW5Y`%_gcj{O_CZBtG<_@$d7%y6z@10gADsb!A zEeH$VwJ7)RqH@G@EHgz`Un^)qa-c;CWODQbnM22hr+_)UZ`)YzOy>LMlxol200SM= zqMT^A)EKi6P4jh0l_T?U^nXa_4lj%qp~p`e4>PFsEIC;VK=g81FIWjXG#)kKx|aq5 zY<`c*H-OC_QF&l<`_HI+2iRo%2H1rE3t)5cH(>KCDu*yx@FJ`=ISj4K0n8!XRxl^X9KKyOM+TWgbg0bIc5EA8h^x%Py*h~3rp*P5F@N<6As45UsK-cg9|O1>YAN9lks9)vy>sxuMMuy6 zU+;$Z1D-G5-VF=sGIFoS{gJkP3MyH8W%9z>sSksqmS|nLU&<5}77{#eV-W zcCwtuzq<8^Q(=)CAg|erG9P$+Fm3+m>m4k6tA^abuNUqt$Qx>qg1q6RZPk=Df%7iw zp5F%yy2&(KoS=sa5bq<(#_c2Is7K>wtE~Z==8Gq*tIfe#$+@lruj|>H?`!)@8Ejs| zyClv6n;PO&c^lCCxxM;3-slBz!PwmR7#ZdWpG%{H!3;VL2H1eRAyXEi^;9FnSQxK( zQ19r~&D{`1vmm?l=e=`iw0U-~lPu@JXF;Nm!32NTv2YG$MJ+oxZ_?tB} z`qLWXq5PLMq|UmrhFaY}X~S{A8Zx?IoDy+adfQQe4#?S2mdL(XEDdWU^d;qou?+9-=E^j*KywA=Yhj>&Js_i^Ft zoA~|i{f^hL-{LiP^MPBlrG&dA^~Dk;tHy~!7e!Sj6%#2JIQW&RP)hb|#cv>+UfIAt zu^WAVOJ2_~6z)uM1aen&@#!_UXX(=A+iwn67H5YB?|hI_N9j*!xe(V z>vtgV+G1AV54+`)z{ zAlQ(b?>F$8=6?jQIkOAPxT;5Ee$@R}d_7Q9Zm0k5-} z?B|i-cHf>)e}^D_HL*Qeb0SI+slfpPuM1|^);+A!>E)(=TEls8Q(0UPc-`m0rQJ}9 zb8@6V+Tiifn*sl@L`Polo%@R~f&{^Z@0&ef{}e;9?^`{8SwkIzpJMpO3Pn;+OEvxr zl*z;!5Ny~+WoUwGanmS+U_)H~*rK_0dFHF1u;KUB9ulBL8CeBN6l$|)(EOkh1uH;~ z^$BMp8rmQ{ZxBlpyF!Pa&&n-%jd(*|^Xxe7azy+julqRf$ZPejkL@|L`z=F5^ENKl z4sQChJY1d@Gwzpb^GoS$M5s|Ds6kP3;;8(8iD5iB_kHx5Y;U@YU^vDEUKp*G8`yBa z68X}u{#Q&!?tp8;Vss0(1**X^EpIZdK2Em37 zv0?ymm@I6oC~BLR4sBVMu1rU_0?%3;^gx}a}q%E-_E1i5kw|QR@ZMVGhh0FJB!1`{r zEOM1mtNV|jj3xd0ci7MkfDL(Wb|@nM*rBjZ)a!A~^112#zC*cz4Y}a6R~q$%V13y@ zJCuB-yP)j#t3|;Cg0g`gUsd4W))47`#~Sin+qTP?AN^=i=6-8YAb807err)op?rR{ zDCwvX4;?SZ1B4EDVrtf^l-HKWdCn&qX)vsdpp3w*9hZN4s zXMD1e9_&(iF`6T49xwf#i|FdU$hu`2`{k?-97%?UUv5s6BQ`kp=ZALSj60YcPCtTj z2@sTr*Y$q2C@TM}7N!2SMFCmEem(-7v~<>p{~;)o{|L%Qw?Wxs00_$DKu}Hwg0c(s zzga`GWAUKFk6h1Crf@+)`7IEX|5ihf(FT|Qg&G=lKT)PIp8nwc33?8kplv zMx=DJSH(q5)S270?7$ACrLxzf*XMMu1gv@`?8%Z_q|=x6qmA|}cecwnAMg-QS5w7= zgkK8kFY?;mTO5ij+mD-%E1S>SadA6YJ8IqHBjDpt;onG2m8Bk1I@~YjxXL$wm|Xq= zxAh%PST(YEH5KV7i6{@L@EBIK5eYhYd#J=4bIu+?1M#Yz!a$u!!kTcDjfkLL$dVB} zB!Y;V5-3!_8bWeCsweY+z0Zjl<*(W9spsHWASfe^zd1Y|E+6w>e=lO zg(cKNU4!X%h_c3S`g%Zli^T>|PkP=GmEuYk-K~sXXl^gP!I4x(;mAK+dZoGss z|LrJmyA?FbGX)O=k=LA^z$mX_($KL0sxSCEYi0` zxa!Zud6|k(SvF+&0k4)K-e~dKA@d(ruhJ1x3xAo@(-!>mpJq`hDCSoB$KpzBHLu$Ypa^ctWen0on(s#eO*`Yk@cSphEgl|F!xdQD_ z>>5-+I}{vW26%j6hZ35YxhZ5RZpmP$EB|8rDehGQLj4(l*L>;RNk<;LJcbuj@d_jeN4$E8Ds4z+b^Im-8AXG zAhtFcAf1)ck>hCKHqIA$*8jPSP)Muc3oSG@Df1I01@IBF_kI(>wA!S3^m%49o-457 zK^0IW!*R4ja78i(D~()ev$6-SXV8MfLsQ2~?bsP6>{htuBJC#$qg!^fHEs{Ri|`JM0c-dkWDPO?X$?VQIDl?O`PU{- z$Hn4bbFv;{nDb-IH^1REjsF`n6t0^YN+M{6a!wVQ)dBR$96#`ylt1vA*>j(q*G}B^ z*{+A;w|LDJzH#jxUULZGHP0g~%=P7VWZY1enOxI z1q}@SfjjAKg92ks9PQHL^5CvP(ZhOliVid=#b9?0%Iyl}M}tCnvqA})eE+jSkvL#l zQRUyxNGCs6)2vsUwrkr|N`BigqFd*)WH@a#6I&S?5UQL}XngV(FFHJXgmhS`GA0$z ztb&EOfWja^2SKJ@$^RLPWu<+yPdnAZ=XWbFSljK)o`-$d%A8TIB14jrv+Uk~F<%G0 zIm5o`rVLHNxA^T-m%Hb##^Qb#I|qd%Z#0mNJ2T_RzCF$0e3)5A$4#3li{lu&#!8_X z&E(AO%yVZ9?}Ln?Hpm#}va5>}{W6A3iBP&uJbcsW_N|Xka*A=QsRPk7E<~5#2<$@^ z3s(QRLdgNGP;Ag#VKgzq)yr3}PoAXqC8oNdVSu!774GbFdM-!{_nhtq%EE7$x}vDF z?%fv3x5f}uD4&o87JuhP`gT_+e=E|RamGWjdcE|cLD9M$<$(%iQ=NQIw|OD7`h8Vk zl!xhFmwHzy|K6b76w0y-lRq1jrBl?q2BqUip?uSzeD#R^E{ZwpP!-rIm(;4 z8ReyFKqdwd_?tIt{c2EZRiDj_StB``#k)8AM#wci8}HxBFfe$6jXt9sS4x!rD8!kU zBIG`1RRfKif^0ika;j&wk&ir~1+>~r{%G7{aFpSI)=1W8$XD9!vM*AZx{2#KFK#w@ zK|eNmFu*3SDJ10L_f4M2gCCnb5YwB_D?nbW0Oa);D;tP4G} zE?|5OIvF<1Z9N*-+wMBe#T#a5VRQjbh7C}!gDY=mC{yf*Y_PL_9T0P`7}#SrxhAh< zb5uF3zJ8d8Rc=$O7Fec3z{rHcAk2x`#Ct71v=b*07dKl!Xmfcs3t7g~a9Vw_bX^}8 zM7@$VE7iY+OyW6O@lr+usFM}L#HL}$pG^@?p@{vjjA8BnhsMzA>sSRHQ%gE$eAt;J zfBWU+JHBCi3KH|Y5xw zWQfx)4{9(c01M?-V4=)9k#~NneEtH+50oJhfhBZtn4*7G2GDZ|NhG`&O zHx9|wnKi`9-J1ov8S-+=WgYUGy;Go#>hmat1X#nvH<&K~)-VT}?uIp_aQ~coW)?S6 zfx$@*u!iAQ6W_uoS|PKh*5@OW?k4~RN_`{WAS&EU2k5niO&|E?6)RGpPVNL)!%Cig zofp5&Pe8f1RPoN!-j(Y7&0VP>Mk_l<)1Q->Be0bPfEsBE6w1fUaR@!FZ(A z-81yTm_2LrEIJGpbTh1=XQ!{XX+)%-Io5Z*wqVxoZC^dCG-uK3hBE}}WH3;jJT3eL zNXapvNuE{t2xyX5eI)`jb(50sUTb)ifOhj*L*s2qwrnUCkJ)^eD6|RO3_nh60yjga z)H4=)U6xPC*MT;Kz|D|eS#4`;V`QegXeR}9GYkc8hNJIv>8Oq4GT54K>tr#YPS)S8 zmeUu3vGRO=R0pb))!kpT@B(!*1|x$fDT5v&Q7&=`P$v@sb@I%2+xDK$wdHl7P9~a~ z>bR+sU1ybmIvGwyatl-^#~xNd0CjR1nupZqaiC7F!_q=EV=;4&f%N+}lMSTgr)zCM zN>%|RFK{{ZfeDzv#h0oAKjTYTX#PbT33GdP4tk|$w{G6e{p-S3UTHHt9wOQ%j z-xx78?d@AF2up-G3uQvRfW}S$6(|%wYp?z&P(WfB_(9a=D}Wjr0jMGHo*D2amw~0; zk9TWS|4}AGb>Vj?V)7_+etCe>5%qYmJ^d|=``Bbf2Kc_=2gaMT9Isr+){?U&`^Ry-1F!A&W!6tj%P z2xZo5*!tQF6rl+}w#h92P8pu|UXyPZX5fZEpY*&}yya^6>w`e&!so|!rg_I!vd>?A zlMUO)i5;@7vX`Eu!KG0Ns7as5vIClA*)VxIph-5%9qM%jnq)ShNj{WCN4RT}Q|``% zc|V%ut5-miTz1nWNhlqT?^0nqIayK7>CZ>(`U^ zWeRhe{;J(N;n5iadw+hn)y5{!J8J7a4UHHh0z=b-gSb+32U;kCtV$GN!Ph8#zA zhw*0j!-9hmv&%4<{QWre7>gxkmIQ>PSY41eeOhd6E^ zYz-cf9e}Pum?6;}bPZsJhCeXF{U4a&Rx=v_U2B6d!}L0DWB|H;3qaRy0CeqidW#u? znq>T6m?5Z1zQqi;pBm=;H)c2`af=!1{Eiu3X#Oi^$nzIwxbq5Fp!~oLJ+`|4#tfZT z8veix`x*WNGjus)|Bwq{hVRV9&%y67!wwK;=wSn3h8OjV-XP2nwR{=z7Bgf(pvXwCP*sjjwIp7K>^4+gNFE!k_!V1ugwl56w|6T44%N!m$?b^@4pW23E% zuL?({uHBRfz;jx^hNU(ooRQ<~R9Dr9e>soE#D!@78sfD}1dcj^sr)ol7t1PK!H`;v zd`$(6Rrq|+5Kn0gw$o}&eN}oy7zZ5#R>qy049?9O;u8lIddznyO1)iROu^pLG?SGo zIyGQ_n7{G9WsQbwA=W1(jk9tJ*E~wQdM+q&)~tc^g;7Mp(BQeuA(7Dfl7*8&@ zm`%O|Q#^KHibvLx5U0z%!$UVfs)o7qMyjv;almq4q0Y={Sl-1-#QpxPSLt{yK#NSD z&tk5t`SZyd>boavS|k2^vgSnNKc1|yK-NjW_GsuU`SpAk^p6(V8hE}->*o2czgy%1 zYv7TFu}jeNUChAqU5R(kca48l{JllKdA=)qt!PH!uP1B9@{xZ&(lBqJ^)FA>{PU3p zum5X4sLep)LDaisk=LapxV6b^EY?l|nWlJEJ5s z60&8LD7Q*vmzBMBS>aY>RoodFA=#U(u7r>o*%5Kc9*K;Gp7V1J*SPC`e)sozp4YGb zsQx(e-}yQ}=W!hGqnIzdZnWIP-da(XS;33fIAEoz`|FbniucZbS@Lmxv+xCv&~Q8p zA~dM{Gohj9hWq@~;#G<7sgPx2g|SQoUD#K3tzfm1c5*DEwh9LoDhIsRK8(Y=H~p54 zmz^EOl09VJI~1-Cb?J)PToMV<6k>E{ZFi!a%t_x1l7-xv@kopzEx;Ixcg1z**W`{j zJD-m2R)RZk0F2?ueL-sJ4#IVNAdI25CWJ90?X2e+f9PxyXMb9RriZTK(3QnKP_mHY zm=>u`vaYtz=F3ePvUXQ@ z<1ODUG5)!S62q!#M6+t1k_Giq1wsZXi|9de0CMuG3hx0 z1AK;zZct4o;4@s#9k}a%J2@5a!?;@=RW&rt0<_ycvMXw~i~?^q_8=^>{$0IcS`j7b(_Nyx21Qv+|>z%hS> z_YX4sFXQCvya`x911$t-coo|B92d~gGwUV6n(|vf1JiluM`%C;CqAITK#&Urtvx5v zU&eAb%_6u5G)01@0LRd!6!MQ3q*kn=13G*tzf+E%1icdh^p|l5^2=B@>KM#?_tn_I zszmt|s(k((Ktl@#(15@PG{AoaXjnyrYduYmwZaE9yt#z|Gz@2JX#Wn-Kr!cezE`3) zTUq1oiruR24BHZNfTKujiO35H80pv_Q0$?5nNk0l4)SE8n~2536G0 z8oD{fVn!qc8XSKHf1+(Y83NlpSEvldX^s#z$tknj?=loUD=Rtj=*}ORXAD?vFV!17 zY^Uq1yy_eq3 z%qbN*By+4s@<8k^`3tckYi9ww>s;GK=pdZCauNY!0taCZI0(0PA0kI1OhYwVqF9kQ&PlzbC5;=8%|N>2Cc1- z=q`e5;jrB75dx|!R6B9cM^Rlt?F5FOEv(Z%c!XRTLU)auPHdS5I8`#W0t2}^mC`%O z;WKFAK~z^`(83FKEOBavFJ6iPrb#6Y4KPhem`J_Qris%vU?3j=2J)^h(vKZ2N1ql@ zKQJ07>5QEV7UbroI=HT_LPIf1y#10Jc`F?MAdyD`ZiPR9~kKWfXqd3@fBs;4|r(U_irU$HUjM2B6kO7WU>=v9%F&uUjwz}IoA zW3lZ;zD^`~O0krdygIO_TC3(=>yqG);VaufBHe?G=>ps-NbL&&qs~ib7O%ty3xtKs#B1^Bm8+AE6sQOGcKd}#aIrQMPX}*ombuB|a z7XF{sP8bQZh2?7LeS>%(a@J5#Zn-U)KG#px7b3&Ey2(pE{u}Nzb;~IM!qDpvJ zuIs_I-*8=jSHknB-}DVbGp+}UmH^`#3o^tct&gmySyYJh1L|NMwFn#}t+(A|4Ybv# z#R(YKAZd+cTqAH8*Wb{LYy52CO#M!_kop>yagE6q_P;a>*oR75{}N<~&=F-qOe1u? z!~dh&36w3&TS1lZ*#2z^@3(}8|D=SMvhu%PJ3(d(M;!l6?PT-uPVJ=g7EbL1A#h%0 zBFi0)vXGITN>b1?nWLx9K5*<>XSzp}V1GlTT{!??{Hw zahT_G=^B32+RD}GxY+Nwt_w}98Dw20N>I3v^U=LjIV8O6t}shVJ10774X>`g5u^1m zel_Wvv?~JhUf2|oEBe^H%ZI+X`x-D#STTSGEj&QO^7ofL-btM{Sgz}KVyO{|>pHfT zyp=uR-5Vc%+iD|^#Ht@&I?D5Hw4rDGhd2D26?@Gv^DuQjx`Ve9sL9O_sfOP%P=Qc} zZSvf^+YgTgq#{H~BADNA4(~$|8myl!C9{Pr_M3LykU)7S9Iy59y%PZUGrw$pP_@k$ zMQF(2=V}ul=lzp9yf*qJc>ikaY1Q{7GkpBbawD~0d=1k(fjs2a%*?E54f+1dB8(M= zD_<`j$##@D=y*t)x#FtllYH}3^GjKe;^p}F@uu5Ikba4==jFR?uo$i`&~jxwcDL^G z0j_~_j}{Z19v6p7xnyr~MieI+45b|dfQG(&($jBsk$?urI#@+Vweh80XWmq97k)M# ztLgW8UeZBHMn^sQBt*Mp=1GYBrK6yjEEv{#H!E5-iTe~~3*+_nq)vS_85#Hd5zj;POvP?;Dp4a~e ze?)*T9h*vW-9zGQjEhyZzVw-^hcR5&y;!bm5-!)Z#abOsghl?V7>XvrL%0@dse)dp znnUTrv~7Va8|=4(YWSo>pQTPu>G$czc3*ONeRvPOcel&CSlbk17>$bKcc^&siUTU1 z#1n8`U4OxKJ&oqN9{(lRHCfj4Z(LVtvP=}$H366FDlb%kGLb>?q^>E`RCvK^y{otw zuXys{)xFT2;z_5xVW}djc*6M_Sv*n36i?tNu4^aYx-#K#UHAN*>)M3Jb^Swf@Fv7{ z{WbC5nch8A9G!0+!o`{d+KexNtl`}@@8B4@3^if2)VAV5Z4t-7h<@s ziDf%nS04w;*oO5Cz;)FGlxv9V+M|l%x`xM!EC!3iT@91K6cS{&R5;9Y~U zALvuJ3OeFVhcA@I7s`C%kYywq@GTBCeA8XCxPIn6fL!0^yvT5Ed^^1Ks745#hFzj+ z!8JdY$Qo+(_nj^9rS#?`?~R%$0J-*5>+#ME>RJD>6r>*1)6)a)h7ZooDNJ|BS$)XZ$KMpRe*GHLBW0f&;-fl$&~ zz#eTiT}NboizE+Zn#{t~&E zwclO5w8IDZ$Z8Q6)Pav|m(_jtX4%8=!@x&g(WVvaD0?qNO2U$W_L0NTKJq})1K=YU zqZ-MCNo&wZ?x%Of3)BF3*WUs)HNLg%zX;SwtYHH+(s*1~3IeVx%}LKa&|!G8%un66 z*&ohK8K67Cu9Dmk>BYmiP*qby5xsSnp2P?3pD+zwL;5G$yy+LBpVPXvk+7tFw>}k~ zg$MvXa@lGyj4O;Zgz{-Q6W1nO^2Gpa^u5>qfe#*Uu$+_&8~@-S&eJWn)-Ib5vlOq6 zq^|NZH5ZA@?{93%V50J>%cwCHe3PQBmOC`#Q&4qMd@Wq@GCczs@=IB$S0y;riq`=r zYQ20R`{o@Ox5QH-1ZiuA! zKe;sAKJapk#vvW}Cw~Mtb`}`F=iBP@U4_1si}{*B)H<%MWwqsHf+;FqmPgCJf=1>%L(3Y~*qVm>$5SGP_zudh2J zzm$_VD8QF;AOqbu=u3IhCtneKDGL&t(20RB!_?@Un^AmCB9iuX6{^Y5MKv#n7?zx3?tvx^-9ERAabt@FL28UtU9IU*%&ipt>-oE^>P-O3f z7zt<)x{3xge7R9lW;wmu4^@&I>&d>$iS)6edZJRi%hmK;SNN0Pdof5Z;q=S7}x2KyZ}1k(A@1L(1e(1@GDY zsUk(sak))F;sO$LdhZvxAZYFRXsUyi5;!QtVe3|jjb>+K6mK8|*9}*r-M_wOIlt__ zBpbJ$Cj*~__sB#6-glC*=P9`4Y@~W7d>j+BMza|t$V1YhZ)9#Ol!1cWfr1Q_3fm9O z|HB<9B$@%e12wCO+JP#^-+?NWMeRVf&NaS$IB)cSvjZhG_^JjE&0re=Dkpe5P?`E` zHh0OaS^xPNF^haM zeBV{t8JmNAGK^a{R-sulA@LhSJsFz)WU%`Ro(vbGF-CHH!^|m^kqn*;!y?p03_mqU zj>3v%{l%CIEfK3#Q_^^}{|X%x?SFlO-?0=)`-g#OA&T~ox)qu{%78j2k%pDrH3JJx z!+dWRbr!aUEV{Nq=fr+}4%s=WYiE%HM)DvHu955sjO4E%YD>fyNmAy?`gfFguIH80zB{@R(5r zy!FuPDX4%K3l;Dv)=&k!@rSqtJY>#VRMmem@^7S?8XQs$bxMl`4x2#;iWV-bdaqu< z!x&D-{u*Q0F6U!=>EdaP7jGrfH*Y~0Lr}oG_C}V)WOP}gW7ce0Y66gImiK6FDI-ZW z<>$1vF9ltXv=Gns49$b(6=a0#BS|%&fF}Y9c%sMx9w61Me)`JPv0y1zwT8a~RdhSo z?3;NS6>|GT%}dsx)B@ZJgG!CV^+fnIy*=a|O`g-d)C=EICfC8#kyCT=>d4SRm=jwy z4IPBnK(vq?87*{j!qBbt0JKZ=;0yH$_OrpgUjmtp-LI4eY=dHr(cM`~Wt zP8b~U3U{g2IuWH-9W{oy*AzEPJN86rW}ey`t^^?r_xhV2Lx69xbQ?h>B@NC@n-7mt zH~^R?4}qu);)@dcR_Ej*dsCEIHeR+!sCib7jVdbN4Deh9PUU1X9X%wh6@RDWI(u_5 zBag$3bWW=_P4m>6+{aFyIKKHieqGMW|FF(RwTQ$~l=%4zaK1ps_-|KpP&VXa6J{fe05$>(K-glpwx zX{xJpfn)BqM<@d{$IQQ*5IZ8Ys&!8nKH3!^koq&XT5_YnUf;HPBuz9-(I;joyH&ew z!Syd+W6SAdG9sk~t<@GDjH&F5(i^Y_<8_k2V+F@5Llkp3i$yl>N#C8MvYl~H%pw2Q z5pFm8H5_*Im1V8ut;Hgu{<{jz-VO#Q?$Qof9cfOtp)qH5joMp$w1#NX;pCDnd|}L5 zjjo+^KlL#yuRF?NP2P+P!t`5k^ViL^=F6L2Zd58n6Y>1q7Y~su1Pk^?mC%z41gh=! zwLNtvl+&EcVdloCzgl+Fa_~?;T1w`VVu6R&-;bc<-9`{MrVn_DyYN#iaWb3${KC!4 zT5n{}_79Q8Ql7I`8D2ED+wC%r5Pd-b_VBjEn+-bhR;w7jdb`N?t7`tK8Tg4)KcU7n z)akT{^$2Y7qUX@m+kgXigSt}#S$sk#LhIZa8c8nx@xA)u?hAG+GAk>TeQ*oOQ3cqz z_S-`jW0f{Q!Wupds0_p&6sqFh3*8zG-TRJH8;a%hvE+Gptj=-7=xr>ro@P_0lruxv zD;8C`btcje1W0!%kxKr|nyagOpxVqGBQ0h&mfO$<<7VQTTuP^;tSYIw+)}c>%XmV_ zGR{kCm4|IWw^pzCjzU4);yGgwsDXE;!g&Tq``iv+zAx8EEFNPjsWd9%EdBAblf9{b z;tWN9CDDGrSC%nCs#mD(DKHLH^mSr$JHA=)l2ZVXD}em{8%C zJv5~z&VX%wz}0+4G-jdDNM|i)ASHso)PU)M8%estq=vBsYtQn};I)81SXF#Cr1Z#+ zu<_pH+SRJ8;$t7coJkz4R3b^Oo3CuZIhCVU*7?9K7XD(5#rUmsx`$Je{iPhhwzkt` z+qL*SVtB5!qFY&R@280S%pa$1g@#~J^#>+Sk!!%dSP!1eypxYe_{nVK%x)dFaWmaq z`;&5W??aPC>W>#smd*;--3XI#k2xM@-umF-WV8KElZ2PPEot)djUhHA$#*Ig9CN+P zT^T<8$?5KJ8JR5XiEgZy*H3a2N&HSxOQUvJJfNpLS*V7nes8CrO}??Trl*JevhnlD zxcsA(Rg6J(?>=om*%KdqBGH9yFEgQcLRAo2V(Mfi4e8qbX8c@{{S#@yE+a2$dGdhyfWcSE z%X67Y+J(qrP-L#q9}it9m*A1#lkC16`Ne5%rt|%*liRdT;kOT+Sp%hcJvDG|csIs1 z(MFBosm-@(SaX5eU6%eREv;#R7YbZx={CQ}vgwTGG002PpvRvyAs&O=z0$V=^`0~V zHJ{FuS;*30#-AwkzR`g3Cp3?t70qLiPJaz}47y+G0FR+#>GWc6*Xk=a@41Uy6Fgf7 zR|TThFTA<$BbaBLXIC}yCHveTV>d)c6VHsNFS7S3z_=E~Kdae0uE>MIxJn}t|J_T~S7~oQ$wVRk1GS#F5k3+o$6cM^ z<9H3mK%vDa-<%6zA@n9=5|fTh*gI7>#(V6q<7AR*k|z0>8RP^^>F=ic5lg;5J;kfx zdF6EBOP7+$vG$pV`6H3CwYx7qMT$}*C{6z$e?!jO9vTLkau=L8E|(&slLBZ<%S*!>$e34*X(Zx4evY> zir?vWcc}-Dgsj~q!%VEmT%qH0sA+N?*);jZE+|B&G4x)H@kHkex4F={LR1AAohwuq zHoX7d7DD__<2lIg(06gPsU;;Fqcx2ksb?3jl|e?mi`78klCiV9N$v68`w-L`H4AzY zcNR1VGYk3xe-_m9H?yFYT52Mle#r5sU6}EwU3;~;i+CoUN5|^k=O{pqKdI7aV8)-e zy5e-2ql^xoa7@X%>UTBR*pDg8?0tjcn}pX~E=Fv^{KsRB(%A0xi7+>PG;d7+c`}Bt zi(F2Y#KQW8kv2jb}p(t z+wRCm;ro}u`oJl;GYjf#^XEnel1?-5)`w$sJ1zcwE?;bN$g4B+H;OOUWDh_^lYS7V zF*(=E4B|9TUz46!w|!>ELo4FcAGR|0@w&~M&gsQ4Ca7qFV<4kHi+Al-AUZ&_n~0Q1 zBFj-TWAueA?JgpsIM6fM5AK7gUx(0t@?0~yE+!#tZsvAD6Q%pzY&=#c4gNQR5qVtk zua=pyV)}h(@y<>&uJ%_$rdaJEaGyo~;A%@=N?%;k2wS+iKtkzE$t=)lR5^4$Iaae7*I9j`dk|Wd-vX-#gcqxn)LtetwLRAAo zG6`0jDTmQwI3? k?1VzXTP;>73WJ0@cian_d%;OdM8pDqlYqaS^oRcSU*1Qu?f?J) literal 0 HcmV?d00001 diff --git a/Tocsg.Lib/VCL/EncLib/AES/$log_aes.zip b/Tocsg.Lib/VCL/EncLib/AES/$log_aes.zip new file mode 100644 index 0000000000000000000000000000000000000000..fa1b1be0e12da6f9855b28d60ced1e967d8cd113 GIT binary patch literal 42854 zcmZs?19T-#*9IC)Y+I9LV%xTD+qRudY}+;_wr$(CaWn7x{r`9G`tN$q>h5|rYS*rP zPM@w?Eh_>10~r7S031M~+(x2#MyGTP2LJ$q3J3u5o7FRN&|zkzwzM%>PhE?eqlFLt zQ#J3BA|VZfOX7_516))ikhRhoN)x}q9^0fj&nk~7V-uIdO5k@{3)RI>^U4OL!|W+s zk{7Fijmh+|@wuN;;?Jz9Lnlu_++MP7bYe%{IF7Fw+eg-5t(ij_4O{f!b85_~W$y$L zll(cbF2lf=d_k>kxhG>sWzXzXP@+hrG(qHsL^OX~*zz)1PeW!QBe!y$IMCwNn3Zx4 z>AzAF;q;Y0LgZ11iOgW9g3&sz-N5S^l{Y3=6eSPYpYuJz_s+xsUuAghG7rZR_|ezN zk(5)L$Gb02Kt;Vme-V4i@$_gOI|n5+*y(r_zU=*$pf|KCOrF42GM&16{_MsG}F)w+S-9~6L2m07^lENuidLq{vixu zH~q$5x}lCS?Oe1Z+r+RUE{0)aavN+9>_9RUThBD4 z_850?qC{;B)ds$$_yp1OynCqdClI1>ZVD}a7_U1!+YyQEpbuc{z-ssz-4cz z^c7tH>Yk~lSkwl4koNYZJ!QaIysTwk4?aXO>zabgrjlk3g4~MBo)? zERg&X0$u#Yi{3jk@-E-nHgh76-AIT{X83x4fcZI0^Kf?9_CHpvjd7%VB#N_9Yv6tB zHPN=2+=_H((!Hi1P8Yn5rUAjsITxBlQdS&jwTtqDRGR8$a1F(xdFiz!0<80PFsCUp zpNo%<>L7B1GDSHXm1g-2xfcAQ&3C`<7Z*^`^k5n{vY%U5doNk$ouh9p9{4oLr#@{< zH&Lx#CJI{T;QZkI0}+#50}-TO`$+&1h9Uu zS3Iw+B%*kj?3Z)Jv4JlTVFG%7FVA5rL{;bzBXQU(`gNe}KnfNTxmFKw>(jD}&#$rf zU&@m=FFMs3X?E?2bJNjBV@zwE_F2k&2{-X%rp<|S_$(C}<9tZ9RcXRv>7#z;a;=T@ zITw=Ext1n%iE;Fsll#JMDJb$I>B~cKeMcTy!pGx#8N%qda-AM)JyK6>iSpm+mL0W@ zGDyL~2E$=QDBnXTwju{B6FONO^=)G42(HT9_h?u-~;u z?ib&^5e20+Wt&+>bAL;|WsebEA+4|-wh@!UIl;);?UjrDo}@NaWu91WgFox@+=(Om ziFCG+jA|C@F`*P%c?0X8&^&N0pf+gir2=q8fWbg)Lm+iydoL6=ACid{v8s%HcD^ef z5`tF$1v*Y{&J-01xcmxDK89Wqn8-k+Jygq!ja#)zqg|Ygv3?J(?{jBew^pN|2ROxkxsvC#uopJm)R6omm)JGwAc}H-R%+=RPPTc1^$w2(P zu*rC%ceLejG!CQ|>Wl6@VHHf)ne?FbkYa}<$wl0D9svX|B~a;~PG4>E!iua$(X;R| z>YX);o2L88wnyQ-Zu5#>JtCDwNVSt}#d`qkJ~}Esyg##V)*=h^BU?V|(%ufL%#iKo zjE7OD4?n}}RnC3X`)c%1?bj#F@K+U$6CKyOefkt%{reG>-c!SGs5trS8D+N%LeO-L zKk~=zH(n6X;;3js5sBRg?zkxkKJ1&{zpWma>r30kn4UR3Q;g5D0bm;~YfIZzphKAJ zbK9MuSLileB5PMY30K|zfXq^ICGtM%7$%_XXTtFuYFaC=c2NG(>f=FA$-fy zmP6}^G-%uXX!y(ofc*GG+<3)m{mhnN(&O0b~-Wt?qs(o5b?A3Wd_OZCr36+Zi) zG~CbEQ||p!8`sQXTdmsOMz1cLUS}OHTi*A6vl>@Udmr0#(RkTD?+3+Jw@uDnHeGIK zD?qIa+#CZMSB<}?HajKp9DYZ6 zHi24RFE_sKUkm^a61zRA1P<{)BGUE}0Y)kOUc?9S9N;A!+7Wr(h-r03o?(V~7zR~z zd~PWW-VZ2lZ3KMYdtB}1EX`b0(X^WDYck{B~t;Z%4VYFKmUJj?%}1uO9dnHx!y%5Nx_)G-6t$lBFyqh2F8JpDBOn`P-UesFl@{j2~EABbYYsz`gd?3cx@$vwDbuCcNu%q)Cr&aHeHs-&x%|e zWM+lO^BrKT$8TtHwn7H#om#B0hAZPe$s{!W4>4#@uAqQLnn!6VI4nr_{V3T0;;elz z8%za{n-*)zHwj*Rt11Fg0v5F^YN>C~4yb7@sDeDwE!2UrWvmD25kMn9(-Uzc-1YVs zM^^wL0t(54(SNdzqr@BRJh&CG<3un?$Gwem`8|pS)=tW`@vcr4E`wDg0dskBpzIs# zliyGFXK2Oc0yGs^V&|10(>bp)4yCf4@Hdh$)j_MC_E(vqi{ppv=Qs(H+N=w!HGF z8AQA7fUBoFjQqBopJSzkqHEFI(4-(<(!=jWs!?E;hu$~@KibY>MiTPt^P|DvJOcHg zVk2gcqUf?Z!^aIpS{``V+d?6s0^lGs8NO zhee8@agCuHFut6hoj+-LOI%QOrVBE?ZW)qpS-pzZ;AImUQ1T-M!|p{a8l|?xcEp)+ zkWJQpK+|MPefdKTNBI#zg_9oExKU9v1Fgw|pfSbKcS)_LZWlUnqDKz6*_etR^5}N5 zeh;SI4D5ClIpG{a^cT``jhsFw9{)ndbtn%+w51|#;cKKZrP z394hJ-l$jDc&)%6FIdqRzWN3*SrwxrGXo)3Ht4~`QEdZIKkct0KHOG1yEJZY}391CUkN)DVBgkhEly`OO9!EgO9+bw3gWFkRR5m67x+} z8IWNzWOTEW$Wx>~<~ke9u496p(oGb4?yP-?cKjIXJA=b)GYUD~0Bp^>rgwfZRK$7a zKiFGcHmV%OPZKI7bfw_q`LXR9^fUYPtjN^%8woI&QoynZ`K5poxcf2-8j4Y|7!WL2 z1pR416eGc{-pNgW+il@-@IFf-aGY9p2Fq2kc=-p)VR*ZkK8~iYbiCeWm8zWCct0MbcLa7xH0hkDUQxf^ z!F66TeWG=(;;k!3XepudU11PT+> zD_ZnB9Kt`vHYi^6UA$igsT5-trA6>N#M>U zaTZazNow4tH0{$_jTo%P4K)z|ui!<6Fo+M{lUvb-BNLX|md7wY8p{TC$7@KNqY2}R z4#)$?rqA}Mx^h4HYF?5g3pa9gs_%S=@G{8J^^v<0HK!DcfjdS|*iIuChwIH$$bKD6 zYgBQDg1Q(SjR}myYb9_gebqFCkfM|Srb%md+}u(Ge=3E5hc++Y1M{TkGRE4V0Ro;(Z7UH%hY?#` zK2fEU7uc-?JK32x(0`gpN7v`1;f|Tfj_yU!hfvD|j=-cLNzssSpR0O5SqG+I=0Qa>W$DI0ZANXAg4oAZPidnIqs!MC~G8bT|nEy5n4+dB*Sbonma zgBbkgtsjyPrIT5_fT`o3Oi>MkOH>PbkS%Kz*@gE?HW)#%SIF-hmsLzH@j((`FcE|? zG!2j|oHW3$S}_ADG_sNiU50ylP(K`qqArR`dW^kLYXV97h>zk<+%yZNHt}ev8bh)4 zcK7k8NWbbk+Y)tkIgHqI&_LR&-qw*iMHd@?QdRbT2W9s02(GSw;Ld0!S)y~S?9A4C zQE1^MJfpsuD5Bicu$u0vAo1=WqVqx&K)SF%^4rw*t>t+Swa@R{~7f$xmJe(=Fy&poD{wz zt1=N_4^G-42MvrJC_FP*%UCwIvK@%YP(1Mewyo04ki>cW!f>o@4 zC2WcpN2?sWnlc#fD2vmju>`~Wapt?Asn+);%W(bhwu`C1v^qGQenk%We0ze@8tINU zy7b93>1};QM;czMZ;|a$n_oIV13E5+{vt7bpY7Ptc0tYxCjw^LQIF6r^aV4SoUU-K zeg%6gye2D&FQyf+|j*AoGM&y}0spI!9_2=Viqp@TIl| z5KgI00gZJv+DQ+MikCt}0YB;Q=Pw@vzCRu2dX;8ClU0~7j`^3!>a-B;H? zoUy8d?_Sh=7p1xQCL>!-t0uSl;ct4(_?ZsK)*n0J@(SDF)%ox$)eewTH~4*O^CgVH z2UlkoM;I))A6|R_i%m7}kO84UKghQVXa9{OW*lCP zuD;)MUBAb=$$~P{8YFLmg}@9IL!f@J2|Uku*%l}l#$8(dy4f4`kpA4ap5g+%70O*g zu~D*J?FmCx7{AXP3z8g`hX1^E1^x9y{{3i(;Zg3n&`>nr`|8e6bUZ)3XRCVf`9jF= zHeY`~{snb}!6!2j^&(^{+istM?bJ<^;7hXVUNXx2*AQpCLH7P9=-)#F@2ZcLYnjST9|Hp0N|d&cC!c3N$ z`-eoG*ZiT|4ZRot11wc;O1z}%)B~s_xG|N%TaYo98qaS|2Y3waTL3o}a=`JIZI1m% zBjlj(wzAIC?XSL#b|Oy5LAn07m$&6V2H4Gdw4uEu*Ghr8hsB~<=2u(92x=9(M5<;x zTI}BDxId@ImT{5D7Qe8Xmnq=`@b*oWV^%bJORhR#-2!$XmE%AQvU~AZh!T& zUM=1r$Iz;KZU?x=jzse}v8Z5EG}T5;R6A3G4(}{oiw@(O;hHVd>E=X=;|D#xvlX9zdtJ-SjqJyY-af-OG!+OT8WBzQ5_>a?>6C15}(o<96dewJ;#s)8oh#h|( z=oC&323w=mlHFO1ZMZN)$Ucn5ncX>U%py{4iogB-o5;KR|H;_Dc^d@zE{eZc(t+1| z@vd_0R<&Jz5RBc(N>%r%=j!^C3S_2a-vhAp#%t+oBN>hK+**CFb;; z8oOO_Pn!DIo9+wl;4Q{Kv$N%_${lcU)>HF+@RS%5fE#<_qRj5O#rap$-S`Fidt#~? z{+h!68yi=RC+L5od7}NxUk?Ar86M?UC1ti%>H&jl=h#dl&Ud&dV02$4tKJJ&8+<@ACpW`u2CJ zD6^gVZZGsnnY@k^z`X-+&9eHuZ;gMysL+ftES%XJeb{rNFkcwV8Pb-sy}s^VRi|)8 zoo}fpO|=@l6x9|feHZ;0%RXGBz*H_BY%!;%$&31#>`br=<<@BdO@mf6F=tyqmG*uP!D{*N(S(v{p_a~GZ@8UKTTf6x|t5YIgRS35bMf&(_Gn&huc zWB4yKruNq}#a|OJmqWa+ulM&xg;ks{Zf%mg3GoNR?c1Gyu(5QIp7^gZbMI|tS9Ol(zsSt>Ji;Rt z<^BhqpQ4>=5V3Hv)g-Z3o1r$K%BQ>J8O+4Ic_;bf2l8?S;wRK(NlRe{9jPvKMnf0FPrxEm< zSz`wa#e=|=88)W?_rX3ETz)TEBaOD?4Zk=BSG^9NqGlo%Hc7@~Ar-x37ITwOQ7Nh# zsV#RxLEJ}cN2As+w^vQ&Usv?mhci)U zXd@olgx9#=(0;n!tO#ri`Cq7jUE=;aAM3d!yq^PjPhG0% zsfyyWl;X0pxo#b9#QlS`P#$;hI?gg4%UnH||Dq#w1L++18=HE6Nf6po-6wyW6N_WL zr_aFuh;Yxfb)98uJZd~@|7!@M`}Cs?>>oV+{41R@_+O$qdSlLS<=dTBl`J#%xi-;X zIo4mo%H&(=3F~j$6u@TW62ckI`3knJxVYBCeS`R!bI18-~FT*W|#nRb~>P{oAv}Pp>i(9?1kvMDczO>dx)5fN(N(=Hw z<+Qbi%>PLa;C~1HH*c9}|Ktq!JS!7U?@7PTBU|==w|oyuZ6pZc#MhpX008#H0RW)> zv*oL2Z}oT2_gvk|=6lcg(7}5EqSH60^rD?H6`-~eho6?cQUISI5PL`uK~0|cME5Jp zp~JttCWf}m3`KdV?8YJbYVv5vZV^e1s=n2~fOO~Dm2;hk%|C>sU0tw_l4ge$#KiS_ z*ggJm>`Jz(nnvE%YRTEZXW*EQ6Fd{(P-Mu~y(usZnU~A+g05+Zw4IY3M7RX5owEzw z==%1eZRhty@6I-Vl9Kv9!1$xplU;_Q4(R2ceXRVMTCuSjI}j;i36FzXn5b%i^h7T~ zD~m-|77aZFJsP?XSH!_7lDXPK`T2#+QNT?P`eeAO`VfYU!}*)`m7ek}ce7Mo?zb?KcsVtPJ-L2!7|39 z+zHDvcF<)%Co`D`NMFEl?K3%Vz*LBg;WNKU8Qo!Z3@za0(c?-#R)fljP6$hSW)xxw zYdJYsI3Oyr`rB}r@Tk^2cnerr?2A+T7?fR#l7h>^o+*EFU-DSL1{* zmqmPjpilC-_A_!p>^=7cW=wxPc)@c65kgw}3Ar(1eFFpIL%|V|#1O~aBb7=u!0wff z>6LYHTZw*iCcn}XR3*#q1XiJeZ#fV>vC^NqlH87#^nqLCdwa|AlNrtDQa_Z)h@^Yx z2_+ECJ^&9z=HVY^iSl305$Q$Px`lhs`UWS=g+gK~h_T$A+3D!3#}b7JGu|Wh796qB z>Gke-4_oiM)PtYhqBi%=#iv^biPlzD!k0D^wGOXaQLHD*$|AVnCwOZR%rZ6ePZgEr zdtuG<8UvBsy64;>q1P!3F99^syIbH-YEa}?`*JmLl3Cvjda!dpw-tw(wnP?(iMB_MG*r2KT}Jl+m>gV^X&?`uw^3u{rphmW#uvI zw%!T{GhI65{E{sa#JM=*vKYm5c^-1(J7rqZB0SmZ@FvKs;Mo{~3?*xwA3l)%|Gu4vtO$*zMur zuDokG)EI=Xdf)@6CBNmbvo$?^oSr&dw6;sLp}jRfS@>?=A~piBC5+W+K4z47sFPFX zhP$W4`!-c=Z^y{Ps%e}`T?<8anm0e0rf;;uVhNA-=Y0d6VC@xMmFLSDnj!m{dW?@U zo-r8(TkBKCY^!LhFQ9`yc|{Ew~KSIfqPp@Ek? z&V!jQ@ibY_x-!G|_|mtm4N^Jtr7Fo8rubZ`-vxFaYN%uGg-Gh`^BTYSt|{k`!X(RJ zHWt7HlhJ)Ug65fK4U9zu`R6m2HnUHMDbogVTR%}^MA1y@=AVR>sN90XX2#j6h^O}O zGE(_00(jwru3k_aETGIbv|N@>CrUi%2&P3(Dn-rtbAII^zus|F1*fr!33PyOopYic zUPK({Vz>LtR9Qi+h6~6qg|PdIpt;mY;;~bjp3kbzs?Mm+E$81bM0z1Q2pdQn@EIfz z#toVWS_!@KO?MX!#cQK6AXJJOtd9`C;Nm#khrft#;mgY>CE?* z!BiDoCsVsPv~rwa)qct`;5D~6#0{A9eP5uU13YhrHPEd#a&LFZut<{-cA$c|gqkmA zTVhPUcbC^8jeKQ1N;{0x_9>Ei&M9MIdEKr)aVFQ?-`W+{8}BRg@vMX@*F0!k7``^F zT$K@j({cb?F5jwODn6&`>#YYU+76++L!`;V*rT^bR;|o8>HJ7;*q^ZCkq!UK_w zb<|Jjvy;GQg9bMEeuV9s?#wT+Z99Cs;T-Xd6l?w1CzS?bVT_rX{%QD-QLtuLoTIEH zbW-csIL;>tt(=lv^t6#2KBGiD$qtmaeRWw7*4rxVTD?05HB=6wHzE~^`rsVrA??ux zQ9aZ?XBtI5mxhrT8sglYez^=hjyL(qjqiL-n<-6?I`{6akCjH-GaF0Uzv^51*sO7| z5qd7MB*3+B$Y_SFZXG_ro#3X!dJwKg2DhIvC#_7-vh3w0?y7##ekssK5I!T@x)S;yi?(y(RP9MgZkmsu_paESy#u>8d+Ar z7Sq^#q~*=QA<^>YVA(>Si7L}&V%N!|<^YBL8F$_qksr`k10^~T5Ka_sC3Uj3Wb9{` zV;~yibz-VMouDXd^<-s8*ILzLLAN`$RBH7HfEy!F7kJ~r%*M$2{#zb;{cJp_`-LXv zIEa4sgf5vc7seibnOUrplyu16eXh}}#QZ6pDw`blP)!1_Khbp4&yveG`O0H;fSDr2 ztD>@-N9{iR_7+W#%vscgZBRPpcgw%~LYh@~fKPcNTkHdR zQpT+pFJ)zhFcD|x(O5woKUeCLuqpJ>Te1~w{bDUiJ`GcsZ@7X%z#&xeTX-IXDW9p- zZkc5^%#=oz>{c%=wM6KaqBgtx&2`2F3L+H~*>2Y>N+8W(*G44VV1=)l_Rd8>E#Fy! zwdzSTqa*v8`4R+ZWMcuBGzP$ovU6IrOj@j{DsgQeormMZFR)=dkXkgHYX_6!%EP9O zR*2YI;k9tKe^S5}kWF#n5CMNq(HC#%{us+cW#v_^CQ@U{L}s5R_swe5w3E=q2)>jS zb-hTe?eTg%PA7sbDN88G#a?3a7)R`_AbYCmb@IO^58QC6VUA2ysZK?Zc^9Q!EOP=` z9?l9bblea8-4In;eoPro#%Yxa%ttvmDbQ}pIZKjpjhd?0*)$}CpRAKQ@2fd?t9%r| zMsI%HH1cll&`Jv}Sx76Phqak_Eqk@!E-V#pTbl`{jFVbn3rK-KeAB`4xLRB(Qw{J5 zD9d8Ifm+mg1ig`yHKdA-R3#Ln7fqvgXy1RMvy@286Wk;8yue<5B`(oz4+w^x zykD!9#h5R6m9oX%x6$(LHi2OdwN&QB{26D1tyo(dh@LSjN>?1xESlGAAJ=5t&yWnE zRIoV{k7w?AA_y+%*UeyB&rKH@T)QRa|_LfWHG`H{zo4Esski!PE4ld zBPcU-(xQCIv}xWZ4?Pq_ZVDhj_`|u$4%GzK@<@0w*t;b=m*vs|i9n*x-Iw?ygWcOIOJr`0q?);UMH$))1%Q=|ae?D+YJ3@K%DeqZBbj4(@i?bXwMjo>;{(di z=Jo?p{!YkAqFAQ6Y^tNV%KGV7n2!rnRwUR*pHz}}7vdNXb#HO9*Vm34?x@g7p86ZY zzz`Hrdo@o|AKRVXb3DQWW_~Y41T}Z(V97IP{;WmBXf<6KC!Ko{p~{oD23^v{XP5p0 z$?pxEIpz=~NI+-Xo9CXi57t0?*SAcRt>*srR57kd5ggTdKcSC)_I?jShA&3#&+bt? z)t7A55LX++;IvL!IH(<P4(KDDU?`ft zf#jXpG20iTmRovFFNDtLXL`>Y`gh62&?pY9AGjVmY6dHpD+U741TCG;D%XwKHmJ2e z4jA0HbwW)ZDPpcg(9gUJjmr^N5)B@+eeHj+?gbP`FkOO9I^-f`+b9~dc&5yRs}2R; ztBqaLzK--LxVu~@$DmY3J*u~=6YSP8YGj|hf)nFOx`etuX~VSf^SzPHS2dA`%tS3^B|S$MF5KjOVXxm*#iA`}QFmxcqvCfOyGPILd_af z`P>nfs!)Z%{`(j(_UEYG5+F;Aj>j(DrAtYHZt`Lyy^y$UV{uCa`f5 zEFC1mx!atXee`=dmcr@Agm=tlcW|?}>HYUGbG(JO8nd`}*@i?%m!O&D zm;v|MXM~z*_W+-|qkD5AtA<7W{Q9sFkYXX!!uyF{(c8jEs^{N)W+Sn`^|}zoJzb zOTuN|O%>y3jIjrerkd>pGc~DB4uJPa3G}_4dH$#}so-sYONZcFilUjZVDf<90#jjq zS=`W7-Fr;^?SHyfK*cFq&L^`+bS+E%k<>6*MzYI@YeVoPGkA>_;KKSaYcOr^12z&_ zj9+jVDmYj))Pf`G<+;}kyC|(XG%>=-pLWX_npI9F+FWc!n^{f>Eq{TPK%}*|#)>bDvC5}UsbNc58uXkwEZ{)`JtL-% z0CPtQ#y?#M;<@AOmu}Y2&s2#({h=G?9%n~4#^eNF%x@9dF!`%Ron~r#tQYiF--MUr zq8ffC3;d^|7)bM-3uyn^80=3qV>|m5^W5Zn%M!!cA9Nbp^x(*8{p=4|teM$?#}$Qy z`xylxkGJ-Z&~4lYGQocmVX3ziBXUGo&?Rg(r^>1B41$*O3V!Ldap; zT^hBYMmp*X_`mCeO=UI`X+pU&O5bmY5KI1debA7e>Ho7nSoj%&l+B!z`Mp5M=exWr z%@6*2kst=1KWuN>R84^xW7=nmjcCBg%}kiE0kYg;;cjop#pJDa?~eKsw|1Gx{r+Cl@)HDK+{}yjhwk(U!50-H`6I%{$b>t#q)Za#>&1 zTh|V88O~TQe)2d*hbu>RyojkmTO7B%Ee|yI9z+VC0+}6q1R`G=us9*)BPm3YSrn>V z)0dpBvnN~wz)?!u0OYEE%!1slbn2H8L0i{9;@KUpBWnygqvnRJ{6%|5)tp2vt~?W= zMx5}JD!F|i=aDVo1IEO;u1|Ex#wlR%;(dxfZ|2?*cP_dJ^wSjzBX0idYCd9<9^8fk z>(sdwozAI;W#V~QD!(k3>;1K z_l~&n5;UR^?o-MUTCw_9RH;S7TUZ&8-^xxsgrOMz#j3Ch0vDN?I3> zHo)nfDkryQTyvDq>VX8#-Rc6FSBn<<3o@w*tysqiK3F*hxS~V0swItEIRZb4^07$7 zC+0s9N#Bs875Bgr`%I4tKa;`plj;c)veSi%3HSeGwhNVDy$Qwd#9mv{hf!OB$QGgI z40E>3Y^lmsPB+V4<|eOtXasBfB#t$unJ87nv!mv`LT^$5<$lhB2R=!RypV zT6zkyR!_TZO*%qfZ^ns#R?_*zskmrG}#FU)XPoaVW;WG(8x{~3N2RburT2+=pq z+1qlM!rWGWb#bJR>Cz&nt^NKW9EOc!oiMza3QhPliFNQjN<=qWz{Yjb*gC^}#$d%o zMw_@$Lvs6{<}s_FX7%pUT6~KRm>`HlHCb~B!ylHR{w}WS*-=xMu6kiq9IZ8ihtgGp zX<vlm;Grks~x;7eT>JA=mEG|$|{tX>1Kcz2R-^tHG zz^7SnIJp>@ZiV|_Z{}n=wUz1|3O$t>hX>MVB-?-BRer}OKwn!mT$pV>{(?x-ArQ+f z3~}ZSrm0SPpLjoi{{?-=_9%7D_}f7S<>B-x*hj59JSndME!}A=TrsHQDen+vONjG2 z5RXy_$Y$|NVXd{Kqe1=WmPE2>ZvE#(TrppR{-Y4l&$T%u^A#A9JuUcPO@MY>j|McD`T=>eFWw%$Rz@^m zy_7PGpvJ{ENuhEzy&ycW&cT_b;B9@n<$0W?{0f;qNggWm&(Q5XETtcOP-_#C^eh}2 z>l?dsI@ykRze0VIj<<-jL0(e8Tk2;UVYDSThDFh^K@|Wh9~#Mh_=)z zpgkVI^YuCUcGGtx0_RYt-R1hSKTwXgRT)qW7mYVgV|o&44SEjqw#W>DwBFnX_Ph~N z7>(C-csqX)PHl;J?M(aFZjrixbL^sHkHY1RKXL)s-GCvOD6VdPfFXQW2b;+bU7Uuq*13(@p9Z|>nh$0Hx*PSB&i62pHLPmDp z`tjW3KzzsitMoRpav4HXmRI;gATFXHv4O%_r-kr*aKY%rJT)=}y<(a~>S=|fE8a0M ztiH*Y^m&D$d~bI{xTSe_24>6#qSuin7q5PD+dT!^5c8c?~aI~SiLA;+&V_T^0 z0^krXZ(<6(HYnUoDXuo7(qexu(u*2%*8Rx;4Lk-DIS={A%AA;5nwcO8?(tpn>fLPMe$ znQH^>;^HW-4}=nSLm9GB;yOxGBcX$ggai)(N^XbVN5cE&lg(Y_X2@m=FC&;2gJRYd z8>C3MjJABuH3mEm4W*zo^9elQyaT$6*k@pyki3w_2OpxK6yY<1Q{4+UK3e{WCp|Ov zjG&aCEO4(;N+*J8Smy?PzYxhmfDF*0XeWkl8=x3pS=El^w7P9brScpEv^ndg291EY zxbL$SK*!cqDCYNMi)@s23$iZu)05Z8 z9>22wKv)>vyRi0|r&p-?oDu&T7hJT3J;WIe&HX&HM4GjHM+VZ;bmnYq?@NJz1m&a7 zSvatO+FLKGN>f!T*aoO%$ zE~KS2yA&j^-t*(JuqxM`!UaFx^e|7qQ`iQ3q?pPgfLYAC8!@H&Bovm3`Yu=JK8Psa z&_h_il;oB-*c@5SGqIX6c$I(~k%Gr|z7Nzb?ad>px4^B|gnZ0~D_V~KCdnOwn{e4E zw$>UFgP&)gwF9|Nh}BF+Nw`)GR?fh3kHCed^Y14<@(^lWkhYpn#dp~*$lqQHLl>vV z?E#)oK?Rb1@q6hD0G;+BOjQvTkBAbO-zS& zZF9w9_S_^vC<(yxqmBcyh77_USkzS?7R-*mT${{cz!pV?C!|BIj~rXzeoaQItArCVz?oJaC&wT>^D+-w?zEF?H1ghkvvMrTIbJ%4K&w)H+L)JJQk91$X)@Ykq%8>P_O?x)%iB3G1OzsJR(Py5r z-1H;1ew6s4FC8@2o9>UNM!vj=Kki0U8SqFSuNVg!O$a`yE9;_9cgPt4Ax0iqHuR?u zsDK?(w?O*kLy+30B7ncRfChSCCvoU2rzpoX>h}sHE0&&DRitFUHj%a*8U(LmQ}Q3d zpVSJnM@KJ6n41|}@!X!R#Vh>xX@9F($R7TJH+T2Qq?^zmM+*q`SPJk+uJVO3+Rvp!+V=EQ>I$9?*k zR2GnvYV#(pO8mj6+pOTS`^8}qccVHBzaM4-fwUYN0&C+MtDePPqBEW_DPI>6B$Eo} zz-l*sh_SjLBbbjQzDLCOfxK6HVbG1NFCZv-SabA?!Cuz`U{)C~om=QkAS{itTK!GU zWGzZ3Jq>>ItaO>DM^s|uaiTdie#NNR3OCVB$>@3W;LYlTS_#S_!t#l=h+f0xWn_`g zL%_`}aXnSRT`T24A9<%5)7Xuf0DDGMBA0%Xx;M&0#Vl!9JA!Bqv#$$vrvq8pLcAwB z^24*lGw8}eFt*EIa!3c*x3IrEdY6#c;cWw85d;8Mi1iXEI1n4KyA`0@FZ2?d(RLUC zpaKd2JG5ooE;)!hi`iR1(dTzaLYrqb0V%LcnFskp#6`*V?HcQ*94E+O^@2V4V<$zxN(El!p8;%GT1vcU$T5k- zveL6H#E}~R|A)ft&Mt0^KeNYV3wO`A~A?F^V z*F}7YM=Xt)E8a&=@dUw~Redr=c@tG#vua*G5ZVoh?52q9E{p7nZ|!BpW?8xN5X!-~ zZp96I$>`U)FK-Nu7ue{A@IIko{QI$CivHl1;P?vg zzSA*1?3y0;DR(=6Qd`ZnrmT3Qi|-o%vA;)~T21ZOTOcH_r80ZT`QqTkicjnX+ee^dI9NqUf}H%AY4 z`PCt(grbIhNnKjy#WJX|pgutvpgAL8ArvLo0HbVt??R7<`@M1ER3H7aF6A@SQs@&ejAO-`HVj>2mR`NZ z@p8ethT>~R1QW~sbVV&Apj{A9bXH{>cp?m37b(mPUQ-A>{aOsRYO3#{oJL+=|?6UiX8wn`$05<;eOaxQAqyyL!1^56l>g_Sm@#>tU6L30sd;{0~-=mAB`R4{w)#lRIZqU zo_pk@;>;*SNEybx^-xQb##kP7q3xPl+OmmYKxyve5>`N9Us=IJAQ`<;KGSfH)>ct- zVCiNhV`dJqN26D&uko5^jYhX6n7=ilVnrCbUhkaK_hL=VOtEoq?zyr!_wUBb7P{W< z9r1fa3=I`Ev=>w?xGIR@%t$B!h*4Y3(z_JF@;EKNnR2TVQ0IKDjwE;bnHR#DUFs&! zIeIyAuJ~hxn@IoX-i=%br7GQzt2HD|^>={JZT0^2`jx=-wcly)!Q1xgL#l>f!76TF z9F(7j&@^)ofX3C*Rp7^E4~s!hHVwQC7p~7=7rl$>ce-mxKcp_i!Aj~ho06Y$%I_M?UlM_CyipoVNI4c z^ikdvC->kD9od1ArU%Rm0w-YshL?(DH|jI``weQKb0#s%== z1ui&8R7gCGqb%XBA9->2ramJV`+f}hfz#I6+{6c2b!|80SlFwqb%Pq5G#2Z?Vt#X> zxWc`_Wq^4$zWd?pJc+yj@25{SYq?E|2in>C)j#=#qPOYfmW9E&#bv|zHov{gIvR(a zy($T`Ep!MDw^#15XR~K?wnPGrR%#1e(EhkNswpeNV2t_*ZxJSkKUAhci3^qx^%Jba zxvsPIC>dldBijA|T3Tg0Dbk|E7G<(|cEwN!(@@(cRpUOQKCt#XTYl~xyZS|rj6l9v z`S(zt{5$@L8Kv%~es)LVd&fed`kL zN3)UyrZvI9XvGA!l;{ortL$(ytevW8YgF0 zEq^~LFFi2TtI#|#S41o7YX$fP9K#MFLFLgUEUDNPB2bj!Ju4i&J&xD&)^xZoMqn zE9_XbUbXrcR`6Iz^YFn%Vv5#QDf;5BQ?4(~QHl|m=KtN(*K|m0I*@@12z>+jZ zhDLAnCE#J<3%q&Y0 z9FksGcJHBx<5r#>OD}p>LD_F-WNH~$_+9oYX}5}3dUqqs{2aP~S-SX$+;SQE>G}D=oVGB(p6-j1 zU2Y|_6$Q7iZp*m0mP^I$pEz-_BIqd-cDpF;ZTdVx5DM&i-qM|5>sRD?iTCqP(SpZF0LAg|q&|gWa!MG?D zd2ki`72OChstS;*DykMt;D0i8RMSB7;VSYXDrpdr)$}3N^hJ{~vDAPv3Zlx%Eq&cU z-k%fyQpzd}m)|N6pwX=GGK!^;@W+stA|&cN?c?E#tU{Z-+{l%Wrs0tgkNigjc>+}n8= z1(AXD`vLU(N@4W0n+0zbF}2iBLF!CG>f{uS$p7mFaex=7aV?1p0$y;Z{a-IIdYhzc ze6lELwJd-FxzQ@{Y7j%GBGg)&ywIekM&DpzpGAR^TJW`4MCB6hgu>$0d)_vSBTi*Q z87fC!$Zj1;pATnS)PQy|*WDn=vTT;%my0a&99K$_^NgCy6fVj7Rl7zpmyNRpa0|TZ zI*=Gw6jjIDjgqFl!~jP$AER&+dEF`4-Qd*Hs?n`ttk~oW8KfSSdUmc!;=ye8qMRMK z_slOu@A2^f)@;SXPms+M&^Hb&1|rx7uFI>ttHY0LC3hV5GPc^6pTlvKZ!?Em8*1s9 zJH!vV+qFg~Slmc{xOU9a~)qT)Oz+wB2snHXo(; z(aj0jvZ?t|RlS8FX)c>s&_F^+Y4IRrmy)_KJk0CtdYu~0$dTRdDK~7TZ+T!(`*z1c zo^O9Bl-GSa@%_!t0Pn;8Yjc=~<5c1ZyW@JM+C2Pf(Q59`1Yt}LZDaUth-{UkHj1Nh zpQn~5%k?d|s&lw1uQo8+PB2=^YH&YDbw3kuR}|2<mM09cH~SPk<9349;IiY`~xVB&geH}rM_PQeS_L%AUDJt_I&Ko-w^l<`VQs|b`M+j|4tI1Js7MV;&>rXzavC1-h7`9-yAohc*+DE?Q|G5`-1)pHIGU=X$UrjEhhkK zJ+A))HM5iDuE-?;jDd^Rjo0%Sy4g6HS)IF|{l~@0nDc7+DQHG3h_W&gwad3Z&c1%r z!7c)2@a~+CG+6t+>wihiVz?{0Dsjaob;vPpqNS36?Mg=P>Jm?W%gZoBTW)#a+LA4a z_eoU8`kh8mtL#NP)^(jyfb@{RF1hT95c7@DPuWD;vUOL8jGw5#4Tg4`WANEYD`+cqVLSOWW%JNNMGePDA zUx=%i^WB|hN$AC%arUlBN>=hm%EyetB2KA{)FI*Zy6Knjju*vgeyK->#Ly12;t{Hs z6xPeMURlMtt?=zIGh;2x=Fv*NH{S7ah6BL(fgrqJAhdBbQ8^O&M`%iDb4oUdg-* zt-8hN*N2l308;`V5h$z#BGJI7FBitm z8EJDIFkah1BPdxL5Tz7Zd>mb{a@ibD8xWKnE?fA1=vf=H;Z87e_5sS2k z|AKQ2h=b_EF6uSczIiL+2-NMuB_?rP)^A6K3}i~sQ+JglC7*N=QI0EpW*)7zc7y85 z?o*OPlRc7ym0By5kX|>9v#5zp-NI)~lQ#7{ zB~CR*$@RHqY4-3}FyG01cA4vLtay6(zE*Z7?ef($ra4ECJ+OtJL@)uYFmRNTBz3gT#Xr5V zU~J~|Y+jl%A*Qnweob6upgd9?Y~y;H`~S6FqX-dW05Yu#6QU1@L}oq(LKg}`R~!vM zE&Y|0N=!KXColaUB{lyevI!%EFk{gu%0G&NQ-m-_kT6Hl5eh@-pW?~+Aw46+I03{s zN~U3{!hgz-#2s}5wWA=EGhJtkjx)jpGD=M4eT5W6fe=I~l0bnn03@zJ(B{v7LWCF) z5ICaG*n$5!Rj_KFv4`*uQT*%Ua7ESE#|UBhGXcj;yP&-~p}p!giRbgN z|2}^(5U7WgV+k?lvmN4FRovb2$bYK5uE&1{`_~O-05^!GI$M3~6bq&NUv6Od|K$dn zR0?xKxZ_HzG^0$c{kV9t61Du^cda2VuB&O*8*-W*BoL!R40nc?n`E5?&>Hj)p&D@y zBh9qiDnDx;`eNBN@F7iG<+`aPSZe5&@q&Et%r2NykL>Hhei(0Y#*m(^Wdty;NfaJ( zs7~0huPvu=ZqN+!iMp#5jic+)T#@{`X5edNgPRY>m8ia$StjGxgy>UqWH}|d|H@zC zJi%?c5ZT!naxhRqHbuLV7E$#O9`(t9VwXG78nbjgcEl8TB<(()*bR50QP|4@@B+H@ z(B>70rrPJOMlQwUb%}L^Vw`~=#do9e6HT}batv4`6g!8qfETo86hjZK$(Eh)euH(7 z-c3xO%vs*J=>xjM(iWU@#Xq^0#R${)x3bc0FqP936As8M`PKo#n{xe+GD~iG=^P>=5hU`6cJYrghphl13dkYGMZur*>d7lO z+o*&{$b?9|!#^tqy_G*iYo`D6hvG{_ay76K-yF>uR|=0RNC=P?xHk_(K{#NZ75U?x zN=jvJ%qNHxGyd!+F0E`V_mb;jy^b}s*dvZL3PnPSHsYvbe>M{8NELB15g{@WnrI2c zx4lr&bl9vH6&evJAPHC!1AY(^fS7=mBfjnZiV&w=>^L$ukY50y`Y2K%O zIwbs0MQ#0JZxvmJ&AwGgCh~Yj;{Er;l((Vb0^kJ$a!=_OGd)mT&Wy06xilK%|@*r5nzJGMz?|$^cS*Dk%Td-}+bUG?EAlxE3UFyK~85cr} zzrS=Rm_%x4^ekxKnf6+>{Rzu%@UljCbyab*-&d*2?Ph1bJm#{uWFcb&@CAwYa3^V}?ywk*sl*lntC+G~75x zP2+N=eCbIE97Em9OH8W9E8aVF7HPGwi`Bn+zNil=5g1K2DzsEa_T#>nHschd9tv)& zaqJ@Ju3U8L@z?V<+qNdM`KfB?y)iA8(1kM>cRjqQ^rCm{d+XX3!kH#*I^J4|?r=@( zdX|TDI9-vb0PS)x=TER;q7Ut6pW2rl!u?(POb&geO9#qru+BcUhv1TS#l+q$-fWXT zlzT_x`^csoyC3vt+>QLsz}D+ijJF;BslvwF2~o>b_Nfc2$lA9MEwlS#;7*LGOZbzZ zI+o5@yZZF$&4-5_TzaPymmOS$$t$_^l=p!@c3v=kcj<}w;=ODz6!L@no~KUb2J_#K z?4N3Xohch|bk&E_`bN+;ck>p;*m5{MI6uRjZjDP$Nw638fAHHZL+4Cp!gztM98 zzzr$>?d%+Y8=A!b;>OwWpXizSrxO8C3VWOVVXEkLMGAS*xJmI1WQ%y}{fzyUO7BEh zb32|^C6<$HjIB5PldB*gcwgF5_d|~$PkG8M%lSnmG3Sf5cZ*kcb|tdxDtM$vUrHqE zioU*eA`<#dbbqBbXcuL=ynI7jchPw`U&APR5Ca=4B^PUV`=3Wn&rgPszH}rTSJ_KEesE!iQN_&+LVt8V`%{B$3n6<@dVp zhkw(2>-|kqUU_+W+CpQ=EZZj>vSP-w{PCiAvG)qPR?4bb&ep`Uvr(>=rz54tLTV<) zR~mUN`7LgvG(&)I zM~W=t>@+dlm@$9ffX=aYD>IPABwuB8I@3l=!0GAaR;p9{`kh(kR>k!_P3X(Z=vv|M zb9$F|@dNUm+3ovJFBuP>7Gitmfgb^(vqBfwphy)xmfYLnKQB?W)$~fite!fK0b|Qp z1;yhv_X0-*e+Tsu!TMaR?_DP-J|JxND9{doVDudjBW)2OZJCG9IHCSYn(f{E0{518 z{f{!+dvK*1%n=sI;jwl8k8=Gp4xAGZ%N@q}z_&cjEoU7H$G2+553`1!C7iU2d9Gu)jj&5T}YQyLo>pJJA#Beim8+We=DW0bv&KmZ(`GP1@{^7 zCqMCbImG86$mbxjSUlL9i`M=u9Dytxg^ZmS+F~4ofjonS^s%u#e<{c_Lw^*82@v-< zX!p2MHg})@FlxI1{7tg=2Nhute zt(I~lTkbc!+iAir57~66bT76hfKa1#CjBwZ)R9HDc*IWm@|-xoUL*V2HW47yCagPu zg`Vo1k3vB!qRDxYN_DkX*0+^TV^*zw2Ge;M`111N#h4_hml2~}@lpO$I%a0Ok8aD5 zx0dV3>7m@vTFsedv*+DFT!MDnGLOZl>1BpRCTJ-&-(+j|P!=msa%8igP2?w4ZX9(r zdY2QUKdh!tN&k>iRAF24-3q(mXHo~pQyB^GsNLV#G@h-PeWwIp@y;E7!z~S&H!jV< zFM!&z#1F0vkg|e5Bv)C%S1H6d!t9L<%Lx37SF3LS{H5XlBG}MV zzl`_k2a&4>kgFH4DmV~`(Y&3P5J^w?7aK?4QXLfeR?)-$w8$T(&OMHv|8I`tZI$yR zzy+N58MeNFf`C+z{O1Z__BWmOQ&##)00VNvo9K1(SQj#bJ<-Q})dEe#T+sR}l=idY(?=;94YG(&W_??%5@QMmoL>+qAsd)((s08UdW3 zt~ToE#unGlmMv1g>SPZ1+wKRHc&i5ZeGW-s2lwO%zq#=evyGpUUTb3ARDYdsixoz$5yQ>7H2P zXkagORrSDl=_@7U-} z(Y^A5eBD2Ap>+z+so_IqT%w<$-?vexDAv%}fBc|CD@sN`(X-*Ams|auQTs{Y;yf+X zKXJKgVts^}4wr5jZ7F6UW!M#?jxL?f4J;e@q@M(F`;Vvm^%-`>aiW}Dbfk=1gzIX= zXgu={@A{yA%WhKl#pR>kx4j`Q=@|pGUtd;8>zINs;-ZJ5#jRy*c}$HQw_)EUzSFB_ zYQ9JUQbk7xuLpmJ{)QgZ9`g0`8XEi&`WyDI%ley90|4TRei7Y&5HKnV&HotH>|{Yt z`iKz&mLOUz;YM5iFu8>C67U~4;f`)Z~Eb?4Pxiuzg}$FOPC?@v#Br@D)zG^chuVStjyqe51YSXP+%nj%)3xw zw;;r$AmRgN`_u&w4U0B{T5vu{=tN=SV~T{46$PSDau_?K7(yNpiNHCwqzl4yOgGSk zRJ}_i6pOuQ^g^HJmSkwxF0GsMz^a-d!|hjW9F{;M=Oi1-ArmKCOx#H$^GwK!GnP+y zm8hj0qLw5fPd!-m0t{d$IBt%7D=PV8t6g!Ly@Y)jzTh|AFYbRkaz}t0#|jBIPXSjl z(TM+8+|KmxE7{3kY*0JWjxPrTd&tM|!+M3hieROz;uh63Bl9R0){Hn~q6M9lx{|iO^!5! z^Kc}=wq>(&&m=X0rR$oaa+3|IcPpN}sVd&kelBB#<69+#G5R~Y;yycPq^Wu%{t7)dFmN(Eh-Q|==(ef}w zAHV;s`t8%nNpeI>0b!fv>)91OChi(f!;|L0vD$50*6@rukm~08icNndIallBf&siZmZo|&0w{bn2s{C8 z2CeX0rVu=Q3NetQpC2sh?T=*+NPZz?=38O?e1Fj~!rHQr8rkt+W_ZRgG7SS z`dn7Ld%I*&C6QRZ{cK1D3?bkK5g>|GqUcn9U{rovj2P`#7Iuv3NLdzD%iqdFD7}NB z&Zf3`J=(;P>5wcGJ?8>Y1Az^kHDanP5X#&S$~;N15EL&D5Jjly-5=)qP^N(Fq+Nir zFoLr%76#$kjCLXbg2-~}*)s(}LIg%aMB@9knr;_v5(IIQDli26@6!=oc?H2)1qw0n z=-zTbqP^37|I>-P0HFVC(#1;v2zK(A|AD@qfz#U^zCqH>YNxtQ0b@ z*KODqO_HJ-X@gxbtP)ivj1=Z;?D*$(;Eut0AmdBr*OA-5mwy9q!fsfFhmZbf|I#C*7hPsZK7SK9iC&p-<=qojN}Xc2;3-7 z=&`V_L_J6{vHQW_{YizY!Eqglio^U2uF6f4Mdpw`N_TN=MlE zzvF^~%m@J+6Y`G%R%I0OAFmev(xz>Psz*eg&%-dehEhCYr_^3~i^Ync|t6m&)hvNb79h7Bh%K@#)F zb4+C_WFPEsP7VmC>~1i$&v{B^{Xy~i&XP48>2hOYTjj5OOR*Y^lhw)!7c&vBiM#2F zea#tLPtK~0T5m?Q55+r|sl18}(K15C-5eRRK2JH%8#0;RtFP^KpIe+;KN!NskW=}Z z4qaZ)=D6o{94#Hu|40n9lcb28OE=bBCk*rMpzT<~jfXovQrO{$JKZ5{ z3V}Nq=L(a~WK1NyL~KkE=Z|0!8ka5v#au)nw2Q(VM|^_9%rYntQZGCx0>_d@d_u(X zn$Vh~(Xq>MvC$1&w8#vcuUu018gEWMW(-A2;U(5H zT~+nnR2pZqU4GTI`SRK&JzcACW{T_iN*uWt`{Ix?-f>!A;aR?996XKIQQPo-_>wPh zgAh)E!wpU{Yp=E(?UM()J_tAt0u(ZWK1dHJINqdRh#ENl21w`+{1AITaC{{E5Tv)m z6!1PY{0;jZff@*Cj(U7C3~776p7_5L8D%c~pn2*E%?W{$;GzD)S0K+}`WO9%An@v)1tW$qe|FuWK;o1MQ^22{1MFXU2yZ(RrrZ@#c#J&1o-TZ(%ANy1 zcxp_qrYcQk2HWugb2p?sOKx%Zk~Dy%acm^ESLE^A+~xn z18d1Uf$d2e+?||=TKYSNS+0;~_F=)O2)MphBPM2fSq6=rfpQjda+IzigsAtZmYGOTghs%d$y82#Rk3_JmI)0vy*o_)?BKD-26rw!|m#n=GrW@ zALZ>zI~qsQXAJ%A%R&x{t;waIBptz1fef*sbIs=W1Ga9~iQ;HX~TIu*O z?cE?*R|5nQFMW%4a6jxv57{l8k2ThQ4F|au%Gw0Mm2}D}u*XQzi4eh&CQJYg1x18lG1sK^S9JhNx|n&m8x)cM#C6XXsg|Tl-7z z|8*xQzzxDRdA8~1`MhK@_#KctZT>8&q|{Xq z4C!7uM+L^wATx~7WfJe`Kd*IHmNC<_e-A?W?3)M=r|WNrZrD0r_iBLW*pm@1z4(&j z@m0Ax#_>F*+Vp6L}^u4U78H5<{w z?!s{j*`)Dw%?D?E>(sCTMkilNo?Lbq?UKu-Gox^%Ju;Hs5<6(BGcQW5Ul_L`N?bvV zG;ppcvCDFLFsdfQnOR+y3ztC{4-xSrUc+dZe&N&*@EPQ|Fa8$y(7moold>d^nG9E3 zrruvRtqfc8L=zk`mp|zj7b*lU#0Q566Rl`2un!vy6_leWL0S)= zl8GaDS`{UHK8}F8`C*F)^>$aV02b{T_4z-&*(xA3qNZ$o^a5-Nh5uh){A~TFkM&d0 zE`Sj*qZ|5553ene=jFndZZwgR6tU_%ee24?nW8eK7M;11^V{Z5C+cf zC^%S00;QUlVIl+kZrVVj4DOF2)_O&_zrZ@paiSgY94ORD4B~g0xZ$c{iO=~y;Zl#} z+n^aPsZ~82u&Q(=MF>-f&au#BQivK0JHd?IpRk>alO`)?>)Hd$_IF6(LsT6(T2*qn zfNXSms+6ij=o>(Bcfh;T`i`iBvBut)$9+pv`(W=HXCViPFOp%G-)2(JrCs(ZfqSl^ zP1ClabC;}~F*=0(8f3QcxMxQ+c%tV^wI|_t$zH3!TRczmS460h*YifWT62xbUm<`M zxv*37B7Z{eNt^{Z6}cR2;2-GN$6V8Mh;w0w{&i4KpAt+zPoFCaF@~5ooEx#O_ptrT z(z?oP!pWLN9SRP{yV4u~y8Omrs`O`RG+zTB0dU|hl&hIb_&EEh4&i_3e~!G5gyIu$ z3gUvgPx<@r3)maMLI8N2xDK;%K42wy(*Lm%5HaNeD*U_$qK&gRv#3Rngk9~Z9l44n%w}l}cf7c@I zy?;DA;?)llc1sEI2tFY!MapOK4`ZWwx)G!#hm_`1!o~7+Y`ukNPh$3&E zc14)7JPfEYvFd?$p1ZcD{r!z!bMiSWXYO$n)2=6rObrVp$BJSp*b+fAW@U1K1ZJVc zX=9s-RNFe(2$OttZEP2e-x95X0g5+B!_`An>;DGNI>6y%;W#nx08{!){$omDO0ALe z-+hrTxw=0DXktf?&S3zQDai6^(pLXRifOhaCOR^Z>DEdFre5n(<);(YOmkqF{CO~VeZ;Yk@(6oo5AxT^65d~?Mf`K&mBaPrOpwx`!wP9?e6an*fH8%my_}0F+8q2*fCzm zgOoq^{Lco##p&^zopFyIrS$P_~j5U6$6=r6i-Qxj%}KJETfOn_9i(BX4Qv z)ImEXw@9sI*!!ZFBIKs(tn|wnY2R-gjH^hP3;lo?_=Y~nM?Q!f7vd_xme?aEn1L^< ziz77h@OLJhW@;DULOw{-CCUzTKKM5Y{y-4qAa2d=AUB%iEP4Zf{OQo^qs|1D{86y_ zM1n|!;$xELB?|I|H#P$?;g&`?@}KWmqBlJ@dkd6s!xQEOYy&h0{T>#$r9^q|k9>hL zA=T#hIn0cl(1@q^3XMPHbJ$t&{p-H~p?K>Z5l^%LuK)!p)B7KQ0E3)$%PoPo&T5w% zN2(T4g3OCbyOoj03?}wTWp@j$Llj$_akuf(>9$*vQZ>gD2&EoK@YyIn^d%|2U~a^C z+`|VqrHmLPDdlh0B&svz71d`hT57?k<{UUkyT!8=%Fx0`wToYxVuH?|uAfqM6e>ct z;?H757{gx?pj~@v_jM~`D_hkPnz-FKeT~1&)r}uHozQDdZ5GG(-|i3Uu1{ww?+w;5 z7!}-5aUU90-kEY#TeV;Fk!vqjX#;2z4ve=@oHz4-eZtN3&?uc53>a_X2x_Udsn zgXhK!rb0=>wDP5pXH?(z7ytnG{XtT3Lhj4n_;s$!8q!?t3GnrJ=ooE|zX0=+;k#Bi zFN9Z2hxE--ldlLv4(;NHmUB&P05vKvov*1#g>7Nv-l)~!gLPbQ`O zdGA_q4^!M#r}C3Q-S5s3*R{Rj??ddyJAiwe8sMS!FlO{T0roI^v^@W|c>TW>i~4lrhPz#9$WiL<_) zfBJm_+V*g1YqTF?+tJeX4$$TP{Pi5!rn(1HZfxK=pb*0(8)k`6=l*G7iO_3ZiC7|n zX-{I_5NC>oMkT0dYs34dl=3Wu5hmYz*G!@*AHlbX8^u;6QHh z!k(QoRKc6zIC!|2#V03FG@P_c+TisnQi6ss*6((BLtC~sBXo2c4l;?yaSG4Yk70{HXpZ7! zUf4I^Z+g0J)Up1E_<8NNyIQ=*wa5A_F*7soUAuU4oZiuDdtE#vrAg@-G2*Lo!~mWoJZ>p5UlAZVN;^ z6QD-3{JD*<9cO}6_<}nbC{qg6JB>Z4LEWe#G2xp?9Vq|jz#oYnVbCwi02g2$>G4p_ z{rZWb!~CJl5oS7tKoOx4X)z{oN{Fi!1bPI);UQV^Spn53u0P8l-!CK(3JVS>2qO$o zjBczx^PIA=5CEC=zTebkp{Ob}>HS9sp1ryqwi+>Dp3)j>dLT?#6nZ$I_lMK|`G!FO zjdvh<|5u9OTY3Teb>(%7htJ(wsS=1T-pMn~kA|8)6ifdDgFV%2>BAi+xL z|AhpzlZ+|b0s)MWGs(}PPK&x!;9y$qM+Ki;r%OJ58LC|*is6D~3^G{0KH-i#&F1NP zXpY<89DV=HXBu{1VlDr?UP~{?qk*VLkvO}>7`TRt+b?sRHVm6`ZZ zjR8x%f5+hF_YslYiFjA>yUfddj@4(?TfMnuhgl=7>EnGq{OzT2?UsU)fw36ohqUI& zM3Saele?a@i_!L?`dqup)rNh!_A{GYu!s7BZ;uE?wT<7YDpZ^fs*2um9j-wQOz3K? zFCXkGl?$|(x8o&9xpB;`^S)nlNfU#-QLqcGQdgPFZolINM$hK>f~Zp*As>RKgoz-c zm#=PLUs_R0(1Sl$kVe~Kro@k=Q3V}{5a;ZF&qgIL|Mw`~;hpC#*!A&bEI)nrGIP>W+t`0Q`9vUY()z+*nG z;b)t#P^^BI?`^YNGBpZytdvqsiZjv_h_@P>_?xciPh!#i&!0iCk+QQbd{Rvh%jeNo zubERl>NQ2~dHy1zv~l5|vB0T%Tu#uBntJ$djdLv_IjBx`PvL&mPF}|K zRBrlIsvA|bQA_(X`*3fa)J;@Yqj|(!j~80|Ym;-CZsco^^{YB9e^SAkgj^ST96Y1A zCw`b9ktr3C0*JTJu!2CIfEPeohT#ZkCHcW@`qB0P`rnpn0fOk%M7<&( z&{Dp@qD*jqM!qHnpPAo+=<0MAz+2!z{NXK{a)?F(G}|>cRb2%XK z#Oh5N%|M^?$Hy%Wc@5=CA8jDj{@yH;iL9-3Q03Z1*_|%aY{WX}UDu+X!n2|Ybt{(N zwd}$*x?i|~HDMJaHX@EKDU@G7djGZf#L~-S|g(NU?VaSCF?REA? zAqCIm$8lDtF##zdXrg3P>(K)Cy~4uNi+nnmPnheak)oqLUk5$VVU=WJlO{={_v8Do zCD1*JsCkuoVKO)bXM*w$9{gp0{M*Xx03PGwq0Y>JRu0Ggf3>pN>b#(QAR~_7CO7Qs zW~+NZ64>a;M`+5rQS0yV9CeIp6p|M2G-q?|`U0V&&3@$I;hC>d(uJnTykn$P`=M<9 z3#7e%A{s-}(R4u9B?}P`xJdofVUeKI0uPnb-pPcLg7GhH_s&lQn~sZ%6T7-zygP>0 zDiOE6u0PaZL&++YWE&h=U{uHAR=Cj@XjB*`bcJ%H;PM9VtK~|5s{Sgq&K+wbQySx; z?*aPjw&t8ySDkP$R3q-y3YBJWaL4bx97gBo9Asl3EHP)Q%ixlHJDbQ{#S%D3 zC9~s=$0bb1C3g48L%r(0Fxm-WX>z4?P$_FEAH4XO4@)(r09G+Awv1+bib*kPXW>sN zLJ82-dxVx!R%S*qBGMuMjlT9MgzUOM-Ij!d)luH(B_uHUDRBR5Fu4^Lo} z{Z>#;V`d(sJo0MPoY>)-sFgs9PzBWs=|J_;c?!-hHF~fSKQHdI=Se18L(6zY5d@G8{!UHAOF<$nSGfVaw3_Jy)dT*t36MY$t4|l@g_Ii-NXnZY>Ecjq-e~0mE6pb2(fT^ zWin{qwMpWVQ02We&Kw&$AE}q{jPN90E@dj%%FtTi&7iQGGb^}T#sMx2+L{n3C`jO4 z@kEL|I1vN(RQRC*b^2Bz!kZizRS>m#3TjcC3LFT1F2q!N?SA)V*L*PGy)`-9q%9+b z*J-6ZvEBB4+4newacZB*kYjhYgM*c@X}^hrp{EUFWOQ5IPucG;cj|*sarQ3JniswL|*kV zS>(N4HEoy(J@KgXI9xp#IvD!p@i2R{`aG`l?fqE`e>*(LMu*R$ufZyB%MPelXF^AI z&hh*E?}xrNuHLG4P10_zN4H1g1Z&PPNCiXo5)tYwzq(!8KQ9clezJ?P+Iuf%I9xC}8h(0w(&-#NnP7!gp$z4xkh+)}g4=H@1D=^Uo=rS&az4!* zn{R0Tl^P-f4L2iWKT471lPcOMVRB3vtAc3lc!aT~Z8?MyW|xwg51&3s8N*F}c?c;D z@?4tioJQbYiIfrMumYw^@}g-pUGg3)ii)g>Eja#CotUz87Vn4EG5sl9L0PEWC2K82 zSACW-{EuMxihZ+X6(Zc#)|QqP`Q;JnHOyL~JOvcWC&P}o9~r$(d}CiL2!e}XH7W8E zsB2DFuDw@F{L928ju|xhjrhpm#5@ZbX13B0l9GxHi)QJh*p|tVfdwKg`e_oXpS3aL z_1YdI=h-7ijxtB=>p1vhyY#g6qNJiPvx-d{6Y-iW;XN$&9i%20Cpq^jph;%R^Jj`; zN|a?mnF(Z&5qV_~H*-xB*m_EYh4)@9N|L&cPfU%4DE-P8HN0&1P1IPdxzcjpjcL=Z z`L^)sLev-r=!+&<77p~6!6epASHm_^MBF0eXnCc%KoplqC=y!iqKc&N7%Z@g{n}np z4rp$VH_8!v_kjH`1}y*#>Qk@~dO?DKG*bKrgC-`%Z(csPC~Joy{^sT6uc3V1UBaJS zyq)*3taIa%sYF0w6(B~q)R}dy=E=6!&6>WX6jA1^ZvNzKKg`FqAgr+TNYP8p3_U-8 zdY}39>(c1E?zf)3x!YkwmnIEhF}852A1s~^o*%b`J8=#WNH-3KB7e>Au_GI} zrCwDzWpM(;1`Ub z1j_l*5`S~eBH@Q7C4I07l{)=;I2tyM5a#lrXR6|Mw0mV>vO>f$^N@mOac@e8o{?;j zIwlOXO)?t0WR-i#D4Q~9r#_nA@QKbU@@CUT)aETxg0r5pF|G&2Y(7@;{( zaCOc)a6Xigj13GAv9u`XsLDxAWu=)Wp}Xvmkx~+H{vwqd$`aY*6m%_hTnRU1ms6S@ zkYT1IcN$jDzWkm;;*RB}>{RMy9_{5gP zC%8vHG`B6_N7pF7$Wc0$vW`%TH+mRyoI*^-D__#CxovqjxdrrxOFK~7B4-SrCW*-% z%S~QqW4TazuN+MH_+-In6_U>fLCo@8-+u{CoV~8X1If?eq+r4IhD85jl9WNNHN#}e zl8YyIw-Tv1UdC3)8z{8<4aSB=K>4{uOCTD~9(|m#Xlf||4=YGSXj`zLC)f9uI!Oj;w%aLE^?W)dC`X1c7 zH!p8Y_0W{@d%x#Kiup?PJ39m zGJG5t)MOaWG1Rr}pib~~I7&9!E>@WL6FC)4)SXTLqBYW(GhQ#9Z?wcXLaR$0dL7zU5>d} z)_LO#gP^WCu7)%c-{`4l)T3#@+9~- zCpUW!hyAU4&-|Lt2Oby#t@P;f2lYUpmG)*m8z}{z6o6Lx-$*HwE1U3Evc7WR%tB%4 z<~ls1@L=yy)JLClpr&oV+t#TDI@vq2_X}vLn+$VKTIw<9w@~jViVhB|B@{b-jlAb}C%ApZILRyNn0EPucD*o8B^bGqyAK z%R6COvZ>Fx30f@q@nde^iuP4)WefJk^Ye$-z_yR{u1Ff)wPwY9LApumnuvj)cU;0qt;JHnv<;;lc0qs ztG)my>*cC=I`V^{F+Ke1U3;tkXt}zF*uO_OXeEkW|NGPW8m+Bj+)S^3QmeKz%Y8Eb zI+kI0Z6}1H0z{M%)ivR=sov^k5sQMbw}Aq(PYzD0&#yldJoZOpMuX4I1x z1Q9lcdsSL)Kxv?ds>Pzp92S$D8;q6nmY#SS`48tR`9t+2iV|2Q!`QMO9#j#DhsmhG z)fk@HJfzKX6OU(`^Nc98VUJniikvQZ7?fzJ9)ZU$qXGm}Zlt|{@hRp`7=m>T7-ZJo zJZ(!+QIIInYSRuBQaSY8n0V@1AG%@*xse^$laO6!Ywn^SX?kna@G`du7e1FWS4m@V zp*wefi{c+LD(~QCSYogq8;6HOTu|cb=U4eQVYjp+(sSEN9_kX>T)T58g0av>I!r03 zzXb-_tf~!y1VivE`77zCLk$ZZEyo6+e(H93L_7v6Y@=EM;Z)*c%bG(_ak;}iXmt%{ zC$xc$sE!#TvN1L(vb9n^9N&saf?RvDH@KcVNt3 z#dLeW8tbWb8dnCvV(SZ!Fo|`JvbqlfNrWXSgxj< z{6f!NP&Yl1j96QR#n@s9{`pe188CA(1iiq*9%Q zQn7UkN$=WP&z-N~w+vro@VOe5zk_Nffd_aXnFxui!)tTq6+ja7v~5&Oh=vkE+7(j<*35_i}oBS zZY-gZptB&`yP#umdp|10kTs$_Y@GvAc_ zgevMkE@*7rT^e~DfBW0Au)e3FUY3L{?N(g*Hie6p0_eAH@!Tz~s%EFbaw-#Sq1BDv z;oHKmrUOhk<~;HG$I2p?x#p5hz6X+q@jnopcqB7gMunBOYVmPVkhW8=XGM;nV(e{M z&a(JDWuH_vr+&NMW~=~w9NSSd4v|rhkMi%vKK(BHu2vIe)+IoR27il=<+7LY>s()` zJyfg|K=BlFBheU^yXtC7^BInCks@>2`K zbP6st`!ky{#!Rq1p81fYMM3Kz5|M-jp~=`YX=RMzI%F0qu9RG!vu1o(A7^G~?6CZ4 z@S%MTTw8M?iWm@kDH`Rk%70wkKsHqE%SRIWfNiE}oHo4v*=PF8I8OX@K06W<>movu zUBj-~CF<051`|T>YPGf3(uOqY7Wy`xOQ{u4of|eA z$g8tUHfB9aGJ0p6brXdahIi`w7>uGjGBjmhQ^R*;nVzvV5w>X5!w0^tZD*K1-zJN1 z>g9JLhrjJ{rLcRX&a<@SYSErO_^3WYup&2k)3u&=uBk5Srptu3>b~ey%G6|iL~nQ3 z@$2#Sl^ddbv@QpJVFT)xvW!s-wWu)8kz+|FF&&OqA zAP!ShV<44fAc^yoWx0k}m1EGa0#;LH%dO>@7|6p^&#wxEsa7KdJOtuo0XAQLo_k)F zB<|@T(=$>fS%kjEQ!z=RFhyntKc_Tany-1mb5=p}{I4`4vqO}{iXlU^&=xD$KkmGW6JWja&nW*nFu1BLVBQ~(Mo_#Oc&U)lQC=`+z zMVx7gNfJTr6$D{=3aJEH?T>jW?T?1O8K`*`3QQosYV1fU%qON4*CeNj$r|}JbUud) zTWPnGCB}E&r+f}m^1t;tLejp-k4&yw-HpwcA~1*GaD|3N%=H$us8BdObot=U++2)g zES`>7=dGO15u=f~umb@R5ie~rtesuatwVmi2C|#sv|`mty_9jZ@d8TW+||!wnxmem zv^V&*9>N}*jXW*h^uD=sG*3U*Yc`#|u0=6023{@Pe~YElAJEqGwSWP zeeRh&e2D+dXhu5gfDv;bDoUxmtV3-6j`dY`UH90l!Wd83g<&b~vgWis@Uoc#l05Cw z0S%#$P{m#=Onm8&I@DGs9CEUWiHezaykFwf+RzSTi8F^^iR^~8nJD}a@k~f&))*Hi zF`fc~TOC%of635t)TG~D4q?O`mu4k;zq-RsiA~npJLpg3E}_cu65W4`hz z1{HH%B4V?^T`8O8u~lVr&6md8V$LODqe${HH!FbYjm>}cOkfdx3H-~Je%xsy!lIFa z=UN$Gi*;jk*wN7v-|bT-eF7=n=jU&6TUm;*9oX%;wJ>QX+)FQUP>JOw#E4`6*@Db) z)bAUImFWD~cZ@2ZQT=&|DQ$}LP3Ggy2h-B5N^cG-(oJeusy9pp~-75%i@Vk@TZnuZDRLu9(cUQWqO)WK-#>Vl-xt&Tszc4 z6Fr`ofcr%QntB6Pkk0q(UTk;fRNOW9BxWZ(qk9!ASkiWRzYrN_mVc8Zh)YFQ5`Z#!&fs z+T+#wh`RN}Z%vA-I6LrE9Rj_Gp8i-f`{0bdLq6O6Uy!v=fmAPyOEPdbIU7CJ{nXtl z6OFD)S{R|f|C9=H_~i2;>EWMLDVx2QVTu_)`^$|bv&D4AYk?T12E)~F|2-lhUCiZS zG^J>x+9u4VHP5MP%j(qVP{?5wf6w3ag0^=IYxkxXaeG)gBPAiecauYSt&y#e$M%96 zD9Sg2zmnRU`sIzgw{tv?u{ zx>vf{p9^k+9QdrlC3mwUTB1BX8mHPjc+**8m#Hq5&rN~5clWMTbnjv)r$TC}tXK$2 zoFP7H6Ara}lQwLRWhh9az1pAotjI)I+~BWSBeA^y%INj5FL)#_M6pDcu00|1!3!3K z{cX2ksQ~t0L|_N8h7waq{jcudWI>;r8c%i z(@C2=`|lJvEbp!bW+$1TBWoyC-rLmxS_QsHi3RK&(_FurMR|%MVgu*Moh>-rVL1N1 zFZ{hqWjY_#9b1mTy1b75KZCI6^)B3xSQQ*fV)~AX9_cjm)zB;k4DlF-VI+IHVZF3} znoK4ypSj$!cCFZf&DIm2*0dcLeBcRwr=io4_MDNZW;*eMAjPeQA%%uMT(xd4UWF}$rm9m|EA-6%w zVtU-vo9!N`YAGMB;HqWjLfS3fYa5>l4cK?D$Vex}w2Xk*do&l6Z&i0WQUBtM`AU5q zqxX%%?88E3dWYnZjyoavtfs7%_JxoZan6sMq*%0RDMX88YCfCuB>LZ|tk4)qOw=wD zN6NU&>eL+Sx*iR%zHT)Qc=|lePU6t#={E~1KciST$|;S)iD zSd5zl^HKyqooB@nON2E?AfyJmXcqBY=y99@Gx>(t%8Rq#Lel|5STX`G>w?WtESw^( zi0uyvHiHo&1%Poo0o-i44O|`!LMM|oc#BT^wZHi}BNHpV79M@MZ%W0u&5WB zm+%m}Ob8nV0ZK<7_`wLD$5xH-!~F^N-Ja;IZghxUAtL?sCpGDS0U}yb1l`WF+>RG1 zIPCqLOI_17BG8HT(E}xJ92h(hohtU&%G&&ah!iF4ASv*P{gkH1ylp}R$^bT>7#Fs= z6m}%HiO(;$scpB(74f9s)wXzq8}!F!5&;Mo;AD&6^FSyVoEi6cAnDmV=n4OusMBUd z%R&nY;DXI=cwmC|OEJ4kzu6UxcB-}niYIT+0YWG|^dLuBPKVkJ?!5J7VE8{{teW>y{4aFQ$LrgM^7%B5hHp63kSD4yr zKuy8Mq_OcCGga%$5Pv{@`S@$e_i5j9g8fG>&slwVY~hb{-zlMn)^%;h2oJ~3#5mFM z#?>@#{2}ZddZV|-Bs?TaVy23ESbvIFSROm1?^-hVo7fI&8xF~OJ~x4jHkBKK*#5Gt*5Cs zf{8Xa7eRITY@0#r-Xgde2NEL>QUn~@9uE2xTa`T)>Z=$UZWuRG60#Oh9Oe+RNR1OK z+1wh5WgPcdwu})=t4^ZJRjp~Se_O=9bcbCIkE*kCbHa?|i(1ijiJYws={olpM&pvs zzHq~SE>=0X;V2J4C(L?u{*&KY?k`E{N| zCG&(N=k?CW6Va#hBr1g*Bsr&lN}lTFoRNr69x7oGB)I@6_a2|yQ<;(TBr5d^B>C?C z1@gjGL8XF#B#TW>$x}^)GoOg-i7JU4N#>cIlBX%<=Sfsa(MXa6$cjBaPUDjl>GLG2 z>{%qqXmNqOaGa>}Cy}Iq)fst`O?l=MaaB;I`XR|>>kH%spQw_|kYs@^lKeN2a^@Iu zf>Gr)A#r#6GyEjW>5N2F8C9+glB99GKwhXas?-i7`NIi8A`?B%d?IR#D&`+af?Y3= z7kr`$>qe5sKo2G|$osrUR6)Q<&dTE)cflX3SWzVB>3PhZMvk8MhbnRs$-VYMaA$Fp z=Q&idfJp9=&pGZwJy8X%A-NRaWA0xF+j)d!Tw4L}COlkr?n9z`{oCVgY`mfLP{_>4>%e0qpY! ABLDyZ literal 0 HcmV?d00001 diff --git a/Tocsg.Lib/VCL/EncLib/AES/Source.zip/aes_2017-11-17.zip b/Tocsg.Lib/VCL/EncLib/AES/Source.zip/aes_2017-11-17.zip new file mode 100644 index 0000000000000000000000000000000000000000..7b625cd8ef317b0086e693ec0ec45786ae3d0a63 GIT binary patch literal 246955 zcmV)$K#spqO9KQH000080Pvt6NB&6uYbF2y06hQz00{s903l*zY-}!KVRW;yN>0ql zQAjdY&`na%O>yz@QE+q(jtA0uE&)NjTo7491FX^jP)h>@6aWGM2mlAIZ%g19iiqR_ z008qD000L7001LnVJ>1}bk&(#YokCEfZqlG!+9A<7Lpp1rftBosd3A)%_by)W}zTP zk5Mp==%kl_zcY@m4W;ewJ~;z~xtz;)E=q8|q90M9VW?}mmg52Tm|`CL;L}4ECkQ)_ z`4NO-8qypNv|#)!Eog$ZOkPOU%sUncUdS*9^te`i4si%%04ZgFhm5^Qao7M<|wtsF;_rBfC7qjoWcB1LtuTQ0%>DGL`!(2bh!&8~< zW?h3PbT3oeIe0IyD+33bLwZcQRV*Kj+U(up*5VqvRxb#5MEZOt{M5C{y#q2{D^bQb z8GC0)lgsI9Y6*?n*zOo70nkiTsH**EjEm*Q>IDJrj{63xq2DW4^_6;R*^q*R?nV=n$?)x|Y@X7u_!G zDWkCX(Ztqt_fyOw7#UY%*u5|maY>243W3jvy_m0;j!odqnUr?UY#@esqKFA(2xJ80 z9LN~R1&~W1SGrc>U>cwVnn<$pS>K4HmmTuK0}a=Nw-3>^N6Z1P>s5ob%Y5kVbS=OH zWV_)r!gbk(WeS1tl9TEz^NKRPDP=svgEGHe`M!`;{n|$bxx(U@Fxji6x#qm_Mnq$h zcj@e9iwVp22s3{Gy_>c(nkq0V0jUV(NCnD~p#-I=1f>!c9~(+gno3ZP0yQudpd1>8 z5|pM2l!HO*DBo~CW`5iMT4v|%Cu~3BxW$CC$-`{EeVCgMGus}TeP`<^Ks!{5cBB;T zxl*)arD!jdqP=Q0ZTW6}3TW}%Kz;7uezsU||1TW_L#gTwOto+?)WW@NGp;mMnfSs7 z+*Nl36Zj)DkzaP3*qUpJ<`SU!c3(|-FqTmI4Nyx11QY-Q00;mOt#3;la!!@E0ssJz z6aWAV0000ZV_{!pY-}!KVRY4)ZEM>w5XWB@0{IRHAV>yr9VboOfXh(jE3kRqutGr;ajbxlbs)nhkp%jgTSnx*RLTqg6#>iCBzF`ohlGVT>^g4crJOwfY zE+nwBlJCYmj*0>rR-_;}6yg;ae}SfoVkOLzT;_rs%U;|E&vi!w{JVljC&=n7suQXB zQJTHw2o2;wUC!vq$}Odv6RW4w1(c$6dEER$?9BG|%IF=oI(ZN^@O{xY7XAm%QF*bt z^U*^Qn+d^K#96H7$2e6~M-Jj$s7vXAd)9d7zk)Gybm`lbNbE7yDgy zC|=H0CG%SFl5zQS`Co*ixBe`wBc&Y{g73l~1j9zwIWA!mp@P7%?gHo$^do)W@BN8y z-!#kWOPgBTnEFVJ-RlW#-z8IN8H?Xa0Y`+cmh1a~5;za0TIZYsan)fU9*_}`F^~%& z6CjsBu7F&hbR(8mk(mzG=M;2dbqNs@3Hiut4__ zkbGSScpAE$gcU~FVQ&m>bSvroJginxqjp&zn;seJZSI>BZ{VCZm}Y%o&AyPP*R)Xk zy^TXuW04OrZQ-;BbZiOe*tG@JvjxRAFh99jVSQpGUX!hei8 zpFYo*PtQy5c~0rbbAqP;i7fyg*#HKSB^;{XH&9Ch1QY-O00;n>YCAog zQ#zf|0{{To3jhEL0000ZbZKp6b1q?JbEK5bP8%^0fbU4W!yG|?cm40J#DO@0B0xkX zfuLj<3%DD7 z04^LncRP3q`%?hU99(^ThpEDwr><|@;lcNRy$%lmU^;JK=HEi)SIc$x8aBA(XP+W3 zN635P#7Fv($A!BKk0M>S-Scd<Ks4VKq_Gx)?ITqFuL}{dy;=F@_1p9Do$e(%ewUSze(ziTN5&yk?w43L6Tm zGX)YG{JZ$D+dPE!`WnSl7=>w?bEIW?dYV*YIf&pG&nzNO{F7*kSeQk})F2k) za_T{_^elquLfQ_V`^k|qi$z1}>^_y+5P4>KYLVty%Mu2W-3da11TJ$Ma2C zz-|Rsuk*!n-ow$w!(HW1PLBWMu#_`{$=eE(0s#Il5`P&9v{~2-B(_t;C44v(V1hzC z#{ikYM?* z+e@Fn(9RUVJbc=yqts28$K+X+;-yikvp-rbx6}q=7>aJCD=>Om)_?z7 zD0Kfz=|op0^*~7=Lx6)O6U@=IPx&Xe2Jf?!ka3!j z!c4GJ(bteo%6NiZM-*Anl$pq>w&rUxSVP+-V913rI%y;BGFXhD=#AFHHzhDsbC+T3 zMBE(jQ`Mf7I2V6fegIHQ0|XQR000O8g0pW+Ns|NgtYH8EQ-uHk2mk;8BxEu*E_!Kj zq?=Vx6>Qk9>2B$kMv(6AZltBVyF)yOD6O1?s0?{QIB1PdIo7 z24)R&&vnP6APo+I4gv-O1HzhTEB$e?nFkdV1SA;&1OyHQ1ccO3*NBOg&OqO(b7D}c zLjVC}$usjXR$34e9upHY(^K(?1g2rJ|JJC!K$}@csnFKeGNFxRaem;X)LXe`ik7t* zBuK({gcbqwR~9NR;~O~jysemZhk;KO{5|(p?m;Ht=rXp?1AIHlTAg514Q}guDtIa~ zmS_E0pz5rioHJ5*q%4YzG0P!Gf;H@G-zBUTrqU#orpRB@d7bxvljJN@^fllqrLu1! zH-?q940{LGrirJQ080G~oNOCxggVC8pXohgA%fkk@8x%BnDSduY_3j1j@>jfB+x+x z^ZW0k9D^r}kb@iC1>ARfF>A=-AYanI6Bl~HH)PYjSAp!n#we)4xBXN_2QvB&hhbk! z-j+kUORp*UWbeu22L}T9;MhXUrEizdAd4VCK#FKVK#&2iPP+QWj&!CDw$65T4z?DR zNy9d&0w^Je3Ez-dHTkgSrYvOna#;5`ec~Oe*N8;s{KVF%r(JFJw#I+48IhOG=802VLyHSK>@LtI#$NS5P%1Q_Q$|-0L%CnDjcN z4P>oz@Wzx=$(kN+o<0=== z`u>@MU{JKPWT7a5|7NAz`%ZR$G-S@$6~VZbew^ogl$~0_;g^YMF#^v_MLiu^mUDyf zTe!Iz*94&1tH}aLZArK|*4|9^zud_pX)j4j5n-0%F%S%%dZYFQTe!n5 zBdV<7HK9+ZYuNT67D+=$c%Cy(uMBXx)QNkJD5L#x$-nC zGJNB@?$LCk^8Mm&FhZ1`&llbrzqztA z9vi{&^N%KWDpwmT8lyT+8OX_G27@FJ+%hW3;kFSAi*aB>{P{Dy3vM5;{cOE`gdVc!>PuuK{V~W(^AsBQgh|Kt=#DlUfD*NQVzrN+8rzSnEc#Rb<7pcMs zYM|VOW_{ARjGe--UpucO*NySwO>@l085Sq8_wPwz()XO5Hobe1OqYx>SsZyNNuiQ0 zoL^4y@ukg_A%ZiabhN}3jjVGs!HABR`;jyB@;hlR>wBgINq5s=G1e9))ZLdHX)fpc z{Pt2yBeBWHZ#DM534#kxaH%qByEa8)o3F@fYy|KE_$z=f(30DHc-FtaI0Ih7e!T?i zyuX=_>Gs~!G7%g*mJvf>uyrnWj25lcLCRL2ar!_K^d^aGe2V{lnn8%-dn+!X*I<28 z1UplCIF%F#5Qrfm)T4u1p}GS zP7{(bJ1XRz97dB~T%?}FNNVIyiL|abE8faso0GWcHO4TNfyG%Q+o5VP7$s7WW0#Z1 zV<6!8O759iJHDQ4F}02-M2LSq0}@O*Z2-HJE^bwvR0ET0xIkJwT1KS+t*`L(*6%j4 za~^ga*S&FfQh>0nj!`a5rEQx?EswKm8MbP8WL8y9(Edq)1Wa-p!5gltv*Z2 z91M~zuRJizqYM^j7F=~M#Uw{%^vX!*N}}06SGf0VYCH)M7X5~WmOO~r$~GImnddszm@hVt zwjh6!Dm8mGq=BC!0{ek&$Z(jI-`R6jXLtwcFb(mLx6yI3$<Dfhq|uDHh;Q8rBQ_V3V{GTvO86z>ri4%vV8(gEq?1#AAVEZDD%U3bb~Hm;1sDib;BW z&tzdWGN>s*8%=MEAT}aNv@%qOcHo!57T6n*E0u+ZpE&O2D+h(ftQii_^Lk*Nxa;X^rLh}UNA9!YmxexSj+u@*N(t8~iJERY>W*4fk*6(U3OeH#SvSVHOGeb2 zx1|A^s(^4#TDwiiMCmtcgxCZ&6tGm7~bd9_NnziuoV8tg>r0m_bSZOGVi_d+lmnk|?S%Tgw!Lgy!e!loB za#KYPC+{Ai_^qkYdenPr-R&xWIF!1a{Cr=F*8{Cq6d3fcRgxxH6Byxzy0XQ>k>747 zm1_1AehH$>xB>rMBq-tFP7>UlIJg+@l;AHh)CY*+cF5=K zrGJQ_q4iHO+_o7LK)H|U;0}bL9z@=&O(T!~n5OdngCc%3Q9@P}uO#9{ah0Vo_)70p zE9o&@BzyEEWe}ME3k#RcR8Nx*<)P2ID4Co(<-h7!VW|V_&TH(=EnwkGyzW)FAF@&@i!Er73F(%7@}t?&+ZFA$f&K zVzl_egK}e9ITsFrH4QX>#tMmHk zX0>tt(n9gl=$b#ZkOjZEYclvM4BA0Sgi^yvN#q?3I;E&nqNu6p_)wM$YC4n=Jky5U zrXc0DgqY|s+;pHp9#O08Wh@TtIECd7hMgRKO&aw==>(2rD01RxT@1HDw0iG7z6;o8 z2QisbQr@03Wd<@SOJ9?Mi4NKq#3EC(^tBT1kEnK1w@p1bR$=@`%h8^5{Z#4noIov1 z-*O&C{Z}nSrVL1~=aXJjVd_e{p4x^H7xX&k_xt=M1P?Q2kC%t zooqHIBh^$zoTqi!zhL}pP5Fkq!^t2U~gzLPCFO#6~#41doABWNc z#r$}=25IFB?o3=pil`?1IjL-w$kd93u#xBP+AH1A6S}skzz(CR#}f{nBdjGl^i*z9 zUeu#`@;yJ26RsdJEGM@Evs7Z%rm&$D0l!P;RHNqyx^LDP9@ozAgPm=`c`ZpodYsEX z=XShw33Cuo{cMDt6hUrju*30Ui+*0|tbF3#IrXUKx{?Kw_^TcTkGVp`uU9{{5Jy*3 z0Ma4+B}n8=VErt9t=^j}oyv-fk3(@R;Fc<_njfiIlXzOr;CO-}^pmWgA$2C~_TyGQ zjq%N~ST$Kb)++b_LVZ#-l+r0~MLz8&e~YcneQM@)z9l&JcF#2i{GPe|L~P_u$(g1g zWa!JW@fQMB5*vEeap6flpZa&+_N75RT~#FQ^c+0vV`-roi>iy3qSr2}GCa zcP-5MrxxbpleVq=Lkmqfern+^5Df2aSGb88^{@5e%XO$_eO=hM`q096Vq|+p2&XN$ z#|F@~S@=@;y~uQ1$1;sPoSi4AQfZktxi1|zx@zckqi{@ZTchyQ^aVQKyW@0^Dr;jM zkOzvGWga?EOmj`X#M~il4Dl6hIaesG_F3A#3=jl_#iPr%OJL z^R=6bsS1S=Ruf3{7J*2HZ-x}^)b_FSLW!G!@hE%@_i|v$Vy~ae z)0m!P*!dl#E_Ba&|3X9LHQ|90?^$79=#$K9kFwhJ@TpuTN$-MIH}Kxx+J$;jYYcdd z0-=S0Jw--h9N7ZFyj&|%PR4NyQyxvJF1XL=$sV~dbtam&CV}8lvK_Cb2fv#|u8;R& zs?3Ns^xKGH$7ReWu6}QGhgY4Gojm^pC*jd`{wm?}+hSGM>PPEh$yhgHO3^d2hz#`6 z%?C6z88t_BF3(dIp?o^y3q-?%A7~f?L_;?K8j@%Jg@&1y)jWoDuq}Ho9<`(!p$U7# z`jmF^2&6);VSR$%JCIw1vgc!rHprhYj6i7@#owM&vOvj6mSS-RAi{Rh&f33n#K}E{ zq$CUs{QM-~o)e6(obpp1dMj09QKXP;xY$S$idp2zYW!%T2dIRL@DDi*t<~e=MiriZ z^#sa0q63JAB6m}zJKPA+t}#E+kdiLD{}Bzd)+^~%`I?T1L+S3;t$gkW2jzV`Tp+P3mMUziT<`pz4QHLZ88xAkd+gMZ4KuSn9c z$yV3ACrfYl7EAFC37hQ1+%9{6qTv((4Xrp}DJNTuGohBl?XYAWa#Wtty1Lx$9AKzj z4&n)?Yp!RM>g_8tY+j`BI$8Zeh9Q5DVFkPzEy^PqdY<4i%GJNAA+@E!)_<$v=NqgxajLJxJKKi3oj=qNI?!Vl0icEuK8?(m05z1J@}f~hRagHp%aZ&vRB8<`L3E?2W|8jK_tQp!_LG^9fH3b4QX^02;$iN0LVp>M* zll{aZZ5Ff4|edZ3h2Zk>cL zE{5^5%Qox|XIxCx#A)Yq)kdxa`yD*iE=!5%?xHRNa~j<|1t1!xUIT1$6mDiTz$Q;C zWG9>eY_c@KCajQ zgLa4$&oy^?D-J|Mcc%=oP4{uBY*oVaYa?i;4VN1q?t1_l%EPNaprPbNEa&kAh2<8x zofrTOaTdzYaVo-~O>({cxebEV`|j~Cz%E7jiJgcF_AYaZp$%F376brj7>8K&b#(Sv z*H%n;>5UuoYvyTG+YWzTSJxzcCSCg#U->KU(Zh7oB@)lVa4FQtwlE`fi#T?Fn`;5# zH$<`_sLnjGd%+nl%?k8JsGw!7l@}xspD(*EJq*#%uH_Zb&UD&yOd0X#txd=@gELZc zRfes^rjDOtALvRsFGZmo_cJc-4s5UEg-|`Ha zXSX*R9+UkpP4?!x5p7)W>g5OYGf2;dr~g{ zyAnq$TcR3QjN+_ycX>ZB%BSj2%f9yB{b(+ZRPT z+jULd$@;34iKPo|p?=ObGDg7^`VuR|Q>w!_i3-~296s2-F1ef{I9fR9zU{dvz2=?9 zJA)!)I`R#>vk(OGn!&y!?pIH}0?QGzGWg;PQ1S%iUc>s@$0&$vfnY_V4I^G|WR9E1 zO}1(#lqQ->4Rj(iG(pHOc}Lq<&JX@RLd8_)YS1{bG$WiPbRSRx% z@d>@q)X+;@ZQe#*_S}$#)zI&eg^j4=>oiSD3ZNuoEEpIH&*Qj~2WwX#%Xi8@qoih*sD)sb{N96+|InMjY$0nrX|7 zGx|JDpy)wC?m4!a5h7V!?xGhjP>cV_%Kff}4j_g!T|AkPd8Ok(F@*g$F`VJ=Py44B zI@tX~4D}4#PTDas$5o`BnCS;RlcxH_&-PT9TdykJ+(Z-Ory35744&Bee!F#aYJsXlpfxL9hZpaMRR0P(DZD_2ehHp0aa(Kw&t~I@4apr31J$v)3%~tbQ zUfl=C6suv($!zxOZ~`kzHzT7o4p;#TxPQs8;Ue&@C`ZyFC>PfOHk)lA#VCn$hrGSY|dq}g$AS} zSKYir%OLAH5CzS}dQJzh!;iT87A5oqVM{U0CkpwxBLi+!4`ujSqe#kHGB{Pjufn}B zP9uEJf-)k#RJ5{R&RcY*DpMDL zIj487O~qhw8IE_l>rHj81apfrMFem`0G}*o>h7c}Mnr>7VeIr;9LsooFxv(vUED0j zcwph+Jq=%+;^-+D9SO<~^q#3_516P$JZltgEisbTP}<(s2JE>)Xpv40GPi-BdjCB( zQLXV9mDn2bi|F7A;*Mwr+zzJGxL9km?2JW>SM8jV45U;%;XJLL=(8+*rF!3=^=?=O zd*MI52#yKH0)c3udx1&~rg)VP0K-19mLeDr*tPu`GIF0#@&@y@bo$MgrAOHA(+t9sP$Hg-AWeI&rsvNq?!p8mP4T367Al9X#?)Cy~^N& zVU<`AA+GGnTSJfOv7|Ug1%u9tngJU4N`9;jQZ_JEOmL+pQT|j+3jx1Y0Usd-XI!5m zo)TIOAcj33Ze7g9d;ww@7E{uDK<~1;AD??bhS+w?v~_!qS;X$?{S~Y|Bh&04k_UI2 zW0qvYPg3k$GiYMSMrYyfWas|8OCeXaiW0vO9;RA#jB>1uJLv5*lG*|a6;2MVKv!C! zwpd6lU4kZBO2gMO2Ty0e#1yHGKo1VNQ+TYj#BeKxnwAtVHn`8ZsjEcgC?YB4R%~qqLzGo7jo@MpijlPX@9+ zdWhF&lNz;rc`tMYf`KQ(>z#A>M25reL&pqLU)5ANZG) z5-x#2?zGbZ9sYO4^VgkOj@OZf)j2F{9td!j3peplh%6}c2~m3{R&?`izq(UsBJ$j*Gj*NXbf10w#N1y7?n%1b%IcRU<87llJxiiZ`M zrbgwTbWq-LS@ml(tdfH+cfE`VeP~cZ01e8L7K0Q1#(UIk%U5G9^usaUV$g$=3)#G7 z3%CfHMLC=yAfW;?yqq*m#9rWxZWX>AmR-X7E{MR?FimXK0Lu@6hVTmJQavY;oUo5* zXpBB{Qt9vm4ZS~{Bk;-(l;z4{knqJKGk(6*tnzq=p@oN0n2Wy`G)`R>v*JFtc9iw+0OzF6TBYTp%Nj-x zk0;?8%o-!vF;dJ8l@lrl#c|Aa{2cE^mYrn^i7&)B9<%h(v*%49Kn>5}I4GmFh60Oc zPB2KBOg;k1Yl~&Kmte&@z1(_KrnIFeaM*UVYh?Xwk!atA%7;Los@r5kK=T# zUPl(eC3})Rm#*E4pu`n7F?p@j z6e}vy0Xa4khTV3b%CMzHMsf1)J=xCZV3n`>9JQWr;?3|pY%)}M?QygzLS8a4lwm#3 z^)5Tv4uTeR+NL)>Jm%{99_69{@zd-&4b$!^1yQLlql0SjjK;35mIW;RYoHmm@s?S_S!Ju184PUTC&bEctTk1-qVq}d|0;F zx@4NXvG1bwygJ$2JavxVCs?^CZd0iwImA&|B7>r&IN)~Y$JoBs47leQkwnNOTifdy zq|ylY0f~Zj4k&^S*jONS9G0CNFZb#i6TFG65qG##_EFU-G zpp$j{a_t!R%4It#*E`f~U}GU}j)dk5)75LVuWVMLB9{1Q;yN^MdXZ?W+l=ctwCIml zQ{3(wu7C3^I-9bdZk`4vY((hmx=g8aVIA!_uNyLGgzs*qIyoRV3~5?aoNM&V4Fbf5 z2FDkX6=Z#(XgyYGN8PMm zv7G_o5Pn5DgnS;7SqBYeskrhXHOzQO4KsW*S4%;naI|kyF@4;9_L#Y>Tn~u$LKlYY zrnf6);Z=LPMqE1@_xz6#JC+8)(MoWTgJ#&z;27!caYZAnAt-jxXa!uEgfdLqBw>iK zUs3wuWcR3kP;vYQS1YhNcpv6swk2xd$LshB{V=03=Bi3QMqxOkv7}Ik&bn%GFihsj zS98WiAqTDlmjg+yb*9cwGBwPe3P3hAN8O>GlaNDnuIG$Nj4SJ+hcsEF7RpSROyyh_ zFnnUa_Ja+vPz2~2%v@(mV1>Uh&pF)ca?q=(EuPl{Lc<|oXt?n!H1r^*G^2=6X$bY`HLuD;heD1m>Z8QwZxbY7_=ZSc4E7uhXp~)> zl>kN=)xOoKnk3lnhyno$Gb{|yp@cz|=(E~kBOMT-lhp_7ByXz7Yl|gqqb4EA?1}bo z>lAx=Yzv}jU-w^kUMqVxCPxpOzCC0TrU$U0;%m?sw-RFmg0e5LJp@-K`*Z6@*>aKU zB-W5!aK`O`YBVM>ZlEe+$UBSY5`!B&rNI(07lsk zO|B@jUkI@cW0?-vC#$IM?`=$YztCBzu|;qvVLc0kw0!69uK$}Fz5uFW6F?0S0ctog z+W(-2R_zaJXxUPJ7VQOUxg?-10Wiwv0HeHj)QwZIH`-tEZg`5b+BI~p0ZwhSuhCS% zFCIHBx%P1F?uF5&CHS{hfn3JGIE7MD_G~BWZ=jVq>F6#LdJPS!|y^@Fb`Mj2{&$zfUrXp}L&m4jLXjB?Rz zt+vNEwrBYvv0mAZV%Mlz@YRd)#DV}dWU2FUnrEYISTKxvFv^wdcuk55pjp4raIkU( z17MVMa+q@TJKW~`j`X=3n4*sQSWF1hK$kTWhZg`wIsI$#zNK!*%6rEO_1wA1)ToT1 z&B^VRN>B3w!&{|igR!WDv6E+65h9K48uZ-}Y8OGwyziXpb$_YhBv1|E|4j|s`WzPi z!G@-W*8ib~ndlfR>V2L0VB}FNAUrR^*)GUfryC}V5fMY_SN-Hyu&{0Mi%QVpV3hJ_ z(wQ$)n%3u%O1jc2YL-Nzc3X0@zBYzu9px9pZ^Hdt*F1S#*91JQYbJr~ns&L(TJy!G zvB!0dYuC?pjR9a?lP)JV89&;49I#Bf3(ODW#O8JuR-{&b8+ZQ>hvXaO(r>`azmd1s zzLe2;BHW!R^lCXVE2-$dP(Ez(S(1_?$2Z~NFLNf=R|}s}_=K*Z6y=F_xxk*qDzAa* z%~Os~Y_vdTcU)$r*U>vCesC^R#VAyHtK`@VE>qH?T#M~8le41mvaY#M5bp%W>=T;} zCgJBQDY#gYuUlz~ULC6bQI{Ptqg9SET~jectb@HimmEv{q%^h=ve!~27%zN#SY>4) zUql!onK0+Og%#Ep7UxHrqc9P&Dm8wUDUlIwWQt0LHx;N&+;IF3?`vjKW4Sx~+Yhv&p>zY6ZbbuNzzwnC_v*+;nLk%fcp<_B| z7#2A+-~CWS+k=#*6JU!nG^1sg)upneJZh^Wrg#NtQ5<1GQ8kx10WC@xO9*5={9&u< zQ#)Ri-RV>9JD*&~c^2ER7E917$FJ9SrAHixn-Mg-xV&m>zgug)?FSQ#~(C7 zU%o>)M65^7nD=xzncj(%i-yjQKQ<1070#Dt@>Vt9?to*%7QoohMSe(%9`>sc#KAn}Xz;JGVF1I+ z1EIghhOm^NUV69b5GFsyhBOajL(0E5%Df(t9!P7#*5?NH{TL2b~(Kch42>s$j&PMecroc6i>zO&Fz`SoidCY$%DD z{eaQCB3*iO1a zAsQ;MMY+&vuQz4JpXcq9tVHBxAO4iV6xohj&Ya#1W3_V2;d7Tz04h3j5?k{$%fZVX*JD^1= zTJ9fvghSs4I1F#h1;8Q9UML3;4nJ&KA_CzM6(TOS0sx0b)E;~+IpfEMSl}~wrfqly>G1Wzww}YjAE}u-z#VwB zD_@7Y)*kndo+MP2=5AJ8bV`GI^(NC-qF|`jUs57|@WZZuHsJcF8e)al5&fe?(baeS z*WB=Fkn!qcZdgp4nRh=Oh_LThRLwjnQxMTbc^VS4M&riyMy8~=7}q%7c*AScXK4QF zV!eQGbMHBa;wl$ldCgXmMdkI$ysggPH&pIX4Y>gSUXN_3`M`#=_BC_1xUPpRM**ME zXlK*yF+->o!SbUjrX8c?DJSC>Yi$8*nlIig?sg|vW!HL6JnmQTzi%C{WwQE=9}>Cp z?`n!s6zo7A=M5Sh_@WlUgko^vpk-RZ^_0hif*AH1j<5o9L&j`8+qo9{sR$mikip5j zhujcJt0<=ogy=_ZNah8PTI={u1g{HR|IDcfm>UK!J7D?y0V-uhU~VYG0lV~&8yfzW z8;*L;b52(AFm`8fsf1n$@O9kIW_yo25))YzU_@vYyLms0AFsiUWRFdYoGbGDqFSc# z`q}vY03il=+-N0kV0|B3+!Nsl_r`!3~ocHu;?D_<@6@TQ0oP;H`hQhZGxnVpl7j@P!1~515&#EA?FjZ^_ zl>;w_#Br?g{381=Vz{IEmlzHK#Bg-?;_qk(bjqi#5X*Kym)93u3v0FvzoDVYpJ<4U z^j~O5nf-u<+Wo)Ka2kMy3~o=Zz~dj6*8x+dgwqJnm%w?Ac0XWVlZ%vH0G!uAU1XWp z&`%LIIkh5}G){Qg9}nQt=dMO*bUP*&um82YHp!+4|2Ql;?{WQxefHb0-=a=b&Lrc&{;P17X7o01x{s+rUqOq}X82xZ5u()Zx4Z|$IE9VYW1 zm)8sQ#Rqfj!CX~+y!vfj*?P2vj=SU4r8(iD2cIN0kcJaGxCvuBV*RvqF`B4=CCUYz zI|2j18HAV?!?9 z--g%E{>R}pJ6A5&!|<9HIJ}49sl(TMM7U&E#V7<+01+3 z*sznr$PC%)p-~2o4YBy*N|v@2nC^a!4Zm*=5CKY*iA_L>LTT|5k`Gv-pa;pb$Z{m1 zpp3%ugfO?VDR%4oZ9Fco;UAXQ+y^d)>`}j#*FzjXme(44bzQlO$L(Wd%XV(IP96q} z+??K43!b-I%WD~|_{cFt$RRQEV#s{|5W@sguBWK=IlicUFJ-Lk(MhsbRqVpK5ppP{R`bA8P0bK*NDQ&=A<7{0AD!i#?!Wec~@P zECr(BcZ#DMibtb-12D=pKepHPiN6_TggwzQ8{I-)k7a)%9gl+RmD_w)!1di`Mf4_v zcK;tn8D09_?_)y`z}S%c;SNRkZ+9rHGfn#Ji@YBCz&n&b#)h1*IU6ndg3$h~z&n&e zhsnF{}T-n{x@jIeQ)0-V|n(oMOpf-MFHa`8Tze7F^BN`*`j11 zM^QW9P6r8|9=xvKs!`cmpYp?b%cDbDSaX1J$^T(|<`9To_iotdRNH zPI|OY_0?pqh-HFwJ}3U&Q{ipv3bxxtT^OQFuYkPV7-tMnj2>zSP=Padp!(Sfc(1qfGkKD4#tVWv>x{Q6>c#br%gr=VL7_JS2CF;{ z1gm55702<*@fFM22W}o0TW1}6ytur4seC(WX>ycf%BRPr?01Eh)G3vpusS|sM${sT z)lv{o5{YmV3r(TNnh>Fac7=<-x8xWQFchmfC=S+*#;cD++KCDo1TUMwM!=1#FM~h^ zpdmQt^Cl86=%*a;F@aiL-uh0?MFKL?2myLk$Snfe{_c4!Pd~Wlq+LB8qA-VBX=pM& z9-?gVnZMi8Oib37PwNx)A|o>N+5bZLxHdfb$J!A5$J)^5f3-G5`Pl1vn zAHK0!cF^b*j%V$>6B_|x^F6keZOG_kZ7ErlvsI?gHi8^N zruvqU(@xsua5@S(mA+7M&12hmgk-&rj#Y;?t_6F)+Cs zJe)623T_UfGUbX4TeJB`d_f1sfv01cr3(R|Ate9}IdPhJzF&K38+hJ4+@U-l_C!MGfNg~fy93^#I5evQ z?@%!P>0xmIcPQaWS-XPPV%GEydJ3RNNVkq6M&mMH6?R@z)c>D zX+I|54#l(?zeGniadOXLvEGB)w*>pN6d;EA|EIX~j;A_a|_TLh$CbsJEi;mo#8mux%<8@f8gcy{OR$0pU?aAd7x%U z{ikNwNo9TP<8RH-!xjf$6XJfB=E*L+=Jh{eLynmNzm7xr$tn2&mO5;ZEy{4`VH>jxY< zVArzbH&#VBJ1jcurA5dg1ON8wt+(%@E_~^&s2GQu^aJoVZcdG2|8^xs{A6kok0f`h z2Aym0v@nO>gH!I3?oz11kPR9P4WYp>Q&i`49%e8+6+>X`CM7dOp`SNAhE|d(&h2lu*xlfNeRHt}qd+mHedrX1{B{kFwr-(P+BxORq@QWMj znXLHa6!c6!yt)^&GlT@?HTHY?KP5@Op#kz}(Fz3$B za2T;OOwh%T31Iw-O|1b&L8;W%AMSS`b+!JhckP|93pM)hJLXcZUq4SvHLMj?$ehF* z!MDu9|00tu;k9Vl2lV-S$a@0n!-e(9ei$}t_$8cbVS$Nn zAv}5a(Vo10z>`-K6tuP5lXvf=*xhQ91K|~XRMq*-nm4*u{0tbEvf#l;#$^$ zKCbi6%P00c)Bbo;pS02z>V^77eNV_d352zn#7H7Wb&nCMMdrD*pO7`>u4(k9p6e{J zlpQu0c{M1^xkFwH1M>PRAg}v{MIb?0BDU@6_%R?TSD*xCwIu~1*e*di9zkBm4d>3Q z13~$zYss~&;hxzr@+oJVGUk{3wy2$9E&jWBgo2W=YFg!E#h-xi!?Rw^+9{xH353n+mb%7~mjl&sRd5TzOwH3I8${Jt@QUnEt%UbZ!{4U4+Z zIhi(creltb)wi!C`kXG1lP`xT5A8duKgcvluKbS%!^;2SU}!(uU&3>$E=l~aAscG4 zjo&|{%k(&Nu-asO3en5J z!G&CXs$dJaSAj}at`^f_KDtRq5!)Rb3NeM6^GjPcszt}imZh0qGpn}tshp6Qy&J)& zD7FY`A3*{NhyQdu5Kyq2;k_419;2WcT7YIqifo2?`ArEM+X_#7gji7 zmG0qN>zwW?O;KHmOZZzG1wR~Z!@^mA#SF{YZX&$N6Vl7jR4Ba%c$4=)>%vmr?;c3X z(4KWZ2uT^X5faD~yj^Ja{CsRoFR;sq&b0g zp+?BX3t(Mno!Q;y3D$)oU|qPZL3IGNE_{qy7iOW?g+JoKy08ebE~LwjvilV?{HvY4 z+TX(rU!pL>j$bgtFZm6OUS!uO8_6K?WHq6j1FvYb^8S_yu%JNDwL1d3e!)zB96;B^ zFHThC7A((8D{KYhVxg6(Hbh@!0?aVoMrCsk3NvhiFhd_lfEjMV z;J2YhNKyQW1c@06l5J{}J(POXRy+bQ!-8jzc43ABVP9&YscQv=p4yM9^Z13&M=&7&- znhJIPG!-7m$7>zIZiJ3b7C0K=(`cdabY>0O6IKWB!&TF7T)%MnF3e{BL+5P|!CPO{ zs`kRe(pJx;+&=Qxnc>aJq=8usVwiz|^*iK{(FrTol*D)77{2?(%un?%AHqCcwVDY>(YvU2-g#f|DhY##6 zf8_R^+4j<8+>=p18j?`+XyYi|LRl#+^xft|8v4Dpqd~V8nfFi(&}dx=Ha=({ddZAa z`RMdjJYmJnF0(_L{Y1_7(>hb?y^3^H)I{gJIoXN59QM8vJ5Ck(li--iBH-mj>uQG6 z5|jozotLv`p4UxtNsK@A4@wk&IY@64VOaL@e$0qQ&2!7l7Sj^`RmZt5 z-wtNAiXX@fI&d1O$R114r2|M6c|`UuBVtwf0I@2}YrDMnxZbV%eELztOm6VuH2O7x zweNF+H+}*uo+z;5vDZC{GL~GB;^{ncjb`D=nfBtd0iW7)jfU4lvbH9}*gDeUlMdAZ z6`3zv$i`T2C$feU6h^ghCTBHJ0wk2IgO^h_9us7+oIjq(EKlcpKnx3S2` znyt2#TH$(8O`ac+P5N*VHGxQ?27VJk)QJ5nM2#8fgX%I5uYAPngXSh4f;jr1 ze!@+jPu8^I!ohV*X_t!&IG@*yl(^a5ke6nV^WZS_Uux|7_Vl9sgR`p(KF%F;t5^vQ zr!t|02Bp8B(9mt|Iy*V9C-OZ7l1wbok_nH~;bl!ruUBHWGK?cOa);!~`n^{^j={P% zZY>%v-gFR5a+4ai&s!eo)D*M=X*KG+bT^q=9mytMq!9wLkUb*~5o1UNVhn{kW4m%H zv&Ncko{s5KfZbdNF@~c1?y98O^VQ%(F@_rIP>dmQd+pJ&M>maP?N0Mkc2n0Kxi*gv zk%cT==ZUS7G&OuSUT;Y4Z)H$^$&(Y?t^Jy?!r>*W)#1|})IxJXn&pTX!#slz$}*~7 z3ktoeiyOSOGXyn!(;7XW50}(%sApP0S#18Ktp{{Z`JOAhVIWEB239R0~+Wr+yImf13~4cd{{2Fc5O1UdC;Rm$7sNmzU{Yy_h@Y z39`xLIVX1l8k*4o4RGv$2H2kh8kXUq=bxp;SYih>blgSmh)4&zbKsw`op-1G^ zb4C7Y(w_Vo^CubS%_z(H$V;OGTlg-KznP&Yg*%-xKMw|h{oicd55jJ&TKWc;JSvZl zt?ObHj2;r%7ND4;H?S;*+D`$2={3N1ocrZNeg&N4evEW3=S0x!QcspK7~B z6J3O8V(NDxsCsP%r~8!p9Wy(P%F=I`XUWZKrk1=-?_mz#evq>AQiti* zBL80^E>DvXRQh^zW zjP^$C4l?Xo2rUvn7euXQm(Y-8bE{B;MMnDbVYxD~mtJ+=>lav(hnSM27lvnt7S~wL zhc{7NxS!T>Z+EP#N>-bsac;)nwVf!SY$yBf{sY@dhDq5_fN?5cjn9>M>OyH6jlIa> z@R0IL>70aK#Bk`wYSnZPJJ+@N{{P%|Lia0MSfY~F`yR`LC-g@X-q0d$6CS1;4$QAO z{*f)*JLZU;agFJQa;Dh1u7_4SsQx7ro*&JIZwM;mx<7wm5EEpGA+14>p?N8PA4nan zq2PxB(t6uPT317LO6Zr2YYSAyHGEgb^%kl1AK1ca3|mNX{dcyo@3o2lK8Uo&5o8Fz zBtQ?Jf@^w*{#&*ah%L-sLYnZH|5XznNND))nedXA{+qTF3|lzl@UPfTHlFO*PTFtp zvYo)WFDQ*?y220=GSZX$wb=L6)uxSrEAi~7rH|x%P7OnNl2u!@;Q=x-$tBQisNU$4 z5`ZhA0cwZYK3dnYQEN+Q$5Vp1a$V;dnbP-n7Ain+A?xD@DKd!gu3$dKR(0i8a*+iCou%eNpTO)PdV?VrMTb73_2N?z_a+ZDpYO-m9p|7G|gZ)=a_gfv`{rXR~EY?%{gjUeAA*3O{&B(}{Qj_hw z%1>9Szx3_O@#hXAha8SbFqG=KKg}^sG1ba^94B*fA4i&%2=QvP9S7$<-T6>e?&fP_ zF?%%^53=>2dpw`u_@p36-0AryYgj>o?m#LR2x#cdAwK<16A{qhP~%nFR$-{M=S)Z0 zcHURR(aJuLs=_w1{nQi_PXjdyr=JGOYMlT*ktd`*I5SE)kzJCkna->=v0Vq1axIRC zGE|3BuAwMHOv<&;BKO_0Y=jBzP(ZnJ7)mUXqx;@Ewnbl5hQJoaY%ev0?@7 zSq{G+C&Tr<*T-oIN{GpIP28R9+I&M5hKGs#SJD?qgaxwA zy&}I`t!xU>g{j-z*VYf;yIaXA5%e-;YEq|HGp0++>CG{G8t*Qr4>2~$hF+9P4&Nc; zNj(c>Jc;`y*VXwCxvr;Cxvr=FnCqG(?fzS?tHk~cWUg!c?p#+{-rR-9DC0>@V}>!` zoaI_)K>?QWP?t;7adPn@^M7}rk(m%>|75+8X)fvil z_1wVZx+WCwEk*34z_bmw0@93(WUpq4ln&CaxE40_gwnK|fs0C81*(NCGUcbc{ zUP+-k+};dZNNY;;UayP*A=mCI-QF2@yVrg!+*Q5X-Q5jl!-r?GycG1U3jzm?@69F> z<1zCdsqLf%Kn?Yt$zWCEX#mt5#Q-&Hvq+$3dYvh(qWq6QjTdH!T`oQ~Tt@vZo37$aPSqX~W$9$x%c{wtXWT!o6- ze86a^5_VA)jE1(EU1vRuAB7$Rqv4VUm0(-(FfTC?V?1g!3_*>C{fQ63Xjp*MPktq> zfqv3Q8hvGvWR~M=o9t z@L~%g4kUY4LeI7V6RYlLihA(I@6N*~>x`l@A!8ryg^qR!uCz+$cv%Qlgj1Az7@P8k z=kzr+rqh#q)TCD$@^mC?sALUH`{b633ay07U!|elk9aBb_9z9USaR6!Lai4cD3DnS zdOA6_rY0C4|5VyQ4e2Kohs%yvip@1vw$b+qIKfr~Z~R!L;}t{bC*d@Hq6>qq{jWzU z?bCpMayg)(J=buUbFGx%qXxG4iFH3SPyl4E}o$=CpXI_NOmNz-1KV*LTreD%>g0&#s zcwT0S-DSR9JuQo9eRgtXrx{lGq-%p_Xcqr06*R-kL`4kRRq~)2_Fidhr8q=kvwtLy zQ~Md4VVp{c@mh62wAwdY=2>~LYfmaU|(6DMEI zCiXd8H3K$=o(oag3?d|fX#tRcVi||I0|f~vr8Xa%{=+*^P&5Pj4%BCL^o3- z(#ShdZ)Y0bJ(@N6-`s)XeP3URB_!K~HT`l2Dnn<*>i0WPpIsj&r%YkpfvUL~0#XbG zI768bjSwXy0|5m+6#^j{ITgyV@=%hmE5^B>Q7bJ%PK69%w>8IE!BiN&ah-0VywsZ} zeVLY%j{ueS&w`o?hYqE^(SW8xyc>V{3jd5)84hpOnCw3QI2`r^2=I zlMY2F10MENX!JN8@|=Y0m$6s&&ovHmcFbRz+Z-_O+ytIwx`C2=4Q<3Bn+JKjm z1w1F%jqpWG`4rR$uY*QNf@p+}j*jR)2tvCA4ppm;A3ht`-Mr)wu3Kk5H$I^TH7-6%nKG2aU0xsYahFOwUqy!xW$hLqb1eE;#t>OS9rp zP*7vdu=@BonFR#XWW(V#cR3??w`v@nq&)=~q~oOXd7D1VFq22*n1DQ2ZpjzV=}#Qt zJ0Ewy&FpYf0o_siX^9taH7J`VgVW!4np}IrbM|FTE}`752L#cfgNa+JMEQdZU`_e5 zyq-;k*@Yti1x(TQKFu7zVzlkakTNL0Fw;7re#x5kI*sj3#ygkxX9{ZGWB=}7=zb?w zbFZm#w(dLa*qg+ob8>wwj9&Y%G?-sZ56v5!O)w%d!*k0uvD$;@YGIR6SstzPS&H|q zE}kXaek$pUR#GNMa^_&U3>POy;pbw?CFfB*%Wz49W2q&S*+JZZ3Ow*c6cE<(q*3(* zEKk2K%EezVDNa>hp1CvX`sz5Dzxt@@cOwD^`1uOW(|M2g_;aWH%&HJu&$ZLBX&Oou z2$A=R9(ev%qh-$dufB#BQ(RK~MY(S)%-!fx4%11jd(|1P5#8a++?*fnN`VTOyG9%`Q+)8 z7gkPk>mj~;l(}E?m3F~>x!llfzCH>C!)RAxe{*P%{)^>R$XA zu;PE2Ny&FzTzmgqr_smy?4bBvmb}7mbehG_Y_%vn1JKz;jdvIKmM9pjU#(U9>`#JFV zp9}^!58nt`_e?X@_@da<^T=qP;?ot;qR)Ia)*&LU(WgR8-#&aa(PZao6#v?{IaOA+ zA<(KY>3*r4LzZ`mGwqkZu)5k`MUaKvQ4O`SI*Bg)3ExRyQK}ph^6&0S;;qE1C2YTC zm18KO?(QbLXjnB7n{$G!obGPThcDYt@#6whrf8NAWB0*JLZOkvSbflAM?}{ClkqP9 zmp!5G@5Vb@%XasLsn&UDPk0Bx6}G(2fcAvS09vANXCe;l+}kmBF5m8{1W%`d2Zbz& z|E&M}`lQ8~j6{t*=rAafEA+#PE|iIP%jr&XT?}7!T$yek{_N;7bt!M_V|!+QQFeDF z%p2B)R!uZes>y7N+6^{fyUWxWp`tR*^&myr?q=s1H*TWx7-S_VQOBRup*#ke2Sx9= zYuzdRE5Dp6HkYPEAAcg%-l9CWlgIEDmB%1~$Yap_MhyYh3#aFMI+yF2y=ShljUU}S zw9Fl`cCjPUhbP-G+qQgY_4&EWqt*f=@=k*GrS@m^8WfdZT=uzE!nt_b?zjMB-<<}))Qmo!M zC(9eu#V6kv7r|ucNtZ}}Nh;)nvJ2gV!*61x5-SrYI2mYVxQ%IoQ*IH64WFLmP;XR=oK15>v0od-^khVKZ;k_C`e!zAo zH6Ec;HZ`(vKDu2Sr67Ns`m=)EwCgS??e4pvK`qX!@VDPW9Dmw_UJ~vh)L_p)I$jkOqZ!GPi&zpWQ>vktgqxkQmzp9B z4hcIXXX@S33oyJzpJ_5&C*KkOhRw-~lcQ6JbeizzXI{-jv_7{z{)sPA zE2P&o8gmxZ*Xl3p>4X3?yMzDZJaoE@)EihcQOg4HbVwo>yA~6 z+sKcpEmp*~^`mQX8(%TCuT`;au;^OcJ~2#f+c}JD3{#2QSb?eRyM(b>U@CE=$e7BJ zs~9jDQ;8eh!&FY|VS{|=THK@yrgqgBn|ndm;+BOmwFDN}A~Cuaw}^tNrMAJARM54! zcaE4^R!7VR5>tu$k&dZ6;fi^(V+wIjwU|NyFVu{SE+pIs{fZHM5`phT{h*)z22e`_ z1QY-O00;oRVsJ~=ID}8rnE(K0rvLy90000aY;R{@VP$hJdTDTt{RLPaJ-0Rt<67L^ z-QC^YDemr0akt{`P+VGEixnwOaf-XUyZsmK^K9;S@BcoIuUX6_D>;*ytd(4u6{(^O zC>Sab5D*lQ%vXDvrV0JBVLTupXgUxe7y#GM)LEaMmEOkQd?|e~W{MFp^n2yBdzy?q z96p5`3K*26b}(m!8>|jty%Vl^Q@(9JY1RrpkFCh(@@BeYVylXJwVm8Ce2RP9-sREE zh>GW?fO+_s3}eM^ztX7s8QiB@a_Yk zCqf}Dt$F*yyXAM>bg+^rlnf!%CZr7C-MR9!I1j=mVWL;_TzN1OHQCj^>@dHkCnFfC zJ%=fyk&#-$kA-5ipLsylv8peR&a2AqaNiYpLv0>P0Y4}RI%e+-CkbONQKP7*H;r_j z>_bTUgp-qbD+zSz?74+H-y3`(<^44zp^!7QJZOyaJ9sg}W%qno19Ws10b@-gh~mr;ltw9N80ZsVcZtPe0V|! zJUzXUzt!7jz3gxy18z`5xu*ThrXB8V+=B1^u?9DGioj{!_`s3@^`ZaG7w)fTO z&0t%hR#k6dTw3W)fyhYxV@J=pf1rEl(6gKoeee^!aHW?yF7$jM!Zqe|a#VW_t$Xmy z)>N%*_{hFI&R}aYDNe3C_U&<*VsUxAYH`2?C;i0JZ26RbK0Quf6?!#^cB%~stRJ{A zZfpO;s02|nZUp;H$k0dy`N#WPVAf9o<(t#U?sSf0$mS`WO+Oz~n(ZSXj~z)yXW_ z%5*5-ZSm}SEZATX6w3bPScg>3mItHew{jnyj+P}teTig#W=*LG=d>f-L7KwL?;95_ zaHT$l;xEe;mIW+%*20oam*iK!XV5VW;To26?^+hRPdKLCVlS+(g>Y`c6C4UBTk?U-3)1hZiKW8#d?S2#Lio_)G?BUi&p%rISd9HaiZ*;t62M69pY) zk)vn;*+|IfCkqsMuEIJPBEjmPc|vn_Tw<){lKohMRRG$l_Fa(v4g5kje{%n+B#915^fYH48pax7bw zXJcNQoWQ&?x+U(BhNe82IoFTSv+I>3zBjU&C60Na)Zw+*C3nk}tPH4b#UZ;G<1`#x zNIX`gubY@;w$za2V*9^`{2N)?Lu<1Ksf(5!$JfO@F#Eq-@kN)?ZHnFP+%`EoQzK=l zK$BLx(bmYOq@-7d;!ze%4wH4LI}4dlkAe zrJ=Q>ZMDp5`q^Ay(`Cw3#3=5FYs#i_L^ODKaq8~0DXT|UkuQ~3AINz(weP~cFQ03w zppk>VM_CF7|*2$bpi@VQWPmrAnSQj38LXb`VxKQk$F@@gXO zl6hDq{&lDqTWioc6M^Z;KLbC{w)+HO5gMmZkq?Qay1WCAx@la!B3jLmW|O7v{1?hV zR2;$Q8oM8msdb}t#Ty>yc#iStu$_l;oB0F9b%P#a`_CDRZPm*f-%RRyKzAd+>4pMb zZjjfWZ;9)Ej(RCQ!+h-agsmNc?VfOX-qAYDzcE6ic7H;0k&ZOBw<2x@;3cT z$P5^3KQRc|iGYO(N%;v%G=H+&K+2EcYEk!}wwLp^CdkkF-aZRJ{hF=2+x_OZ^}@h^ zcQ)qvb8PvHJz}**&)4+9eZ}Xn-F?;fDqvFk)OGWDZ7P-^*Y9b&#P*`m?T7sjkHdM8 zmKlDYUhUI{&toecvIIA0{TKo}yuX)f$V{GPhpudMfCn&9{!ZhB&0x4g3LP6d3coU?)K1@!P6L0Q@4XMkuSVoVZ^ z198=6K<(k=eLSikmMYsQz!{;B77UENMl4e%MC|1rWIa9NI8Q+t!y&_|i;}jkX0X@- zJhx6w5Qx$iF&fzZz7Kuu$Mh}JeS@p` zmYRbbdyyN-*pa)XLTkFc)p~5~vm4FB32pi+Pe!u(|3^^O1Eg znFq??-bIV0s~d4RF7~XX#_n*Y2px8#O9XI&*3v#k<|LxatWA0Pq?axGA2xe;s(d_D zmPLEh?T`z5j~EFKV#Zn>x}5MP^CMlU6bwJF<1lVNK>!!)>}I6laiCoNM9T$|=Inu6 zW-Gi|v0hX^Px293_$VSLVqG(@nf~~}89k#JT~t86nLaqaoO2s93S^KtGZ{b1({Ste z&^$17P!V+~CNbv-TB7m#wMQX0UKE>r!s8HMz>QRJ&8SkV;KEqZ9Ap&=D4#bE+LoCS z_0{OlEZu}WpvFQQ-275hCbtFF{&cQ=;RXt}+7B8BKPxRUr3u5fzPO4i-k#h`_f`Nq zOePuCd|l{NWakZj%Bs34E5vh}gD9cxTS)N2h3EF+lhqy`s`TS`jvg1jF$CE%X?_sU zG>-LHhtkS)9{g-GJ;lig%has1tV2UKYe?9EQmw+S{9$FatlUnF31Wi4-LS_mu$i^ZK@V9>V53PgG#~DupIBDV$o_!9R}T4 z`?wUHdUecKwdS5R@zigCKJqfdn>DEFWMMQ~6E&o{_|Ixq*KT}B{?(-f+GIw@46}PN zTDJ+;W(j$*fSPm!ElG~DSFL2kOCUVkkJTXTqhOmZGiesyUHQAdU(;~DWtkOsz=-+0x+OW6`h@&IR zw*upCabK=SOkTH-$Occg-tT)Q;F|?)9+-e}gVoQU}ArY1XN#gIxF03y>$6-OT z<`4~J09TEMvVEeq`0Th!z$17ki^Owa(-ErlZ5kzmITqAY9nCVPE9?`37Lx`{OD^4% zWwp6%lgo=?_!KkmzZ5}Z!IuG+p*v>yN9+g+`5 z-dT>&GQ@nPj&+qxoHIdqYT>zn?(jIjHVra_|>PWmK%@s)l#ioqi-DDy`60(-`!FW4)l z7f?6?{S<0Bf{ArLvu$l*TMwyu?)rf_KIv18lySK~V!#Mj(z%lim4_$G#y#k3dWqAu zc9`d@+AG=%#TFa+t(nwWvpHnV8VvA92#!|6@);&mG5jJypV0N&^|iHf#Ux{hab*ST zRcP24CQlL2EoN6kIitVVC&rO+<1xGJcNKq>$C#oizPwFYr@t&?#!Yv+e+u#`?XR`O zkVD&mNj)MVi|mDzK~v75DHic3M@cki*iW^x5Z6yRSNilofReb~T)(&lyZ?!PY0)T$ zNaYv(yo3?+5rwwwAsRsohHl$#`tZ}HUHWgDEfosXQjlaT*%J1hT)N`dsOo8-xwf+u z+0EHkI}>WI)RF=f!S#KpnUZc0pTan9^~B;FN?8(h2^iR`c;N%dUnPsOBpUCb1=3hc z8T_df-eNirS?!Co#w{k>LF0vl{(7?iiManr5+a1?&97?DlMPSrAYhUhi(`+z?$fWw z(};D-1mcBf-{Y`bRk4+NIxS0)gCD&x)^pTPauVY5>4v`o{Yx1v3xAxUxTAI+9^a#d zn9~xZ?vUyP4Sfj|1{)-g&wTJ~=7L2S2~CIad8M|9s0p6UZGM1lU#mz_Kh>N=5E(XG zXcSRQ{wJ4`z7GM7+v~|&z@9-nK*DwyKXJq(@;v6IYxb$|3&q96n=n5RHB`W$Ke;PI7ArGk-j0+Uoqc|N7bb?42Ol7 zyy6rIJgPvx{S@tSX%;)G2iu2w zP|uN5HU2dv!VR9xmS+QnDzuU&l?wNpu2^;uK@!%F5dS87Qb?4sTLkY9gVHfByc!L% zrre=BV~{WC@~Jc2wxS)}?8}(M=JK(1Uo!BAEft40qnN|!6@mxhGEn3gDEN;wd~fZ7 zGs{}2sm4oNe-CvNQKY-TxpvUspb)5=w$sSQ(PUZ)gqiuIE;Avvx?h-lP}BSkzm4hS zCg%6Uf949@__JVLzj8Q}!tZ0aTH(<&jR=Hf&5&!w@&<_wM4wdSK{O|of}RmY)$~$7 z6cHA4Q8*KeAf=*FW8BJlOYkC7Tbb}VgxhPao!%Jw;+T}1_+!mR@RaAo82;oH%W!&g zulmYiG#g(}zd)MI)1Jds$xrS(QJc=%D4SJl`f>-DQX{t->b_49?0#OMRdv_=SxpqP zOfD52xrX;D&4MI{^yj~dX*acP$Gg5!`2Or?@hPg_u|6ATuz%Gh6u&8E`m(OB|J?= zT=iBlylUM8Nn@fkM#b>ynDIb+d4d6h4I}~Bq5q7IX3wi4%h~ng2DZ`cLf?4iDK+rj z#Xed~v?s>U>K#E2Z`z0CMku1kIEF*PTG1f)fK9a5Xv zE8J*mrplStDf|JgtY^6v0rG(CJ(As{6@q{aBnA&h=|<1Icl0mu4dYTC7VbIR(ah5N zN`>)NOo0LvF`g`TNb(!IT~egvCVNM_W{SNm4xM_jb8O@F#?Y>oQ=_%tOPJVZpD^MZ ztU6t%A-Xv}gKb9h3ev!!O&=xdd>AZl@uyg&KU+7W6Ku*Rs^s+xu}VreO!%6~+QFXmpE3<>=~9#PcpoVYY3mrJD|f{GwJwEg^ym&27~5 zWnsUX0vS`NzJ_&nW4Vr7EL;a3Iz+Fsl~=MczU2M9iN?8G zFDdoj)42-6679v?UUI{?87Zf1bgKd>DY2ga6MChfBe({5f5i2i0D=rhOEqwvgg~HO zMQs?5?ov{*KqT25)mPWa`VR&D7t4nCf!jD5{ImoqRq5NXDG0+K`!2wTIjX$@Jbln% z3|ayJFKnCVjoTCtNbwfxxu~f1_IOKgua}G$w*A!zkjvxTcVpZpL&orKiZiv~yqyxs z9IMk+G9=A!8>AYR>$=>&R`_7!A&}ICJ3PY|;IymYDGUbp{67I+0>#eAT5sTC$l+Ux z6bAhMH`f1gs~&IZa~`Z8VTLiPx-NS8hIb_kR&eOx({wb4%r!dFLbqk~tnDrAk8k67 zWSdh=4~IV>(Qp55?FFW#{eB`R^ZglxQ`S_{Y12K|;NFNig@H@FX{q1kib*?)$p_b& zrri~9^T<^V+jwU)&DK6)VZF_HrIqg5Enpi~gCF2J%nj~AQV{;f+3Qq$|8>vcNGYeU zCiiU?6KW}A$p3v}j2iD0gZnp^6S7?gHp~%Z2szAgum5mA-gDstIcyG{atil1E4{z4 zRaM$tGK~(7zvZ2p-_v$o{B=G^f07%%#qd9ed&xajG^=vxA?#XL!8I^8d0?7AoMPAmuJ?6XX10RO` z<7V{{4ex!coh7)edK6JZKQek5fK%=+L>%AR6e-iF!VW%@-BhHv?3bGt6^{-*OZyZ-T?P)yT)$uS#kZac)V`D>jwS*h7oeo%YQ)&?DI zu4~W5u@NPk&#nrTZ}5d>PLJ<}+2{L@48trlhfb!?PP}OB$Hr48j9e9sZ$GRc;Hj2DBj|<2i`ct znr}JNyg?vQ&ochphuuTA6HofyqW`apd;{1|DJ;@x@b8lW{$Pg9*O}4KmIV^kUTIf5 zFQk^My=yIPm}y!_Q?JTMON3Tr(bgx^_~W+7#}G5G)%zAq0Or;UsplH+`MS}%Ez^Sn z<~sB2u!Ob|&KYK7Z8OE;3%K6lk(}*jU#_=TeRH<{+ll{_?t%Y*-t7`cRHI|p_v)mu z(1eahh_9lEKlLU(zdQTmI{G)Q{UXQj{<@Q|=f9*4yl*@27M$|#zWj0OO5SyoW@G?x z_^FdiQ7`cMH7Fnzr*|YSfEQ|y)U#WZcji-h*1%?X*4_wnW(BeO4Xg{YYZlqtm;QwG z?3Xl<_y2XUKpi*q$iDW82n&&S?KdcXM&4C+wGFpUtYdL*FBg_}n;I{sA090m+Bs;h zMNTboc}4iQw{Q>&x~Uo%^kmP4rLp+x^a)gTl5ub;vTlm#m}PU=8^wyt&^6K3KfTzu z@OX^zBpQ9wjae~0Hk%6@rf2)9!PBtt%d&kt;kl)~L6_X)K}VhZlsR{2BIXcd&`Xcx z3?Jb1ZqHV}1-FL%kNXIDg8#>@?7twoo!axbCoU3x2sXR}TgsyleCZ{){h^VWt|~oA zE3G)0=h5y#_Op)>*6Z>~-%Y`5j<4(FuWJuqMmfR8v17*n!)S_Ko(h-;B-O1{WXC<3Sv-4NVP;af{eYPYiRm@YH*7hzWkNDNl(Smqb5a$dh|Qr=^lSd5oc>^h3klE%PB@9j$4)QW5`s{ zQBGiu7XclDwQjqQ$*S}3vdOHf4pZHXCN*p83&Y{T1UsmnjFtwAhQ^!IjK%uw z|5gt0+l#-uY>fX@Oing};jK}vSMK|i?{=BJ3<-kt;w=gg(55sH5bS@Zd<~s!-{yRe zv~2AGbG|#yzP->L{$I+D+gQ_qY8vo_8M!M&2#JDm`wfvamC5!EUUQt=1HV?sF_v4R zsn3?5JI9`m?)E$WM$x3JYY8l*TtEB7yClFB7)H^iC0a|%u+9l?{^@MMGjV75RI##( zLD|7})-ABBcaMn|DjR4=qTj)@F*pKMkk9*=sj;83jh7o-ycD60_Xnow*~M||`sZKW z>ubU(YFb-BBR96Uj#;Yu5GR{X@ydsqC1#r3Ae6|Z0?wKdk{Utszq*N9IIMGW7?`1% zF);o3qP7oEtTbo79vv&}2Ay|djz(%|^ex_+`Ao>P( zs`=a4Mo<$-Nvr3h2lPQ8+pk{5qMP1)--oA=Jvpy(&-gVWWIoRuYVpTJ_bD{nsCvte zf#$d~dy842;BQ!>-u;0FIesNU77PbXRXZh&0-^qK0Vqc_9YhzEedVmXdB1GRxgq8P zTrCx@Vf=wd^bVDLfzzS01`Y#86$}QnuyjG^hW07~IE^c!I-qTs+0n?L?Ua<@5kTmu z>MkPTB4b+e5v}1BagPt2;?Oo|N((F6?s)8yhr&LKBolP1u^W2#4bv%RQrGcx8AzRo zGV-ZG-e=Tq&XH)iHo(S)LS&9dwBci8kHOzA@IzkHX)A9XK!9OU)AL6z|aOLPa=3cjS;CMa<_(n+JPKt#BAa0fO zoF1 zI-hVSM^gA?iqtU5!6VXl(myn5DjWt|MT+C{&{5w=E1on$ob?K&yKt9_$*_CfcffAT zy$9xyEsQam&&( zVfE383*s{>_{T-4d(VQ0#R z9i4DRgS(Yvos^(i%uU100v<@0hBYp|6Ckv`C$P|O$rEh;6;U}Ljn*L$4^T%1Xt^FU zN;FrPk+pZq7tYN;^wmNnJ+k!*ugNCM>RuADUe=e#d^&F&o}e&^fIGdsJk>XB`Wr$B zHMac_bd^^F^;gHo_cGH5iWfH+mi1PrM~j}UnxzJTR>g5TtcFdKcl5uMd*E-X2|kWh zIXSWlaO#+))7QXK9pq1sW*C{ybJ!qae1BTTBwBpH)DU=e`@oWWM?Wk?o5-4qhO7Ic zV7Xe{Z&4X(@7F~Cdm)3?S*b)!ud5%70@MoMwD#f3nyb|+yE@vHIaMJDDsWRB=oMlQStJzA~3AV&MxzB};UYh8`o<%5H+|%0RLT9v7C=s&daLY50qN$kv z?IF`_lg4HeqQcYJvn#m=1GE`^_$@DJagrG3wbQraYIGi<5fdZabYx?j1X<}q)>Nk!<>9sk zDpcA+FGPwc&xUdPOJKNH%Mx(YS{zMkOlnMMOwARXvqbwKJBu638w(ky_9gUL1>1@} z2#t3Z_a(HYLFwp6(tu-`0V6yp%=mZkM1)5oVUUn#RrMixFiAY`L_O*59QtKH8=KdK zy)Mmp?j5?E(Cz@QDS(*=(6O$fpJ^U7?U`ILjQ;AYk?^Xmh3nK@TX7S5%wnqytyQS` z-9NvVWZQPY)9W+!yPqHU3*dKwh6(tn3EtSC%G9&XJnM%H^~zIO zpECM^bvI)tLC>#P;qFU02gk!&)xI0G&erONxZy}oxu16h>{p%bhM9pglZpie=|^2> z$hohpb+aW$bUod5K*eieOqa+EIar&_cBm?j`QCh&Y#(cwAZE{j3OT^H#h9ab(WH@B z$b2b_Q)nQK5PwU<3;=gR)Nyn?r`B)%vK18Wmh9~BnyVXSI$Riq)5|G74I{0B1e!8M zRI|d`PqYW_5nF6k5*3=c^Ia(_!s#LMxjB%{muA@rtafPS$N^=)$p1kAt{CrPl+@!W zL&)_3)EMvy`(wPLpwOXp=kc6(&^ubH<#~%z9)yE6ZepC+jNlfsDZ7V%G28&k0TU%?Fr<-*ag-4eXyy?#Jf^|wt~ z#86LVU?qo#xpiiq%z=&&jK1&_x}7m*%QK@-J^32pWH5G3#?$^>@GrY*(%xPUKa!ah z;hWiEwM5mji|pl3^3dnpj?|<=*vgucS0`$o^YM}Xq;=eOBGSqbi1p2^k`o9X;bMB- zB~>0j*nK%1L#~x5g;8GF37no^lq#lqN|R_lEOdTAQA1wT#17PTW8+pDx6xa*Co@AY z65rLFRqs?-xy&L}&vU54AD`#fEk|+c`nSNW)?*AX`s)Xm>dd`V1AQAiR7DX7Y%{CD z=0|7eWSjHtIcp;}x@`Af8?Ii}+i2W(_|taC!odF8XtBY-2$Bf%>7y;B!^A&af-zXn zlGBZtL?t<^Mk~U8ELQ$5?DWKyORstc@?Zt|0oAZQu{^l6^_Y)YH<<|Gd8~sy0&bN1 z%Ye$C4{MXK+%n!(PCjh&D$jI5X8M3hgG-6OzdA`UkaWC}xb);vxnfTXXrfs4w7C5I zMz4pkty#w_dlEfq4T4GiNoRq}PDw*CJ?8xI*JJc$vx|dV8W0&)$Mb^~SFS0EhN*{y z-gQFXWGB|omc)z{Zo20Ukmc2r_TKob2+tU}Flbictj)$WBf&Hd7>Yu;>2SAp+v<2H~WeT)m=j?%2{R@0Y~@HJxGbe@!} z1yL7ojhF_$kZOz%j}-J}jJagl0BkrPol{Vwid2&=8%s}Zr8vw>fmMfYWC>#k5%bN3Qv-Zzsp_0=LT{@ zi(IyXKi9{Uechvtq~f*B1{I?18x?7@;GLw%Izvx4>}c#4BTUs#pZ3?8x=`N@;$pVi zYaD#Ca&BS#AX~&JV~Deoe5QE1)g~?%=}?mmsg9Ta%>kH(aNxY1=Vqa#LZJ%i1;kg5 zN@fSRgI_|~#u|2T#U;626*AYDJS}Kz=bLPeTl0{A+ekaGBUMkt^4B5YRXGKF2<9rc zc&hF|%$yeHzJ$P=k}o5?Qfn*A8}1+Y^1URd6|KAB(T5?CeV1)&79>dO27BTMkv}p) z8jIyvuhr8_x(#AB@N$M#a#4N^$Lhw=?(W|TT<$0%mGXx23O_1zQl3vp_Sgi0|s&#T|(f%~F&BJ@+Qx``Jf!NY)>aE|>)5PVM6W^D!d#v8O0_?}Kb|2O@0{xCJ zTCZ0!d9S51J1(9N?FT=xxLOYVyh_1ie&7ecHsrmmV)#+~j&ei<%O_lLhJpVQmu+(c z!OouYTRCmqB7a4I85TM(4OkfJ`pA5p?ibG7U}Op8lMOeY&Fls7pYud^2H&up?o3hPRDfBG`=8h+|N3torrK?$Y!pn#e4 zm+>?6?XzAtkOrsMT@xg-?H_jaLtzM zrz*2g8LzvBH2gn4jSjd@73FnCi+oio7F2}=$L7;^MjE2Q_Eo~n7qCI-+WEcyqJ%Cqvf22#p5b9lJIY^=A2;9> z`vdxwRfs3Okq~LGEl7Lg`uLSBTFZATg9B7#$%Zd*e$7fkXLaIuzfu&0zumAw3H=gl z(xxlmkFwE#EdmYP3gh}flMfV7PtM40j9+1tDjIE*qLk*qhe+dCE4n}wNonqiACpOw zr27zB)N6$;}?u`GgUFRm`53;;MI(#5*$h# zt}N7X+WW+NYcweSSE3=s@37Sp)8$;wA1c|s*8l6jAClN zF{3{iD-c3n8de9+d>xR+kRp_Gfdt#udM*c+x}{OWGO|rT+Eom};>pbCOPtYy3^oF5 zU&d6?)2+=jSG|1e%RtA-88HDpBJP2GcHXoRAv5XUG{XSYbyynSc$R0rI8Ep#} z+%O862_EIvX~ix)pLNDW&N{=YVltn_&LUWyKdkDFinGkb(cM|5UP|WFSe&H0Rpi8+ z7U)pnXhXxFnN*r^9pWCu;@a268|#Sgmm`= zBKs?L&{ggsiB859(2K#)=2Qe5Fj9P?0HV%l2Il4V*jX9_fx%=G#iv|bc!OsT7w`?~ z7Ps|h6o&C3ZhZbiHekO&5pcWQ$In%XlStv|PkIuiZWxrA9QumZRA^Z>%cv*PmFq{% zI01JBJ>eR`N}snqynr>S#%idTNY#%=$SNx%^@XM-jxe8Qi=b>JV%OZYusgDnMYE!I z*(;ZnphX`~9m1vKtG;M$G7l)3H(|3KZ#2CFpxCfN3v2`w}m!!TjZ=7qQl z`H}Pf_p*V;=1uzNz=Op?I$p`ILJFItXNuI%DfOe}6dSDg_C&V|ePGL9LHQUbiBxm5 znQywrF{!;?qTVA?3vmJGnoE{mr~`E!Gn1Hnj|#glR1qT66+5fP z2OTY3Tr&*ho`+I7H!y&2bA&6*8=GzcDV-UQ-WCagutNuhuh{oBi(Qk2RYo!lWFA8U6&l zj7aNNNI)!Wd(16b5^;s{S)cDPANaiasHrUIF^LH#8Db=xhr>3)Ix|)-(Ti3yA!olT z`fFT#YL`~vjrS3zPGEIDb>Sw68tZew^T=QI!r<;grtvFOSa(7q^=E)g5JTOSLzb9C zqsz0n|FU{`i*F1(MC%ZQTKN;ZFmE-J{(ex@;nR2N-1bj{i!Ay>RwkUn#hbfTyrj*a z1b&5^@*>iH%283;JpN5(&?9h3(@$#D zi{C_q+8RPbB%ST2d@VSW|NLQo30y+iKt!pK6;9!=11?u^%`r<n;kf;HTWQ$gb#FjJgTcu_!qP49tMLvWzjYj6orE-upVP`mefTX&#pvbqFS(2D2udq*2l*XDVm4~yM zoFM2hLYch{vD3;pX-V0|Tx!BgeBd|!iS+vWqm@!7_jFN~r|P)Cg$-wM=M{0}X-ui@ zLojsDIB$3JP8xe_-RbeJ5w?4?lAhkvwRi+Bo?X(wO8N(q+fkftz*{1FFakF$QO4Jr z6tIS>{${mL2sfd2BDRWKfUvCdl-Cvd?TihM++UqDl{D~d6CUXPNh>#I?BtVS1RYOH zwdjs~WnV^w+5}gUq5}xNASGQ01eZ*3D16yBOLS~eW;8A&Hc8u{dQHBPO2R`fxCk2n zHv{=QL0&{l8+zLDx|YH3{f5qOL1ClVW43MzeEkt_ue|nU1a*@Xo<5Q_#hL=7|3^Ux zYXRIz(XE`T&B#QPhxodxjXmolot~a4(uhxMgFA04!zI^^+!^a)i*Ev4=CTEwd|sgikhFTWB>gz9D25@QR1%Qi!a@1MMM51j_9 zkI7gt@)!z+G5hT0`_E1`y!{K*2jE{me5KuUGxDd%$F@x~w6|J3u9}*Pg=yB!@eOwM zNbpk1r;f;oZK#j>z%xZx!DS)7?=pD{Y^4 zO1-R4laND^%I0a}2;CsC{Zy?Lem7g3Ti6ZF#D+65po~(0Dlt1`Sa+k0WgH*U%^E|( zYx#lI#rWodv#AcIRo!rw=14qb`CD}?^^tnWGJTVZvSA6D8-P!J@1||f% z_)C_VgGYO5d1FdH*M)#Q+%IKsl`Kd3v2NFos=}}C22h*9FVC4(S1cEG{EmLN+sBUt zO0TRKvmGLOBS8YMFGG*#J-ZSJ&b4|!KHYEie#Ka=2r5B{B^Y6_*pIe@ID&ip%?^#S z)YJ-jw;Wa!OVGG;F?}3KZ-ad1#(2|aoj!xN=dSOB#^*~ocnsWGk0qKct!1^1C4N~1 z?B@;xuC{sJGcO8aJ6G60s+(P^9K}i7#(8#n!lp4C;ra9hh&n+&s+RKxO%lGRGfnx0 zFsj6yit4E4`L4^E?2?_l>>{~h4q8W1Q2bdWA*wLBp2khTndGQ%#&q8*Jvt5Z+c<^X z?L5VgM3>-*x<-G>yLpzcn;XmG%}pB{Vn8?BE6cBkK_y%5Erh67G zKR17uPPt?48btfLKf}LBE1wLhZI>4U*bvD>gbLKG>L`Wj5Tu$|QQ3y$y0B(K_wgN$UNB$Si&8(~7|4!RwzGQVuSNMK(T>$0T)0m~x^e8J4V z3a|tdV!QPj+!R(f>WzqCdJ@+=^!5q2nlcq$hsZ*#Z{UyA{DSVV=QUDL)n4~pVVjg-LE;}- zt+8|W%dC9kF%QN@o?8w^(D3eNPh5lVQsr2fV0=K}r)$JAceK>U-$0geOCDsjTBEQy z=2{zk9b4d%LjBhfKjmaseIci)s_)1&&7dkpJV;f%)(ZS!FBs2nD1AjPbbl$wEq}uJ z61YNfiR2+(K7^~gh{6)!-DBrW?H6V{kyRS0TaELjcdkq1SjX-2tq^q>y#aV@^^5A0 z;t!b5J}Ujk2YYQn-nSuzvOS5LnKM8gPGM}7QQvNmWw5C=GirGSP^t;Qz4{(~;nNK> zSJS3^#)FrPobpsz1btupe|EvuGpQzEw8@|78s`f zWaMav;W#;{f-Ha6Q-|KTY0sVP zDsaN)nG_s*=&i`lJm?TWODK8Y&S1CVd2?XuFNh3wIjF%xKzVb@+S_1G^h{q-8+))$ z%>oQPc*C)5G=@Y6>YTm`{!=*&rFAR{^py{!w+nt0kGW!uc38V^vrzWi?A^jgImOo% zlvU??(bM>}f*Yt?&BENFp<@d6Ce{`Lk2^c*Z-HBkpEa!&lVQ{Cx3Z)VP6{HJT|(2k zfNN0c6GJ*$D@X|$sFz%uEVEQAuUzbD#|?^#onC6J=~|(C1kXM?9p&|2*K!8nRN-oI z-r_2LiH9Ogc=0o@D5R#;6HH!^`A*2R@{P}toX0xhTw@Y(E5aNaWiC7n-u_d(Rt|Tm z{z%fOa&1(ILOP@~r{l;D*20W}XaS1!CaKUf>SoQcaVM&gh^XXF^)5M!lYtk|q&h(+ zzu2KjLOX(_}x@p@+sOweOW*+QBxD%2xdCV*H-7#JtEmH>cqDZH( zdw!s=x1*|COLxUaKYN#YhnzZ##{USE?biqOFZ$UTyFo(c{J0GC8ypB;jPnE}G#D4S zvjwO#Ap8WE)nNb$=o>5$Zg}&EV`>P04!f_2j(zTujiSNu;X$Pe!BJl%=$0MHi+!8RO3E7hy$F@X@c!^#)77+=!LGfth8YZAv^iH$UgjX8-8 z>DA4g_#E3$0whX^EvpFwJ_<&)o^#9nBZc;cagW|VTAshdU!Od*o4E|IdZe&F2l?(Z zu)dK!TkJEx49{zj@1?%Q&X4gCzpoxgx0(xicC_CfnG$udh~C*^3Qr~;JtkS_Ba8)S2&VTPr`HOhT>hX zo|O<+yh(FQ5EV=~JREc@fBt6k;jtg|n%*uoWmLu6iz z!_`Rl-%--;X<>Lo%tV83_vQ?oW24bH%Y-XWPX-c}btLGaJjE{cN`dHEKyx@oHL4#H z!g+BhL5kz7P*bvhKsBkX5`h__Z_$krb8W6=(k{gV$^U5x(UU+cly8QT)>;#8RwI)q zJEMt89*qxdyETY>2(Jc~$u7!i7Yf`j_ed$7A;PV$4whthhb=wvS*#~_wM{8zO0XnmclH4LLV2N~UilxKT@n+iKJS6@xbGli7qqwasAlJv(9fgk;{ zEnvB(m3yWRZO)oVx@g9mMk7>G@VfeFG-VNC1H|;z=fUOboAu(nCbJkbTXC zLf6CK2(xuTN;Z}!rDEtAeWN-t1RYk6b!FGz+^9XA|DniXQ8Q!CTr{XGZ*&$XD7dG* z@H&`^*|dOd;EV2RaZ_;FN(F277c#E~pLBn-Mel0uP8-NTI}+7z5txSEQ?3AGP25C@ zS$E!%x-|dihLdKd?#^}TD`YI~kD3_w=r{}e(ONfn;Dt~L})nh2Cy2aqB zd~J392&;35Z@3-jE~I@JLVEtYg}|2#{5)Pa{xaWXzPV0xwQyR&AI(vTKQ z8_Eb@inB+^nyy^`aML~7Ii9nKAj3;}@Y--m>K@x6-vC1pO_tBm2_r2>c&|F}tw}zt zM7}HLAtgL7;|NQH8#^D??!+gAB0u)fADC^O-<$ZstFG)PoCjqYWU;tD zS6bqk<2FP)9o?b%HcPA^$oKJM%}Q>Q(!Nf%LG^C|;pj~|`9%>>9tpW{{`Cr+tiw_0 z>C56Ey8_3M2nUrO2Q~*r7b|$+Xyvw`IUV-(5iL1U1{0(QSj%vE+`&>!3M`O>sNWzR zE_I!)hsi*{GNK*!A!SrIlOipP?GVSmPcIqiq8aJfrfS}Ot`DkhX3NXH<(3EL6Pr`lm>0DjFEIf??~8HD_*a$exWh#Q>)x!twS! zEJ*&!uLTRN1h|q`9RC9g_+WWX!TyRY;s#v{1@ab+P{Cpw(-7QwJAqo?RKy3;{02GG zXzc*q9!zsoi_ElU=c6b^re?Tu61sHqUGe4+>k*u_rohmh2A#0HiP`bH{HPOkeH28# zoAPj2cJNlMX~HTT z)JsVq+G7li)=VG^i9WE~r3dRN?3f=u(`It!?vHiV!`dFfTBARbig~%T&IjVuIJ>xM z2lz{S>w~CWhJ6utgR`c(QiPquH0lr*Qn{HV0+EW2vn%8sp~yy-KKuofv-0(e;kj-2 zXDO7p#icDNnU)YuN|&w?OO!5h$(}P}v@ErKoBcPsTpE!RdSuxwnqHKGHkuWGgK=B$i@xIE2M~DMmbAysxSt%MV|n z!fu^n5Q09BoO`$j@cFW&@F%&%h!C62=_v2)N6tz_IzV!9RyxpHo@g*vA$;O?|H*=} z#DPxhU2AY|4T}yx3ma1S{0j8f`UnEBJ`Pma%e<1WO)h}|0mZ}u0et{iA6@hT_D5qQ z<2Uo;@sgqSf*@}HIUl+=!fP0gh+IB5-J!)-_#ubn19iigJgGuMOJv!Wic?>6tCA0n zNiQrrcMwEzOV3Uv=RM2795++4wG1o*uDg}A8%0Y$cRu4tSmHkHcqfA8{g5rvp-zPe zXpNfs6hEkj=y86liaT7pH6@`!7*1lTPWSa-E_-L!X;8KKYHE>D=5pF&L)tW_1Xo~# zGF7}w&Io%$;^cyU&?+Z4myG3jG)UpGK>GHZb;j}i_9SB#c>MQ!5}t%}*SOF3Bc$yy zsfX12w6WT=Nnsgd>Tq6`@HN?uBSEqq5AL-siuBhcO}{U7xuj}m?d6yHDRx(Dq(0dt z=;7vik*{5dyz=?t;v1l9*wE|6gG!eGXH?kauN3N`T5?0wji&b?yItW zZY8rdIgg)S%czgGYx&KAeD4y|sa1pDYk%Bloi=R&OO?ra`uWS-q;Id(^Nu&>?2XbV zV>bLrtUp#>Mt-Xg;-$B;?ZYF1Dt!ZL2y+7sVWJfsRBqzy(oaXG?2P9zf8JE_%BN>1PihJ z3rzW5dG`k>HAQeWRW(Z{&_9v7YH7fEFy&u9S5m_vs2hN*8;B*Np{oPZD2k~hxAbc=$@dH{*7O#)*$0BGXpcDXxKh5>X6fGFWqZ6f1g-f*b- zkwNr(f%JRI;qyCr#<`fPqytjflKr2w^UXTz1w1Qimf3^bSw?(=p z$MZtgi-L&YYpsH>hB0)i!mYK*b4}{%^bM8{S>%YR`QM5}RWD$U$t_=fX6>>#<5bsF zAaWFh?N{Lq_%S!d3~A?cJq(kqN~iI*UF8sFxKj#Urqo?0u!vVL+ck^0ZCxw@Q{Yus zK}1+$NV-1m6x8j-hL~b`s0Hf?tIi=Fh9_3mjqc^YicG(fg6mUiWapYD?oVgW%iHt# zOl`yYjE)AfW-AqZ1pht;dF{wzD2id|wz#~rJoKouT&PCF`NoU&~8D3+FV>o9$+8vr+o& z?#>8SP2V5XG+G#vX0nNd3?+q?=l4T*D5!cP!o5$gR;iGUojB|tbHkT<7yEa0Znhj1 z`1c0G_&g>P39h&L`R?~#zlVD|O(YI;IIU)?&%!PjF6aJE5JBVAF@fC#%T_&XBR?GV zeQbHOTHS!DI)kb5ZUdq11fiv<2K5Km@HYi@Lj-;c6I5$N0HYgV1@uaPs0QrDunA1Y zGyqOP()jih2(~(^(})b>Ej4>gH8Ln|Co@RopJ)UPA|Q0Y9enOlUCBXi4W@GKq4K+Y z-|*m(6IbG}R7M~32t5nMABEEFjDFLsRDvboH&wd`;sJZpJzocuHx1l|yoGv8b>D>t z{HBKj&BTE^10g!0PUi~rTf+1b-|y04zsC(LoiG7HTOG#V{ea(9&9l;828>N{!x^Az zJ#PO;)y$6?k zi%|&7;L|x9X}I#V6L3MqVzeW*EP2T$eZV;9x@6Fxui2v2SrxvCSM{tUX&&Uq#qa(!#d21hACfC zSTE9k$|=okL~Mqen`onbAE^XA56f9Rmh~I+e6TqldVIn`YCU_o_-?0l;49O1TAe#`S=Blj8ZM{ zsP*mcnrHF|Bdtg+GI)cQ^kq84Y2fXy8k%rSLn&1D!PGBES~XueRT@6|3s@0#Qpa!} z@}FoCGC(wJQ9lbYfRCRP%R3(>DN2p32@eD$%DI zjIpIQCNpSlq_z? zm`-SUhlB3#n5#?lHQ{2k<=>S&>D{GW@>R;@UtIm=U94sX6$JN0OVqPd_e3eUU+YHo z-<9(hpdUmTiqT#MDCcVOKb6yr^Y3WD-g-e1pqza0TYOo7(LknXLyh7WY*;1dtkBxT=pQ8CU-)0CZB$zM5) zy6Be3>Bq#8iIfaK8*Qu+!#uPK>y+s?wppK*!go1iydNxJHe9GGS~jQonx-CXw0DB* zO7BvV#F9OeLzG*~mEm94jkOCt#is{|4m1839BQ{zwJl=ZtPG5OD9}1>KFoAfAX&uT z(LYQeOZ;Rh?VAGW#2*XGv>JhW$@+t*CQUW3*a(gIYuv}CAa85_4bKjp-Xa|d4yV?h z#uh1TJ(<-H#n^*>eULlTvrRsQ^Qq^+SVar#o%OL)QL%z~ymfO>(D|sTQKtiZMRwx(>DdIX>m!jW3 z=uoz^Uu<8#qk&CkDQ=HlW*|OL?r&oGSOolaSBSzyr~sN&g9v6we?6&r>X*NIWM$lmKr@J?JY9Yp6bq;PKh41C-!T9I%y{!q$d4+m}cDl z@ORox)!#Muy|EmcxZq~3^4*k@EH!kC*ulQo=I6|*hYoe&KTI~bVn|L`G6ES_Bnu8W z)y8Z&Ru)sZ)~E;g#XQstM^W^tFNwFW82B66U}ht*B&*M-7D)xPzAgDB^7iXa#iX zVc(a)nrffB8o8B@RwY+I6k+!ND7qbqA8W#5kY_+ACf_=c1GIwHj3UUv6}i%5z6xlM z=$*v$@tnoA>t4WcSjLh|zUVjiqBwr~-bPlsEn3sLM}xYn^`h?1WJOxLnF`x3wO!ih z5Bkg5wjXu<6qjLNRF|9emv3%NIQ%MC5`Da@7M`lSYPAu{{eHc)3ogr`{!wbOkS9&l zLFRMaG8g;+5lGWL|Jh~`Vb3WlC{NibU_u{%UQop7KMuZ(8%$IXK!xx~$V32Af+j5| z`Qx>eQFV`liU80w*~b2dH_z3Z=P$?V!X;ExGFbEh`TW1084N`*F#sK)p6CC;)svNT zwNVNalL{02M0`>TeoJ>)2W6QW7w%iu~1maRs!kQA4g0TsVYG#DoiR$9W4p> zb{8(344?LaLu_M91O2rmGlWEZUzkqDLy50)%K z8Wj0&Ms0oKZy8;LPYeHHJ)9EzfWEhaIY2Aumw!x$2ebkR<$tyUCx<_+VBwe55+fqy z*<*J{ke)#*mQO{t@vIlMj7SDMtQ=J>Z9rE|^s(>O@gbNKbVxC3;jlhNP~2A6(|A;f zT~Ay1b|!3Ht~gSd6z>P?Sb_(Sz3vBZ%tdlD37hkA@lLtZ7`# zR46$vhGD3Cd5KBYe8t8=VUbb)HebEn^HpO|8P9mUQL&{mvJZYA~d&#;J>p zr*hu8CqUoFeA9-|_P3gm&)TGTLKo&t+||&$@{9hF-;G;aC|8<{*=TDeisKcn+vykh zgURwlMM&5EnE<>wQv*nMht%HeP@ZO)Q+br7E?o%sfjWoO9=r?MB~u6Uc=L7oFrF>V z=HYdD4u8l`SZjHmL9JIOsBbsi6UDVRK-40oL+aczg3b+C%k-W&s54{g0`54lu9XY= zjsbo8_k)8DZvB(7iwmpAp&>9d#6Be zetl@bwQE)PdVLdosgv&5tv~n~9>^KwX8;S38F;t=JkSVCHIN{XEbtk}yWXq;^o9iY zW_kvoH`Iy$)EgJ4|Ms4lil~203cKrl;c6&#g^FLIv6A8&NawLN`WX8vm2t$Db2}cF zB^Q%yO>EWzlB>YL_+Hvl_rearPk76$$^^uu&}NHtc8Zp^b|kax%Xwu+UWz5_3ctM# zA`<#c^|n(RbP6+FUn-DSU3KrzR!|G?#XIx zME+_t+m|!MPO#ayXe>qeEmfDgP~Qs8k3Ys;a6irJl|A=c^L{>_IC3(&>`sqh=!pPB zK)k=Y;^z}_S>?sWNei_Vvs|x8=#n|_BKvvK{Lf3sT50R=@^+?PosIIfyd5bumeNx( zeliHZlHWSd82MRZa+3!;8*S#6&qM09?s(V_3SUKh$NiY`9(t_LZd}+?=f8i@X_~^r zwI@N4b#WdWYRs6uYe3;#xsmP9Vp6CwKACEx#pCjFb}!K_dTnNwy-{@|pbmR^8CfY9 zdQR{1DY{3vHNPSF_>yt&WhuUE5yTE4I%^aOP4ZN+BdOgjfwN*YJ1y@NwCahY7!bCM zWngSR3vW<3P#g&M4>o7wy*Qn~xBy~vK!kJz5Nhu}5&Q-r{Dwuulrz#F*7VQyuP|?( zt2fVI&if<3PCpWVOW@AN0o3+Hlb&cY4cKLIL+b9y#1G5!|0b zxIZTlcWDmoyWo~Oqv1Kk{Mp~0yr2LO{LAsF7s9C*%1mj1Mo3*ZsmZzvGtnM)g>w>?a9Gnut-x9*#Qc9%|{Ew&PwT`zF^o?wLE@3_a z+LONoP7cu-5W*QyEIKd7`n*j53uh1uX8~j9xsEvJKoIXh0ex&N?_UqX)ZiZv!x)f9 z9Hd8F37d!SKP+lH0QEP`+C`uL-xf7fW26617Pa$2LndhQ<=^fZv6PfDZM#9cS#H_Tqj$kL5c1e@B?5_%K;eF zer=qVeTvx}D2Z(pM3hiw;E|tq*1jI=4XkjmoXljDnJt_8nL6o`?c^O>pn(Y%Ny=(O z?B|hblANxYOICNR2bt>zS!DM(!tQ1EImDL}n%L`7!i}`&kPz)LUD6YefkSO_klIdL zrI9VS0{dnXf5THQ9U|SEtqEXIqje$qG0D`CMLK`TLGkjOIJ;US_sK31U{D*g>D&%G z(LEc1fK)=3_a>3snvI{+y1x&owh|@%a4uU5b z#zuZvPo9wcF-lQ}Zzyyt?nInQ?;lNMB;ZhayjjzDH)8gj6Z|APw*-tfG-cmxX@>rR zR940QFr@%0%@6!*MEfQUr}iIXSVquaRyhm{;hR});=g9K((*|Ih~T%#mU71bn$@gW zGy>27q^7Q+A@s(QQ!9surTLS?SD62J%0D0G|FNrClwCygWe|cZ6N<$q6~<782U3RT zQ@|7o0_Zb76`ZILDuBS1xFt5_?O9JeHsxD&8{qI=E9h;g22&DjsGw;O%!*o!0hY8N zbO^e={8AaXH-pzW8HVlwz!(Og?|YMXx&Zse8^P)51;94@!!~aP$iV(Ju%V=W9qly; zCesKc)5vF4bi@;hTbiX$#`o~h|5l1fo{Jx|$3D5*w_82z4 z0s{e+6aS+LnE%I|_FGQoQVw$QAjPk9ZB+X3eWU{U?UxWhF#j1>DCU*~x4$lt)G>ve$3+iDOW4TT@tPSsZ9?ND;^Xwu4kfX>W!rJi$i7>JWZ!Gym&7Ss z6XB8;1Pgpb4}KqL-J4ITH87)h6MisDW?eX#?5eebeKsR9i|U%{MksZG-3+gx+?hIe z#=HxLG`(%8>n~rF?>0CL>WAhja2NL;aZmmQ$uan0$cHAo$_RLkmg}~N3sggVKGFlJ z*un5Doi;@6Ca#gI7;Cw6-E@Tt3*w_I+-Pj=IJC7I(sPoVE%ijV9NlN}dcRk5O^93X z?h>TevN(oy5*q)tissGg*U1 zy#WHS7aFxdxDk{3vC*zH$x+NP1e^avx6SkZOLqA787wUFeFE@HCieLs61V^FXYldg z&)|0WEk8~Mj!^c9gL=g;5xD33e#uc^bfHRzX5eAvT#>RKskWexOAw>f1|w7g8wM+BeLDn1?`Cx33q z$8WQGJ-wty!&>2Oc+}cIQom`-8d{JsT^tpk9P5sHCzS>~wKUr1V0`S#9ks!3b7v(r_KUtJX#8!aE z1`w(+V1fuhN|a(Kl>Q);{u_*_?U$DJjOp-MmQ{-tWuX*4ArPk%n|z*a5(sqgmP%eT zfk;6B2g>?+qBID?!XLsSNvHrA`wM`SAfk7ESQtQ<0cb1j9GHa>l!dV%7|V8~^8n4PtE(@5d`0Gk9sjhKYPPt}gC9Ezqt)hRD4)TnR_s zs#mMl3i&I-CIhFVay=budm*C^;SSRl?-Bn~Cn^^s*<8Q}9>hnKSZFuG9(dWDVLb6O!fevYB>CQglg{>=g>U*K{GEruClDM0No+y{_=jnl^U+JN2d@ zvnhz_fBsg}y;JmYj8d-_UfPSaP-ehWy5OxzX|imXi3w6@Kb~VMQ^9+ohjMa&xa4+1 zAbrnLD(m-)R<{;xU`Q4l6Wc1c^Q^>cP>+`@%U#Vyy~l1R%lEXV?7XiiF8lq)|i@G^8pr!(w9*(s$B%{oJlv)TE!3d>7eacz>0@CI#k@^m9=ZhY@_j7^?GfGdEQ03*=YPAJcy1fG1mehyzIIOr04xCDos3H=zR4}C8PPI=l0LBupGzv}ii?9|3 zHLZanQ3VPbI%8?v?~tJ+@DJ35uKC>{5NMO!N`}Bef0ClYVya3WiiZ4&%tID?%V9Oo z=?4vIGx8Upka~MT&C%K6E2Heb!)+s`&plhjHD-jMSd$$hW?)zYac)rQOeTaP3q&U5 zaRDDJ!{X9~A(#vCgm(~`i(ao>+pgCgE9n#;``>+|trX zMhrshtBRlhVRm`~D8vY+w)mUb$;b5nC$Y>($Ps4uwgbjszh-p>c=TI@pdi(1_?*EHJ{nR~U=HtPzS zY;E(1Y^g-vulTjbZ>W|U>)Mta$uK1uI3FY`&8Hv!ogX|`PH}cWeX(euO~9u-cZ1v3 z=CInWq;5mW1qGuF3j@W_Rh!h%<9VT#y3!<@?c$rB?bp{X znaNtkQ!^~DSE9(>*cZo?(Tl z20);gA0QAu7y$JEgJO^ShpL0(t^tMpzzucq2gQZQ4TXOTrhxV$Ni^e@_=Kd}YtRKdeqx^V%~Wy@TUHAUO_3 zGpDO#2!MC~`vu}%Z%P4r<9r%CV+!a<$Z-CtH|~EslHaR#fsCjSXI{uF>pFHAamwRm z?pg=GNa^o5(jyI_62U@H+4cRz+AUH~pm|d%p5-&25@M@IGSC-%64)MPKt0F^sbrc_ z&2xpdvJdh{L_rO-8`03pN;9bK4OOxblA~0Fq1viU^Gip^ouM7eIF5YgQgp)Wc3N%h z-HVrtJhGJ?$k%YyVev=Jn4Nvv(PvU6j%x4N}`gHKgg)z{yZKJW5{KFTSD1#U3{{5{nPQ`xHZ#hoIA-gI* zNmXU74+H($Y)=9ZR;AbjdCp)1c@AJ;T&nQ2k$nNCN?Z>b=+U6V`HlvfsPMT4nydi+ z(7MNf_=#|z_rV2SD*b?y`FVWrPh`T#h@voB@)Z8sG!4DD z-k;2(=qQmA2!PLp_7dKz6o5F0N&k;H0G|uL>;eT5 zf!27SPZ|4ffHV=mT^GaZVdo2JOHE^nmXgxQ7})Cn_<9ZW?GDVDxXv%pdp;fLYdt#Q zjic77pY^~eaC3SIWWDLEq6-gt=M;6ey^Kn559RX=bCBO2j$2Maa!>)kQgz}kL39!k zry5t5vnvPT47K#r?gXwC$qjI~*60j1&rhlOSIx*@kZWb)!*zCo<=hNEh`cU8SiQhVmS=-s3=ZZqf`P>+`MKHEi0+|IuGhM?#R;iH6s6g@~m=r29 ztB1kH7pd8wL>BpJ2FIo38a$r|5v?WIx)zk=vPkkNDd!Yh$Uy_)#Mrt*^V2l$)Rvg< zy9lIg<0i#o8zBShg+linZ_oO)8NwR_+OH|`=86gKEv9O)zQ|QY2eG%a(=S{te3&Sn z-GQ_9v|X7HuhI0nGz~`mWo?AiM)AyfS9=Qv*?NkSg|xA^K=9t2AOP}nIacIg&*e5A6t9pGDS0W7H`R8?RM>E1bq`6kgoQ;gB2k~s9AR=O)o zndv#2gAqUZCBnk!1=yn)wT{-k8e%*3WJJi!zvOs+Q>l(|I!mdxyE9MBvS+Dt0KG4g zUKHL5zP0WPh3;auNHiY&2?@kI-fvAk<`l6Ba&&Yyos~dtEoa;_)Rt_%GMYCL)os;Y zjqA=Fa{R!?3ddanG>fL9(J|n_^ok+hvhKE=4QFY8?lgg5+IX_!i#fV+V$=YonzCZ^CyRg}ot=m(^Anhipvn;oHi zXyj+4=YNc5s{maiQpy^;H$avUxc_X6pKShijY{@`i~upZqrCL+*&!GKyBuVKc%}FK z90(rJMi?TGD2u0d=Vzr(}>Qw>dY#{UtEYBe-N0wJYhf2)Wn{3w0*B zn2Crp)UUf^wlfKmWR+|^hsN#o4ryGlszWF1N^V!6wJtB!5)Ci|LkOM@SPxpiVGR)0 z*t@d0iZpc^2e&v&d2n3O4Eww`(|T^5(vJx|Gv#esb`707q-BiJp&VC0(*;L8TVf$& zJzuN6@JEYxTLawVdB1;ygBX52YlNw_&>Y_m1xS$_BlSz?POgun~lh9>0$pc6U zmgN6P3DDRS>;vBnEUgi%>v&B;8i?7RDh8>&&86w2&P-5ZQgI25qxZ)j2Y~Q$Qpwuz z{U?9i7x@HKmc|h_;iD~9VG8%H4@~3ak_GmvF2`D;s?dK~wrVnqA4@mL3wBKcJEH9* z4DNi)EJv&Xd%z~j$cud-I8L#u{<4886Mx$xkm+K3M{hnZ7I<~{8|}ybA}l3ED{eOXIADG zZY5|p45^UccA6@%f_y_vBl@a09uG7;ZKIXwvqdqkDjvRzztfx5ZutGL7i@xU)Deq2 z;IsGjSujaubQ7Owph3xCpbIIf#y5t#MI*brNiCGL*6_<{9b%KvL6=C9!B66cx<4Qm z{Ot5s(zt?xh#CR`6}QaW)VH!bPbXL=1S|C6ZC8RS{elYdOT4-t$7{#Vtgo-}TTUKV z<)UU!=a<)X^jA_{%0E1aLani(gEY+?K`m<>siVlV=>XT$^P@vK^ z{805EPz>->Hm;a1Ky5#Hr7(f#{dUOv0Arfa&aFbB_h#KwfM;a(~#f&=_Xu9H? zq|c`|>#|5Gw1Vc5`KZR7ITkAyyK3+9Tv_+*cxc+UCcHJ>_g~Jeyu>{f2N)Jg|7l;VwJ{Sx{_#2uL2!F1z zgnzEt8^HK$UQjO}Yrr`uchG<-C5p2Egmc6(={EmQ;pSxc#=Ji-kp)6Og`XDPy}m05 z`P=A-Xsm?}@R3uh|9=z&@R74>wITR6SnYD>Ow}e#kbO~Yw>I{iLc=(&>~5iTjADy3 z={8w7*>q1*uI79MqR z!HEgKQ#4(!0x5D>JO8yQCiwL6>M>PUu{?Am{xnvUG2--H;tGR?+*;Y6wz ztOMEjkEWMT^G_A55|iKgjO1*SQ-4`zFCTqp@LHQfQ!H+nRJjoLit63`1yBHwy#W#l ze4dM+@vGbyH6*z@W1y??kTE)(e--8>!*8WvRv5d84!*)li@y+69{K!-wo6THAQciH zou8R#WdCr2L#nX0XY*r6i}L5C){RKrkESI8UvOHm4pKbSCi0SjJ#Nq7R&{(}??UZI zI{>rQDmtQN3}VNQK5F}cozUO zmv!VZLb%;run0aMHr`?&9HGqVcsm(jiLxrrK0X}-x7}aZ8SjPKb+mNh0Q~ZQO3#sN zs=GJi!2s+73N=cyWtI$c>6;Xh47<{kj3vaI^djO5b&)&`x!U^bA_(acGj0!zH~t9Z z0|HQMtOw6V4cj&B%5?rtPyz)9Kr$C#fU3go-#tL@KgaO{kmh91c<*Y}__lsepD}mi z&1}U61O)R}t!xdA|MWU@U6mPvnBZ%C(5Gh%Rj{U*j-IaO@yQ9~4aevuYQAgx-zf9U8m%!_1s#YNY@!1*CLrToakP?t5@lJ|{ruehA6L?^X@+Qc{%6|^Y1J7o#mok?p@Yr$*HMX zpW6B3qx6neyQ`u>X)Ow`&r`0lMf_5=V=BD+)cIx4h*!)qmA}}mT?4LMqU9+dTtEj=ZC@B&4;cAq2M8Ur?-7RYUU?Kl;p#1-1gK%7vl-fHYY3hqV{ zjfq%???C*YKma_)hXMa6Lo9&lkRBV!!oQC&Iy?Zv;=@#@Ffbe>94+cNW-(E*|M*yRhNhMr1&3Ui*Wb z=r&o*{&lc+o-l?RnladL@#>f-?j)PH>;8M(-uei^Grw8*S+R}6^J*=z-vd)b! z%%ces1b|pH4sZ1<^gS1A8{^ zb>+}KqVC=2=~rDe@NO{=&1yD=?_~BsV4uwx0KgpZeqjiN41#Q?3VFi%!O84RAu6Wj?1Kn#0jtgJ=}m{UFLwOofku>>8E%XI8|Z4*-1x(ZBLVpcsY zCKyCb+&9}`UP(#~Xi(mfdtA1Ym2y9pnLU>1MHQ~q(*Djq*j*)Y7n9TcK5U`S2dVR| z$)!{;^0mk2RfAR_DSt&$z6&J|mQlhBH(ZF&jFM0h$VYfcQSghPH^68ajwu2R43Y)f znHt|IVSr2-dT>?4x!UM4UteT#NgFAu!3qu`R{3QPEvY$B`Q!KyTD?%7%8N2bCpf3` zH7b3U6pi`hgWW#ldrh?fI?;)-dL@29P5Ghzx28-DKQX^`qRW$A0J{Yy*dMz^Qx4&9 zpjNx)x~d$Cn2a(`(4i4Wmu@$GL#+O|@f75lKz!W%p!Z;|%;6e*?bCXxY-DYvqZ;=P z;?88LRwMcu->Np%1hzGGn0t}Jj#U?y@!i}tv?;4Nkugzhae>0>A;GtzV=Hs}Y$M7F z>@K7>LQY!_%@&;%W;tv5?6@>@99Gjq1M01vz-STbhFXPzonE5V5RdrBm71?7tq-O3 zEL(@RJ6@H%ulGD3@J&D|6uB9-;N?oW>2!YFbbO^>totdZrG2xibx`-1K_s1E((QeE zeC-E?2Tdj|9Gbw$jVd1|yxZ9q1s^h%7spkd#suJmB8!nyu0{(w{1g$Hoafg?dqi6; zi4+^@`8ME*00=my%*niC5hr$NX4i86DosKXe#*2{(XSlkM~;U0O(^}JjAIv zpq3-B{#PxVFV6}o1TkXzuk%2^uD5ywCV`9`vqMtUjo38DbJj7clS^6RXiewZ_Xa^m zoBznc#uap%OXjq4H_n|vy}-U z4HZz*?vs}YG8q>aCw_S~e|rR}T`XaDRezw#hL}|%#WpZJ$EbnMqj+r~*r+&!?*`#S z&g}!*Tg#pNSp7|Ul_%C#wj{>Wz!P};rsj-KMc;39p&MGo8Q+CCF3_hE?3fbU__9Oz z6Q2&&mF(d{Ojg8K4^2UIGU)U6U(cuOUm>&3qjll5W<(K}o)^8fb4OlIO6DHVLC;{3 zj{<|gU?^UJT$NCg?17`U6MkQ#AjJ6j#ykq7?56#cP0wa=srLC!y+C>T8f)~<+i_%e z#!)Wz-U@B1x)dhKud|8NO+0~;>?{|-p!e^~KgG}Pql2-%q{J;xYIf)RkT(1Uwkcw zq?=LzQZXyCie`I^Nil6_5lAUS4Aj$qfRt8IVMa6}>~Xx<@p|^Bu>Dbf`E5~LshaPX z({1kXZH&Dewx>RAAaP~_b*93ya)}>LZT5<)>GQgmOPetD!tZ(%7~=fQ`<~&?nG=^IGq^Od{%>0Yu(7RDRuWRucZR8nAw72a>nuW8azS zab{;~gT3cIte$+E$eGg)UQjB@DRVA^`nXA>hDgB7(89;=)CLCr;!lq;Ys1~Q2=C&O z1c)nJR+)$sAg&th|BB1Z$kyJ(@^Aa;dNa&H{4vadvYIVhOkSz01)$fk=0Q&@Zo(9yn*oYgqb`xHrFuO8;B6%}g1O;bCQsFtXyq}Lsrs=#H~3^yuM zK@_R+O$xacwODLKF?sqh0he)K;Pv62*gbPBGJ}sL^K%sBw4k?t5o2;q7hmb;fw>(U zW`s`BL>?E5AyCcD4E-z~p`bzv$+t32R2-(Vo5q!6OXn;75|I&+#K)~d30)ahYn}H4 zdVOjMYr`bal|e@f3=t6?v@4!ai5K&8zXK(1SYVxjb*RWXCu$W~?H5J$sC7lo552BL zl=|)dccoYSP@q3+a(GBuh6}FJN_bTl*@X=;grcPC9%-d7^IQG`N z=4pC-sarJ~IO*_mLRj`So#(q*HftCQJNB&eJXqcz+#lTbyq~^aeje4WAUJIiXom$_ z>+qfTGhF6t*#h?NOz6nYIU=}gKJc@3^HH;Jl5uxCyg3}jTXBJc&mVM<{H(#U-R;`` zX|BKZqkW9^E`hkwP$5-eLZOIspoNjAkj~4T&C;`5#L3Zdr%S|mf;D=%3WUF6>U?S_ zR-c(HXlCMQHqor<*(7spo{_~jDzMMUSQ#06QA#Wy)sRQ+$#f#NRIiL1zD z@zE^*GMKOvl7q-yu+fHdGhq3J%MOC8)H_{TF3MAFV`WvISN2(>hFM#TH=kVPc*qHh zozchCFZQ(@FQgD!i~LIhRn5uLmCtf$zqLY(2#yBD=4a#YtU9$7UwN6#ixN zn%;JMrs^y<+-W&DzjWwU{95?+z-o*F4aAbH3i|s>p%UvRtDzgoKi_=F(e_Sr1uH6+ zRKmC1K@v^hGMr---`-qO3H;t3Z=55JbC2<^gO>G$3ce_XY<7Y9#-M4w{;p{8@!C zFK3S`@z%=8Uc>miyF@;^`nc?(+vLV2Q;GsZD}oJkYcT6s&ysGenm2t-DWu3*UjNP2 zevpS{iC=EznWCSX8FqH|NRausePP_JSJAUOb2DV*+N8Nm-*kWfvg7uBC3q@vD)DP( zuV;g%u0Zfd4tIi&ezqWem_3=RjW~Ad?g3$#kip%j@(PW9>#5s2!^b_vE7v{G#92Ob zdQayUrp;~I-*R@Q(|z#!+%%12t)j%o-7!_|Snko2Kz{mGX!vq-7LmUQxolgDy>S1||WMR@*9w&ME_87T>8b z6=h8cU$S+c!#tVLSJdDHirJCk01K@`k^3fP1CTM*I)i!`YBtSK=Ca^t%A$7UI~BlU zh0jOKgNj;3KT|sNjpc$h(4Zh~laV>J5`J2ZJ|u5`nUdyXD%*Y`$c&2k!L*H($c=Kp zkVbr(Zt`>MJA<&IF|s2$cjvSt*L^ARul}JymKK#9HF@cYtTeME6xS_M5(+%7Z4&vx zEYV#qA-58zr3fPqdFAPTS!N0{=OK;ki{>0+4|I1G=h_ECYy`*E{?5nelfpjELQwg+ zcon;Buw^NVEagMdt!tCZh_E?sAzZEiF6d?ye20AB?B=w@q;z>3dFjh6#SyA8hlDvt zJ~3x%hdJnco`6{uyDaiY`Uh`i{uTF0$5lgSifnBK{(j9JF0yiYEQ3%KpCgC30+BqS z_&bBX9>s_cpT~J)gru(eR9b&^hJATpC>>e-s91gpBi#i9GdvL}T~h+wdjhs2Y9p_1 zUiQIp3oM7*3E4d`KCvb75$3@k*?j}>&^0PA@)S-btix0ijh;rFCt&08Di^dX?i)T$ z?ty&~GL95>2pK~sN#gQH^5a+8=&lq#OZ#KKzFDwY1!S|qVAH%;cV9yir?0B8f$}oA z$XT#_z)`-MCS{OmPcfOX zf^OR*RSP^?-Wb{@Gj1O$lFobpDV2wbEG|-R&nGK2xhdHjuWAh>4uYRY)#L*t zAui`Vi;-Vv?W@j?d+$BE*DtP31$v-sxaLtCcU5kKCI%xowUB2}rFN`t;{p48q;BWi zhzO+`vGH9dX|DIcCp|6Q7}!UJv>1kRjP$HJs1m#!50i~Iixg-5MNh;M^`_H5dO5}X z8kYL?OMWyOGH)`V)^x6zx~9Yh)&R&}JUc zdAB5^7n4WV;7-$DU5>$bOfPW@&yX0{84Po8nb$*3dRJmkXtwmu1@x-ueLe46s%G8*LIbFAcr44^UmKa!ZpGE-~|SHT@M)x_3M>wy^{_z`34Ah#Xs!{u+SNF_%~J? z@zgmm!ooE)+6P)LjTi~}(!owuIKtt0lyc5AP-`wv;gBT(4N5MLkaJo_s$VpA{2B>< zo&Q{TpabZo=MK6Qf&jg=H^tjb>3c8zXQuSOUG<{)TUQPI8pcNs$#VIdx1&tF!*xuaEan+&-GL zQ%$`OBQ}mrT1%s|_s4*qxu}X@Rc^{GLIluO6wv!_2U&JFVSSb1K~tK8Dq- zdq)%Lk5&2=laa2=!`CI!5v(Qsf?so{l_&O?bj8Zk9O>iz!oj0*okCO7{_yjMsrf@_O)`{gRSV7KU}iRvF8Rg^W%L+Yy2wn# zfLZO2O%(|+;yWp7UuHm?rk7^2)mhoT;;K8!f%_28JVv`(B+sxMz-b{fv(fBHuToo& z(SE%X%}_AeH)xvKs^(P2EqHKH`~bIG39vLks^fm$4CF?4{T|!9gLSRW6*?D&%)K1V zCPa5^iFU&j50a+_skJbR3}1n*#XgSRsDAT%2v@67LZ-O9mnpn(vmR3fR+nbVx8n7n ztAUl^H*#89MEnKZ9 z*$QrH8uKOE3zGUR3s2bGGSkg^)-ZLxZ^;w_5tMnRj}3^t5h61Ea>NPNrg(X-yor>X zo{?XzsbUZ5qE^aHgHv=AB4MdSWB>~)FEX%(6GUA`p`M}6U2S?{bSJ@u&)s1nyTk;YW%R8hq zASFbdlID|rd~nLiM1Gld1iwmTPDyX2sTzVck-U5)$yaNk2&v%l?f~?whUQ@O5OlbD z)_TH~FrBXs7V}eDehRj*h)mitlyk~~pRss(4wPoJc*UOXwHlki1|d|z%Zk!xL7j$= z>PK4H8&6!dltVk%5=A

Q15h1|!i^jEkSwo*wgGeYGDbHKjo{%{nRL1E z?ox75J z_04DcCtwS9K#X?e%%IwR_Tq%UF4a~r&fFQHaX1!xtPQb-_Z^Ouq*p0XujTlLN~pPaH$ zO;{gTg(}=?4d$>R6M0Ut{|Im^-#3|w`-uW+MV=Sx!)Bro4gG7)N=*3IgVlLU$OH

BgrX9T6yLImUv0DQhM45QM6jvT;Nou;6x3}Nz&$=fH zZya!HdP=J2@!8;A$JgFqI4etloU2uA@+&uVI!@PO89;EHT#Wt}=FDFSG@#k^gdLx+ zjyj;*Of%RHLWy8CWM4EBnXASE&pa{j*<;5WRR47-246Q{Q(bhxt0C=^A?G-5JK6~z z2nT61XH3I2_o+v`b$;l)dRwk3+IW}^6R5ui7~J_j_xK;SP&+`6-7S>+>;wWZcDVi5 z_GJHGX?9jlL|%VTP2e9SeA$TM{M+KR`ON;``k4EuL|42n_#rDX3Jy`L4al(b}w{a+*1# zgugR(k;ErU24jTN_A7ee*VPTLjgxt4%m1yafR6)ojA2!wV^c@R9>uos>~f-by7>=*!g|i zGDfT$Gmxt!T8PtsD@vL`*@4il*wR0>ae9+$lyrld*fGlLh}K{8%LT*MOo3^C-^IMI zVA`xDlD)1Z?aHNvd9&ktG=uY^itGdTa{BU8OXTRt@Sp1+{vka#3!d|%U&NGxg(wMj zRpt4Uaq6-q%HXmD?*>vVH*epkpCtI#pTI~7fy_3BS5weYM2Y9f>ivqA^;#-VcqR8>#)1(O~Qh(0Z2__=2QEO_#^te1ES>2GXuE9 zDCq;Llq^Ez%<*N4J5cEZqQ%1LRLt=avLVa@gnuHPqhw8pRpLid=cg`d5Cfn@@xlfu zw=kjQEUXF#^ariK0`8tID#7;+?zS1>whIC?#Z<-@#} z)Wcj@@l;cO7_3FiiM|6SCku~Me21747)8{2*j5o1gw)+2d93f2Pwgg{z{}Yt0?Jra z52=gtNP8ztB-l)UzeL*}*jYDFbXb3X*ukUx=4Pxw9IPtOAb-)|tnO@l#3LIQmzN4E z`0X9{^%E;>8!E$RJf23WQOtO}L^i3GOoQ6ZA{Xr(v#=*1y(B5bw|f-l04IXKfxvFt_tNnl7LM`M@!XK z5AbZsTM)?TQsf8?lN_}KgA?je#j!M?5fe>G zk^ExIJQ*+73-lC+^yPOx*Ih)ffy6GCXL1^u;sPhK{xV>3tNkJ4u?QYbQ;zUKC<)kt z5C!6olUqhi2-KgW)BcEVe6r-(=$=|_0d*>UVELaaKq}~95Gl=}53ARhY-A~2%7kFA z$x4tZF;cxujLQSm=eO29lgYWW0YBM7?t=zgx6sPi4ob42HMpRs}pc$_MUJ>4@{+sdmhm=LW;&ytrvM)rtu-xS1ORgbycoJU?3h68= z7Ge6sExdYpG$0K>6+)ASCzqpi9;BxILUwAN>Bfy&NJ)mCRMg6#4=B%JIo609`LY~O zC|?IrbrY-WgVKaZ8qL#{3-bH zJq7e7T$ZM($`hq|OzB|}Ijf>Nv;banrCG3ng+Q!v4RS}Xo-gaS&Yyb>eKD_OR_R)9 zK9*?ui##V#2?o17=2He2Ymg$_a(}WA&#i?@-K1AIN38bJOQkTp8nvg z4^X-HPb@YM$LOa+L0DP(mATMYwC$hH{1n_UQ*;Rg%yof(3}t}W5BYSZnqFoITHj|! zNah}m*Xj!t@Te{{1J*FL>6~o5m?5L=l`xSQVf13%AQa%46gBkb4Jr;u6jAX0VC~4l z8=VKgWAH-ii^w6tM1b?|u>ahwYs2yBW=9Sr+BcH59>*IeoBpG4k>@LfZ5jL7A?Iwo z{ts`$@#}AC-Koh4a~xFozUG^P%wD?KN~yw|K1*;Ko844Mb~{LU+_;Sv)n6~e@e|? z)R}k49?fI#Fxo?0u zhdk~83#N8+8EWM29=mSj4pce=y&21r9KO;C-A8WGzL{mon$lea10}|*FTv+fB+{Io zwdoYuLN8yp@V772Y<#F>r6_)1@)yG_a^i;@*AT%#s$)bbd!DvRBlMQzk#p2wudB&~ zFjrFp_8nu86ZvO7?OVU^aL1ma1s zMDguF6d9HHHSLLGd_&T9in_h-@3;S*_`|pVhfIAA3zobMP0;t!f$_`ffTR{@Ml%Wt z`^wm{*KcO3oh(hbdx0}dIuW30p0428cHwEL;^JQpx=)EJ>?v(L;qZ+5prIZ;p;{GH z2QrgL5Svy~y4W%J+YZb^wSMkfAgH50ut*6rYBfOrboq^{6|?{!Gi}18g-_;^m=miq zV`KE&q5+CjvkU!~l25QPpY=LsAJtAto1pp1f{{0+21vtx8BjTa#h0B-erBSJ2?TAb zJ8Ti5)Y$G>5UO8FJJS4(!;Uz|w6W_r)S#oq5^JVkr3vlRW(VX$;V6tKEbP9bck|Nr zT%myDWu_zUq00GOZ6RxJU|9l@AREYiK#CG^UQ=y)QgeBoqA2`n6d0bAY0LNI^I9`h z1k3>U$+A-hR1f=X(tkDPKc3e}2v)d2&iH%$+aMWmJ?b;%fK-?^)wLp!LC3PrKO8@` z0KZ!8elQ>)Mks&o3cqH&1!2i9%`f0ue<<|rVn?S4%J!G4SpgS^Zvpsw|Do--i!p-t z%~2Wz5N2oqVG+F2y~r?P-5KBKL|@K0P_9430KX*&f8?~r3%LKG&d4|RFzz0#Ga;lC zfDAU?xXh3b-M9k*Zq<$O>nj5talsfcNg}DZXsXK5MGg=a9r1T_dx>?q5g*! z30(x?0B`wU!i3BNhX&Nif5{Lxm45$-sQUDu zrI@pF*8iC)^Gh>^rELA0@lzWIgOXJ7Vgf8fd2)s|u%&jPP~b=AMp20W?1xRuE_ZW( zNIl2oCOntZRb5y}TLb+R2l@j+|4B8Kr0ZQH(M+qP}vj%^!vY}>YN+s4lO zb~oPlucJG+(6IV>81&k%EtDCN}$ZD}^Q_0vnKE8UC|dwn(u=;LMqfYyALbfy!C~__aB|!O+%Ow~^Ul zE$GFXXIN%~5|?slkti3Sasj>B+JlT9u^eIc@E7}lHDqmcyIGkQ(Ydh+yOlQ=W3gbh zChMPN7lhf{VXz^w{y1msd+5TTVD$+y^d6At!WB2y_^S$B6;3PT5xd})KhNl-(D~2N zO^A8*VEF4hbL@aVLb zw%obQ4P#Zi2)VBZ3>#cQ?Ysvv8W81AKJZZb zfq&z388=ob{t(<>r5VD9Y4$eeeROdm2pMHeTd{|ie3zBo8mTnd8ZL5*2&P^FAOXLP z#7Q-;^b*LgdIKK+(Nh6{+?k&*vDaTWc7coQGCSora*K{B{hvUBF84?vkVZ;a^~3L< zUAnvPeVE_2+5tb`dPQBp3TZn(1C4IGJvp|Ya8c-f{1>mdZ#U%q-NZ`8-#ZTmKSV!Y z{xfbQVVB(ZU6X$NK6kk3)IYvx2i*5N@V~4X8g&=G-b>8q%b)J;_#Ne)*iTQf?+-?~ zn^D@Qmp{4N@jt#o)7*|q4_}>GZihYiH1{!^a~}Nh`#MxVzMeze^(r^GZ@R}lxq-Ja zl??9u$a}xTXO8Z~7Z2ZPjqk+&bW^_LhFiaP6F-0P{`kCHawiOa{?8jXx!z)yTHSU( zp7akpE$>~#@Ri%~Hzwa7WDRb{ZBsw%j?ZvEFFrCi_Us)mU(7eLpEq7M+wrY%H={31 zKR#9?+>R@EKDa+#=|A1aKe&)b_c7kTUrKf9A%5E0PJQl9eYK19-*HIE-FCP+`r6Q( zbIba7@-aT=w%Jpa*`LjQR%br(|v@0-i&{X11K2i%Ta`?zmC8Dl+}9XosZbvMH| zze8XW?>PL0yeS!TTkU~q*)gb2|H1J73I6)fzr_X1{elBd0)x9l6NIy$1Ngce^ML;P z0g#sh20;M;0Du4(@=O=Zir_^Ng9QMfWC8$y`Mqmk;-qJ2;ABE)Z{Sp^Y7>jZi12N@ z@0W&wyt8V8-pbt;iO;c%(xn9A9h*_lJ+Vx^(R39!xasG%zE2o94A1t`Z<~9PZdQ^= zsnQ4Q{C+U=Px@eN3Y*<-v+JiPMI}hrZxa_bB(X2@M1SR1?8ab{L7r!9;vTS0DE5_F z16KGg^7CfgDJmNR-lqWT=`hP({<1DeA9LQ-D%kV*Y`t35caeYayd(Qwc#`dO>OzJ) z0~^?Dqw`3w8@1h6;c()B-`wIEba&hN07s|$*xa0z-tb-e(i8gI{oy4{Cyi_&et*{|*u5N3jS-q<4^JG%UCGLKI^u)4&;q_}e4~ zG!Kw0Pibo3wL|B|U_Pv1G=peurIaNVR3H}9xg3P0P5JvFSlVM4*%ac>X)k^1(ldD| z+_y)(DhgXh3@U!e+yFyCD5-4%x00hRd~=0r@!jpR-YzKJUZ!&HKOwSIJm1~Dzcx3$ zBO!{Cy|rZmIzc05E7`zKZM`T_AR+Hg5#jfip)o6AFQqoE(tlJ@!>dxB8;Rw(*To8b zD`t!v>df6Q|GcnqK^&N`+!mq3<+xc@2f_1pU)_lrY_9g@sx~lxUt!#0v-dLZ4h2Hy z^pjQ#=rc06EtrdL@AyVfzY_8BG`nmiHDP{~I+*)uZbZei*cC}qX5@MH1~SjKm0oBs z>1)eeZMy_?Y7XGf_whBEwa%NDBZ2&a@T;8pPv|3O2Eq~S3q@2-}jUU9YpJ;~>bcve$<**W~! z@Y^rE4Od2urIfB|a`H)~y_J%S4BiVCOZx6~k?BUw1-Qr69T}0|7&1OlrW1}?4Or3r4p_8^~CE+kiubxjV6YXF=2(AE1U2XH(cOKO6004GUY=eLtE>(_7cP zr{j*ruQcoe%+*W>l=U_HvHZf)kT8=|Xuk#R<@|9{so_z|}X4 z+ApKy0Mx3B)5Stnf>gT?iuV183U&RJLWj?f5Vj+v z#)_O{NmFZ+aJ)mTIL47$FwG8 z2J01z7uAVzbx8^&ZB~V+PfC%dL2Bz!E+!;b!uEoL1tr&8&4MXcMDHw25VTiJpcE=C z^D55JrK3#JHbYQ^=&HJfq;8qNR*w)u83@CQg7$}Ga~NtG^DVKo*vD1!t9aIV;Y+<`c^ zSb-GNm7lw)(P>Ob6&*X5DaV+T7YVv5!pe1opn6oZBu``O5rsyUQy4T=sRY$u>5NX6sN(U6aQS}?-J)eYlXP=Uu~@XlkTuW9sib_P2Tl=x+*vXc zDn#2wOq!Gx^vm`M>#u#AbIr?xl-?)57!%9bt+v)*|KkU!!`ZgbGuno|U}1A;OIs{y zXLF{3;-7la*|tf(((ac!ihj8vt}0TFKll>pzH#f;Uh#A4*ed&;IQ2c)r2+nKOq|mi z2)dl}{REBcfNc542=V~GGfl5zK>%T>XB-G90WH>>~Oelj%8jG#A6|EO}QhTVDgt*@fz&l(`U%kr3ozy}o zPOeCGo`=w!&Qdu%93XF+5rvNhTzXO7z#BN?Uqv_z`Kp9S99I-sbueemEeswZmY@ur zQ$Sr2;A$W%+I$KJ;+Z%z#@ci*9s>)fZU6y*-T)EiA=n)e&5^Js;|Z&#Z~!?7J(nXO zl?Je9s2T8M{Q=kkgoVI?@Ody5(Wrn)xRwD=o4d>q0&@O%@gjtZEJRTi0!xG9l)Snl zgun(6aS^QYtww0Rqa8&E3oWWh)S}j;Sj6TgA`n6mhQTp#5-C8=0JCFKvG@G%&%(0> zR7p0k`Dg)=cMpdNI^0WR4jeHGkZV%9_W-CUZHu`c&NAAKf&m;ssnv;PI=3$`8TJoj zpw@KNGAe5esrX8os);pje+kb5gFctMcOHo2RD(hY0mcbc*#{qb0J504h)8oV=pvwb+6F^v z&6rKvfH^E6rtUnDKzLnV0H-)`sgb%wfZ~YvD>kJHGEMFXF>wM}2K2J|Ez2Y=NKUJ` zHk?H`xzuvYH2dn~r^oH%SY)c>RdLDysNZEj{7p>eJ-en2(o2bYMJi)ngUBV7%LO_P#uPkvVJ}oODMrS9<}ddX&&vA40O(#J06%3 z+nt{yuFr!v)Z<~VtjvdTvku}bDZ}iUULbzokH@u%nu7sXLmkg-6Cv7r)2}i!toDP| zB_EGCQ!bZ0)*W#4_ig9gBG^l{lYiB~Oa7ty}VhTD$R zTbcEflwMnQelZ$-wyFGLTVZVcVqanBK(7%+`%K9?twfNQ?Ig1o2?9Uz^XDf^dF0Ih zs4+a5ykJFUT3oAcS}ZUieyDw|3Cgj^UHllg-35Xm`wm!2s&xo7PfJP&iY$J(U$Tw3 zWiyyE`oXLdmq~WE-n?Jder2$9nhLMTbUk)*7Kn7r1cMYrP~V7 z6CDeEEkM{IR!pr(mX1NXp)bDB`PaqL%TzGBZSCq&Cyr^_7w_*f#|y;Xl;@R-A#Tlw zv|Fl)DhhK06Wg~{$OREU*b_zkM2A^ml_lZ&b5`YHh3Y%*@+!FFr7W%0WNG5 zqrzCLWfzIFWE7t}ri254x=Ox`(RX4_WkB*-(kVHPYQ3rz=NV;Q@~H=SmUh?FnZKsC z^vfuLx|~2uJ9b1VH1{d%u^5~na_={>f8u$#+nA;g(iI%vnSsx2(*cSGov;RpoIN9f z6-H!hZFA_mj~6RRd;IUq^#(weH3jjCeAaWW9~BR}EZT&v_fnrr+X`%ngPm$9+ozV0 zS-=`lQXuJKDDI=NU*fXZ0> zF>#B?p)aS)>NCz6X%T?Bl++ zIKF_%5299*U5%qJtc-GI`lDxRY+^`W7!{SO$1BtumtWa3*~ub%IL#8{TH?^EhqV+` zqEO0vPa(R2RAwo3V3Urs^p|Wyk<(R(B3+Dl8tR58$CagaJ$xxdMvtmq@eeWRmTGsY zj<>}@$og3HobM(EKMnivhrQAKAy}s6L{_KTu_3(^A8(Ratmv&l38oK3BRH=G^m`uf zse;$6iPh{`37gp(+G7zJhFx(}r39&}q)O3#M$$&Q7;0IOOL!EvRMA~_lp(H^vK(E` z&ktL^2j-(zB3@x zK}3Z!{pY+gDdOAFnbvIg%ktc)POC>IV!;FVds3Mh+gc)P)==|3Q8x+v~J(+b=~;hp7FG> zZGu#GW&`ux;s53TUx4c+?}O)q+}R}z0svrw7ytnJ{{b!|L!+Ce&6E!|!4twiTZ?XyW;^{EYYCw26?Jwvd0m{k*LmEJkA8_jdabfqt+;X zu@x||fVb(#s-L#i=;8GbnGzHQ{pv-oR{-`G%zv(Y?*ufmQ&t$Yw`41v>Xz03IS!NK zg`jBFVZhPy3{KHtw$VbW@anX;5w$~wetF=@W7*^kIQ!yRU_qq&$%s=;#FLh=yg}=k z#O!OqmHF$mrD?eJ7Qv2#5^2U=Ci$y4@Nvg1&cK5VcTh;KJ$c9}LMca7`?MpcFa*Mg zyjM+1v#O+qjUwq1U#muT`^h^lv$L6W+?tK^EGw63Z|Ph!o}h{Y?8Lc3LXcDBDdYU( zPekj!KyZ2(CQ3tbWI|T8U}$=E_fa?BpqnX3#9$sEKOW!EK4@UH5g+X%q=lR8qaJhI zFpGnwHyK*5xY7y-q)z+OGJjhRH!jtN6`@&|=`N6z@cp=Ql3k4uPGB0L*|8 z)d;gJ*~FagnqW5P#hXkRhI7;hKHaV#9A|=UbM;QlLP`@SjyYT>;T;7uaGPo{+ zWQQ!A1n;5nKGoiwx<0G?mpK8Lq&RHXex?}~Po>12S=FJjhpfxX0je?n%MCKLL1`KV zpas(hdD4tY`k{taM}jD#g0+1D!YT$)4TR$WvWoyvdSge72m5Z}Cvjm%DJY0Uf`2Xt zbR5$69KwUaStyK!Qj~0`R8XjxMXwXudC)c#9ki>YJNLB|JtlJFmEp{b!NX(jpi(8e z1ekwDJ!)(7%QlUZm%W1rTY~^suVJ7KLWvCe!u<;~RL^dqcGq#pPDDIp%IJJ`fY zx;R+81a?od7LBwV9iVmXl~mJ;(o%20h=j(0(IRIr&GuPGXeCh7SO}MAoSTR%@7{JS zV5bkF{OF{^oGUb1zonwNm;ip;+l^0YDZtaZ5HFPliO=I*Zn)KSdnlX=TI*qVBUlnn z-}YMFgkA=6=_t)28Lr3O_G-?vSbo)RKy@F-oGyCvK!im5LN5s5^s zQbs_pn?htORFH>=0`Hd%b(Gx^!5OP~?CF5A`J@UdAlT3cJ=C`@1Jk@{<$<#Sojkc( zPa{DY&qvlZkSZ-scp~!K^THSZp*n2Ykr{Tfy>s)8Es@`jW;R*t58H=)G<(ol5xBNVJ9)Cq(Z3=C2Lao*lmd7cylyRSSZ6znZbsf#XVC6* z@mJ{vvkvElr^!5b)APrF@Zei@ak3DJF0hEG3)?2Kl0lVM`2hjGG&#K{N_p6iyPk5p zsP{#UbIt@|n#ToS+7*!@HoC{G&l6}ukUQSz`X0qUQ{P-J8o-D|Y=Zq^+I-x{Vf_oo#yRX`E9jKDhZeOA~cS)xG2m6zM@~drV>6LGM@3@_8#6! zVDnPX*10#I`K}*s&JMJoTu5JI%@6o~u-98>emdB$AAYK%KR(%;?i$Sx^514zsx}${ zH|8#UJ`-^v{`pfs+1@H#+`f@({ZiH==uc9L-D4jo&OYG7sZ;3|Nq+VG=>gWZcesmU zlueAT9fP%7ZZ71B%sus2qC_!4ph~cpz;Hf9aA%0a*7+If1%wZXEFZ{v#UJu1U5yy)~pOq~rbZ0k8H-P__AqM(oh{v<> z#de`?qu}8H0O)!DSHfas^Phy}O7ll)V-)qLi}?#**NmwuJ2BV>Nl1DWC916*P$*zR zCsP80u*wEhLy;8oR^j`_cUx=BDi>t>Hb}W+d9EswI5lfr;O4z?g>U(O z1^-s_>MoCLo725%^qS}AyXfI3DuAnFITuZ2P=eI?SPN_K*c#rGO|_iOmpvF&VoCdJ zdn{%^MI-C^^IGON&wYuToedS)aF80UhIZA2AUUa_a4b``sKLH&AHB**OlFXYdUMrV!U7L_WFI8`?zp69m|`MyLyp}hkyC`i)?Oa zWd)+M6W#uiq)N}Oi7Wg7bLNYoCj!EHqqFi#@^y%X;SLHI*usHQcG5J*rq{s8;Q769w@3^e$u-JbRG?k|zS|Kaq zaCB1)e)_6NEMmM0=5<=Wg-%EF=R{c);lR&9DRWGUO21k6wDjo7IGu-96a7u7&Q9V< zejkw6nmSIzPxw=Jpj#fbPvWSO@xE89X@si#CV>*8lBQAVTQC@DARHG@(R~8~M%^sj z-|WSnd^suPm>oxVZ*M#&AJ8&fP$Y!U>98FHGO2K`U1sT;YAIPZPR1w_2G|ki9nNV! zELrlUYz(jv-VakGY9EsgY|-O3&wWmW%@W7g%r`gYo4U-dDWktpk}Kv5wu8WP1k(H@ zFz>H(#5!Kz+R&ULq7b*ZW;S5Qv)nb1=KiBk`p-T~mYE!?!>8z2*zRa7YM zz$d*3^Mpc-n@7G4jGpDp6xG75$RA~qV=xVg9H(5lAgcf54T(Hb(GLgwTVJv_H}p~e z8eCh|HB+;9q8KQO2^+qWHyaWvx+ssW+G<`cP!|f&GR& z^~&Z?ia|(?>jNOD&r$k3nR3-Ju=3Y9ZP2ewPx1!jiiOL-nv|trO`?*^Aed}Ap z>d!(8eqN~5sKnX01cVn(IoUXNXuaEmR^&2ks?00yF|Fg;iyaqNeVDxFgT91Lqq)s& zaIOUymg@zr`?hVDwtj7EO$IDG4OZa;?@S&glD1gA&KsAfr1C(Jqwoc%5Muy=bn3Bf^&M=_1lFW_4*Cr zL>P}S>DF-MYJ}S=efSH3v|bk_?9F$=o2l~%r*ABTgsIth!?b%}ZXqM#fE#TP#pB@O zlPFw?he0{c5ikiBFlu?p4g#H|ImR9CSQVycCCZL8?0TU3MCK6+WemnUpyGH8xdaYL z)OHeE;=u5t=1Y@s|F!UgwPyVQA!ay`jPy_0q|hy*ySV^LLw`Z5;y}uXg~R;(Heh{oV+`9bYjbw;``+xFEYV~Q9$g1*<`=`8 z2F6St*}|BUxpi(p2LdPn8cMEl_?D({g}s@rm|Ak?OZ}%#COUf{ki#_Cg+NFQink~S)hwLbrB(zm7)ymQ!Oxw+1OITbJ zq-dNJTi0+U%%d`)@*}(Z4JQczOw2G?s+>p~9lI+COf@<9;;SZ!MPpPIZ^sy@8foKt zpM!Lag4GlVY;)h7J)6y5V%y!`V`hAIdmWO$!{x^T4PUIWDi#y!hyL)cyD0J|NS+i0XxmRrB@uN8z=mkvN592)}pHj@PazfTxKAtbMj0Ay4I+ zfrrQOb=R_0%2Yh9TQ*fKLsvB2o!RQ5SmV1}3T(ZI{WEh@EVaumBT#We2v-QZK93Qy zt!OdU%Z2Pr&ct=(k+WRZq)T3-Zxhv>&*wm*x0^H1sZfy44aXb8_qxLQQGW$j;24BG zC|i@bQXtyoM0}}gb15d(i>u3Gt@aE}yOU?kkdAtWgS)1f;#q+Vq@@ZZrpEGDcQ{uP z*khSq##xxEFid3(E$<-ZsH(zn?18txS#*xvzLI55#_APx`$7O{f%cg5mjU{*13O(B zc*_j%c#_xUjdKgk+Y5!gW^&hTk09Np6Kq>l;VU_exCrn&_z-#IPu`S7fb?tmJ8y}= z+g+(Pl_~wYOuC|kmF#$%nG#9M9voOQqvyr;xxgg9lCt+u##aONu><^8G4geO@z4c% z>)!fMrZzRr?cuepzU878udqd-u!Idl$?~Uj!TFRZ0_fQu)0?#|kW>8}@A)=oXr=m`u4JgSg^Ag^&2pg$=>P;Mq<`;3XV=7x_8(mv6z@ z>%ufdbJPwTNu-S*kApFLY-|=QS|vP$`?yxZ*=K6mGFA|q{#2M(?-b`SY^3Z9F0FK( ze@#i1FG8;ks;v*oOKaEo;SLa2XM;*LP@aojyFm-RTDXtP4fw@{@otQe5}6EBPirUWk>qv_YUkvU?=aORZa$X;%-3$(c(}@|v4( zps=Co&Fv(;W~Tb>V7iXbu@U>5yte;(y#Sk~&HITf7ZOLkZY}F{vpF&+D>M|Q8oUih zp7`I_`PN1ZWzJY7WJbGY^ZZ1tx2kcQH$uUQEVDTAD};I+l1>f=zXFHF%9J^w!^jM< z;({)swLMRPQJ8yv9#5n8`VN66QTLG#TKp;yU2^m5;kg`P!f%(7D>HT@7HKqKi zyKb9)BS$a7E*??`T%JNIkIt5H?_~aAQVz2Qpish<1g%(!!0|om8>`?)nhWHA~Lt;JHUK?MwE_P_t z@WSo~B0t^^Q#o2r!Grzt_Pf9|kfx3y7j_0bTXVlpsP zv~*ZtUw)u+@P7lupJcF;pK%fua3P}^XJ|%Q@@YFKV5?0^iHD4wmfJLYpMA3nzMgsf z28RXHVTfo|O$jK6yS#_}=g5iD-=<8M;$hlt!TdNyb#c%JPmdP0jBgOuH-tv^!HS^7 zL~vvFfv+BE`MT=_^0@i*mWC?hm%JqOBb6ksrp-Hh{16ER1fEy{*QG^hxR* z%~?=3-35#vOmLzo2~!2yyS7@=5S^HTWrEt@U{ft*fOt-gt_WHL<@>mhbLrI~g|cq5 zB#k0v=3j9_6AWTp_Sp;$>hwH+pbzDZu+x|_#h`KU{r%55ehF{av9IS;SH{X_tY5g! zVjdI-Q5zaubb^WolL8upDPwhIkEC-|+z3P}>ptM8Y#y5iaSyr`){P=rMlk#{k#;-Er@1B6!KW?UuG%iUHNY!H?=Z;E4VlSRCf@qrfqM z;^e9qa^567(qF?ir|$vPxWicSVfS`Pf&5;1l3j9x1{g1 z@TctlkaA)?mKi$Hs!8)Y2dkmxKp>T0GV!V@7(0u8YMfw!ZtTiT!zW)qp#N1C<^K}h4v^@3cHjU2+SvaK zH<}v$4{lU9t65+``HC6zYsHVFnAI`GM8Xvq^1K~K%Ug8N{F4E)aaKt1&3&>CSsc_w z3gjts>2=M~&1aiIK0bf6_x1clX=RJqa@c7WuoKH5)doiMrV3}18olBVFF1B@4!rFymp3q2x>$NI z?J89#rT-A(J3hiM&-8k@^Y4rLjXiD$_r&cUUbT$D!qqT0aCT1$b{Zdv(@Gf{nJ(C{ z292fU{W)y^Y9fF%3OC$O zBXgkA#fnH`TPBwC1LM5i$d8m^ie9veNCV2$nY2FcGvnE~@_cwi!}yqxzZrh|nmZtb zj57}^3iEhoW?)R*FOEzqO{-TXRXq=UaN<+jownZF##2zBAjaBky^D#06+sv|VWdKC z+~5wiW9L1%ZPcNbS{hJ(Nz0?+M=kR*o)F_ZA3+!Xn$81XzGI&^hSD^5{_O&Fu4s}ApBSRYIP3lS zPiLgIEZcj?)u#(cTc`_Ud3Rw#ZiBv)jGi@~CV_b$=T_CPM)>TX8zy?J=329qg zI4DeJ|1=4xY(9(($&@jUVr8HNO&fgn1Vb9Qk_E-=_^z}41*lpS%{1bNLySx6bIziZ zNfw%+?KmU>YG(ZiOMI)*EtVrHjDEpAt+RAYh{VG96BibPlS+l{$c0yiuv; z&C;86$fl-it){W82&IIE-I2;7Ko61LB^(EYV9DzXG^D*1Q(902+1i5|P3i->ChjSn z-b%h6CdENC(1foz=Fsg1bB~apJ%QLLn`*fNt-!lA<+^(W_Qq*X zKD?#RebGe+*q8g}paJIU)qJV*i$v61)zLXrD~&lgL@hFi&=)Jk6YP=F!TX{1IU){H zIX{SY#ivQC+jAl%eBM+3?N}X^TMhzoQw_S?(V3t+!5xF^G9hiyK-DnTS$_b3@^GVY zp?nrwR4dVFbyCmRAH`&s=GE>P>p{Qj}4?#`s&i@ETzNCCY!8I+Vv_-t_uu(2zOGMhPMS>&CU;{ zv z^19B<*Q*)~6#m_(-H6#vgUQ>Z3Q2)-n?3s_R?p5&D_l-9SW!8x=xXhXPBXsx2xqg@ z_}q<*LY=tt4KrgWrnqjX#+l?KU8lO;p}tOYW2<=zg{P`vKz7r0r!;W&5psrah=t%g zXJxsk@gw=Z*>^Az{sI+cfwb*&(!h;&tlHtuz+2?QF7CYNNopZQ8UFA^inZ4-`1hiR zU^aXyDR<_E z2Ux$O>|+hx89(kv^QWPy8|8u4W2X5qdjlNNH*@&_nSZAf{J(K|;5RNamRWazfB^s$ zqyAU%Yh-H3@t?rFq~>M!TY>(;55KWbh%+ZVgYFZB7Pmo`7iJ&V9F}4z4qw2U=UAPV z6#Tf}TpK&3up6F8)*Lzc*t)^vV;31_ef%1myS>(Lal7juf^MQdVTFL@@nhnF7+%=z zkH^PxsfA3nm&7N?>O*ZaqY@3aa(v=uPRx&=CF6; zao)AJe*7d?`qA&<2dd$}(&Alli8i0v@v^@~!IOD^@#dhu4;*t}^n>z(@05urbzI@U zeF+tBDERzbhyJZUyJb#^kCnzd6k|I%Y)(dMj2F(j&lRa?%TH~oPINV6v#ID#V|io| z+%F3pKBLDW=TJW!HQQaQ`wU#iNdzwgbjmYF&e1;#iF5BDGs;Pdwr(^5XMZ?@v25Pp zg)Lb&YKd0-_6)yf(c}h*#r_te6T-Ce2apO6rL3h%xX>P`Beg``$fc;pP(EntvpCY_zcqfjZ@+cw1 zsDp8Tjt|IXm6OosY*F|(I5*}vW0e=#WPlq&q$kCvXMWnK$!+^DIED|+f(gEXQ#qYc zg;~cQRFcFKRT7M2rkLZHF>=qbRJ)pvyLMk)BshdY3)m}DsssfB(mVYh&P#p)40D$) zfo7Z_nLloWbfIQOpe_T13@TL`qk1h%NK$A63Nmp~K-7QCi(sgL@iDXpHI6gN|dy!ogU_ zZ)a;R@&iEsGV&MJd8E*sib-=(Gxo56NE7Ouul%V@Yt)M*{?LyaXGEaxNr^%=SGh#P zUxA6@<0j!)*-pr*qe&XEunxicBu5d=jLzUyia1cUToFtD=@$MgkG&@eC3CHIYw*tK zk3eENh(N_~kS$;Bb0dA5y4XMicG#z8AADbn0PNhvs= z$&*dB5tB5{e+GO&u~js^_RxKBcCuYqxLnF1ib9z)rKn7fsxZPv1@e%;zwLy>I>_BG ze8BjeHSlW>lJ@~7oWx+z`h_Ct%-ST@NqVNBEE`rxW!l@irwfTbTmxtT{3DT)D5d2} zw52dcCz1ge>$<@uwi`^lg04i(@JU0$el?h~97Ykb>$=Z@f^gpMYF(aSq@{ful!)8R z7-P39lE{5Z8XJ;%ybf4e(vl4Fng>n^54&yuCa!5-h^f&@XdKnbj)hB50w>sFeLy8; zh^G&iLkjhyo_o-419RYGru{zt{-pK&Iid21%PmfLJGhPk@+MuX47#kVpgYk7(#+YQ zd0BexUF0=&v5@Hf2s6$`JtEDAbXkx5no){}X#b5Kxy62CurR^>TWRp@&kGv&mAdOy zmzVFsA$@i&zZXb(+V{SJ0C$)`CVQV54E51SyqqM(={DI+^un>g(yYP1`*p&Rb7fPr zfgsHyX&{h)XIE%CSeRFKAfXgu(-fj3UOoBN-*dL|M~0CoLxsV;Y`SFPNBLbY|6n%D zu1}gQrc&=IYCU+?|3rpR>bJMCDIs5ugAMJu4li(RjWm^duhtJCAMBw;+TE?fi;Agu zTl`=Wp(dZZHEh8IT6~0*@kuF>l#4P}>9O+AZ4C)#RgtVGd}2&dXS;6A*IlV# zeojB9rs%Ql31}BgL&_;Zh0wGc9-@=xP$lW}o~a5AcUQFr38%1>ugliX51I33+fg5r zFm;4(UdGf3ITK&lMo7@IB#$X5SmoWt@)yC)ig#T-RztZkZmFXE&1dTX|2H;vgpT+Y zd%0ikoZ{hq(6@(+|(5&l=Surc@_z0#7JjU5&z!nbbOj{%>urREh~-1$4uIXKYcUrB%H zMi~{A_y%r&Y$H1xI|#L-o}DOmXhIpevZRh}%<#)~<{2JeQy#M56ukAWF^QAfEel@n z+uOeFg%7MKu&wPPr$v0Zk3vEK7EUyKn%a_E#X@LRu`d4Yr&!O>u07{|)rC8|yGV%k z=+=*dWgk>G>?h5ZI{dy&2lBv|gWW~$oadO3D?sOs1vbth2b^Pguh7E6*jwBA?=J9_ zONp$nQS>w~*N&Tck*qp{SP%w#pLjX&3-+*#@RVtCCnw#B7G<4iGmHMEYVj4agT#svk{Q#MUElQ|7~+zINKUp2go-7q zIZ(rbq0LGWZ4x4x?n72mh>eNl+XB-RB3Qk#e)=Vw*%`h8ma_&%i0r8)$5@RW5|#CDF80qu}UE#Y!>4(e(JGXIIy9N0Z(Juy>p7af8~ zxhP2KFK9VT63Ra+mS}+V@Zz*WV1wdB;a_6~KHf78j^obV3MW~>Gscx7*EG0O4l`iE zJ}fa-^yA<(cg{wbhrye<$X{ZY@`$K`kZJQjH${?LEJa~FlKMw;fscDzhGf|-_l>s@ z2}vZ&VV1Z7)UrML=W7G>97T$zL$7FSgs^#2wV|R&>!ta^5?@<<1{xf4mY&Pe&zAAY zV%uiW%O$IosnKLALUfRVueGi9A!%>0o$^|M`TRziS|ADSAjsOF8u6anykU>hnaTau z-9@*?gRRM+#$>eae50V$N~KX4dV7b1=_E&+amoZbt8qg$!6c9q%GczxrZ!{4>HQ_@ ztgs_mFdH)#PMTE)l$V(4kYY^#BI7cmVN_;ys#eofIRINC5h-{Mq>~PfBT!6rAnhD1 zrXho=|B+yxCr*?ac9ek>NZa4>#*_f3uCfg^ZrUnp;p|Eg&;yOQ+|2D}}w zW>V)hqqD8awS)@OBXme>@qPOhlsWC>BESEEy#n&8hnuaG70TBwg_Th=(OtU+st`e? zi`cMtPt^VR#jbKUWBGYuRjGJ`#+4k%&LxB5enru$RsNG<{6pGxU8G97@)h}L)ow#N zJoO{@Y%0VVwR--MI4lSG^9B9ie7;Wmn+0QN_!t)i0N?@gf9=qAwx)Czwnj}V8~;(1 z`iSl0gF%LavUbtbZstfL%Y$}kHEZ~j9}de}ieKt;YY`3hI9)aZYR0*%m%uw%&ZIM& z4JQ_Qt(g4!_BsU}>a%nv(a%0VqdIv>GsvXI8^=xNFpi5+QnhNF?-)E;^4yVzVny!~DRQE~9}O9?XE#7`b*ShZJ^6HUWMwH09RBUcvSojvhx?7C2gJ?BxF$thMF z9jpdnT+7=gP0)}A&PthEZ)!%h9%sNR@9df2bPvb}?h5x_|DJ9!Xk@Z7Zz4`5J0~PN zFCkvyka@vj3wBL8s}LemkSEs)vgI=^EZYu(=EUG=CHK3EkMx<{qmvAU@*+TeGNx2w z{8a%ORejHC2i!SP7&WjdyV~I(#l<=;Ku1z6msytWR$H9SBs>TJf zsTQ|DQWN5AO(tz?B0y`On3tT@Ov;ixtJt4FCE%=32V6>zR}Iv)bq1xlSyLC}B7dPC zG05veC`n*@WPFB_15nO-4%39J?0mS%@fmDqY-%_1Jsx7Ok><_aW%3PZ)!Om<*nZp3^_}bXWaGi97b-aH5D) z#>IHh>CK#cy9_tUP2NrlL`UsEh#T3;Ca7*0{@Ib~kG7SB8`jFg$|5YQfh`g$6A}{j zwjd$7l=R>!qHG-E4r3uh?f}&9Kv4?|K2%;)9GW!4F+yW9yO7V&4bhq9t+L19rs&lh zgh09ekaRvYCPOIMA_}xDuJPaJ{zr`YzR)rkW3vO92h)0rWy6l$ty7>J@YT&9#?B3xPP%F3#Ed>Sx94Yj0KaElR!Y*$ zFlm|t$|hTX)6FzS8L^3&?_(5vKo#uZK@GS5VA| zv8gl)n@3Y-6g?a6KyXC<$6DmzkYxk1c&HM?U^$#~nn zjxSQ>=Ry>XawZs(--qSSdvp}a{Dro~bLn8AHOaVeB6${=JM~W*RJq`bR%@iox=YTE zn%6LJ+_yE3)v{EElfX?0qpQ>-26po3PM92e#sWeOzgKF1YQh)F*Z9xlz=oCv4vmSd zmh6$7HHyBI%Yqeu6o1~HLK@`4x%c%1dMK{0x6iJ_d&)8A{~5C9n+uoC`#Wyp`1J8#;Jfda5#Mup2^W3p zc6MN2_s3Qg%Q=xfXpk+>88>A#ZMhf?2xpL7RlciaInY350$gj)5o@9t0p%>pncAt+ z;E1S`Gky7~^a8613kbtmaQt>{cW}8jMzT%HnWtC@*9!vAM(JpIQK0V*oa+xOCk|B= zEU1lf6>aVr_T4;&L=hWC8|RBc3L$yK>l zE&R1)d5y?p|4?QYt)~slY?Lx_Il+B`S_m8LC|*gX6P6O&Ts#83ck9omVAl3{PD74y z!=BlOb?r;-j9>x!*P5VdWolSaFG*DxNKrou>#U@ z$|X&%;a({;sg`(LnJ-lKqJtrMHW$mM45{>;MIofB1AV4r_%1C?q@U28fqlecDQv|y zhjNr}A!3IPn-A+W$vVM&#I@WwT~h3Dt~{@?sA2|bTC3zR$~7)BT`vlSB!&ugQzAA8 zFp^bnRjk~2$;XznC2VO{=@1!ZkL(6et1%P7m44Rnke)>y{kS;oN(j7H&NDk1GBfJM zmP~d6gY3-kNT~-hf7hRxN?^OaJ}!c~TJC5`dIFGwMcE`OAj;`SZVU~JVV+nRXb`?ojBQdAlcMdA5nVT9$1x#<2k_tZ&5I{;@&rPC{vD!5aNnI7u%ZO z7X)6V3SgPgIL!`J>;zB70iDFuI-Mu-#kY2vDMQAb5sq-EhLm#Fe&ngYG3%O1dgl?z z96kq8k(xnWpv561=0|}lbe7(@k`HGT&4@!OOH+lb=MiPR4%ES;Juj2-ih%6U5mV-8 zS;?Rx#%=^^=raK1!;P^MYO4o%n-fJkO;g#A&ADVQus?k-*ZFnCQrTU@6!;EI_Z2O# zid`wys+Vll4qqH8Q}OxscJ!2F1TwAa`_W9=B&4^P$*{s9zR=6Fx6lK6p@DsAk`#QK z1K(t{SlZ$C8V!uMFJrG<`UqJHhjZod1Orae-I0F&=G!An!;?5F=ywrCL&t2`kksc+ zyO%o|Mvtqb+FOMUD{0*97!AMSP)#$#o8qWYpOu>A>++$R<0UShuKJHp1N7K?UpMuO zEw*L0c$~NG&V=)J^5CLV!0rNu8$b1CZTeu0RHc?J{?8}MchBjA|HYT!ML#eYr&s&Q zEg+)70x~8s0>V18Ic+PtUSpNu`5+T9Tf5vsXx6FzwzhDIa3yOn{`Z9f-c)4WJe6+E zm|?TDPh0T?@h7{4XB;kc`^h9U;+Bmfrw)kT;a~iEgFQK~%8_=4yMg1g6?$HbwLYwB zPzaHLDy8iOr{Qv63E4R&`L~gYrgMn8Z2iH?FaKZDZ7f$Z&r_==JJ1Fcog_`w;A{MNYT#jgVnIgeoB+Kr##A@~RN$fr-pNr%B!{(ZpsHIcPRlsiq>rRkepl`;OhuU;#g6i)om zy=`{sfwCo55dR*7J0Y(%JFqH$VpP5=Xbep?tzJ)hJ$CF^iyv5hg0XReT2k#9v-*{o zc`b`A3-$%KdAEg^dAovZaDb2drWF(foT3p6$Se`*;F|JCw1SrT)=NI2SCRdw*~Phl zTOU3iH!G6eltq;jv6I$H2=~J60J!(LYm0Qxh7Yc~9{*|SLi~7Md@m1`4kT8rt*c1x zud{lzZKyq$WgR5(g9JKSD@n(5^uDHwchiPC+wGuJAQ-zrW5=a7Tnu~LL*7vgTG@p( zxYp5x5p4pX&%$r#C=Y~s-+pHG$k!c=U-OfZ!0_4Q=73EUK%6@uY-aY^tpxp&l;4Jo z^{#gZy{}gDog7DZM*3oQqyd-MmMFj7;1S*t!;aj=W%w3*8&P_Y%AU)9vq%_$_U>we!Ft%5^`8 zgXY_F7kk^Sfoov+O&FGX1wLYZY0BjY4DUDk8T0>*Ue=%=o-_VB$p6gTDcb*1%3YlP z*I{j~d?|wQeG~Iz$j?D+q2;wt7C}5;hzp2_U|%%Nw$Vy$iPQwCFn71>yW`tLO9&`9 z%X!Fgl2g!e*lSi^IBe8!<7F{MJ?pIk#HF-j%VJiQ*>&wq^jsF}!Hz%?2nA|cNM(%Yj zW^Y{bs#&yVSM#)qE02?N<$ZAQOXl|Hx&4E8ix;(X^G+9m6&u#$zs&#f@4qxJL#eGvYm?BAg;fJx#<$!ArDiDqL<<3aYaz1XJ7%rEIQ>1asd za}lUb$lY--(vX7LEm|UIE9M`#=>R}*YxHj8@86JvB5dDw>C<4+< zHN;Z&F^KG>mh1s`;s^j$?`ohIKw{>ww1b!zl7D-xmV5gc?(6i4JiIpwS&W8S~SOCnN-3YkJ5 z*eUatuP2tkZzSu1X{zJtJmIxs4oDVKx_cNCGW?|*vK7rzqWqS6`p8%^HWzS5$D*MG z9~>%A(lHg3i|45PITfwntcYm3AY8T!37yuA-BeTcq4*O-20A!# zC??As)Tp$}1dhB(mgkHqp?Id0F3Uk?tvoM;4pgdOd-#PKyl{(5#TklzJ&HCrk+icZ z@v~4#*d8ixCgn*}wmF13AAi*TVpWLDeAW&oNZU@Qsp7TVw=iO*yxDyT~Qnyk=m$ZoAdU5OVx{A6|@PJbyuuN>7rTZ zb*4iw}h-2Wmo8-V5?q%j;m12DbuB%6q9fEIk${H zBo6TlTpuU)*I)EyhjJt)%~MDw|H3b7YrA4$6pl*C3d2r1Y^csysO{|dCkU&ko&Eh> z22BB0gI|Jvh)S37hpHQ=QZW?DN+ABBOFYBFS*1cQbgLT6kOSC8|Ok(JcG8Ow^$ zCy@kS(`H?|=T-6w)jARnA0uG6Xj$}1J|(h&8LT(1bpeG`4eM%J%39T)iz0~p4>&ZNnvsb zWfiI{^*v@7b|GEjOwaa0LCH-qJB!WCat4Hgv<#^6{WMd8GN7XGS4VM1^pEsL6P<+gkuLF%H2s6+}m<8y&P}jyHMe!WsBdyvLS#css?8Vkg`$OgYS@h*_)4 z0L8>+WRy@rf9J-%2z@I-3ZO=L#>3@|3rTAz9Pt1GUk)Cia+yG` z&MECqX9oAFY==-ds!!6XK@^kIMu#-vUuWGp7yt#z-Go(icd_OElK6gG2pR-f2wK$ zd);lKl{*dPCNkGh^}cbJHZ9YHM*$O7A5%DMBrLZ0=lF765YDe}ADO`Y$ZR`$^oP9p z>N`y1gO3%*+K48>N=oiNaIdIXtV3HLRXDf6FD_64H%!8(II#0H~e} z!nPbOWyeV%&p3d$$*%I`AUBXjL+ioq(GKxc|CR_pZf;Hewn!T~psq{qqfE;_KfUb5gI~ZJtq&?;^Kn%MPzH!L|P?*ye_!o=Rt{8s1DsQ+~3}Wyq`tA&z6ni%%^neQK+b-hpcz%#E;Z_Df1Z}33?Ny>9=|$?6dB881eQ!yVtW_oveQ0+{WQ2)UV?@92SnY=N^wXqwb*C>F_2E+nY24 zT639KiHbT*{RWVi?pjk%50xL^p~iQan1>+gm;LF-fsvtWKB=n%}eibCI?LO2E-ht050Mo2kIEG??UXYOd13Rtv29 zvAMo8w4fvU^0!y*CZ*BSxtIR-R^559N94dA$Oicqa`GdU@*Bs5k)#7X=d@Op{oDE3 z+vQKsnZA3Pcdq}0<<4mP3-U|HYj*GHYkqja{H~ZLnMInT8c@y-Za%3ZusbNxXH(hP zJjBtr`2K&E+W&~Lqo$dH5woKwo4@P`M$G@a(V3VU|Iel{qv36T*pB$qC(t)U@@hp!A-l555He&^lN?Ak^B4dbK?5V$%i#N&3W2xvjrJm%+S_F z3E$Pah@m`w5bS&Z?0sfFxC^_A``eVQx938?znuS)dt0l#**pO8yE9s?tY&llDu<}LvEUMXFz$$1tQCw0TE$1{a8?a4 z77HrYh*Ev)eh4H%7$S#~iBxIDkOh7}##32(+Bq0Ixm@RAvG!*%YS|(n+86?K-7$(> zj*$1CK^L|Ma&=+&_lCn_d3XupNUyikwp@!gDChNcMBHtM7MknG8jmWPc)F-tSLUlH z1BGeidzrvRA3v6MzVC0{>K<7yN>ds7-)k9w{qT|x;e|UpZ+qf6xz0dx5l`6`M?UvN z9^J^JLg@&TGqnv@!rV^v^=FfE9m~Q1OCOXO+gaN<>*f$xvZka>O;X9GUx0PDD}aaz zB~qNSRr+$P{CN_u(`LW_fwjS=>~SjL%NgSpM?xI1B_aP!K=;}gPzMHY-P}Q1vU}<> z%$I|^(gl`ZqLqN8Z4PZZYuTx{fWJd(gR9U`9USq^zuf<;%F(VOT=ruUFe#4Qqh7(;lTz_68 z6K8dGIewmef4$=KPMtd*Fq1NHLkFu1&l_Z)bNguvoPdfniAhWh(n4`*=$bb8Ik~p# zkrzE(sz5x7S(K#f9PP=b55_gbIitjx8fBWO_EorgRiz)ke!na~TAi)~T9VHEo~C4h zGxvYWbw(uZ(20R}i8`z*k#Hr-i^xJ(`999t#Kd}M9t;;RfBht`qLFq1{SPp=>oO+i zb0kGCZs}S=ue@wHc8`cfF6`)Ivgq4SE2w5yLF{a7DyXR7UkX*Rl z($2HycfGQ~!cDFB=GY<$P$Nw9pi;Cqu-L5e7sxP87SSRETUbDw_WEt~tM>zkg31_+ zgC68V%?OQKO`K~3DGMsDD0Lx3vqDb@kQwN0pK3OmIiX~?5I1Sf2%Y3=U!Y^| zt05swmFGLIdDogGj#@ZICKt_MC{4nKL4~x!QGUk@89?Y#Ve>svwo(+C77*#NVrA(x z-<+Q5q}3WuEE7jD#u~<<(XpyxR7$oPiw?elA=mR`%!ZJe4q}oM#Vu7!4_E#GRpOWz z*ZjKPCO0dQ#{EO8dJa?(hsW$iL@)oGW%^z1WY$M?iOZC>V)NeTY(0R>JT^(?#;GSx zBW+UgcL=r(C6h2-lwA`_uQ9&_49Um5oWVZ71eE4EyMh7WCw{WB6CiutX5{t~3#^OD zuKW8gM>on4yG0I#BD`4qsWIR4 z!It@3e~q219ejx{JXS)z@=9nV?vBENgc%clZ2pJ78U9vz23{n`=AVDWtGYO{xISar zk6wMV<^!y(8g%QG)D;n{hxi%$vfBXs-RpyJoNtG}tr};OuLBCRaI|;wILyel<_Mf^ z<0V(N(^aS+o?A6vEF!iVi%fMcgKc}^xN_OX8OZY=Q8%T_=ACX&<$|us^-xEj6nx__KfYm;?fKjmyNJ5!$W2JUFVsPpkA3 z(F{U3BL48mL!%+QpI=kKC_tUYiwpV=XX~vhhMzXv*IN`OlfS))bZfqwmC^!<2&K5c zA9aCkH8At=%5d{#fbajZJE-b$^JY}*@Ercym&yJsR%BvhLucaPRIR4({L3r$cOSj2 zho4o!jRRWUT)ht*+%PO|6#nveEatV31C(8^vGM=s8b9fZHRss0}~=*-t>A< z)0QN;6nNg3fjIk**Z*B(szHz+?^P^#s%l_F+~E==$3KJe8tIO#=xynAfPyccUoTcV zS#H_CX_r6l<9gMvZ`-oJkLe!f{#ljhV;xth&wB+HMiIqx#nZ=+@dND7*me`fP1Q&6 z{c-&#>@5Aq7FAR!_XmIH;5k-EbGdm8F^ZDL z+!JUEqLh->3Rwjj zWJf8p_Iq#{Q&57AaoA#zS|}=#?4IW_Vs5bieNMqPev$87j4LL{yr6^M)gw*ml>47#qx2s~E3{4)@JT=gM0 z>+Hf#vjMLqMEmjmxMziljs!F?;S_>m@j5kXDYrk1OP7Da;)44fRmKOG84S{%?r>b6n@4N$t9zl~OrMiUdU_;RZ@9*d;4mXiHmu(! zYN4QIY5~ zAg9)GU>Rs*^6$*FOht|pLIo9=>;1>ppA7X2XG89LWI8*b1B4nT8L1*kIPZ8(jv47) zYGK$S#3l03BAusH(+W=P9++MoLKf_?LLi1KM5Q)AcCnBRtI?JQiQWv^mmqzV=ywFCri}O26h&jnyCn2%w|hV1%$wuPC5xF+g&$+580Jym1R!8H4zr?)6fzq z^xA#(=`<>dWGN0{<>eTi_sO4|3CiywEx$A&s0=wK<&ZmTTTP5r3OIMR?-LGEd=#CS zbcIKsU^5woO;4g7SX48EmTI&T87_b-5Y;i@L+|Yw7+8?IW*hcPD4DS#N!J9W>Qmlqyp|~h|1R2f^dv6l4wv~5 z6aLvTR2h8>yO0xVrDE*J3++i|O~uc%eR9sTsVa9 z;;YFf)eNg|D|tdet^cqg?q{o4y2=0knC^_hlGM_%?LKtoM00G}9in z?K|XLQ)ryevWAfPpd&1zK@+as*Q|TX0wb}YTk?=f#YB@fbe+m)S%IosBy6Nrr4d6D zee7i1P z=6?twm-tuu0wwwK`P34yEMjdchv=roZjA&!tWekp{}mb3APQ#d6WkOQb%7URlJev( zG2aNz9z?i!j0nGy$mZ6joRH|Kfa*c&-yMl}0P6NirT))3Zr=5mZ8D0;!xs<)q9J2g z6bx%V0BYcQJ!A%vM6OhzN({T`somXn!5Pc~!`55VdN+h%Nc6`$u78Wlf}`lWTUbN_ zzq=91BsZZ5mi^LwP2_?t9lSmP>coRul%q199Rce8+Q+%}O9*vm)yjmKcGw{~g=kVY zrVz=vy9#5t-#qV?8)!b!z*9-SM9i&83_**i#Ay1UEAQ?5|BLec=N@49I|~!L*f!RH z004Y`=i&d)lKjssbTW00RhG3zRz%@722&D|L16E+1PP?lFrtLA+gyxqM$m3hN-t^F z8exNVj9OA1T`5KxZ-fE-!X=adLqRx;M?i2ecayX{_qdrc=E@?-oA5Qi$$8xAdNlcU{rFSk^%kq_xfW^F3QVtrzEhD07Ma8xFP^{p`xoN zi!nkjSpP8}Y{k++Jiw)(ZfX9J7vFSDG55}z*zV&_SkQIQ^)hb@#>lr}wF*C%HQspp z)%)7aK?c`Zq(F_Ai`yCu_oR^9uWrSTouy6m6@IHm4Z$Z#=Sgp#%hmyqF+vX_gS9*x za@KM_|BsgqL=c&4C`PACgdLttok?YEeiTS&qdyR)ocw{xQ88Up-yP}O`hb0>`cVW<=+UeZRn+W~qDvxSd{UVm(D-GQC$2nW zFeweQS%VN6STA({LF&|oH=2!~Xp;MZJtg;*b|K${BW#t%DM$QixAr3Ls%szU4m96Z zU$M^LFrpL6p_c@C2TlCyK|xS^#X&Z-ac+-LQnR`S@#kKzhYS-QwLEhG`S##YO)oda zQLumD8f3Rltp+gkjB>ZwDj3)}ZF_ro5HAk+YTau%hrDbpVN5u2-a4`QN=K)sgP8lP-kuFY4nuIYu$wI#27cX-T>0&<~w`+p5L&?@8F)9x#;vriu9y63kO z^I38S2Nx$UI>}k!yCes6 zHvKN@2i3Sv4?l8S{8zjGE1du5{jdB*lR1BgKQjFa=R)lN_x_t2di;-Yj%{hbCHCSS z_#GZjByg-&mb@O>tyyhLS%aW&O>NsLXf;2S$YLFJG#f)>4gA{xayv7RBHW1ESY45 zK?^kKs-*S1i=}V=T{yYV@P9@7nfkmuo;&Nc!gWh$wryVY*gdmmRcjlgyXdYSzK#0f z`f?X{*0*n0xJ74u*e~+&Zt(eS+<#puuwudFabMu$<^6-(%)9uXd0&{ZBc|v?A|Z&( zq}Ht!97_`){b*+0&D|C!!Mv1meu!F}24QFA;N1L!hYt1dowVeV*8VMhFYrxfP5kS9 z43uy&M1M(slNu#qPa^$#A^@Tu0#jO!PAT0(KvfafL0vO+mKRgZH^r69Dx2WQ0Ebpl zd0aEVk%slp*2s3#rp^3Kv6VuF*pYet-Lz@@)4Him|I>^0_&Ec=M;N+Lh)HdneRx#a zB5y-FL=s7tYMXd3L%kxIg@M^gj;XWM7baO^QMw<25-6ge8#Ww>2Q|*3aU}9cD_J2% z!c#l20_)yD7VX~M+3*tDzBwb8UBH!V=3TYn2gZ=zQ4Zy+UjSJ9yY2QQU*og?Ud0A% zYlE^eEe&q>W;XWpeG$&O*dl6xw_FV5rwpzpYEEZPYiQe^DB)WZ2i+{s$H=WvCJ~?D z;OzR>5qg+62NW@jYVB~onDyRMJZJ}!+j^y+@IIbRbMtuG;2t`PzLF^IQ3+qkm2@WS zp>eEi!RwEUy+)O6{fSnHQW>811O04|Th>O{=ImQDr=#UDVhY2euqC@w09PTnMn4A| zb_I(`yX#h1V~}D2bBj^NfRDtD6KDhbp1kxy{rWuxG{hRo__J-p9js9Yn>4emEMcDV z{y{tnj8Wlnm&dUOg;QYzUIoT*qT}}H3a)r>qGk1g{H#iFGjX9qN4Fhlh~C z<6RAoyMk8VE1*khZteElmljOFx@J(z_%cHab^~}`=MXRCms%D(-~w4KZx%+bgE0<6N>rji zpos>!0s+b8g3l(HZQH7K?gG@l&GRMf8e2Jb_ zFlPff*vY^WP_q%lpcJza8~~ZhGGG#N(m?he#L`XASQI}g^3~2d zNjVLaw*xf>!mwKSjjRi37am=Bt+2oMfVRZ0G9;x4;uUPvqnN>ldC3>Y0sk24`HzK zg)pZFl^a8h#!D&pcy{6W=4vEF}jK%12Q@991lXx%?(Tt*&u5^K`Xi= zNteQf*YA!fdFTUkl_xoe$WJ^gQ8|Mn}oIQjl=?>a_A z$cNB2d_XBZNlO+`AmOS#=kSMTB?zV?dKg?uJK$Ip0`IXpDTf}+$EX+f-@7V8RLwPr z)QJQFQ@olh;*d5Z3>jQ0IAk{q+p5bP8U!<%sG~w@nJoL0Ix&jJUjKEo1DQr{(UkcO zQHwD~A%F`&fyO;YKjlPL$OF&HAXhDdVwm3GDWxVRd@!2+L4si2%$9 z*(7DUmB%0u+g#=bQ`c{AVTuluAR?wFB?6mz*gL~5=>V_mXs6ELb<7=opUW^Vt~Hc! zBb4QEzUn`6WRcqm3ndAtU;*2L%V2PnOZ>*`{dG;+^*S$(3&;d8)T9mE`dU}WUXB}Y zh9=7d0ZJouj6Mm5-ic%a>CjZO)KU;4_bDF|o~e%rkYz5$;h0%sXq?NmY9Z{Bu7N-% zeY=84x)PaiEIp_tt*PvBLfA0ssyX+v4Slv#=BL3MLUKE2m)$h#J?5@Ug{kS{GfsRK zwx$S2cf>d+&jCfSA2#4TgLqP+<20d9iZS7BLAGRZyp=ViH;JqHcOrxk-a>2bS$G_+ zsGBy^R}F$5;npVupRO+z0-LW_RGCa|2L@;mDYTpvDV&R30ENyGfwc?c(B{g{vxLUE z6s$m{#a&Pl|6y-sUDamLQ_7*u9`Ux&G*z%>zyE7`ShcjXVktUcDY{@e#pgO#Pa%so zcre9bOOd;zCs`vFP4-rJ1RLIcn@33h z{VjK0zsX#LD@5E%SHx!Su!Jc}7~SbAj!uj!YM5l6)ue7VJIh4m72DO~lZxL#{ETDd zugOaG`yR}pq|ociwcheM#Iv&dM@90RY+sv;$4W$iUQ6I2tw)&7Fxh!fT=+Cek*YXf zOM?$U@->}!q&lnfF;QH_8|e5flVWKH34J9=a{7(4=Tu|&F=j4Ydduze-#rZdzK)(6t?LVpM%B5=Sh-(aNEh%t)-`z=!(b?jKV@XZd%Ww)j^OzyP^$1rM2w+tSVH_x7w;ljO3uYI8|!5Wa9aZ6XkBQvbqzF(_^37h2r3d83L;G7&(iTXEvoOX(As%uS3h4bXERmg^qbdictah3 zu3*D*Yq}-t5`%uek687v6D-O}iIt0J`tA=aF%`2Y-H%G%CXnp)t#=*ua^cT?7Xh(p z>|5$mY1yhmk)cjjOY4kKIm1HyDH;N(Ge=(jnA})6INV5^vnqeH)2rhdd#Wq1hpMuW z!-<)`td0yhF~48=U?sFM!*|3N}p|(6+2a$MP&fTDNLzN?oL+JW8s;PX#J!lKV<=6`ofS(@WH{I=S?(IX!1e zeG@^UT%_PzaF5KCS=z&zCCg=%JY!C<5f3-{ge*X}sEY0+C}fsO*tDWzm$bpxlxh&a zUUkVb?>F2UhfvB+6?~qYqNLsSVxpwtdyCdgmsjlFZ%7>5fDB8IgVfa_0ISN4%o`UA zS3<$mt2TzlM)WK^04nt!{rBI)h8Vh)qBve@$LnqS`MG3yEnO-8OX)&UkJER6O-rS9 zp|CL)?Xr2n^UODrZF8lbHKWTJd&Z=_{b+0t)XTcc=(VhnEaNEscCAXjT<=l3jD-R0 z)P)IKK20l{>o3}By@K2$(1i!38u*PrCzH;fLvFVQm1lmgxcR3ybYb$(Kg62Z=836PFTxq4qJwdYf?bC zosG$L@m9RqqPErb?!9LZH_t-R(p*1>)qCpf+8T?;<#)SyipQ#k9o)(HuIu~VZZ?4N zaQBu1|F2cI4D5Dz0R%Cfg!Y7?T?6gbfC3n#n!LD?S1&M z2Y`RVt$DLtZEtOLfbP#aj2&9FWNmeBcln;~7`OAUcPs>t)YS8@_q9A?*zH21w`Gh! z@AT~GrE93g{K@kLGq!G$DH9> z&_qc-VLi0GM9wl!J-*SeaeY4k`|2>CSKYvX)$p+CT_e(*>sHoN;v#D_KKb%dxoDsGJz1Fpz(U<4#h1SowF}XjFL8%>^uQ~xAiuYDA^fI*Gcg~h&%jFF8^GS#3JJA@9 zoBcM<)1M~+rAdu~n(*9RfMny8I)YLTi&TL$D%%M}JokYm;=d!Pe?O6_;uym2R%_rB zwj`oRHcC~OQO4o%{1>uk?Q{m5RXtL&wnK|9h1NmwB=B}q>> zkBK8PB!uNQO!fmW(x&2mLPcqHTd|Aa-l}c^u1npQJ;mP^iT3>B>g{E_>PUyl za{F%_vJ7tm#Vwr@jXEH@Q!fxbQ9s%gf)`bJeHNBt5lD5hqZZHc*;?OP9Sdsyl?$Tf zUDye-&yEi>3E10=4vM73hwW<|CzLh#62k;daw>&W4MNC8 zb(cOQ19mIAJVQeZ$ph}1g&jat0J7eXgan9LaMvWa_JZXC;T5)mNF&u7gX~L*!+}E> z%MeMVa7ZL9tyjbhi^MR18={8axr%$^&xjoB0B1Z#KqCCYszz0a zXE3@0c(@p;WztSC67Wh)l|+21Wyq0PlB%M|8#QU+A@)(pb6O`mZ^4LDwTs}OqMOB{ zjDj;{fXAbQ(xR2VA|g=4 z4V5>X*=N&p;~cp%hD6iUNXQ}`3C8$Yldvnlyj>&1%>saG_pmaDG~)dU%1D>#W~c4} zNiPX44rd<8^glUbs9RLX>wZe=pMgW@5S2Ts!SDUMx-0RaBKo{he^FZ-he2yi?w9A> zMD=F9w6OROrCP5CRL#$JHn3qNz2Bv;%I}_A8sWSqTPWKjmu$b=s%&-&9Iz)xg$)HZ ze`69zmDyI`{~A^RPdJ76BDoY|TlY{qp@>+**#TI>E+u4=!if|Ux8_#3i)pW;XrJ&A zD(2YhpPPlhhAfw8CLEi#B9HA2`vxld;#JN&pP#(+9#qVl0yIo;*I)Y*T6MW^1rB}% z!$q1EP8u8;+LP~##E*qJqh28F=BmE(VgW7Ff`S=}U!;1Y`OWF*y_;JH=Z9Oev~2r6bEGJeq( zNs(K9^N)nzTY2z~6TeTtxu0()F)z%jppGFA!-L?96St&y=WXHr7aEG@HXBIq_HzL$ zHA$uDK!8=Fj(!W`}B z!dC~P6g4juvy#O}dQiTUg{|L{m(^$|5g}g=WEeDnz_wZo2Bg{^45o-kv zyU?%Yw1~fhcl)`MS0#6FaW<8C<~Sq(Jtx}`{Io_-hBs_F^26i2XU%()tZ$Xnh)~pe zSHoyC&|?RpuIg+0aIg7u=0Yj6e-NBGuXSu4Tjr&`zrQL?5ZMC$RZ=*7*zx}P4d~Ug zKK3j=sJy3*PJoHOH|R;!qE`a7@fl76)Oxdj>`%pVP#n||&!Q#;4fJmy@k{4vsm%ld z%3!qT!9d$Q9hiaR=E|r9k+Ke4>By-zKdK`fh~RYmR;ygy|EUOEwG#dGw0(&G+W0Ek zG>O<ptKwln#4icbP!=>7v6t@LwYp{_@pj8g79VqjR6QlD|p9j#*zOJ#KTC z?D$K%mTVYk|8Q_Zm-%m+E;4I3&>!Ug;xu!=F1a&+xI3_4m)sB9|GDH$?f%y#*Q4%T zx5$9z?Ybf1?lh!rQ^v{pouBwi+;+4qS4vue6-z>&3`6-WMfKLl=2%a;KQXgMTXOGw!$;hacG z&4bJ9#gi9z6OT7-UUKK-w9&N~V0Z>w#}dwKj{!DgxLycfvy=DNsy{h$Brb18dQ2a-Y~^@gdl3 z3;u)Q*j_CI(8_=k2R*ue?UFSdqa}#IVLyo21^>F za*d1{r`Q=FX&;LZ;{AgJbwQilZzD3<#$Mbck|F&TQS=@PKA;jC_;>r#{in91v5zc*OzxHZKQI8$HaNA3t ztNzsFHH&3Ud7 zpC~gQR$6B1B1*O3B%&Ulz#G7t9GX(Yo+7Xfq{Or`8lf!qb?Z`)4mM}!4ItO#EtzS1 zbm3*3y(4hPlvH@16M#M_izt}Z!&yzu&g@7sJe+q6m44;x-h-Te$o%cQI<~6eU~&Rf zq8}EOtZOGEt;-z%3*5t2G&O9xY15ue|Fp%R8V@Tv6(hApz3bR4P6Mr*pMAGAI^r#8og8mFO6p6>R9w8uZMMJ!>W z5h$=nSv^|?H`$<;vmbC}cZNK7Zn8T|#3I~nHqwZL1N|;K6>#ZWdtH;gcWw0Xjd!t! z5hdW%lA@M>w2UWG(tb)7#jHe9Bu1T<0aS832E~wu zv=SC7(JlMw766H)*V@=Z_$MSp6bd|B4ajPti$}7yUt+CNEP3L_r-(Kp_s<>KtcsIw zQ5YGm@M}sIApcVHN?L#ob2Kt_!S9{Sn36#q5iN~*>(6Y-Rw+lJl>tahJg6ZfL{&0e zFX=R*iDD%WlgP<)CrYp^YY564!6bdu9h?fFO{c<*54DpN3lk949<@1KBN}y%0$=c4->T>QNl>lD2hbrdT5*;S*AuO|HC*Gc6ESbhAEgzSP6-#VW zAxHfRAHNTdu|Qz_AwTQntu)Ob zK}H+YWeq#gp_P3o^-ahMsz3r|S$ zJt^!4z2YB{6ghmPat2WGL>Lzm-J!+3@}J+Q%@H{D2V=Kv&rMG8!NYHsE|kim;{uVP zdv|EqRF0MyQR(!pqE%UyvSg82{zcX4K2>U@CiQ#`8#Z24st>ToCxH+bTUAt5V&mLXMwQulw*tK}GX4+lVXMt`LrZh@h zh;)=}b%W+po?Y>}oik_7RO~MByR_|Ar50Va*)?KIId{t4rD0CHpKV4``!}oazhY}# z@`t`l{*CXFzvH{)mwcBT^4 zGmZcN3jhEBVP$h)XJc(HaA9-oS#59IHW2+>zujqf@9VsPpYdcw%4;wHRb!3Y7@LqX$bQTK@?cQi|-Wi;J`^~rC zR9-ySAT;RqMx9~*YTSQ&2{c+jy8-S7^Tg*c%VJN9Bvxkiu=n%3{;)UbU5-cj>haY} z=co$ZhSNQ&bx)jbqgm@Vj_~hst=oJ#s>185P8F`Ns_?%1cJzzE>HRY94KLeopxYj| zEsoAbF;^53@u9k3G3cNl9+5 zq}RP+@3MnxEO_~?@d3In47_v6msR-5g=@hBR)sO{ea@mps9Gn2(?aIwc2vIbUh_KHx^2}L9(a?GRaa^8;xr^NunE}YiFH7%}=~+&SR}= zsZ7!Yr7%jV1>T(gJCZL1PC6>(o}2o!%^UyL`~YVzoJY(@RaQYIne;e##5|K;C>C4+ zqgzFAJd8l_nm~V|i7C(y;?*=*|4Rd>` zHG{P_nbca*$bCL&cODdP-IQrIjf7{=RgGqGLe-Azb!Y#$TN_WDPZr$Y3`mNhweu{RgrJDcmF3P(RxnsRed`7xQ{g1sbGN{}Qz8z4 zLG$GyOjnv)HfehmB}*8suSOmOBWpcI*If zzI*~2&Z7rn)!jzjP&Mmr{lt8E@Ag6&GU;o8ek`S7C5O8)U^o2W zVlpPR+SSeNtBVXcq2282{T-_dKe8(i9)UaLit9=L+ETo<6pc+3Q>KKM?_gIS=Bsz% zzZNmemmfW1dC#U4OK|)Mg0}BZ+U>3-IN3q)THL}PnUFWuWhq3QrBJ+-#SBQZ{&799*EUROtYdbd2OCsFwV#x&JVbh$9j6 z$!#L1<`5Tg*_O@RSN1m{U_$Uo);B!HT@y)(BrvHIypVf0%0j#>Aa>h#Lg8C2D`bK( zE-XgwQU}{GdQuXV!I-pXn#+=hHIH^slj-Q_Va%U+$oUVip!u74qz$yjx>5J7cOnpB9j#*x&y4muSMS=x!MESMc(#FZ*sj5Ou7Sc_G3Buc z`s=j>R62XmNz#=RL8$S-#aa$Oj^KR~%>ot&P-G3_$d)52ndzlbn*xe!;d39pXUY-k z`>Huzl1u}OSHN#mN!dD)riKx?4hbdde?_%GKSm1zUm!O~7DcA2XC^}`s!2i~`49< z(@avuO{Ip2y(sf(TT=r_kCG@$)4MXSiWC+&qTmwRe3#r8N=q@#GzXIlXOi=1RRxtz zf9IYi3LVmx5f(gzFF6s|F0N%{Xt<{FNYGFs{z^`mXUfC_=?!I-oHWl#&Qn+=+1-0v z;CK-ebK6PL%cV>-iC@68=w5-)pV68P3KFpeW8?*X=4p~1n0FH=%ZU2{c^NJu++qb# zBXjS4%Os0@l6S!VP3d6yYCHbAr7C{;LZf54}?mY zhjzM0Y#6*Ki38*u(FkrmX_@gQT%MIXNlY2+9+wJsxvhf%h7F4CwFn?5K7~(brewq^ z@a&x3aT^S!<{(@k%(@;->jMiGWgM{91K0^e>HI+$&$O__(pH$f;o1W8V-5rla8tB_ z&?=e!6k*oQ`XEeEwzP7SBZM((Die<@#eLF@scO|u7=61Dh7tw_uPt02hFR4oC_V{Q zc$kF|wkIk|3r|Z@(-s&W`=>>)*&4O;_Hs1F)y3W0TK7{iWd~gF)hT@-`>JJ1(^K3- zQjgsF(tr0_Kye#zia})0A)LY&tAMH8%Oa-D1(@UW6gi^f_WX6F`LWSF-UDvaJpA~o zSGlOx_wwT}vPM%zu!8ySn>U|9X&+IeQ=COGF~b%36e+${D&+lNAQO3GS*&~ZH}GBb zjFq&1-GVeRXX9z!4gGEY4O$D?x z5+;2XVY+;?FkUW9`uxJIck-1KKT2N3o+t>y0rP!9d$0)d15S8U85usILgjK^brgQa z{k+-sECsT#Jm0 z{ysDXNC`S!_uc}Us%vA_Cv4!YZLoQKvh~f{4!eN2y6D%yMWUhLp}_GX&Lp?4vU_|T zqEY0C*rDc;92s;{gkh~5u21#+;u4}_tipnl*7Qb;ljnbJ5U5Z&eYp33F#JQ2U(;=ind}{RF!|v0}Kpr}kQP4+Ij$*RMA5On@%oesO*-f0-Llpr)rK5&Q5Dvzfi7^l=tu7ZO(8VtzJ~}=Jw|P?s9VjVI||+=KAB+OM7wDjdgNlGxYk@ zO|6?4y1rmz*E}}RBGZbhET~E~a-QPZm-+O{^MCD5_?RxMSkpx>&U8MAnogpu;Yk8K zi-#9kna+w7(`{9DraSktHQg#mhDSMvCyDSZ30|Z(&*jjeaZyXhc%}DBvgMC=A?x3GaICw>@Kn#Bj6+pKaXx zdW_>lL@|e`rDDWnF`~N)Kb82Da96PZD$`{b-CwF7U9tx6`rxM;pE|hfdAqZck152D zTS0@;pLcitu}vpM0K-5G1S#dt3XUUr`9ny}-_4=JyEgB7@~)eAJ$Tn2?^?X; z;$5G->w|Z_@ve8?^~JlsdDk!R`dPe-c$eZ`2JiCmE|Yg@-X*+?d6$=Wd3cwLce#0& zjd$63my>rn7VmuX&KK|e@XjyqeDKaE@4WNQ8}Iz_&VzR@-dVh}dFSxX%{$MYVxj{cQtrdAMZ-M ztKwaqysLwEwehZY-qppsx_MVG@9J5+8{*yg*|i?mHlZN=uRLH39T|Ji7I2&-BAYJQ3~DB47wu=-I0UtXbRm?azuALgYGzm?l^<)IEU^yf$n$;-LZr2 z*g|*A&>a(W#|3o9U!gm$pgXRiJKjKd+{CK;a)W$gzWnVn3Fh{@77 zPR(?0UrNU2y+JEJ?bt*W5N8!uoO3N$&Ca#MsgPT9<9kcT|_%RVY@;ScGY)pRCF?4EnYh z(^uOoL+ymN{&%-)&46~#yES`WS*3Th=I>yg5bw6yPO;tav(k2qqyluj8j_hbwvUELxD;O(d zYUCJFee1+s!END0d=I0Hbv1jy{<$dfWigf?HK=I-JLM~ zDN{qd-?ivf@i&!=Az8aDtPqYGEv!Fe+W^QH8jx@N0l;|EZt?E$iQOu?!`L_k?((5q z9kyA6a=4s`V!>dIi4_LitkR=om-$-wz{$dC;Rel_Gu2)hOj=!v|b(r zTlbVRIFbz)sB*FJRTEx&csv@s{xBLi*m~3THeTF&_|`Tslt?IX5Ym$b zamQz%mi}AMYtnuZ#K%K!r-|4`unn`#IkpyT&1`*+tvp*sBn*XQie)y)h|tJHG%upE zhm3#{4`Gg47Gz(kYJ1YVqCN4=0%;H07DmtE!O5BG9aTT+ltgVY6ii%1z{a-cuah72e!_`S$UX%jf?3dFEN3 zu*eW3ca|pW*)qTXUfR-miDO{DnJBRao=?OFgobUESdKiJv{aeH<45v-EG z_jLeX0$^7!5LivhMNa5kj?RFVAm9Qd&3lcoo>4N)dFJD6M|UOk`+_a!j%pPs0h#yn z__TZ69Pavg6sss~M4=HqL@U+Vs0-!n&h+qNXYH6eNrSpnJ=E$j)5W+lM@Bycxp8AJ ziL-FFbK_oh)l|8c=2W{Qyd$VQm`PnvaCi^LE{^vUDlY~_6xAfAk{Bt`EfQTxw3Mh8 ziK--uCG6;!<}V_5JOm@oY1-%ESn&bc#EVn_DFcZB5(bO_3i&lWCF+-7ztp+z)%1~22uf}3?u?b7%&1b3}^vp256*38Or((QJrGv0A}eSxi3Sn z9n$3maKQHV&h|24dd}8XWfa9yrM$}aQSaSlPnw^!2K>bcY+O9f_VZ}Q(<7_^e;<;2J$~n-Wux;BK`C#iH-Pznc z?(xwmweN6mP96Kx-qH0o5ySpUA9(1&71{v^=r#dJ0OC^ukPw2Yy=&pd=ulf=(%`>i z$98?GFUuY6MnUkv+MeUYiNBNh_IJBRJ&>_yRQq7@<>Q5YHv0=~`{Zc%J^dsPxBQ;A zv6_VTrHbkkdm8(l9z4f_CJTioqxeLlFa!FuJRlgOKN$RbYHYH3XZ`?RU02jNh9*BN zr(tWc-V~-^7G|IxhB}j1puzVEth42~FWC0hqH#fOqpq6VS{p$ZpT!MC$~LeDqNU{5qY}nRNNdUGD~+ z^~eH$oGnS4ysBOc8lLyMiNBo?BO>-yLv6*gLYP_5*} z`;6X3lzurq7$)|8HjyTEn%$jGohTnw>~a7|3qYPjo0Km0K^3mYFYe$L{S5C(@x39) z01k@}9ptP57Js4}FG(o@QMICyU+i7wm`?6n==#Zm96`Xo1BdHqP4F8|RhOP4Yy0a| zOtLlt>1vFQiuqZF^qX6wf>&e$Te34hP%o+$$qe63yqhw&GDywNq&OgvZc|OZ?cHu- z#HR|86wrJ6@bTXBMUucjA0*s{mlb+pI%OcLJY}q+KxJ^U-=?WHLbY4I=w$Z*yqv2d ze=eE?XDHDrqCQkepUNZ9o z`QNUsj!8#CALxwq(kd2)hB&zjcsv_`Cstk0$*tTN%bl3Zb5s}#24;j&@H&M=#~q|x zj3+W&1WZImzN^S6C>Qz?Q2MT*GPCy%pr8pWQvG!Znp1z(3R@Igm|uJTuk#~v3jo~#wqhAiE*ni)*o@`DYq*%4h)uCdeqT(rXpyH_ynbY+lW0#dfa|(!) z){h_VGvcS&8o>c0{0TC^QW3Uf6nPAMCJO5SNw6Wljk(n?ln9_{I+Kg^qz_69z*<&yZol-b=RMO*5g&|p5Gf%^mlv&X`T%&@qTy>wgn`tE z++ez%*b(3dZs;w(S`|d6)&v!jasoXDB>d#}_+lAT65|qtuE{7mN&G?C#bWIVR&65# zv&U@(hn>$rCw974;ZV&9ddGEj;dsaH2JwTgAUS>HSW^1Zwk04BYD=MjX>AYqbEt>Q zUR&D(!udghOvcgNTUG<73r`Ki>*~j?k{UJ4HofVJB|}6df7U009Yy}pW_s)z9-}L= zV+|*5h)UOS$^cE`rG$(N&^;4}%~89D9`HJAQA!2&n?T;Be7Tn6qAn$urBrVYc*##s z3^A^#Oi}2-WwI#L$4mt0@yJ19ybKlg*M=O+s9&zRLHCTYDxm6d8?<}+(76R}Xsl`p z#dbNiwHlIxN@TA0(4EAX_!XIr#tF>y)?s_+N7>XxDD*}op=X(Wh6LC!PChB20OtE7 z+dGbGLt7~gX_5q13K@hys4%LCQQAQh5N?tbzLcAw=@bNZR&2h(&X0xiX39Ja%+$7> z8;{)-i?PCyIczqI9`kqYGFwjcInT?0Ac!=xd}!x8JjZ5U?Ockal5?!zF5vus8O+V^38rrv10SadUZWKK+INP-(eJ7XpYgF!!SLl5D`r_t%;Lhdq6!aBgG~_&h*86-P`KHe zHb81rdv3_WhEouT#7`-tPIKD0SwmSBinJtNsW#JK=Cl>=W>@cSta+D-@boWIfU@Xo zV19_y;(narUW2jG?i;a=9&uHziKE#)cMtwiuy{D0xha32Tqr;ChZ7ml!wE!UMZVX& z2HDoV$FA<~Noro%Z0(lF4s>1iXplFuM>cH}wnqqjvOO9!vqy|i)t3BX)fTROeZ7Uy zt68K$z#@evA{dRUMPeFE&cP0ST{da3s!g)Q#%68;jy+QeLijTIUv>>q5?!wR#NnI}fv%(&KK zwd9OiRSGV3Q?D}ZpHGv98fDrhX3(d8%oY2@6>k5HcO8e~N=&`++M9kH`4h#og|%} zR0O4pLhu8g?Ci>Gh|^Z5N2kla7woMnHvEIlyomC(o8~<@?P6TzdWz64uAs0Ccj_wf z{~N&m_)CxezX1&Xt@RCHQO{9i)4!U7w@!!`BhF3bt$~#JE#B565w|9(kICaJJ{{?NEsH^_Jpsn?XUeNZB>NFdNp$bCk(>XRr_2!%<;ERU3D(FPv zUwl#5FHlPZ1QY-O00;mYRp&r4d4MLW5dZ+0VgLXP0001CWpiI?ZggfYaA9-IT5VI~ zHW2>anf{0U(3yia2}yvEgSImv2{d!O71H-7i!Z-e`}(B@qfw`O(LV2;^?Ro$#ABDJ7b+o# zjw?v-K8&Q+pmTJjCCo+<+?c}F^7Bcpu5PLdGkRGi> zjiI9+$C2j`eb-S~gVkj-AfEq4Jjx$DfK{#3s#>aAuT*y`)h(i5D&4UhJJM6^HDCEo zK-We=BT&-DzGNAE6rzjuvf-E39EuR_VLlmocH8MKCo z*5CpjPy>ynRZcj4u#sd5bD5* z6??!4ZJW*CYCkoyLha*LyF|&<%;b&qMMt;;u-!MfwR`F{7jVzTB)Wz(U3E)S zM>-P$N+6;iid{E4gQDB;M1ghfW3$kb3afS&79s*dhDd-nj)(_d5LEE*8zZ-6GbPSS`lI+ZaBADgZQI{ z(6#RnyE4W@1?l-vyv}|s6hGuxef?r%-5fdPml`l)t-Vg|XgZVrXsnPa)q1&Jg(<&8 z!Eoe+BT8$kuJ`@1A5$C+)r}(s;rCQV*S;q_@GLI-@tYFe_^AJhA}5@Ig{W(BOcD4$ znFc=AK~OrOnpJ?-3n`39T%*oGEC@)A1v&csi0M+$SOgvgzH=D}u8bPeb0*G6#NWD*OChNK?qSkY>q2|4j&O=!%GSOKV_B1T01;};8OBqe7_kS-rF&U6~sGcGPc!T<+4>6Lz#!t-M#{mVoN;;Ia-g$QOPij&K~g{vTe z&3Vfph;D!n5f(5-X;<4&tHAp(Q2NM^1v_by#0uV2>^Imd1$$nwoqIHklKXieVYq?g zPk`VkJ$WM|#pb8*PB3>M^@hBrz(Ia!z#L|Qm$-_pC&#@Cqnki@BR;>dh;h>u6Jh=o#)ZL* zCXT$qG6yOr?%0GTbwj#o&R1BB83dr%8AgRoj)YOpcLlbYrH+@j;4pKnlFU!0QL1gq z1hyY=0RswS22w^^O!4SrE=q$dWT}h}fSs9pT~~T8DOnRO=@1 zkONW9$nK!?qgtud8hJR~_Y7x)KGr^P!rLWqUL{Rm7IzUwgoW6|I$~cnr@in z%CJU(gpM5LFm1ndIvmDAWfa^7=7|`g@?Q&z%)B3Fx~vS;;c{Dd0EOu%v4i2b>$YX! zfD5~YYXXj^$l)m(@)XB(Vl&>n(Y5Z;j?~sVCfmLfi zmXDp=^C$_u7+8n{Pb++1@oXQ{rf~5_Q^(cEo0QJ%4^FP_Ke;WqoGAe*qO;8EzwU+g zWFM8i#gc_k57p41IpMUr8DabqULwWXwWGgYcjwF3_Xy|F&=W)4EOhZge@A-k&aF<*wl#rcr^2!J z1b(dBGQBW*KU;{oX$*na_Jch$3L!3&VG+bHk-Xx$p^&Q~Kr;hz15@`>XYC{6G52R4 z@`hZkZdJ0toPTFQ2~l+6cVl zz9|~6&2wQPm-zsE0*`s%eB-ZK%OWd`T*7UfwN(IF3h!5P1Kg5U!E~TyGRY z;00W^5<(xbsO#BuK<9(^rkbZ?DFha=kF!Js1PkklwIt-MSYHk?41htj00HCdT#8{K ziYbr}EMHYUF|ZSyvWx!2%hl0PH^RBfi}v|tUUaqchq`OIM1%O<{5Ys@>!T$Xsm2z) z+o#cRfMaqnCZ#{q=`I6@bi}fPvr6Ly=B@{58qS`H$-F7f!`Um9C%V?*Xkz4DgfrTA znXjpv9;ch*c!SaSn(~Ytjh%Q*=mru&tyX6xYj4#`7}IS%8g#uJZZC%U!2qq!A%stD zU9oTGq32^MA68oJ8#hEjw;|uNd8B)T82Q7V(Um%W6h_?^!tk9C3UWpFpQ~YJ)d9?B zqf&+$7~lS(z-GOysiq{mX;pIIpY(os;eK>?eld#0X=}6W`jtXwBIr#H;|(OCT=`sI zwGw91D-CkuIsRR$%zeL=`7?_(eF)Khtwj6v3@NxP+uzJIWlvHy-67TUHj*eg_Mb-&7|l0E&!Dni6{D%w@MYoGdB{%eaBhgxx=~W z{q9fLJd2PeTD(Mo;_wale#XY|GX&9Y_(G8c6gQM>MLO=0O`P6h(wsg&Y3!D%0m3}; z)sV@XlKD=xf6}IvPcNSAT3E@im&Byo-p|M7lZOR+eq3luscrb4x_iW?j`;jGb;JwV zRBTsD!Ks>-p!{@~?Csy4{*$ixN%hj!<(X(7^{(b5HCNP7>@QLgx%fZVa){C-^2Cxj zb%e3UWqYQd)1HpV*n`JHdt7VJG-pq7j6OH-K8SO;VmkJ3+fk5A!Zql!p5B(j-lr8n z$b9Akm=BXDas`mq9t355NmSbV?GLJQJi`f?vEU`c1w}qt>C51E#Q((5j`&oDzEUm3 z&d;rd5M5RaG4)Ed5IaAs7Uu0Ku<5{@iLc5-tHaAvkfC3Tf(Oq&jv-pBHyrl3?@LDhM15Lo1*5*BD%I}_J*eZcWlSkyXB;@Gi$@M`pY ziNh$gg}TfbtK}w`GZ4h|LO{8kj85TSw4#)7bS5}e#5E)^?St{r{b-1 z;MtQ-6-2st#kz55gfm9|dQo*8Hfn%*POJy`U+3AIg}k2TzSf#>myp=+N8sw`FK>6D zp0KEf#g7|JOL3zM3V`r;DAO4Z@x$mxF(;oI}c^$XU>)40aaS5+i%qxx4`BKp$?^iy&BNHz7zGJfz-ZU#=GiD|1 z-mK(j)$-IcD`D$qCG;>Wp*AZn3{f?q4Iw)~qzb!NVh+n;Ba7+OTMy<$g9|^4lX#W2 z;BcK`+85wuF1cWkyBm-<60umk{jA;W_yg7P2T=8B0PLhiiR{TYz9zbuzeOZYWtu{3 z8uu7bw-$dEcYm%Hm+9S1Mj1^`2!;+BJ>uZzg{&J3t6t)4g&h)Fk#ScN^6X7Zs4WN2 z;Wiv@iM$2L+YWC15O4wKigXckPY<*M7@=}& z#9}Joq?54QZsiHnfR`eQV`@5mWb{atA8s>3bhDdy3&MnLO?a8ZHW0?v8d{)jXip5< z_SI`HAvK93&8nl8>0mr5NE!|HNCs~vehc`B3p%lF*7hRuP4NNh5z(m?d4{(tFOfp0 ztwIq{$64<-09J8(+W|Yt0d|rHtO=^RcY}42?}iQmt07hb*jQ$Oy`V<4q3T@WPVyLs zF0j`)nG#5k@GOl@WNf)<=9U*X{d|1zs6{+YHQMRh%z7y9ADEe@ZI!^hu>7HNH#Y^L z1I9amouUGAs`pcQ9xnz5*}KSHmTdrZ@Z}-0yC!mK>j)JpaS(xb5{w;CZ(&AiMWpxz zBuKV)DeX9wvneQQyJA?I%*Kb~@0o*kup5de&vu>)I&~o@kit#v#pFH@yFh8D|8We9 z>ImKFS9Jm&Yu=of4Of(v-Ly3XxoECeUOQ$>=;4uO8aTWBWq`94>0N#*g-_>mdih=H z(g7WI>4;OpC!H3~1*Yr5VNiCP7b0@jJm)yA5VIxUl8O~;%Y-fcI zvf5H7yJ;~YxGsfg&@S2-X{rsx^jwPFW*8tW$GO`;uReymLvVfkwvJwRkVh_H1)hu1 ztDNz7-?lNZRY9UJfAQZM`vbm9xYq}J`%o{i#!k#{i*O6&&@k?kvZNol>YR`c zhc9O03-LLKy& zkYE{(_YQ;Q-l3V#Jj9KYJS6qxNl&a+m%d}Os9d6AXp=lD`x0|`Y4(lMYmA@Cg`8Uj zzf9XBrf)&A#w*j*u5!XE>kQTqb&%t}D`ie@hX z?(mnU%g1@`fOh$uFU&q?8TSh1a^}!lk)=491{d7PG?Q76T$(GR=AWOao2B5R#HwlP zFvk07SpZ0z|7#f3bjU?VgMk-QtQ~$ifol_1PeQz5sBC2>qm_(XawnLZW-@q0til1d zpirI0`+t`->IvK~4kZ95+V(15ir?1QY-O z00;mYRp&sd@QjXn5&!^)XaE2V0001CWpiI?Zgh4oaA9-QTkCS-HWdEfnZCoBPG^?1 zz+!UU(CrK%mt{7$2D;t0vt<-pfE#1GlAMHQ^6ouHl5q@nNLt!#{Ud;N&Zkf3CRuWl z&{xnt=ncB3{SU1#zxeWtyRZGB$A|F27b;=FIg>66?!Wv3;O=XwJp2)Sdrx9KkX+wC z5F!$lSKUx?F=Q?W4LXcO9^=(oORI&RKfI@&D&MT?A~e`P=yfi-=l$;4DbTeGP(X>s zx_^AEH7*W*__2F&aB^_k?-`9eV=Z*>v43!J+CGN;cE4?eYPFhfIypEwyZ9M??6r>$ zAm6m#?VTUDe}h=yClT7mcbP&Nl&+Zz)#txy>DrSo z#A?)?hSq8{>y7PtV*}u)`oUO?neY@@%U3=N;Mx)#ifCeDBUD4J-n8oLsrn5Ed(D{+ z!$fP1G z8l_Fs`5SGlt-Mm_q}{1P5_?Q>56|i&IT%=T3)9=jXCu7u-hLy5ytkd?P=R+ zZ53&eeCPb)&}r@%;T^;UlR=u(f~!Q}_|Ds*^gEbW2Ev9rO;~pmUQt#l78!LLYGk)U^&_(JH!Hi=%&byd)rEtobk?8~ z#Z%#r#tI|6(X2HaIFz5FU^rso2-5PYOM8FpOOVk}-7vuczsDlF_C2)mD<*5cd{u=T zA4`3rfQ3`wx3S<-LL|VS#DR};s3=&drgcQ?h7d-;uX(6YEeJr3IWRp{NVw!M=79%+ z&n^Q_1x!PFY{Eud0u#RUksj4>gd)vEa)^eY9&)T}+UHzMd`WI6&Lbj#R8&NWl(#A( z<(y{LW1NUMlDvvI==UJ;s9QIhOt^4qHeqob*y&7GQNsWSI$4$eEx6}PCH%`oaiHRf ztT_*+RglT$@7z_Sp~lo@5JWeGFE}ZfVzR5p;MAdyB9ZVhKNiLblSC@CrXsuHSOq7` za~fw0rcp9$M zg)KM~IhG{FCxubUb`}Xp8R2Rxyi9rU(cbpkt$V3-5}T+-S{!?=Dt<^rVRs27e9Y}t~Dz%~d>-?LC@)C5eb9L7l!C_fH( zH+0WMQ>CKo!IaL60kiWJoXvcG^82oJZO>kT=y9frWkmv29k7VP>or zM&X}aL=b4Rdpg>~#XYo-YzHap z9qM5YM6r?WLFYrGUU#+@;Anj^oDTYI^w0=zO5nVR>pY`+8#BRkaJYaOyz|5$Scn*> z(Skc{hB0Rz7b&an-@@02hmFPp%4rn3JdZ;tjztNnIR*I+wkaVnKi21QXjDaPnieN- zAacX68`Z7qPStr+b(&RYqv~vZng=bhn6plxXqAM@mPKD~FN&2MMFX~hVCer#UzzIp z+9X#lY7_<`6Qew4x;{D^4kcGPf}4nW%12E3*Bm0#?uWTmRSxQ?e5~6Dh0V{34uYfA zu`L6KRLCvd4#H6rFlvG!HIYvzHsj45Y2nIOptjagur-z%O~viB1%F}A{P3An$-2 zHdAhCD6H&l(kz5}NJE3pDW}!VDC0NoC4yJ3nSQ9;&BWJ8e*U^kB-QC8HY-2`LnRG! zpN`T#>}AvhcO&5yfWgIk^SPUiDV@10Jak2!Jn3=#vSy3$!qxp?Au{3wfw%2ba(0zL zTqeUJh@T>HMQuYamP23=8HgJkYAZF?9{N+#YRkiHA*@FrjK>xrPLs(c7vx7_1 zG)8x4;o1UnYP#W}1CG2~qvc8g1P{GdJ~i!54ZPKBqG(vj;(Q@bX>xl;6w`%s7d@HU z7_!P(OYlBWg9G52oA+f9CvsE>f%l&Z;VLn3)omdJ-avybh0xO{*6e&Tz@3>l)q`SQ z20=n(<6IaL1S#u=N)l2|td&Cy1H=GWfWX1owiKfnf&w7#R=ZjBOt(&$A1+!GZ!Y(R zy5a04yA-Rbksc2<#=OC3d=2x_IvO)M z2At&+4(;~-(uloPOJU3^>QR?#@xizR=A8jrnm^<|wQ)tZ$y`qp(!5(?xozAKOSyG< z%jS@t^CjjESw`1r`6!IKErg-H9UiJWkV%%qOdA6nJ`F01FoN;zKK^>MrbA5$GSiaO zxT~%1x?eFI@k{rP7xr9tv(46)KBcN%=uKEanb}bWlbMu;o2}Av2M`rKy}_PSg}r7j z-fSe;7$+vrXyNiw9+MpsmrD(%;a1auk9kB z;v=38k+S)U>m5WE(g>@-=@gDu6uw!CQ@frUN+{6&xUf9_Ln3*@6NhQ6Dn)&@zVio^mRtQ(f%C)TGB36scI(wZb#TT`Z$#co~ zA3HZAyU+h0WM3!}vFox(#HJUD#5}74W{0MteD;1le6b3HUE?uLscR2ks>oPkOT4@D zxwu!VNbpkU?!2IPAM@?b3p)2v*Pi`P68G%o5*NEJ^X%D+WvyjZp0fRmr}-5HSMJ#Q zqF1S(`$C#8`>if4cII(=z;Dh51$CSU{cEO05qb9B`68Sa!bB*14g-2PNjo#?z{C3{ZK zo?MgeOZfb#Ux2OPAGQnel4M`big56LoT#dP@92^Py|2zam^^qL#Vy)OA$@ZSu1&7k zXlaSgHlDm(&)B7#1UN1r(6{u*A;6Meot1aHtjFfR(qr?H9&c@rS}xn-fz>h~sIs|v zRngyBP4stG8~vSs82z1pBl?%1U$j-GWC>wLW{>03*PtHZ43DX91lk77ixh`Ws3qcg*U|->}TzpImgAgnK!fd(OVmD6LCBoIw4GpD+a5vE)1t5f1U+#j^|-E?vQK2 zyKsQ67$?6 zS!o2goCxek77bTH|3jTM0T1g5`A22~E2VI8pp=K|yb&CN@JHDORLDgzU+tsK7$k9) zzmtp4o8hDYf-=#+p76VKOE;6qS7nFm<>~RvLkuuE*vUvz&Z`zBCpToq`0W!gp@_gl z?^aDa&wF25`{KxeeCZ;3>*Zl&^x-bF#r?(Nm&mBS6k%Rl$)d}ufDLk&7Bb^W)dKgg zB>2V5uiyRK4X=Xpnse>pT743P?rlyD@3ULZ}_G;vM!Q?wroU3Y~>caV*_5aJv4rK zWwkok>ZtZCBOCgx@A2?&`qcU#B`+QbD(|M%Kc_#4u zb*xfW^)^CMGCu)5_JQ;C@l3WS$cFlIwVs0Cl`j^`S)2YsYbee%pwYQ}@R7Hp>-gWQ z{50d_OI$yf!LXmsJ_lv$+FO73+ab z5ZwTQU;U+Zl9XwqG(OT+Gyprn^^0GvwtfZD3;MeG&%$G9UIJef|C@+-VnfcYdLPWf zx2o$P6+FY74d5Qe4XcJLtY-(C3;}^{|#2;CUJNyo=1}mt^5l=nd z=Bw^o`yx+*NZ>Q{?Lpy^Z317d0#TR){bD+}J}p^-T3ln0vW zg2EPLY|}WK1%zcY59?3;(?(*f^uUogEaJwGV2Q3&h8GnC@)V;1tMURThu==lf&9<4 zk@N)AG)Qf;UrQK*=0rpm&`{yF?99%jkrz0QsrZ3;mbJkOdD%$py) zTg{>pKInApvI-2#QcHKWL7a2B8v@U_Sy~}99`a5Pg%U2bPsf7Dch(&efX%M1Y=K7! z8;NH6ygDHyE-`t!r1hU^W^=;B30ms%(3W5Jgdom2h`UzJ;Yiz z(0uK78iV+^k~kJA8h{pXySqoF$Et%kXI9J-grAe_kEl7!TwM(>c-Cn|AUIMvQ4w^L z?gx5kF%FeA5ub8{={|=m>2P@(lg^QndWE&E~M@NLOT2175BtR-lR? zo{2zcV|eU7j@-Fp*yNIe19xXDJlQ-p6DeeKO0!;-5Ih5WZ%V)QS#qMTHo<&2dm4Zz z!4-1EE9M5`R&z>16%W9PqV+SxkSvoYfD%Q+6l<8q?Z*5V$&)43n}pf619v||3n2Qr z`a2Q}4F8S32wo}z1*+QEm;G*4#A(ck7O24MiFV-g6Eh0M;Z27n*x+Fg>g_$~`Hw=1 z)6U!pxb9VQb91r>KxPUB&d$Ev>`-mAv8~`560?OMgt)$=T4TN30~qveZI&!p3TNwc zD2>h=oK{EfEGi4_4Ov=KIi>d<8#K6FHCUuo8_zT_FPG2U&uMZYTM<2vJW|v zM%*ccW2WTfK{Rg2|3?~K1+Q$N1X{=diL(eB+F!$WwLpl$=>9D=-IQu$=Q;JrI*rtY zw+?8MHU~}D1+2CTar*Q}UC9_%GK}M;91p5NkzTM* zMpa|RBwb_Xq)XLiAv-~d0}G0>QYe52gR`+(TKZ_rPlCjgmIb7VIh$T3j3^7exOn0e zC6yul`ml$I81!fxY#BX>a zRYPo&<9q;CL~vR@aDMV`!t}XFHKqnG{FBswgwZIEeAs1#BW@!Q;lbjI-!gHUuv`4q zW)qItMc|-!1;|*(L~=CqgCI=@W2E&LfI4`{UA$p*D)aNLKOtl4RmE*0@`a>zqETwV zXcS+yh4WPj++Me8h$599YQ`lu)Q zV&CrthXmh=nruo;uXj?y0cSV&@xNwhQ??o-WyTwwGou@BSy#}{RpEJxMdC)P>8n8KBt zJESO47;T>T6_dNM__ebS^DBA#uJQE*CWK}qKJG*hurH~lZ~&s#*m|nPV-SH(AfN-D z1lHwyeKkAqN;|dU+>1jtrn)f;(&DgqNWfzv6RN7N1o9R?TL3Q&xl8Sdks=t_cRj-Cg{>M4dz^iPz*qvI1(-6Aa;E;#2b(ZAc8X{JN9^xDGE zd-0}KqIB1-&c|_r$~v%W%`ELi@A7NvIV^XKgRH*ZC%ZdI1XxT@{z28XqCgN9w7(yY z4!*f(I6tqcW2OEH{Zsw#feWxn)z+XHR{L|V>~8XxG%jkT;0)E%m3r11t` zIK8dty=1|@sayPL`CZF?(Qk8KMcA`l z+O=ZLpLcBi9-y`u`?^SUuE>jTHvKNVz05HFrMQATP5Y$_^~KPwxHPN>^-tA@|4!#g zN@=Bda=f9MA~XJ1jIhH+71>~ropJ8}kLLO>;HM=2gWFj-Kp6)b2xyh$e{~!?8v~>N zbeu^IPrG$?oUz4lJu;ccWiT{8LhG_OM*_N%R05&7CNkhB@gT&w{+UpgY z&|C^0nZ*;Uh#Z)qWY)1=2s24jTwkB;_sfO8T}j8|J_6sD{QGMeeFAvbm&3EUJv%n; z1*i@lp)>#4-XyEJiaJr7L!;QI?Hyu1ldiRkE{lh~B~u1l zv74t_oZfe#;pK0}GlI)&*!&jewOg-f(SDoD$7lE$-oEQ$uI@(z?+P|{Ufe6Mpsv8J zH*~DKX5WSF>%aNE=4Ol&D`~F!hL@EMZ5+ANne{uJRIBPb4WhHg68HDk%x1@?^AQ{k z)=DxOdtWRRE*S*}T-6Ey{>C0-=z6-Ht{wd3Ecz5OZPJma zn{$@E?E@!;RKazVb?qA$XXoiEBt>^H25cqNho*qyMQN;@_KvwZaH-4&mI@Ta(mkGK zQA(&8qZCgxuHbCS%Vke$v~=+_5$rV=7M3tyEf zQ*u&EGjPP=ppxJt@_^_9a7d_mVm_MALNndDh7MA1%xbOg58ySPA`VhZ&ciuuxvxGO zZYz~h@AhV%RVg`iKELoItYvNTgTBV{ljMSEr07&MsNh|2m(c4Ni0>}N8t21LJ@dovcf~oQqO%#&5`HwzGo95W2)&qHry@0I*YzLFPL1%aCf);m-Q+z zdI#;@62)hM(@kwM45Ur4c^n?o+2p9Pw0{hTlv*jf{dZI@$`T4(K6) zV?EVtD^8{ajyz~XgV4`I#y}Z{XcEc^`w?l&>{8JUf=ZF$@-cA|x`m}n%jnsVhM(ey|i9YMhgsi{ud0%4BIN0b`bN7C~rA*lwz z^Fa)o)Y zBf=aYK;^*-CW_5aq3p86*~{B>foeD&4^Sxq0r5$>^w9xLk6$`t(wB_Y(i?k*ZnR+aDPt86%V)H;{htyz(A zym_sxMKVD&K}hdaV(XZhP0BOAQx8nN*RrTR&-_zAQeW3HA_M!Zjuj;oZ`GV%UN}+) zl`v!ThLYIxy;}V;3itlb+SDB`bJ?x0l-K%)XM;N~oZZ(e*4PVkqynfA&<%Pld6+dy z=ccJIr7e&|VpQDNP!NfV1c#pRUXoM7X#LSTFZ^w;y*n<7c6Nrcbe25AE1>fECGwbM zG{phsTZg*eF~aJ_ZIQi)@KqFg?)PKLz;A6jm;B>Iqxpg!FUD&n?DCEloY5L2ec;Yy z&>oUB+4~;mR6)D3Sb*+8lAyKCKC;~%nm3*F%idY>?>IE~m_*wY2k(ZB4|`%+iAVfTU8?9%Ar?bU%*E7iY$h>34jIKWDY^a+ z(cE#$NfJn7GBAzP4;Z;6ZrbSX0F>k-wmE+m9S#n>em$Kr*}CC6O*cp{Q|8^u=s}Y zmIl9_x7x>nIPd4v$@m!P=rj{7bMoO0UwJggi{j>cD`Q5Kc#Q_!^@WMPSq8RNc)j(Q zHXhCi7y!x;$r~N1ZS^%`gusYGKLb7jDnC^6JLT0DN(ha;+pvVW>*-mo24W4tPT#1} zQJ<5a#bmXd=A@}t#6M5Imi(m%R^9Hq1bH8JcN5|iV$PUg{FeajD}6_IG76!L(h1@I ziuoRixQHnim`Y7L2AlHpetC4OR>Ef7Jx70h9IB23j~@ z&{t(`Ui??N=ok8%eTbgW=;P@#8p;-eLhsFXys{GjR)tpnYZRu6egOzx&9G@QP(M?u zs(_c8*Mp=N$VSDj1=wC3Xhpnvt`~0?TTHSTO!W$&3SO32i_4e@8pn;@4nY-$@G6~j z>=pN1@Rtu~$sd>HC8kcH?Ix?Lb~TmD<(SNs<}nT0?>E{dm4{+8j)MtxzVz1AVJxXr zp&A$^gR%W6HA;{o`T#Q8pPva;PqBL_bb{QbtIAgi>tN%AZu=N~G?4rnShPuIbxo{2 zrEk?~O`r~%26SZv?LHomb98Zb z$++bw*#irns6-_`Szgmp`ry{>3PcKg;BDIh1>B}=X8Fh zgiXMgU!q7qn$br^ch8H*U`+1{KvqqdBc)7DukCx)_{AQQJ}Qoy=K|9PpClkYLCfTe z$FV*wJayMN>*EG8pXAzkZ$&`4`$=K* z)n1jXPTKtA(pV)6NyZdky_n?z5yd=5o#KBu*F{EAVOWYvx?W&rRkm>@^i|aIjWk|tSr`yoV$b6) z#M*I74lWOSJD(w6m2?zKDvfot>tFli%oIu+jDSGq{L1J0lo957>f@`4Rx$W;26*he|*v)N}0k(!aDmtlCGvP zjK2xy(4Hh?QCd22T1Jte!;K>Z5MLN|Hl^64 zv=MdmBL9skQ0@v;Q>!R$f2e4Q6@e_S6qMMRGq#&TMso-M!h|aJ=FY2*m8(@OyGsie z)pi-9@YWp$a{4((iK_KkPlK{0kYlS$9FtCfi<67JUF0K?F$Szsc!B&BKier1%Kdm& z^kL((JU;kC3Vi!709Q_@@a3L}|BR&*`$`tx^7dl@=}Fo z>~PKJ9kW4;-AZJ3eS<|ZI3Dl(*%caRvQAfKB=ZT;h*ZxHbpZx<11NSQm0p52LYNN34qL;aIUlUbVNDxxW$a}>3 z^lj25;Ww7PUE_9b5Xt`hdV8roYB&qEB0YT8ytr*gXqd9*(4o&?L0l{fG28>{5*av} zg*+4q?Erc5KgOZRMMsrSfIiXS6Sn4Bu-AX6$XuG~*i|W5Iyc~mJ)K#KO|wRE9>11e-`Q+;G-jwpKcsm*AXWuse@4=G2#AZl|V%{_Kuq+@etP*kikXa6>Gw}|Hvnfh)wV)I3?t8a=y70(+B!BX4<`6=7rp!ecYReAMUBe9M(lO|xGz{d z*WF?bmf|G_s7u=A+oXWiJoWhWi>ke83xH&-a&$nO9V;kcKEv=IA&r`##Q`UQR6kb1 zVIfUXEI1s2_iAyo>%Yrff?Gts$y}wy^)V}d?`4Zh)Nydhj-n>lJf0e+hU`qVi-%*B zP~XNEZJ*!zdPHQ^-cOJA?;dyk2GbnwhqM=HLBY95lm|NZ-=Xe5_pN z-8?^0Ms9uHrJoHES_-2Cyq|g&+Xv{f#bU#$2&@J&?}J?Pr$;S1^NkFa*wnhbCpVkY z=j7n&L#c?V2wx{MFq;qb>x>5&HL5S_5B(Uli#(%Fikp_|SXemojcVPR&^S#}A;tZ* z6_bJaY7G$b52v=i?Km=hxAra9DlDo6vHx33adfzNl>RneOa0VR0LuRkWSrdXP5v9m zRH?5g%<&_7w~YCoKvZ-BBdgCoss{T>p6<2pbR}UYKt+YX%92-`zh39$NW@jV?Q~j; zKXc5toSs_eP)l8I*>h{sA8bZq(CfB3Ui#9R7TDUYaGdAHyiG$4oWtL`7}w#6FsZKS zow5Mh&AKoc-p#raxAa+Poy1DmDq5%);L10(*xH8|ZRNXX;jqy>oYu-_DwIOcyRaUo zz%R`fY+~2&)v8ppPYPY{J}&6GaGMF9&6O4|5#(~4w&zCguTmgGxX-d5!SOI9Gl?Pf zBocd#|5n$|jjy+5TkPk`ITaeBLA$`LsdV$#ejYSde0TPsEu1-rLTfg?U21koIMG`) zg*Xz?t{)^|~8FqiR?v`quBXH_=yt3KQPv!jHPvow%j34P6GHf8ZRxD5z6OZ`ncVl*oh=Oe}G=S0x>PmW#iA zH_KTK)(ig?KVnV5ahuT+rq=LJF0snHV6tC0G?(VXs()yGOVqf&4rA2kFXdn>UjO7R z;vb9QnDPBsp0AbHm9+s^Q>G8v0_iGf*hX}mUn3==Zo zw}=2#0TbALYq)ZU;lMtmdnh`1r9(g~Sa>$53uoMe=cIlh=bp zSUSY1Ky`|6UWlLALP)$*ykjAGp@&^Uq6n~Qg9JY zY4@HO^qkA?$h~_3X26+9ic@fc!O9$=Q6C93K{F-w3I(jg=$z?OGL)wk-8RhEd%rw; z+gLQ_w9}^LQ5ZQ8%y|EpV2;VO7=oFI$N7Es-jK6!plq?DNm@71Vj7%j`+~u!#jwpS zQlu(a*l0jq@ST)@J0!#P=@`^O7JZ*qGo?*NUkZD1&AVfpIOPTubXe_e{(DxY9~OG- zIy~$wm@xBJOU0g?lj=@2DYISH3IZ0Zb_BKv)=bnwI>^1IUVPR`$VmWlm zujF$5I0J`yPI%SrlwC5e_b+A_!$`mJJ~9_epVhD=YLh5;8^g&K{s8`|@!0X2z zU`ZrSC~iFO^=^MSQRw;tWSZp7%iG>DO3Bw2($Y&@&C>DWvC~fC;lDIZXM`ND!XqKy zewEIZZ&d#pM)TVJC6=7`Xps59KM_ElNKDVs!f|pLy#kM=Hl7kL?edFBxkp%I+s5uC zu~~r)J(zOBi3{dX`iVP+*@8{F6Kcsn3%cT;;&+p1^XZFJ z)d@^&>nny+i@-23GVR|qk*sBRhr7?riPh(0ta@`_ZASzV@^uB{leh8%c?b1FBq6^| z+*9+{$h1*0{pZPubo77{$Gtks*BrUoNd#^@=@iv1lgoLy%UGIPl$e>x^{5T0CLaU# zIp^BI)T)X8ThfA!5gNVV-PQLgyPn04kK`n?jp+Me0x;l^gg^)MjkjmHawcTFY{$h< z*6k7bOvt@#=cmRGb-h=eEps(e`b=yJmISv}&4+{RMc>2k>b4I zy(ZRN4Ron{S7_yg686vv{(C_VqGK!sOQf=-wlDtOhIXOfBgZHf?90XS?9%?Nx8A;K zh9Fd0cN+8v@;5x)+UoN5UDcFVJf(>dRCkIS@u5^3-fE@_FPfW@UFBxDfr(Qk?(lT`(gAY+{D$GD2SA!WdD%K>oMr zg8qHy7TY~M?}GvY8mIVQr+}Li;J=!CsbK?H6a61Ri48e(u%^EKdTXzPskN{sxlevb zAw&8AAVv1bGG9rK!uo8t+x1x$M2OH?kwRvDguv^_2i41o$sx!5{ zMY~6pr{=R8qiVW2^M{e$Qx{IWo9HlWn5#<-8WckeWpMv6BVp4&qgBAEXS7OY)T%B4 zihTjtMRmCONCKuS7LCao#zJX`o4J+0O%ATx3^~Q=#;1J}{YAhAjAvHsSdgKz`KcjE zF`aoEH9ohn0q;z6QyG#|FtD6#{u@pj#)XihRded(I*L_w!AOyZZDHq6V?GK&pAyG~ zfQ73EjthnihV)V0dx87>;UK~82kd1gp#YQLP>CmAzjuz$56aRZ;~5ExBH z1&C#^v*oON+5rs1)NyI>o<{kG4(I^obg6D6}f?L*zAgI?gp|@tIdB z*s-#Ec2~3EFX5~Mr8-_|uqmj9V-A7!sOyNIG(P9oZ?A9NoM<9Gsx&Vc{~!wMh3^n0 zDW>MMtcuzeU_B7jZ>-QabfIqe$>UC>!kite6Z#(5>}JdnOzd}mc=k#D5&GR+=DhY~ zhhL-MI4?`#tOR*-k3+7J;5jD99!u8FiGDS2U-}7SQD_7cKNbN~479Rp*C>ulawDXQ zo5ojty;Y@Oj<%t>zE6wUJeY8{cugH1GcA%G&^Fn!+7^CQqDCFfi~I<_a}G}QweU_M zrj*j=I)VtTl)_I5<&4!z1;f-yL|#<&8Dsw*b`%W)j?vw7{W>M1Czxi2&^Uq}OU;E1 zDU>ZcPz~dZ($$qCjns64Ita0{Brpw8{M2v%EDoi^4no%8IRhV#q3Y?)(N^Sjh1Xr_ zKNn(^(b7abZ~*U6N25Fcc<0ApGVW34H}pqS@YfV15RZxQBA!5=<@ zBs28Y#sQo+OVZ!h5!>+6PQ2^KiWmce(XH<@M`S9hwaoX#IVg~uVaBS6g%O;zlrVkV zwFf+5J0RC|F1-Lt3rb-ZDJV$ixM{7;qN#mEBn%hDfv6-!>o{syG+_En?UDSAzBQSR zzp!j2^&ut~#O=9%0TSH)@r)Rh_gMxcsOeMmheQp_x9(x&4C zHxeqMn`7%JxY~V8Zdz6oy9(H$O{##^aM+ouqS}T02!?BX~i>N5(Vzw{?jb|{(h_l`bvI-JGchClMYBp;WTAz4#dsQx_qL*sZj z-ZH(GN$jSE@r_I2$~ZBt?VbmWAha^#4-W{1i__7~Ubl&9KQb^*Pr(89q(##7d(Q1j zdkT6X6USXFh8@G})gM5VM8JvRHQI(KPhUtNMgMX~Fb?*n@c|LV*HOKBC4f>k>kkW9 z4%$~zAZmeN3oAv}#XqW3vEZi4%bCUJRDTfrqo^89CLRJ3(Dn5tVREhlIPajw4+vJ`gF;wfjfvBM$A7KX-HG+aj|vMJn1^`>RUF zoN-IQ)_f|gX9ts#DDQPmMtiL`+PaiDb5eZ?vnMf{syf~-S^PxGb1w4U8aj*SflJOF zU=Rx0D=KT*XirhPWE=Qbh7_Os@&{bCkb!8K<_|_#0(HF;>=CXHYYkYsgJ@NtaxpYl z6~MWhmZ&Wu6(HXb+aMQj5-9(8m&7@`0UPVypu*F+@w+5?fNRNm??>lIzPd{PVtd0h zV+xE!DlP9mK zu%Rn$iyZYBKS;nYyY6fm`O<5j!yC?l@|cF&8Apf%$`x&??{$~T`AKLxwg@1g2e4dg zNAz;<#dSEhjjlJqmSF@A7Yx&KUDMM{GIXDC2)jZb9VTb|NqFTzZP^qatbSJx*o!?Z zknE}Pe}Tai+YFp%!V~ubh9J=p91YmJ%Y`OjS2V2j{~}wPgraXF>%T zca5sf93J<0=D0xDbJtcb@d`f@F;xZPS=#N^s2O|OT<=iKlFrV_Oj%pdxtBt)A+eg+Prb30h5HrW%2X;{KG80|-z*cGZ)On13tCPYb$^ zSvpq^df>Gi;vcv^O`&JuNxQGo;q>uo#~)wjAdD;c^R=@Tz(xA0hFZ5^14m!7qh*5F zaiFfpv>z`vzPa-$!FdGG37kCE)viIV)+ z*`PqB!$)0Y_nW$?1uNNHWLw}H>VI23PW5!rY9<%oo*z>v83qv0kM9M@@W0{8|LOD= z)phLV8Bx7|l!^@qQlO?HI4!nPx05xH_!ZT)7&xM|`T-j_3tU69f{d5zjq^+vI17rQ zC&6Zj;pO8OAKZ24IdN?EG+Lv4E(8K@FZ)fU$l!>bzWF(bz)!@mvH=A}kv9zZUOp_W zcxfKJoAXB!sC|j9Kb-8wyxE=pa4u|I_!#ni zSQf0SrDw|-yTy0U>34?n&y@Sl?X`+$yb^G`kS=U5+@+mHUvAz8)WC*OeWwL)gwLzO zanwhT%?x;m(BT3(d#0;@c>JpiuEYJ$n?LaG4Tj8-61KqEol-XbSV?jwAJlNsYv8vW zB-PQohS8E;{Rwt6t{BM~PP+gMFvQs3_WPnC z3JjH9uk`}o?a&h}-TEu$-_#>_ zPxQAWriw-6iVFKfGG6*i#&gTPt?+QWZ)d|!Iovk7(#FppAg)Cp(W~y}hV8ihvWlXE z4^R#=Y1i<+nmxFvG|d#U++Xu?(VJG%Y-`+Jygu)J$$7{Tlp7ouo;m{0GHuXt&A>b? zgDzo4Xo_c$$-pKDlnGRnwcQ~Duf(7@Q&APf^5~?#Ilxsjl2HGlOdvbrk_}q&gN~16 zPhyAn564J10bSjIBnI146b3gifHbA=X;_a7fdK{}fg?)BLW@w7jP+=_G3WP66_TII zqBQYS3l?koWdvwE*BNZ$M;H?|ZQjhVl0eL$6@)2>fN1@qCyK<{XAw|{#J(FDL74X| ze!LY&4430d#uzqeRyo5aPGc`TB#-u%6DDkuI1sV?B|bswK_}c==`YLh4{95+Z^B}X zQCV#y77^qn=78b+W2!@fz{nNv+ocIIxcBrT`NyyC1= zJ_W>VwQh5&>7UpHkAh4wy1&peBU#1|ie*Gfiseme(RXo0+R6CPeA|+BbHUt9A$L|l zj%vS_jfM#3c3p^B9HYOH-j}BVxhi<}qJud~+KF_OqkQG-qC-diBYqWpKpU+I|5-@? z--X}<*=VZK59`qusautS0D`1bv68qw@c31^=mRbLbxZf+$|#Y&qoa0Bh3$^sc}hlh(_l+>tU%aq zG1-36C*SMWV!#+oOaUd@;laq|u2^g)Nr9B*5#9!GecH}?;J95+_ByI5nC7t% zH5%PpMP&|c=SKqsQu6fNxx`m*0H5+pc&%#~3$b~e?;z!a{2{GumG4fa$21PNn8wAe z)#08T9lK4Mj1=?MUIPpOz@nlGeLnChwsct$%GUNYRg4wOO~MfDc^!}X+6JIqq`qCw zSnSpMoa&$dr{Dx?b-f_57ke)dTY**XgIr&Xvr_ZEN1W}S63KGVLDz5Vn8O<$wrG;( zAuQaovHd@F?muHEpp%_#U=*Yxi5Xg&QXR7Aykw@J5e)2%UB zWxj855|lQh+3&AzW9VeH^%;vqVo5!CDxALRLWg5F_#dDcENMHwnA3ZE!8=Pmm0C~l zb6vb1Mv7+hrOf6P+ei~}-57A7108u)5ty0H-`HxKI8LH!o(T{MC8NiupzO}wNNfDt z`_k`2;^d_Y=G?Q2INN!|L=$2HH-rxZCbWn?|A;z=lM7`Tjs4Y0O0knD47eM*c1Tr1 zi4iF(L{TOC$aw4TvHS0*qE zF$}(|&)WybV?7xU2*<%3d}HYSQnOds*(JpS!}%oDEZ?g1S_3m7`Ja32>@F|iq#9Sw>Xw$1kYuuXkE;0)M;P;}Pg=Z20JD>&*^MJ|6D*H~_pU;+?in z_{Z9U98=2~gWlB<19bnk*RLgj(=f+BgLSWMvh zC|G}ue4e$>5W94XN7zB-57Q@2MTzKq9gyPv_Y~(amtp>yNl-GKXe`~B%FcO)y3aoG zQ#4Ttw_**lnLpA_HJo_K;iNuo`v+ApO1ALJ|MtD;ij3C&8EFXH%20E?~0_{PCV+~9O;oN4K+j}3o%v8!Zd}fD1?6S>N;0zZ+>{1 z#T(WVhIN#=bP>2hirnx4zgM{`U-1EL0G*^Xd$1(U8ZDCRLDu^c0FImSTV`JCbbuc| zGKeV?2}xP21w2A}N?h?sX~=xog%2t(YuD#%JJ=U!{D4fWp@_P!~8yLZw2D zsucQ!)TC33)qG@4cr=yvC{bvR5b`@Rt5q{Yog01-&iF&56)cm}w>U6Y$QAMMd~$-f z04=KRJfcu;f=>7^6DMU{3F7C_e8r6uk3pt$OAWxJR5JislR(i4UmZ$p%W-}W%b)T) zx=8lgE2vapS7(-zesxM8Cn(vzHeQU=j4MKHQ-WHQ=ru2bToEC>)O|;^%!};2gsjy} z%WnTe3OA(*XrgA);L*?T0ePd-$Hi?x(PIi`#ab0+*E+CyPKy z{44G+zq|*?)jG@58L$zNM8F?1OR48dxb=;jC_vGL>ew3W(p;7G8}xacR?t}QC5QJC zIxhrjxgQTyvUP8VQ-zo>!~;cLu)JT7RW4cdo_5mKDJL7|cMy##Ej96cfrA}NXiq@) z-zXb$+^l$_8uvl;1qW+)HU=zi4NAESnr0yhiE%HxAp*e_ob+${I*XqCG=Np0jlYeXd5I1YConR)64m=-_#O$8Vua_T-JNvhTt7I%{dg&;e zLE7c-W~tZW@3(|$p-7QNqW)UV!}z@Xdbt{?9sUURwhrL+*>o?ko}*9nc~=9@v@xva zo7#W;OuyJHHfc9!QhlVIR;7GBDsyqqZTuL9YfNV+A}Are#8W#`Ao%8h1_Rm0P#_tE zJ&4}c#{UG$ypJ69BCxce*n4BbpNz=j4_+0d?yKk-EiTiZy;GUioq)K+`FZzawTE#u zQ2s)Jy&g8<6UXOeZ*Os-L>CSKiS8wW4fqiZOPJw9s&QmK%==S&GNtK!p)=k4(qpke zA)AdUiXg?NKe-n{#UhK~G*(AO?azlE7H_MyvK;UL!0je=C`_MZ4UqQs`unL<;(h-eL zPE_2&|K#9FhyA5*#k@}vxwCpHhB5F%e%&-xT2563+C1L-9m@v}lRG4npb2wZmeh^) zsTy0f6mi@NZdm;fJRY}h*0;*vvP!^fC6NXkXdxufr6Y6-<8~sUPx?O2AWX+*!I$Ts zRSXVjs5A?@t5}^@VdL_cSQT+ogMw?sf>QzcP%9&Cgh8;Kqjw_VT9C*laZxt4iF*0k zYAKh9Wk&h3L7BfE1X6IE7-L_0bHXM%W}xYHT`xb2SuUJtfdb3ev~p+dp>#Z}en$~K zi(X}X*wA?8?X|OjO#3@<%oaoz9#LbD*lS!;d|>!iW!OW>`79!t!s&UXIhkX#m&3}%olp`0t;TvYtX*HFtf{ zOBmKYz*vBpDGv+UTo_nJji1@o&ol{mvJ{m?k;>eoC@&q&e`&Q}gJO^t27A;`6m`Z4 zj714}as?Qh3KY8xm8DB@WFD1<^-ISvkgQzv_Q=qx zbu7&)zFIv`wXx@iT?3Dg`#EJ=Jglj3ue2H?Gup%#(_+5?&7gD*DszM4L{tPL$q@dO zCbXHy59xh(LYbWzb?S?0{%6bKL}e0lf#Q_7N>-CAfIP7akAYWazdDOa?7+Q^)(-#w zqv|cd+6tPsVI)X!hvM$;?!{e;Qz%f}iU$i&tS#OKYiZs z``_ogk}GF-ugzxn?94rznK?5F+)1^YXD>E(+A4oj8OhwDi(DpnuaSTi?NefN9H)IQ za@b_@&^+pD*Gib4HT?ula4Ym3SGxrjG~!&bQqyq_nrsY{RaWTtGrw@CHNQ(15nSP< zDz|1z)79|Ir_6E7+7uTN3^I@$q0Bi+|5v_ix%%-XMcv?O>7`GzcCs#AgeuL=bax}WFdLA9KhY0;r7P8b1yH`utnwH+zRJ`JG;WL}8UHD3yBMz;>A4>Z>fFls_&;HdW@T zAKk7EDU;Y0*Nm>vh}B%@@*@QG3(#aWkLSFcUePiq-5K2Y9+n(RzU6S~=cbc_e<3#` ze*1Fybah{--!d#G)4*MUjoOnV=Z|3wJ09`~xxlHk@VruNaLCgW*-%uV%ZIjn36{;* z&=mV8XQSqa4;p7CBGv06#YRytNOc_UibtQtGj_X7eluh_lT{GGOmf;-o^(fpo<{D` z{#W~ERd*>Iv}~o$gM)-L#`RyK?9FS0V~>Y@t&tT%l>LwXO+A#IX7qx=548nDC0X)I z8tbbi)xGax5c9?q_ugpud6y2meT&QGjQuF1?9!nnU0RF9lGu5SKX&hUt)+LgWx6m2 z?%y?YnCPb9LuL8RUFlBiFgs)Sj7fLk$Udu&R* zW&nTaC9k04m-p2@lt`QVd|oihs1_7CoPLI1cMvDJcC^5&VP6@iT#MpnAlED4aVO+= z;L3iGOAZ0`09@TM%4+~X?(#8zZ*k7kWi3YdJxX1qkvqeNSuIPcdFgHH_Xa{;lfE0L8G3Kha}+%=ww0soQ?8^yLjhIZZxarGgl4m-BqZ+k0bCCt(d8-EVM8;EnOmZqTL zobQZ&Rl!mds7WO_JIn1X;gJU@>m<{JB&1eb%W@(nQJ+2-2VA_mzu^1VT ze{(a;MqQBgBhHb6lL4AYSlEv~&*y7WP<6QT&OXcE=?3gh9iOGDvoYEY9f@|XuO@=e zWnI5bZZ`gY>f|yxNvjJH-$ua@C!S60+R?K%EBz6LrcIL4INVglY!{K8eNxrUNfYFh?ZAG>Nkw8`Yf8KR?xh)Jbf=CIxWUqPcQ% z-SX(?RT$rWIDMDz#l(x#)pol&F~;T+Z7a1#VHp#i-W=PFVyrPY~24H@n% z@G5A;jq7pw_BlOZ9)0CP`RXS4&9>V5_VZQk8lh$fT0GW`M$z#b?wE(m-kqrH_iJ_3 zpOjfb>h6!iCAO7Lnzp6{hEz;DjN_Y*$KNh3{Q?dvyU7zfaE^{?$CfNF4uv(Noj6mo?$jnjXYJ z9!&8DL@n?2%v2luI&sA=k;H~*{GMiXiqKO*-SV^aypiDV^oOY^ug<A~2H633BdrTR2-VPAyz^VssaAX4B8RpM~GBH&j~}*k+y%)twm4 z=PcU?adx?c2v_gMg-!y?a7?P~Bmek0m^PeE#6Q;+P;IvvJS|E?oc4=c(b!^kKf0@k z3xZ|co!#(W;}R^gb*rxhZ3|{MtaK=vo6vHGE(iI-<{QI+S;YXIDLVxeAvka zhH$B~;h|$#4ZdRO5kY_kX{D|Wvv;at7cA>3!M~&@!cIO@ce2jBuTeT^wZ_gGwLKUg zBCCI#!*blE5&0o26)hzF-98O_l5YQ^DnYT2cx&;L$OC`U^olCOxZS0mz~~5Wy`owM zOKd5Mp`$@5v-I=w%A=CZ8P|ZzP_2?(UgGRmNs6n9HAtxCcny{|J^!uZDC0E_^TS#y z`z*9vA7F5%aQ|Fwh)4KNi#N)M5Z6jbPg=znbvnPpZU^F2q zZ-(ma-wV7RtCfV{Z_ECLZG!_n22Z($0^OXq7Q-FB(Wv)xeA||v*bbkx%vLOWTqrQD zK{v6SLLHyjqa$q; zfp=$hRE;)=)Sq~3e3SRtm+Y~+!-k&7EgDu^)TS(}16CSDr5*dXt7AT}HV}|YF#k3V zTO90;h+1lHAKhCqrKbwW2)j9PHnI+fcKFHtsias70N`PwPj|r{0y%#|^jBLt?{o7; z2sOX(+?VeVajnjMc{TFUSwk2$YJh3i`<~}P||JCdo2gUy-#Zx!^}`FjNw}*-DU|K ziPW8YZD)iP9&YEDOF|M<(|D@fIz&LjsUgr=9~Cl7{K_b;Nm7D^7FJcp zIcG=$vKGs<327u>5!G}tyba2%6c9HBPL2{CZjRbGNIH$aGGsw7D!-77B^pD&!=r7i zdTVp}fPBcCH#-)xpd(Ay5IRa#yR(Dx$+JGIL3tUaV>jaI*U=%qQ8(nlg-EdQR5yMd zZ`Wl+qxNirqy61o6pi0TNHX6`#}(J8Pjooc+8z>G#`}L#q_R4V2h;pEup@S<7|zNH zS2-nc(Uq2Fctmcup@^uI2gXYoe0RGBD{pLc{~V*Y)#PldVQo>4q;Z-zNZ)7w-h-$o znB|7m$57)DJ84>)T(lCpeJ;)}dVIv(ga3(8+ApEK)rJNM4>mm%GNtV9A-7RaNLxGf z2XMHnW;%IBSvoKH8ymN7FX2q7?%rpo9~`G*2RLY&6;>vQwL257*z^&j2C;Dtre3w} zngY)}MZqqm9iVf?t?ck}4lls414f(dC$x!3~HNFQDk74xN?ZyOkI zEmo6rc|FgY<$sm^J=vck((jG8m zytCh_Woy}Pe?Tj$;5`;KOI;qlzNl}dy_tJfhn!|iy|@Y*-5YZi3!x)ldgs;G%3Q!6?D=~%7JV-V<{upOZ6`*ojRl> zVS!kBonvlmdxKV|^*VpkD57{qUd2`n9_Yw^xOwQD)@4D;uk4lSlYr*z4Uo6|@i}c5 z1fRZ*b^W#A$i}v7#Upa>^q@=ysyTB|IW4COx`>eC0RD!#qBrPTfu;?n%}1SlOkZLg zb7nxlC`7!0-4j8(15d36e6;4C!+9s6=wO2Pk+>UCUJS3-BDw!&d70;DOi3TcGV-@> z7d;GqO%flg@`L>;V(?-B>PY>uS2AiwjX|bwReD2aV3bw2@_pw8h!ow~aw5Yq=JUz7 zmcL4tBpcw&tE!9@Puh@vlHiT_#K1QpMpXXr?1?k!nt1-7f3j7n(G5dIsvzbQ3xOsy zl6y@&Jb!pPa`}jqk0$)ff!dQQtBhnZ8d{LQZ`m##vr$X7U;xc^O2#|>@;UK#EX^&8 zHTnXgtQ?V=vii7zlRs2%UznTO5eD{<-TUy&5b?~I^T2jGzL)Pj=KoAJnrY&7Wz4GH zk9=v16&2yiZCD^=kk*{ITVg;zO7FgxVNWr>^napQAR&w$oR*#vrO(_SLl8>!QiMhw z@$UlZKN>Qx|Iv_rGu`^9Aqy*NdETbILE5m5SGq+Nb(Vk7`&w7kcwJ&=NRM9oUff3u z`=5fW)$n34vom%oL&N9pF*M*%6BKq=>V09kyN}(jM)pUvwDFC=(=N*WVcM3{;b6^8 zyIf>uM+Np*-HI@2yylk_59gbBcdVqs<8J|i`NP5?cPK|;1}OrCNcl0TVA{WRmcFm+ z`~Jl7tT3j>DZCrUi7@%AQD*ThojmUPP*}Jh>K1aowkZ{Hd~;`Bt3;^YFP`(}HBP_} z1)A{zEQL9E?hkxg=Q9rK;iM0a{4!++0xFqrQr{E8SX|b%(LqkH;$BO<>}|b; z*hPLN0i@w;Ld5v9&kR|@FWk!F$6s@zQ4X@=1a*?Tean=WPHKsZ<+ZvD?7&JRrEZQ6 znr4qd1DiG7hw85RurX8`hU0H_EJu5H$MQI8vw2I(hK8)l#;9Z~6S$)(4a9BEW>-?> zs!@E{62lMnIKD$C`V8h{|2^vyFM6hEY0_~#KvJhvsMeV#6Bsy@NoX|yyLfmL+zF-DKR-nA& zT2ND+6q}J4<)`m;`z{Tk9{mh7VJ~Dv{HXiJ zvH2!v>8ZM#-vn%8WA?XcL6uA2#Gp0!EpEDqyerQq#Z;2i?;J-`EHagEpsCD$>V3&q z1*wIGf?gU#S>-laS6J%P952LK;thYcF(4sCP!;;thJzA=iIX zagjXrf8V-Us(*fy?6sDkr(ap7{;QdjBWj1~IR8@{hzs)#T~rOA zQq)phCa1N@lHtzRb;=bAeW=^gyMM^O1XL`JUP=GbaX+^4iEJs7qL&E6qFsxjR147k ztrdyfv_Y^UrjBk9t^WQ}?7n!;cv4VnJ{~z_Z_t}@tz5u@A6R{hL%fiAP)Qsr2t@n% z!PCVG`4e$KFw4VI*^h;)puq{nUG}vLu+cD~F}(T0w4ssMoh@@?$$zUUr1|k7Pcyek zpzkH&-~ZBm=oXy{lLkdAU?V`v=KldHA;EvTk8dUx|9p@Bfs_|*pxTVN8wPTVq8$&h zA{CB%6oWQuMf{q%=I)4hTW0+8)K_0`%FcmuFV1gg9e0-jAc@Vn`ZwYDvgP_sA0)J1 zf^7^S+p~8`0jj&rPltoPzevM_$`^B54`yQ%BV?$?Uw#fOyrg(1t{&Li7u(V6lYyOs z(v2;G!4<11GtACK=fM4$5liI0IG}+b!aC$l4`O$+6R$YF>hJj#b)Te>BW3+9>&T7e zT#QI0F^>kWlOdfdmfjF02)AS$d{W|Z0x@_7xk*S!{Jjc$caJ;wy*uvBVl4U^W8a>1 zY@#;~aR+#ma)r>jK8PYJpRsf8GR5-rT;@~@WQgCT+fVhtpSfZlzha5X6n#yh0Ll`~ znHqS9E~2dlnvzid#r<<7NosS63)fikas9S4&E_E_CzUWMD?v;wCxFV%{mKQ2yozSr z=rV(rk$n$a%%+5vMX>V)*qf$6)aZ#o6Zy8MeZ5g|pI-nSri`V!OUT`5DLeJC zPw3bqiD&Z%+D8U^rYt_K{K@z$Fh1V!_w@_QLV`bOg9S6bZ&)mTgS&_XKYwiwF2jE! z?RcMIl>I1$7rPkgA+C2QuZhvR-Jg%jMFYl-E%xt!4J1DP?J(?+Ayf~e=8LFoT|Tf} zDs$BXTP#$h~&=!n-X9=l!pCMX1 zZ+?{cK1XEYd+v&_5r)d?q7kyK2+|D_QYSIe3NHOJUW5cv3%WcVlDt0(ra!9f8uAPl zl4C3uQV^1SBQeq%ZiEMhybDqbQZZHbs|vesob1N+{*!-4=GrB-4qDsVfRet-R93RcqRW_dH?SfA?0IN<0w;JT0Y@dWx z42#%*YMq~xOrRO&#b8wVyXD)i=r$R7-*@P>Q0+z~q0zI&S;`dqq>gtQLH!e1LIGp1 zQ8h)$Vy}@*Vv=i^1tcudg6gA&u?I+EjQutOd}3z%6+yj-{I7MSFKxHb()Y{X!_9O1 zz(MWvfQcoGkiP0ls#x_FEiECE%X`SMM`gQ3(CT~#x^6rAw7=4Fa{)ca&2+U#uO(Xy zZ#yjOXadtZKxnDMQ)wd%uYEz56-$KSI zNj*CHT!QEPRh(KpU4ZK4aQ}|V@r8S_|5cctJ0A&?X2oL&AZ&js9RGW=as2;ne>Mov zK-m6L;CQ!x9r+jB_JiE48Mg#80dHx+U;KF-HyT^K6fE8Y`*aKUxioR_ZY_k4B1 z<17afNo0i9lYf1DlF2_{8o%I=N49RykL=cQ0)bKYu0??Z`oFrU-Df&Gx{-48ipu?( zFJgRGhQDW)ov;nx?AmwX!j9nk%z5o*{mAEhdnHtmHoM3&?wrle;fLE#E?sypx!(jA zd;4QLsRyUU>;f@d)>`7jS799SD)wTugTe8Ea}xH@GH;5cK9JKeXzI1hhVD;vzCA%0 z|F{|boR{BhYjOCWWiUCn1{;H!+L~i1xlXoY{506?hY=R#);bPI_I!X;V>&gvS>hZr z9py#RNSNOf9uV}czboGNlOox^8?v}E=o29r?P@wp=|O+T<`!YNvnHgu;je);kM6Me zsZaD1V`1+^N6Ec@62b2Dn)I-hRN|wJs;Dd0jPpJcugPXFQluI(1J{GOdox4NlLWhRYLhZh3&F;iIZH8 zgfj><6s2kT)O|-VKn)VRa7r0Bi5iy@zsP0_Y*{wr+e5m~1g zpW~M46q{{2fxryoba+wWFvbtsQX8fEw~zu=1K?oU-GTEo3OwRvy1o28=UfB9$C%QS zb~cTa8Nry+KaP~4PIxSfE{-mZu4N%X80y~fcLp-I%YlFqcc=;@-Ou5WYBCKdf)B{C)QQqkAXQ!p3OC#w<b`esA%P3h8>)d#YKlW|8%Ln)X@FcKzmd!shlBM{nPW?Zp)(i^>S?p^xnC zgt%fBgOjsfWl~;D#$HU0-p!Lc2iZd(a|aQ&xi%A^M=Ln5Zu{VEyFRX16RKDjmPf1E zI(74ZhO=)!jhwW8W{Qcp`*_lbv5nbO34lirK^-P~RK%~q6t0#&7LOu!NNj9ZV(lH~ zXg+mVd*-Ag-#C-EzG3Y-*2sIb{?DZm%k6BF&9@G7B7;${v0_$5c-8G=s}xz}uSIV6 z@7(UKW~NulZ&>#!pmo`P)aSD8&@1(`%Vm~OhQzC(XN_Py0*7w8DnYzdcn zp0ACb(H1rz(Tx9^eU(lq7W%T*QN0oLc-mAnAz;b!`KMOAve8gObhB(r1v*+&A=%9M@QTEHf7M2CE+F)WW zHHYDA$LyK0w+r1bO}Cm|ro6AUYYwQ%yA}^p0()f%RqtWH=yV6h@mm*s*NL#tGlyE4 zJQf^}C2oI6oXN?|@X9@g+q7Qn?9tUU)Qx@Ib=R&dbUSw0*R%MhmNsuS_KMoJpyTnu zluB>2b4g3MxZ6>z0++q!b4v39L>!>y4onG^vshE!`B<3DYuT-iNM1{jns8g0h*|N` z_yOYuZ_f|K1xc5x4aT8h<+-WOYxWlkv*WvL$iy4m1kI&I7)3Z@;5((>U87xvr{~x{dZcof z@qUls69aHbtmeO>_M9{y2~)wpT1O%x_RJ~$muUIFwz%YNmjQl~m}l(X!51V|Q<+tU ze*FDkP+v!t@J9+Tx2jY9N=;EQMr0iMIMyGIDjk#Ln>VNAF?e5RRA*bAW>@J;a!|Fx!rF#mxLw0wJY|3~59JoOACU_g4wyLV*W z9saO{C!XJS-f56TT)V|YGxAs8)7B5xKjXE;`6Q4pTk^8k-SwJ(Hvh7vCGyOtcuw%i zg(9b@$Jp#_#;%r>u=7>6qNAk~yo-^?3M(>tK*MRgE^cFL+aLflT`T7Mx>-iMX<0MV z=?A68eG|j(=#+~K7cv@eC{>xk2aH>SMM{fJn$Y-}FBbyO%qm$^;Q|YJcg-s@V2g1? z`qmy|8zT%)*d8%vluk`#1TLnPj+#`o=;bdWxbq3INh+)#vs;@2Q?XAyIZP{LvyQUT z0MHYyvW>smCp|NsGDMG~Je$tnhp|n8dKb&@Th%0H>D%N zfb1JyP8iPZI_6?KY!4~ zZ}Nt$2=uV{yf73Y_UkT*KdscfNWuN%JlE<+;9msSCZjqTN&e0D`5cjZqxB+z#d$cRzvp)j<0;n>0QP0^q_yLm0t~JN@ zabL0Je>a-T6cWkv+1!RKZm)WAIi%D4UAQkrF};c8(u*M?eZ*B;*nR18Cq9&Nuh^V^ z?A1VE`%{y40jbO2aHg%c|9Z=qOZX~YGR!DaU~1$p6UzfY?HXWFkQiLsUt!0>NlG@h zxpn;w&@WS4afQNzYS0MABA(VAlDK0J-7UsQWQyJ>JDM$D8^l;v%d+A;; zQO*S6C}WD9lvyux>?JYz!XXV5ubCpGd4Ce10&pA3^P4!OB$@Q-dB587dX--<=zYJL_MvP5 zZnk>v`*iU?uO0BSP0I+)Jzw&KSpR?q#!Wb_YL9vVAaPj3Wj3Sb~=^bYa zoOwt6vZ8A@K}h^(5Sbcu(-d7<=zIN74*)stQ59dnDZG54e<-=y^o7jLZ_ac#BW!Y% zvw24*lD+yjEZ;$Yk|7cJr!sFqSuvi=3`*|bUS>ofcLx?T8r6*}>!(ORe3w@)5*H;A zUQ<|1m^q&+yQwMJ&ee&SZ$|{)$NB(KIKK4~@Ubx7SPt=yNZF_mpyHiY+c;onip+(0EnP7KbK&`5QHxKtSeA2JC zK(**AHf*-VSP92A*Z5)EYc^ksZ`uAJC%MyQHu8J9gBiGtl8}qD_i+76YZL|k%PkGP zL1|J-LDsjoKgG>?ZTiQCPlJ*(n)N(7yMlxm1aK(;PxjS zbz^4dyILi?!r3WzPZ^2?>_%DvZ82is`ogN zUiUo3rX062CWtrUKfd$V3AhU-wq+X!4o0*GUPw~V2EsM81ck^+fwnRM(@5JX~^!FG-R+_7v?ocEba3Eq}4qmmae@4cy2}91CsKPA$@^CU<~0xXyiFtU^lle zEbf^tkYtbe@s4+cSUUL;fd5t+!o*ty{nIZG!w=Afv5&9?&aV)I#@Z0chjOGLO2@je zK$RkBN~bRD?L1o``z4U}#RXuxuP_Em*slwt@GgR)wUL7{W(uMD$%y(xAruW&1VFd7 zqYH~BWq?PC5rdyqt7x+6@c{Z19!EqOZzX0E5q26_I6pRuC8~n3)MZZ_nFp{pT?wYm z0uC2#B?6%#CVsFDuu)-vU#Y@Q`N8MiM4(ny_`D+QMHKW_VhBKoL)?w|5{8Qh_BB4aR!QnXhn7u4IFkEgh9~mJC$_&rMhXl-E_AYC{rtkIuTYJp#R#}LXKA7(t zA&9LIx@H2fF`INLlc7lTZ#;D zPBd`C2_xK293qAZ4CC3oru(^|mp^1Z&lmUH{ZVYfDG)Pv{f5rlm zQfYtyHrR@=QwH$!L@OhlSqtVK3g#;z2Cc+GiK!uNb(p>AF;Gw6N1$vN0q7ko+>Q`p zN>2cCO@lJgLC7tDVMXHVFx3SIFy8?oXo3~);tFn1Vg9#(VI}ah6h0eV<1M&>ivjMY z1T(Gz*re#f{LKEd@O^bKpCtjPn-OtJ1@q|;f!JB$ujFCI#(?mt03BHTC+Ijkz~+e= zF8Kni%Lpi{1NMeRK>MPM!3_+Ia05|DmJg=vAt4Bt7P15;07#XbllimWc3CBsLC;tqGtb2lh&Sgw`-)_VR1OybGZ`GUy$KOeR7!}GA~>l8&^P^x6}~6}aY6=rDiDFzvY_Ka z0Gnt=`0o&~+~GEYJTzf;0+1|AU~h^JYzQ5!djqf$XM`_^6M`U!Ej1+WW|xQU3VtcQPzUK$JX8y$H%A32|}- zd&&`jnDU`(ZU~k@Ocp`*0#cAmW=Jf8xOB8(tdtNjW#Ch8Lkx6~6T=9~D6rQ6K_Qm_n*s&cH36U~ z2-q8<3f9d*{2Y)4p2`X_#U=s;YQ4q$_z zHsKT~4+uQ10C=X&U?hCz4I!t^PEF~ja&wF;S123OB1$$*j5sHIA;);4@U4PB9#us768~NA^;8* zlBJH>n;8q`La^zYJ=jJJG4)awcxhGHvJD8cS6&sC@%}%&Xj}$(E{G)tZ6hEP4M2AY zltokua3H361R!@JNW(xZbdCq2>I9yS18i9#Lrh5tK&JqRX&k|0s0RV2Yy=UglLh`u z3%0>R1j5CFn646l3eX^ZhiSy1(HLkVHNZxe2@WQOm^KlDWL|+yjR_xJ(lC3Abzv;; zz~}e*&|@;p-ltq>O*XLiM>f=^Sqa#S;Ov*10KO1n5CnlC8o*xvOlTJx3w-!bl9$w? zI(=Lz|D(nZ3S{xe4>i|BO%V3h#@_Qz!K;)b+?0ZjEs19CK~H>KU06^I^dT77%aIBV zeF3o9)qxdo1L)>~VFmestvd}EqyQ=vjw!oN2(saWh^=7uVx&N)g}wuO>pwvA5&&CD zS};-uz*dg#KPEZ9VuC+_e85S$fUQw=7#bni)0zM@#RM0{hKQvhkXk|$1{8r{e+Af( zF~Wb~Krj@*p5(-!SM>1E18ztgIc6_eJT$~10gB275o^cn1*yP3z5s{krlmotf&n%O zOz`)F5H=66CmYc}nK(rUmYcMuhZk$Y3akKhDVV)h`Ou&u=s1D|LUmy^kIe8N$dIf& zOxXhhP);ILDv?;4lNcmb2=%-i2KM?yL8W*wWkJNCHa&pN4ijAbC9FaeY{REQ^p7OV zC?HvI%-#}J*w=KZR1K!=J@KP6Tmhy{59Y&S4s_>$4BLPkR+-=i?2uR$unmIxsmcIF z&%h_2N6$d8E-_#$0|;3fAbNC0uy>5#Kk~34(S|XnLRm1u=k3h!pBNC&%NW+cqbO(> z0$e&-z)1uE8)JD`M+P);7!aNvl?a_9f{80o?;!CgA^EF31D-;2uCpWKY@wZ1{Y$mjcL(;#IY3> z!GBf_riZ7pKrn>Cd>BNJvWoQZ_gs)HY@qB9LJ%+$I?fER*;e{DowgTbfGrRke1{oQ zDF^0LCjN&wuF;sX%S4av*0%KUO$QdZo)*kc3t;1^4SR`Le-6+(n*|;!D*++D0?L*U zffTZ#hB%NVDnbx58=R6Cy!CGljEs<_K*E1w;GP3~-joN$J_Hn10K+oy0X8kH@Dml7 zF$16|3D~QW3dME+*xV|?+Ez*cHtbCBvnKbU-$vkuJ7)NI?SGtJBnW(RpnVC}JqFms zEBzCdHCULvYHF}+Lx4>_GyL)qfuBDR_qG&4=`UeJ>fnYddbo828=Q9%^GOx~4mD=L zUTMTw{{O-7GlYDC5fQfJ-*1`bKMW7_&&~_~hS<)c@v9LqJtpp#p&hzgb z79Xy6Pp|Lqlx~KHo5EWu>rF6X7cd%k(ifInB#UdGj2GSdJh_HmO=jBEpY{V3=`q2! zT3}oGgQBPzG_hjRf#cJO3sp~E7LPFtVY;1yH(hcGi7g3n_8;B{MyuS%OJAF2F0g0K zWn~-Ws7{s1h=ei-qpdh_-B)nXsd|^G%X`vQn2ibMuS30c6B96BYEpJw{V~KXZ6Eh| zH`HBRt>e5g*Cv1YNs#1pVL6371zaka!6Nz2&Q*O|YK*o^lx#Ltg&{P|h?O1lXW-|g zB11vXF<5%$ul1XGu`ddGlBI^3e<4|9iSH<8`YWx_jHx6i*cBVy@kCzblDFi4R#7ex z=k3uqu_uTA$}jsd>?!s9Gf2bg)6byH6FNl9^13gt^r7Y6Dw;@~UMHC}bpusSdJPpk z+!cZ@RI_3d_6G?t?HFF(O#JBFt zf^w$toBY4V>$#Dw?W9cIxV zwa>g!M*hg__A0OR8~6gqV&r1?4x-Qz>BAXT=H*0oq~=E$%=9rX1U4i3A2sb*V(N6H{Gc! zc$Ee!+iT7mC)vzZ>;_j(U#9hPD@Z>{%3hO?6`tU-ZR8k|7XMZ^EfRJ!$S4ua zyY5f(m(iGg7p{DTL2mYkuU5_H3%A6ybEkjvN*W?kAl&3}Z#C zJK>L#+T151oEv|C?vU2_cN+$S-0N&$Xa)MSAIF$bW}w$Wy;#;TO0fK>aWOE`XJ% z#8Okpy)wdeq8RtTRMr32zbn%siAaDXVoUoG{}6)l3T^F$38^rlm$s-fOH(I4l`yJd z@z<6#9Vha2*p|#(2dPUbzAIg^ug8|Nu2ZnN6TS$o99Xl1#B9QL26Uz# zZ{x@dyzVr>M)(`;vvY7em;dMw zfrheD6sTIxNKlJ?C7Txu!f7cI-*J4k-t)`qK1n4t5wqBiYoBo@-}?%TqYe zC!o!c8`|!4k)tVwWq}qhR*u>V@(fFnrnEK&g%w#nQ%R;AhKbnyN!%)GEzf$u&IJY@eqsU2h~PnfpK!~QZ!YwVrjBHTv=IV86E{ zpQ&M?(^DdZMvQ7gU{vcXH`N|zfbN>un@^C0%Grw0b&ij5=i)T&@2{4VMG+tT;-WZ| zgV1GuX;B=i!AAb?;FdA+>I|*b>EeLQ9q@cLOZs;i!Be}hl1X!J3bE!#8}G5vRh)3R z(62vdf($S1ebP3goq8(YcnHY@U#dqCnQNk?>!ky}F)ITV)WvTvJP0DAFr@+41mBgS z+2Wui3N-&yrezdYm@x!+|7)jZgb~a$b~j(^viNiRUH6+7Z|U(mXgi?+OI?gu!wBO44pY zIUg|Y_EVQyigb}+>!fDZV{0pFr@2}f6}g?iIZst++JC#?ew2K-umGm?n>Ot_@s$(F z`a7UI>Cks&=)2MY`ZgYRT5-_yrO%Z&@4oAx$r<{^N)-3+yk%>f>#&>Wl8b++`UhD$ zE4?oPavksI1+LE6miWDJdLBkaaA=gC!#F=3g`a|DRpiVz(X^MJlC1O=IzBLcolxG? z&yvA0{n?7!itF$*gXZ^C3|#;(MJI^kv`pdW+vTXYDV!;YNQrB?%Y`U&5*_BI8urU= zGW=LJ*S{rY1)4V0H=TA-?mRxswh5w@G3As#FN!{gj_Ao)RM994%FcfRjpZNkcO5>&lMe~0mzE9&2m*~2`c|5tYx;-5weV1U0vmhweEh8R&K90e6ppL>y!BTa; z$-qUYeOv^sr2uJ zSfrv(Cqofjqc;)1hFI~4+Idl_Yus8D{+ty&w6(5^l3UWeEoj{q9?#+|)WTI`c%zDi zb!M3PflWa&(l}1poJmn_%vEIbVtCC{uCF6+^i)h2*!Gz~ndEx3aGmAp5yh8*Of$lKQU`v*|yaptrCWIaQ)&>))^K z_l5QhkB+_>Oedlu$K{{Wt^ajn^j07~y z;x1^E$aG5M98~_7_DebO&vT)7LjYj_rSL%{7LNI6f$+~C#FTTSiB|}T7Bk;Bn!Y{g z@Eg3Y8;IUC#A~_!@N+dZKwvLCv+&7|_y_a?H8Gs=F>W%wDRo*qrAzRQ;Gnfd)a8vH zDDvg!5x8maNi(>u1Zs?B{e@nPq=5ufqgS|V5~gn=q53j56g}JL>#4#) zDXBy$PxYDMv`Go$`kxUsbcfZ5OornVF(Rb|`r^_ps-zXM(e9GW;z}&qrGP!XknUZX zTF*NrouV1Hr>^D+ZZPa69C8iQr{^BGdH1`iQ8i$S6PO@B$KJ5PD zSGSVs4+u*?-VmaTxUj2$8e1w?%DHkq8Py?hu4-EQ%v$=B*M!W`!hT*>)c7>0*hBU$ zz;ch|h00k?%;nX+OEOOaoj%r8JKUME0f$rPk|msfuk$6AD9gSN^WAncRD`yTM*(Gt zEXwK(>P<7D$M6KG|7n3CbTtjFM$$0{^Q1$*bsDYrh@4pypOpdw`hWpJ>;VlwtW4Hx zl6nMv!~+_D0khFv;p_osyJrpFw|QP!+U+6Q?TM%zzM3VAk?}u_+h*2jR93(W!MW55 z2^7x!tl)_4- zzi?42@yQhGJdayIaqGSc7?o#!ExB19ticdd7 zq*N8eb_&qd#dS~INJ_e%FJXhXd|FEm3*F?Vm$dk*!UH{}d$94++@Uc@g7JxjZNz?X=K~EClooXQASUrt~goMKWKcMH}@xMVPhW_6m6IV=)%dgWT zTfa5R7(M)I@uwq7_zcQU6=7x z79W)RVjyPPmM9ud#O8JXXJ>l2q3rzBvyyzqyys*0o?Doc`{#&lA@#J5~i|Nl1RF%+8toOX_wx96-0C?Yf-(L)EH-AK}{gFVl zOh?ntUbw{ySujEp(Ow?!9~{-nwsG*?@WT<&at7%zf6@`1X7N4L5LJFuK?EMyS*P3HzOB@cW)<$C1i zG$4QE*TbL?stNJ%XLlqy3fodWN`?U}Y5pIBLLnPW*2okbA{6IIL3$PM&NEaCIKP=z zg&4c^=@BQ~C$xaHT%VlnJt)~;nuj4e_*Q6X8i&MmnpWKS`lV#1!nO0^{N%t79q!^s z{@4=`uYi>+x4|`ss1=H^&JNvA=i{M_R>`|l_~z#qVB(OvMSSBIOinkQV@}qeQ<0FV z!#<)(DcdP%HCw!-_#p;YM<&w1+zrILdxZ!yQTSTl_J`x{CWEgb6$)Ma8QL#V0+(}TAQay9 zgTHTmtc+*h7QFT8DrBPkLad#+^P+V06^qn}E}K=$`Rqps*XVK~yD37HRk;LJ9|a{LT_u>yWk7xiKxA*X^=$dJoX znb@(1Ci|LXqL#=p6P)wKR)u8Z7uiIuWVV^PfY3KPl@>b{k=H7}@TM?%H9#_#ne*r6Ii8adD3Riyt>pm9F{O3ZOsYw29 zqi+6U(mE+CM20(Z;DxbxGs#rp^6~3eb@}>r`DT(5bBo9Nz8Fq4F+%1$A2{>Pu$(>* ztPtnP;M8OYX>vJzHkpd!osyIiKjz3cW0~TP5iFC`6vk^)PM)B++a`8)Bt?)$#(_j!)@kN0=L zvCKI;GvAn*bN6KC^PLti#bz%>U(flbYFc+=AI@+EQp3ve{K+Psln*oqpYO6*-_Hc0 ziuvH0m3M!`^1fW!KrAC6De(NwIDOXO8eKJYY_*-jRT(3(nyM-Pn{BSj;~-;ow^yHf zrK(tvqlM0@kjYklQ7f&?Ev+%dg-yj+L}e*VIHOFj^BXq*(tERGl-v-rKk1tMvL(9o zPc7rCbm`s8J8r3?B7f3lcife-Z0PUJU?}gIn*E0IyFwRw4+KYTZ&x(ZO~K3d!&?+2(g@hjue6ibLVxGWxQw`-qAgxW$rjMFxMf_hi|Ky^A8aeB90jR2(%L&7|lz$ z(uoIS&MmELfb|Jl)7~k3HtlfvLKL~rvm~oj*i#nd? znZhFWlGA*#4cd}I@)Taq3BvZA6(G{+3Y_zM6GnGT%GM0Y$gpe1w>moexF(!(UIk;y zGph;)7VHM$Rt$QC{+~OTc|pX-7E+7ls)5MVK^Gc~Watwly1Bvd&9sUMQU+_MBf&R` zh0D?$qbwrcco^X9(-$N)XhwDjmhQq|2x{3cD)kz!ATsrqTP|4Hpr*1b#dC@ zAe^;Z#|iWZNvpW1Wf5*O3yx_H+?L-=US?Duf45wpYx)=mkSd-rw%#GgT^cmR;x*(i zyL@vcPyTH`t-|*?ghgD6BUO0MGvElOmp9*8wfODZkZG#0^bX&V$=PgkVm$fwA+#`6 znAhJUiDg!!F7#yqXOc+SBqI&Mr&c=k1GbdO#uGc)Wzz+#V*`3X=xl>y$RSeMq!5k% zu8wS8miCghE`dROs<6L*07bYn(4-T2z8fQra{hwow?fs`*=8C(OI_AlK04Q5`>BVu z4|?{CtlOqhJw^jTaKFmNDZr@a@1-Hn+jxC*ZuzgMgZiOlsTG&1A)&QE?+{VbwLaYgH~;p=pq&9Mh@HTEF%W_}`!l=HPE*6t zxK=L`Kc=u#(5!S0K5RbQJW-9lwdGZlS|RVhHtEZ*KHf#aw`S|FkjIk`AFX8vB<$c= zpKpO2JEW(`+hPT|<-7Sb8bsm*sbkXvOyU6xS}+m`4qNEdQ@&43J^>4IXLm#3G1Sq5 z-KB&d7mR0{v3xBL=1T;tL)-*D?~n&1=E(^y}#*=DM*F%2O_ zJnElz%OHhGg4~oNIM$~^sdVatQ0BNK@RTgq!UMBxKkwCg z8Xllx6_&NvzMt}3rC7v5jmlgjiiPM-8l8Ihr}y6sTpf*B29UPkk@|Vbb1L8B3>=O9 zMo@>LCfg~`1XPllKwxO>nbskUDsSgrGnHZMRnMb^MwZd1E{YRt9JW;K_u2YyQ*#Bw_D>u|QFJ^}N(H%`W2OrR8%!yB zvO&E=- zgPsipwODv-K$~HCG)WV2DcLbQPSd+whn6CaqJn)!EHsXW$$G+-f>N&C750oGFGMq9 zcIc0D<``LF3qH$CZTD|x>nEm`3O7%kbXSe1 zqx}qn3yLgq`@Hl9-KDY(_cV{Y z(b@U}h*e*k!_)Mb-XAc=EJ3bp2jNPdsnELp#*tCc(%Je%gU$xSyk8ZMB^SxnxG&eh0Obfu^IO`H2f-yB%0%pffc-fnIsQ>lKZ+-}b@Y z!cVG~BHA>721nxsv|-Og9NV9JodTXbc*c@{E>vr3K4+iyJp~zXvEF0*vo_{gkNh&) zkY+(HgX_n8Fn|16*n$c|ksue+nP6X&mpX-8;m`16R_yT+t%>&`XBjbD^xQ9)Qe$jO zEOrMchAy0g^u3VuMP};{ErsocERd8tIoaDY^98vsEk*jWyQI@&E?KZm$jYpYENs1p zH`{tD29QmwD;crJlgmt#PKQ2Qz94J&q~ zyw~9A!w@0yCP~)jb8Oe=XVssat*5GXn>zlMw(v7M(Gs;|Ie@VK zP9Z&}ZGbZzm==pE_;-y86g0ULG2E|XY*E8^Z#dR(dMgGVef!v4X0=phH`SLNuQFht z`n|U)JI3~_|HNqI`c)oJv}t%b8}@kO+@#}u#&p?6sLH@o3!nnTcKa+jTzy)GC+rI_ z(Mx0SC%RzHmu=Kiqreb|>2aRg4U(mh%4C`lR;S1+=FMyJptMhqarTD`{!$q@(}om8 zZxN|e&_v#NJc|+JviHcJo7kD)FV)5lmW`$xISq;8JcZYv2^2Zy%B67_l(H%tE}kmyuNl*7w2hROJ4%b_Fsu z&i${ot5R+X`Fa_=f2=({#1>d%vU&9p2%;PU1QvLRE%4|2@xRudGPNHFyib1!ygqpe zhqyxGx5RNRhmRg*A3H{dPpzJrOBS8E@)&B@li9SZ z8J)uMJFX#5U&FAVp={*eJ@v=1Nx$9*q@?Q+L=yGIaBC(0WCtkI(xEtV0Py` z9lrmY7lEhiJZUkCA?sxz3qQJU`+LMMAD`-DEMtFmQ-&=}az}2#&Fc|KbWv1$B6n!K z)f(j*`A~YmzoSk#NSnPLKec~zKj!sFfSpaBMjz~M)wsA9A9`k4S~n%vhW@i6H0LaY zH|;_Z@gh|GtyGK;WbUi@#JmR=K1sJF76TFM($xa@`L>4Kk;d(6=*A1mihY`AT)DN- z7s4S@KVxPvo5(hGpo(!z*s6g&wz*NGhqm``FL7wx-VT_;;^4Jq67uX9vruzF-nDAz(3quMEN?pxe4*Xi z?_YhXCkZA06=58JLY|H1YUne$iErBU#6`7?i~NhRi zaP!ay>jHSR0&ifZQt3>2<8@7JE+f4p10HP!9@kz3b*Cwc4%Ha56%i-F@!M?=HXjrC zkZ@=)im?;>eg8=Dmgku^f1DUqwSoN3V+%hc(<|0W&D(0ulW&(&j?JwE%>=g0>YNIk zdiu-FD1U_*sB}Y7!Ab)nJio#!P+pH_GGh`_{_zw=qwM4<0co1w>j>Gu(yVF5%5%i` z^Q4OG$+Vn!?(6SNO580Tc@6LzdXF9)xSp|7Brz2J>-WT+$a^T!n^L84q%XRwS9`)% zXv)A{d+L3uwjoK%SHgEeFUnXD7Q2r949`~ENqlfp48a=j z-!p$FVyOpJx<*kC)F;(j2YgmseB9+y>G%m&^>Dc=xA-_!gBd9HoWCB_JSUq)=fHSK zCZ5@B?V#UCIdF=dAL80w1e}*EC^t*AJY9)DTQL(RmBizv?cwYM_^vyf1lAc z9-hI#6!-nFDgM`jPfezg`?AbmQ~Z1e^7~D84i`g|O2Le@D|FlE=fTf8*thEt zez4n}5cVX8Hx*4+C+ur_@f&-Tnjth(K8+b+$}b0;6qE-y!hNdglF|3o6j7-P_zXn6745Q z5vkinm}bH5$gY%(zyW)O@5|EI;9M>ebJPzG*-ai_{#=xOA`Zo;s|<3=qn_fozL9TC z#MxFpue-KMUC+7LD8`a;W4UP>9*Fbdb=czaj7WTWKTv*<&IVRU&+bHhg;RG`uR&el z`f)i_9JT%E#p4=r=5Gfws5(b<1y%vk+PJkI$mhsHRE$I)1qq!+MoVfBcq&jIb4w}A z#Zq?)1-({GbtsfoPT`pqalDI)`SGan@(Da7@GJx4@|gg2T~ptF*Bg@tDg>UEuut*H znbg%m8EG2qz0>7iSs-$jkQXF5eH#>V69eNH$qqAPgI0;p$3+#tlaTZFj~g%)U&hhPN98Y0#>usMhz*;Typ=OA7YbOo;|c52p>(=Tr}-F}DS_^lPL}{` zNq;MhUZo84C%91uPotNyyV#aPv9MQnfB#b9UnoF}{?27FD&)P!8rwm@fKAMZsPrRH z`^F6!!aApm>9$lKvzJ{; zFU2|fqGWJPx$WW2e;bLl)BmBTAN4TeXwD}Gp(DbD^S6>|njij$h ztHWkLEmM`aR_FJz=nIM+>rvht?TgkTvL~#>T$592IAw9Kk=w@b`ujT0THBTd8@pb4 z9>Q5UG-hC2q#~Oi%qE0e*#l%o_qO~RVl=axAq4Fh7u6mSgfkdT^MD?3a)Co5^ zob>NYpyUOe=#8<9FkceLrWO3}5cU2t_F6R_fwUA@2Y^FA#N^bf;L8mcSK?;4V;y5757 zSGlh1t&~OR_d^`My!6NoH|oD-1GP6JBZ*B_zDOk8hSLDCPyJmZfC$)zSTBdqfC$)Z zPdvDrRMf=AZP8MjC3bJHsj^eCuP{lyf#0q z#&TIPPdyfd--i3U^f6;@HfZk7wra2TA#X8x<%*~qzK)C}m3U+@(E)ooo4`io!V&~C zKUbomgbW=`-VRV*5_(0*k$4EB7NmvY;zx@8tRvCAmfe;DK=^PIJnCQdwXiiya)0fS zJ{4k=sMiSo6W{E2eK&HuAvW>mR4BRJS)#<&-`kx!FhrhyHsW|DS8!ncMU(3_7~X;D z8Ab5BbKuPlUsL3Ndv!YExjHfBRja0}M&-ZweQB}?;LaHVcnKhs5QoL4 zNg#sth6@nE8p}T)ThTh8X-9JD4eR;SWx7wDdm<2^@OI(vBqW&wF7IfRRR z<$7^`%ohc3W@YiZH;o<E=NdUyFerd^>YdN zD9JWak#;AbXby$t=NS$2xOuc2h+`Q-VP&Da+f3uF+Rn6;EmP&%O~#5xs=cV*xw~>= zz*37TutRr}hbISthf#fcO4)$rc;mFomk#IDNR@U8)eZ;V_n|F$VuP<76X4@P%uLx@ z!1k0G(-*~qa<4K~wyTV^)2%v!-1Te=`#jb_>3uhToRjlM=W{gYdrx9{uxXo^i*8+y z8=qwQvx>BCCujJx61J8~7_Sw67*0O^@U76vSaRk|$#z0q1iNMdgHzc{3T>@Y45ut` z-p5BmIw(RVq(W7sLaMw@6~bSVjZG|_+3P*+jIchAdptrzp~Aml-iRi<$qPRJepxxC&QTu5CuqAvs?fy!~@~ z%e}UF3mc-6bK9jBN890;ePi@px7mgF}yX7ThiG4JI&VG$$qUDsgiMmVp`r8>9z8u&6@ddMu z8n*t1uXU?^f;c}o{(0Tcp53phuQ+Pdn8a`nG8OM8o^RHDc>U?T|5M*kSLaT-s{UP6 zhK5J99&@u#Otoa#c+oSx`Iei8=eA}$AIr=e&TnF#bn6Sf4G$Kz=n&DT?0sYrT5R5I z=wEH#Y!uwm-q1bi4Gu4!Xp)35{Q#ZJ7rJ+7 zNgxKB?v-wnML%ozFHesWi7 z8U5nVV;s6&HcmA)(rYvM5UyJ+y!MDt1p`&lxheqGm(H6g{E=zCUi=ohLF@=mmi>{6rv}7bD6Elb*8FH+w2Me%1cM9jCl$i}d9FkAGQoT8_of zkd_pAky~!m@RW0&wlT!kX39;y*c#i>xBaOux;)f$LT1L6B!-+mSL$y&@Uh{<#nwYo zXTUkME3X{;m)Dkh#3+n_14R2HfhCX4Acrl1^|H1?^t5V_+Xl_+vS<1Al_jTP7(}$+ zjEHW3w z3UqhVty{~B$V4u5>S8yz5@;_k^RmkYN4kdhoZVS0z830i_d}&veX3whBDm4N^Vy}^ z;KZ?1#_7k-Fl*SYj&PpyNjH4-)xdz}q%MtUJ*s1LGFr8I(a?qt#WCWsW{3M{-ObpJ5+gXSsBT8ZQd76pD82l4Uo$=l zD~LS!a%@;y?6!(aL43Y_x-t?++1B^r>+U2}`ggoS;cJ1Y7z#}@6cAJH3MrYx5}LjL z9lo~Rr`ka}JarY9G_+Xt-?6Yh+jUfFGv$KgM*A3jRixF9{lsgNSyyheFJEA{5Z}UM zigj$XI7#x`+Ri@vyy)oPC_UrjjGxR-p&LdCK0cD}^J}jeFS4n+PBBE4eD?_^j;*k; zKFV|P@om0F$I%GpZ~a`Gn5FmPg%s(Vl}6^f$X;$X2k$`@jW9cZ`QvY4EQWz8)1PLw zwQa###Kb%H80U5>>RsNy`DbWNqoNMwyU@{Vxfj}4+@9;BOhiYoO6msiniC~m`+A5r z>9g}3U!z_ww{lC5`Uk)Z1>c*8dfELbD?_z6c5xYF%#D;k!K?GRHf&S~HvbK2+Z)@F zBCj#;PBp?i*c2hZJl_+_qE}P%$G!3Js%jxBu6?4r^B55h*=ndarJM-5YHr@Sx%S z4H08t;;_{wo&n>rASBoZ+<$9?}wvre0FeSMUW z)vL2OPuNu?iUQbMT9KZ{VJ;fRe;k5{{%XzYb38H6dak|Y+c$Q4Qw47(#Ysp6C7kVS zu$d3&3E&rcVqS%@jyekm;X z(JOG^DF;W=FF`eRmEPWHQPDF!29vJEJfUC3lt(BAMn(m#!EpY~Bi)r&YA1!3#*$F_ zk@iPh!B590lY(nTdOQ^=CE7i-$6W^djZcQr5no6#TDo)@KWWdNLnC|J$(Z1>ie=}~=g*ve zX0>K!>>BJAeEs@(1yN3R(jjFr8?)M8$jx~xe-^Z^M+bMKh4^!#h1p6$EGD(V zxPqYdV_5Z}4lCS`ACm0=vcRW@FWiU?Hv6GTB@l$Py@58dLE4DXd+0)Do=<4N_OS9? zoXgOp6bNrTi%2000QiytFfLDFqi>)of!^Rc47?C7I`}Uxi2G$7z|!D_B&9$PT0p%N zw2%dF^qyH2n1VROzytuvSm43{2D}041(3&u1+=^KTM8eKzkQ0I82a+oc(;xjoQyvC5KwUGlLRb~R(kvzf zk_dP=DO$l2FLcpM*z(d+KNyIjmEFjDG#KdV-gzMy4BJ%%7Y>*u_XJ1Qq5wFn_)SLc1A}EzO->N9%?N+42+I!i0`tZbgq$WoF@J$*&(tTu ze2_Lfw4P>FSV|zk8{PbYA@K{Lb)SkfV8m!33kP~Qnk=kMn;gPQ2fnAie*|e8K$8Nx z$b}L9gBL3k5f8~%p48LcNy8TP<4$pNe@HDtjBFXRabQZ$JIv40A7pZ-G!ev^SI zn1k!K0US#jBF!3#7qS!qg32&l6b+MN&pj3qn=S#Z$7bL1bmPYWytcp3)8UI=`j?26Vi8wstRLz5b24xkr@ zsMdolnt&eg23xQIL?Qs8VHTplIYjR{0~(7$yIW8LC^9i{uO`5A8jFEbmOvJ!^zeS5 zn+Neiq5(oz1@C6bWzp+n0YH)dp*Ibm!G`F-bwYITSt1B8;TT#^fhvqR8D!zA1PgBC zg7iiLOz}7a{NQw24p#K>?hgi7-pCJG@Fck5-e!hhQG)BH=-?FkU<><6{F_Q~kw5V9 z2*7cYgYNg>t+C)mmF*% z?t|XrqYTrd1ty3FtnEVZ=At)-75)nu;t$}xsC4iNS=gj2*!>A%$Yl()O{^BQj?$PQ z?hm4k|3m*CJp;SHA`G$4g-(y=LKXbM?g@AyJgjg41QU@*>v^OAbEN{`Pu|eONdzE! z#9;S1<^cIvXy?iw8s82LVEnc~>y}J#oktK~&aPk#z@90Sy=4#2<78n7J! zFs=q@os98;xK+mlpKKG{@bePAs1if(!B>VQNrF!#2}6YFAldc~RoYKs_G|(xdB-3N zXAPK{AlSW>AVeh*N+}L1YDd2l)6{?=gTUd`)5@^ZY$ziEWG@u#?n)5i7!O@|7|L(x z;lIQn{sQPdVoET4FtmCMUCIdm#yLwALi!#p%;HW+60%@N7~-7_rNsY(^9lfPyyI&q zB`>H57#~h4P|lBknBlD=XxpedXuao;6KmMO_r!PvAyIVj7kH31BD6cxXms-^R=7UV zLp%VfGv8ewbWqV(w4RuB=mPmTXq}V`?9M5EbAbd}*P(;Y18^WSUdVMaH2i!URP+>HDTrQU`-`}L?(R(Lk0l+1i~BE z4kkDvE+ktIz2_Mi%4>EAz~amd@H{;*?hweLSOw--2;D-3WQ(9n*#f}(t{B7sju-Me z5~`~FhbnxZ2)$N&1`EY!f$zObgsK{VEM{2YGnz1=D3C?266{ePRFwnNJCy>EyHS5g zK>#nkutYcitpW=jr-wUngL@}1)nSOD5c@U|FTfH%pvD>aArZ0A1Tp~Y=SJ%>2R~rs z4|0*w0a6|>WQYZFsTT>5!MiRWl~rMxqM-HrU?AuMKu4m}!Jlb?>-ZVq<00&f@E}Go zZ`+^10@oR;4+MLiDjmF$1E7%sB6b4U{*eR4{05@cNAIyqdbkZdFu3-t@-SatkOeS9 zgABpEGx#ByKtO>rypVEw$Vt;HG+;p+cJT_Jr|IB7fN%h5%y0@DFs~c_jde0Wch(Su ztcpMkKm;M(%#hd+@CgzFgfsvxEbzwmTe2$=+Dke#6l8oTl+HsX=G*IzMAHCn|by9-$Ki&@m-u$1rK&_kqHTPd_ z{Z9!%@&85cUyaxY#Et$(8%@}s+zNh4$TUo91^DxSYWsh0>%T4gO9CMJFMIDC9xVTz z`Cpd*pA!CP@PE0*K-Yg?6}-pO zeyH7f1Qapg)B3{pS23W8zY8T$5pjguwHlXr>on|Cd^q za%|bZ{Xxtie%+O(wY0bT#|cz5aI?RB3CPQv2h2_dyoGF8-qJYDneJq)t88HSr=`CI z{AE5->6d>QOs?^#N4}c_wW=QKWc}4gfBK6P;Xl?o?fd=_Wc2p0zUgZH?!n)GciTTZ{9zcVZ~v+1?DWvT=0=9>e;ib|Ry_6K+oQ_Re~gm9eCG%KVYc^= zfv~=`$GLKHx}ZBf7nY4m62Xpzc)XzQJEg2X#giQSEP^Sr8KM^TnUCa6E$GFbYt$pM zvU2vt{vZMh4!+0g&Tl^^r@D5rEMxG+e(e`R+(W@i73v=ptbshEqk7Ja_qd$^57i7^ z4eQC^KXzi=1bT?wrA8XW0L!#bG5_(u#J_i9)cnt#7&S7Sc+TXrf(?4j^|6i*V4g!R zwb;}=|3#;_X9<&mbl-sKd#~fE%k$OsSHVitLgqa$y~)cJxGXcv;FW^FQ+s%knMQAL z(;To9Ly3If%5>Up_HP2MIfV^a`_4EMcqAnvb&;phdLd;_gns@^NCBTNO3Z@W%MhRej=J5*tN|a zta|$FIqHxY(es;2gcQWQQ$|ugfjsM`s-5&99?k=)pw`d4`3{-UYt6X2nMXd2Yh=)# zX;ipKlyhe7e6gv#E~OtQDIx=w#`e`^DQse1rm*(ri5W*IZN)xLyy>8R-_YUq(JOz% zZmnTFQVLQzE}ExRjluNTYIY}A!JU4v5F|o7V+F*(lHjr++~SxK7o~ccgXb!Yt#(+N zb!mEB`h49T1-!ouizcus6!H?DK-0Wan=)^Ly{i(O>K2R^-5ej6pGX_xLdCTdzw)TfTN^c~f%F)O#+=t?6#VA}|$ z&dIEycu@e+2i{_1RrNhp?7q7AVM}@|;t`TzE$j4EHFK~hCrs}H&pDq&=(mh@&Qi>X z4w<=b3a7lF=io2@;-8p6fD#}hxnNJ6KM zIsv2xm={MUe%g7W>m<&>iV(2IA+|@@;(9@~AT@vGWNSj}9@;Wo!|M>*vRreLvt8Cj zn3jGP!^FDN%_yX`77ScSr4~eeD(HdDD_zS4B&Guwh(NA`1zXCm@(rQ&n^EGA?q>rB zF(7^d$;eo?H#f~q^<--zceq3>K@7!C2i)^=czZR{LE{66n5)fo&cG5+u= zSE(WU$*-G2F5kIxgGZ+0^PqovLkJUAvgY zP%ucG4EV>>a60+8q2j&9&suZEr>WrRAbY7w{pLgTGE(KQjsyj69Wb94D)k6apfuz= z;+B*t6tP0Uy3nEMpwQ3CDWR%^qXT!U{PB-RE+3qac-izgV&htc^$m;~!WD)S*t>V+hJyviR zvq)TS2pPRqH+7|h{YO^MpL*#t;X5lX-7LMq>ryjT35hS? zlndR=NLhzl)(U1`tD0CqU`ZfzW|%E_Q5jDUY{&wlM3>FPBSQa~Y7)5Qku0tq)Df0` z7muOzJ?{97*#Av%;oZA&dVQ^+r{g-8Z-|!2*|GLxXqjKJR**?EYTK1;DBM0RAm7l0 zH(hCa*dc~9y_tV<7S+YDZGtwW(Qhe2->ERdDW{De&m9HPkZa9PU1uO-rYDXfwyKX# zJ!0DKL?7brw^SIxkTdz{5nrb!q`m5f4{XaXt{sr17rhYU(_ za@OOIW}W0qd?HGOmG1I41+&?m=3>#ExPB-jl|~OG7xB+#z-qiJxQ^`RvLfbqkXBj- z#6!kM93`F*iGs{&#hD8bWBaNbbcK$fL>`^p@|6{3x%efy__6|wi)M<4g)&0SlZj|~ z2}i)=d0k@M?(dyFEyUytQ4ZxtIm? z5|C;P3MGpgIg_!IeN?zPn2Fzb#|pZVNAb|0-(9kp*t*wExQVRRFR0Oyxw5+*5oZ5X zbJ1$`V=;(IvL-VOAYf{nlw5F(W{%ab2|T_Z7`yyJUPY{JD4&V6vheAw!fWiWZO`U^NG|SIoQP>!bD*(ArC1< zBw*ZGZ*L5f>V{=kTh`giCRM~yX!K8^GsnFoPPcSlhS8bnMS!M_TcuDw1X8$uz%=aR zI3O|0q5nMMCf=P8sqx51{E$vh3URExCz^MM%uaLqHx;f6$6%J_GPg^viNn$m9R z>f|2LIP@;sKXM$D@$A_C%I4`~*SCxxd@N2{Utvh5{gqv1Zt?G(KG$<8Q1k$S%Nn9mI{jdmWm6T4>#+$+uk4xW5-RC9r%bO!~N?c($&h%(azS}hsVm+I|&Fi0UTU* zC-we*qe9(S#8=@!(6NYxxK%$rJ{}|ZcMR1vB2BXEk_P7Wg+zWCJyTz*G4kHWJ@Xs* zRM$k5PBuAa{W*DV|FdYB@euUDkcp(o1NXV#3!R-!q;;YzB9Gb?k~F-ax5H}eLFL`r zhVliP&(AeLO@Tfa&KR2fT+VH%apJ>4YoFr z(Q@~`YsJPO=a5*ETQndO>^OT~?4Q*&*F;78?rJ8MGTg+_W?KUgWbxR#Qw-iex%oA>7&T6rU1kzBzn@>=@x5+rc+}c;o)`j&yx%W(f%( z744xp+I!&>#xCT(u~}l8k*py1wylaNr^<-jDEl&9Q!=Z+E8NmJ2hpu6XHAzS)7In3 z`ze~Ye2ACccq3+?lKRS8Q84$GK{IiP3TfDx)-oB9*ZEc@q4|rm#dOg^wX9{r+r{2g zljzjiT#BVw(!Vo zN>uK>?e_{Ll$3i%ggt3s$Br)Hu9z+?ZYq7xiBzp<{={AUeZJJ~TKb^WA^IX?tuf+V z590z6siTz?^Ov54`i9kW8d6zHo|bPBwUH-^x52_kL?Q{l&{vM{qCe|#?u*Ag@jB)% zS!`MIhz{d>9#f}tLWPUEQu|%iISDgLs&4syWz}vnX;q8!jr4}C;Q}L6!|O}KH2U_r zzxu}x;+3mKvCyZlu6mQS78Ef^)r9Dudk!khuxLqoyzy}%NnYC7MeG_KAoNDdLjD3t zx5TKhO_pj_oOWRk{hENmwOfY#wdxYr`0cE|EVn0i371P1{YKJCnbTvXU&9sL%JOC5 z@h7(051s-A7d_h}QV4f6pyM8Y5E8uI8Cj-k~>MKNRr<$r= z6hlQOysR8Uqxjg8ix2e}m!-sV`t(8M>jNYx^Fw1KZw|qW>ymM$&oOrgYl(D|5^HS8 zH$zrweFc8fYk%6D_pTd0+a&T6tZn$cr)x;zGz~ozY#$a6##;F~Ei0t#)Ctx2o%7_m z;dbR_vAMYwDQkk)wJDJ||Mc~qB$BhWlG>?G!%LYuFjGU;GiFLTjt`gKQ#bgeWf}v_ zxzc0xkJ3MNn17qI5Gtmm2urM3@o;XcY+cGx!7fg>9iKDyed7C>6n2Xv6cVu@@>AvH zJ5K&+b2rlqnj1%Iq-?)eIEb}K@Rw@ZjOw6Cz8}orJ58f~RK=b2EXo-X>O@+ph)8Q;#wBhrTp4@e-Q%{XZ?Lb-IgZ9^$n6NlqVva6K z#k;e?V_qk7T*Yej3)P68EDkug?%P2VQ<3L!NIt0&x@CBwxx}-LARC?!vAwe+%Oh<5^xk0Qx81gV{-j{N3?ad@bz(Y;qkEY{%Qw+ZPe%8Q1yFeCO4ppf<-E-+VtH_!_P=Y}^rh&3C<^*Z$Yq zb;8=x=pC@BoAf%q+q~}li{}Y^a;XmXE9Cx~hN!aR_IwU7xn)FKwZ#$&mtnfV)e~;ANhpog<#yUm{ONb*RN0Digi#WF5 zXG;8f{g@zl)>o%Y_D4sM;oD70-G%#$NJITn$H&=UU1n0SVYQ$02MJke$`L}b-AN4i)*wvjJmtmbl9L6MW}CT|c)t-5_nohuB)o0x9DX{LX&q?hm;-OK^X4^!`QT zrjB-aEvnuJDt+w~2b%FyCghdI!w%Qtk`uXgN(l%V$x>X_@F54GvK()r*kg`7EuoKD zjE}*@tnbHd%7;Ib+p(i8Qw^#|dFCN>fDug@sQHIAQl}{6=5gtOKp|TwO2X^0J`8;u z6Zw5weNW+xuyTQ)$RE?`m8QOsCx8kJSqO&CH}P&&3y3W6f>PJA8z3)=;sZDcr%pvh zSRQF*2r>=w;lULrkTsfKWDIHN#8GUH^j!#4QE~7N@i5!7#)p_u6VwV}9qOWFv4kj+MM>AmreWU`xy4g`h#C9E(? zD-qIdr2IjF+1N$*#NU#}?zbev#@1DG0RuSwY?}*5_qlYee~7ir_h2<$;Z!W59C>ZN zv2Pj8sGn}}q691whcnt=$9W1NC(4PGdJ2NHa+vP=ngzXSkvL&9CpG>0ITB5-A%bj6M zeB*6&<^msN9)X28wjY9BibU~L%uJtHV_#`YxOLrNUR z%u!>kzGJd3K58G5RTllqvR$2sX3DDVTAhtd1)d1z(^RmHn}ByN8!4~^>ia0S1hVIxOPR_~f!mayo-K+vQp)L3_oDc)mK zEa=Z)&iIzqfvB&H$V>1mz`p1Jp8~z;{|-`DtPvxy2D3kLJZNIm>eOe|SvP znSPd)Z)Q2t5;*F}1uurpno(LQ#=^)b7x}Su1Ye7-Rq*^?QDEkTF2cqLR*=knp z3UNv;=iNm=V=<}5EZ;K(D<7OlKBzMDmiMK`s;2hat^-TbFV8k)3uBYfnx-@HuCxq1 zWFCu>PHOHvdXBwo)y+faxnVCChtFJ4HDb(ja}9~yJV?5+!48N(EiQVCa%(NJd!d@- zNrbn&p%C1S^ksd5w??sawW9>Kdq?bNWqS{;Uy-=Fi@i&c#!l8;E4T~s3p@Rl?SB$} zJ4xO__I&Hr&3U9WcK>%qMH#;*ow@h6LPzsgioxE_!M?7xo|xLHzRf98$lOIw(6vCy+>;hT!4Huyl0 z10(dLecSgc5g8`~QRHNN`9dXgnoP;Nl;dNhU8>rP#j4u8M^ay@sr4-6i|wlhJJ??b z?pV&3mA>L_t3CdtEQexfL{H%~@!EBvq<b6;qacFyV=`P+4vD!wuaj}}9=-lbV$UMX z2CDya!+i2RaC+OVN&Z3f>UsF_7bywS>i9C#C#ogEl7=0}=OJGkdzbI3maeKC=^IY4 zqBSMMv8*>j79&isqHoBuED&JZ-Oy@gyX7*Dbg_^LB}68e?( z21oQ;qaO8(^2`bGgs1OWBz}&OWqv!<`=zI_RAtORU&HUgRgsLv_D0mHMbeg$r+>tF z5MRY=qFf;;3Guq)lV1A1)cj_+jd-=N%Y00$NUw-7~huh(n_DigWrr{_b!l?5FeB852HGOCi_5DJ= zv%G+7^5*A}+n+^l%%I;^`3QDd8Cu-l*;N&ZE$>RPl%Jf1c{qJ(9*grBjyDM_AGf^f zqhOlJHv+f|Fq^^J3$WJXU_(1sB3FDQ+{(vdo1_y%ylb=1pV@2weUq0g{t(N`?#j{> z%m!>OHQ;Mlq->Cfl`vYERR8JZVzQwTwvb?6I3vIQEneDduhYP^L+3n0e}S^2F-IQ10Rc!M!}4I!wVc-G1r#z~=}0o07GS#)k15j-Q07 z=%{a<@WtW^HW{nZJ)ow6cC7;RM|lvKQhk~@dIa&I}I=s z@Ps2s<~1}x`2<3<>I6bBx-uT=_OZ=Hfjjf^(L*y5Uy0bnrs+R9)Z0~KD;n6_Ty{ze zvy@|mqn1dW6kXw<;#W>qZx0F^k{2p&MMf*M2jA`$ z&P4|A;cKr451!>hZfIzWmH^87={;jrx4uTEjT22AzdK2Ly+Ja zB)Ho`aCfpe1ePEHg4^OwcOk){Xjt5#q~4y>d(YT6?|bIg%=gS_sG*>e0ssI^K%P+fyTX3@&bG*j<}rf&m7@tJ>;am_qj(Q$)t*^U|mBm4?DWPowk* zmfzP5912b-*iUC>k>*&j=i%lm1ORptSSZva(jDJ1a?ES<#Mw7eClabAN)doG+}e$a z@?XWobsP`I#{EE36&NsA6*R25gnAQMrQ=LylX2@o^#{71tE4=*6!SndZxFI2vswb7AIb+*phf>s=!e`uR;U|%fK_K0 zY=`u5^kH3b!pJF+tIY|(6kSb$9M1S@{;gh2i6MBA6A=mNuHTDkK0BGP4A5!de8IHa}*77 zx>Wa49h@m$w_iEASk;D)GN5C5V#)Ow7bl|fTBxx4DdJMECB860PWs{%+n1%qyaeZ3 z>ti6UI3$iq{iMKH!keT5Hzg{=Pf|h2Pyv%X7Olr}lOWP;!sxa|8slxum~_RP1U;v7 zw82k;ma8!fZV|_DyT&LqJ(zn8G7!UOS%~3IWh%MiipACxL}B-07Ba#^H+?@B%AJ%^#OJ(2sOS``YE6%7s8r&ou59 zt(%=i=66E+#49es;*I%g#1`Me(O`@wkuAOa%k#IP+H=+1LTR2Dzx=3ZHZJqCA+iU? zPD}~6cVWIZxPJz-cKG316+AMh7~|rLupY2!j_vW|a0F*}e-T zn7ssZQq}Su~NKLI)_V4C1 z;EKG&rcm+Rqfov1@bH=VHA{I>xpXB7tg<)eZ!5$6rTmstFl-HNg%ZmwdqYro8f>A4 zT_N&34J}apI+P%*;-;4FACEBDBJhCN()1j6q;pSy4&Gm8i@*iO%8GI92ZK*N^cKIY zfG4|uWC%-Hqf1WBo}E_dE3H7UC3|RYv1wi```A+InEjTNbwr1l)6|PDhFc_nW$Ox5 z)@JF65&xuM;(1{a-)H_v_x@ z`E-6AQgy!i!p=EUGP_)lN`IPuGNw9yX6^d*w8xggPN}mXCOqtuAHF8~-1TYeVf$RW zP?P7Dg1I6&pav2Ndm9C7Au{6g#a*W7!J~GdXnGY7S*9$diL_gEHNqVXbjb94V&l~7 zBtTt-my>}lfG_0-%5i?<>{6wdNL|(R6=+RGl3YV1V5Bg5NTfkA@2O3G&U%zRhw8-o z&~O$`?&Dw@hU@k7W|hX-men8?SYs^Z>y?4SLi5a7AF%7n*?+OK6YzU-Kz>XPTA)mU zz{_sQNE86z1|I;x`6D^FzH$Ga8ya;r)ff2*1C`fgzn~CcVME<2?d=ZE$iU|m4Q z*N0M(Ys91)r0MCO6WlKshnMJLm3mWV?bWKkt5PmufSkw}&wPtvO!tta&x(NXOL;8H z7hn4Us3kt@!;dlABmtl>!)8uGR(}Akfv2xvI0bxD%PG{o{2R)RYnU&f%Ash^Bq^Dx zGCZ8tsq&um8pXhYwJZm3PZ(%{aL$Y$S|gHJa!lKk_I z7~=fwVm)6}>O}b!u15*S`UH}AiqB??e2yy*wKlx98no&uN7oN#UELVx`f*%A2B#C1FFBQzv}s@?^_7$d5lm|q&LW?K-ZCmH z>9Vc1WhhTU!{?Ir(#~wyh;|s@ys_{I-9H z;@{nZcB6b$4H4_@p;TE5^#uscie{dRJLefRgk(8dlQjvEsM&nLv@T^d-rF2mKM7mE zSAobZ>J0iBF>dPlWxOaJT8jyGBy`5ZTc+h)kQYY=&3*-!1)?X(>bG!A!G1b#mr@h( z2)jJp*yE!mkr%1`Kon#N7*|V9u#+xZss7Yij9Dj@2#u$;G8{8!7GFQ6L2R4%ySR?v z_0bg@8t7&z7y1g6J402KsiDuqVVL&k!y(jQJZ*2H`5l425c}5@S!*Y04-LYt3>s;ux=JR(`*9PUm4FO|_Q`1xu>PswZl5}d zP46Y5yN0~DD8zA;u%K~rfD5`s@20Zgg9p!L#ou{)f5zj$xx23jgX2uWLAD@MVT|#` zcEY^&XbC@t=G}@FUBT8DR zvuQeujEv01R<7bvlgr6m^9#9ZVx$Vr=Q%2@npuF?bx>TXfIuv{fz48Wja0a&O+DS( z#evZxd6m?1mufoagd%c@;Sj2ONi3kDm5k73&Dd6j$w>jrhT_LbR)`9y{o(;%(n7OR zpSkL#Ht6o!zZo`_P#zAe{spmQ8c+%*a`3S6RCQXpedT>6rFV28R34e%+2UsB?{!1g zb-rZ!DH)k;E*=0DB;-@PHDUI+f&SwT>hAFu;xB4QiEDS z1lz9P8vKB`8!TJhzJ2AdDAQ}0=GDq~K08)uX9=jm(2xxlL9g=#oS^tv0%|c3UxN=M zFFwCCV-qz@ zuxz*bToCsL%9m=ACtwj^;+$Z0s_o=RJcb{Z>;u<&Swxlyw;C8_T3ze?e|hJrgWO+shjQ<_gLrv?Q}oXCD%wxdW`%1$z1{Kk#VuQXf4JBcq>> zFv(NtLRp<&Lf1NQhowa(rtebjcRY_kNTR!ZDGlctg5sCwI|l9Rw5F){(b!3RAT@N| zL#&v@n9rk2vNHssd7nVTXig7TBp`+>*t^{w0`u#52d9x<5(<)3#d!o%K;RtEXaSCQ z;27;CqaaC9oR?pj*Vu4EwQxmvU={scC#lmmvUos~Rc~WP^G`SITa9NMC5-WWMSe+cgB7&Zcv{*LW zP&M+0Py#Mg3SCTJIfiSJithqwo!q2Fgn1ch&tM7;dzMwjO~;}>+mE0Cy@6;rOz>PoVt(4$k+6Oh=I)SvIr_Cx z4eRbOWxTx!xIRrY@_dDHC*?GtKCK$KrT2>tUJECo>LZF&^9q^-lk!(_```Mb>;H0H z3Ypxt*M#pvg-y9v8 z^UJ(rbst`8LOE}K*K13xZc!mza+8)UcvaYmN2+SH@^ zeIJv69~OdJMX#eP4;?79)_RfuL%LQO@5hHtP75i4>77ok^beHqWUM4na>}I-etmt+ z<0+pFyoX|l##!)7IY=`JfbZU)+KE7lviEDqF7(t|=d$DHlJVvgTtwhzJWJY6bvM^@ z-*~(9j1B98NNX8DIMp>FQdL)IMujqijGLdFUmrz|CohdF1iha2_Ro8QBa|TsW3f`c#mFkq0Lrn02!{p3-9MuZ zGltjW7EwoO0Gpl}L~6W~XJ=zb?H}Q&^>TGa+*^yf>YEje%_cvBh)g&ogx}nSGF(b% z-X-LDU*{xG;=+0mxW!O-j=GVe8_gayqfC&$4I=iYs#uVA$$(6Tg)be?i0L?zS8uy3 z|66?Y4O{OCf2VjWzn~PxUUg6qrV@I`-JVdR5_4Q9<~m>R<>2BvU(e+T|GnFj2P?l@ z>n9IlaY4ibW}j0#jRZV3)0+J+f>iI3HPn!hNdf=&r1a-U|GoOp1Jm!$|G#hi?W95f z>-O=t@&C!^Z{sM|-yHO}^Z(D4zn$gy-<|(h5)J+P6zb!@_1J0>e;@q{P)h>@6aWAK z2mq34J3R`7XK4iu002EJ000L7003}sa4v9RbG%slbJ9Q%{@oe>hxJ)iKuWDv@P&Yi z+KPbnt#c#?oQ5RcT}n~w-|n|}5G~S(#2e!I7?G>es`PN!2ldE(@W3zz=Y z#c0%Q^%~uFr{8|MLqt`gdaK8}NGF+9u{3nyLASAHs3Y}I2H+u5sqw!t(?o~nqC@Gn zo;`1OTidOje$S!wJDbJp1!}Gro7b;2ZxoyBDSm69p=TYf4n7^~x6OUg@L-lOV}rD>Yl^ z{39au1(QfembkAhyAdkHoLSm8Nuh^&$3> ziDX72Ef7_aia$Z^VCI~Hs^QMxP?#XpEFs*}2x|$Jl_{*k!^tsRm<2GfG%CTfdy?`K z&DpwG150_#DJ~ALO6?dKDv*UkTHC0+>eIE&Q+L-KM$T033$T-TUL9d0CgP=E?cDoJ zPsXp#ka=Jx6!foNcZjrGNv_fE{g037MdyA@cf^aFX1Zg=sIFJP5R>t!cZ-YVfAKfEZl#(E5oTB5d(YZ?fn0^0L5z1aGa z*i=$}wI>{iIPIp|yT_U3MJmULAfi6p=SV(04gzcZ_N&Ki zZ)pvu24fj~LL~eBn|}X|V_7xe56_ETa<#`nclcFn-^w_Yp$ENo4CsBe?-FVf$@o^; zL-eF=aO|RwvMLX9{TPs5qAd&&S_D=COQc?A%dJ+fmmsz*Qx8KryHjN4+=5S@xb)91 zG_?1P|22+fd@2zpc`F1@jZSQPoTO(iPQn7tVm&*uNkHQ2@f2(hGpHemZ35hGe~A7ag_vXDWh3|8_q}c zS6_`;WfUb-;6sE3{Iug+_j(E5hk-aF75`=@O)_J-zO&z8tCs9}$#&LgmSp+5uc|>L z)WmlyUYzO#%xn%1t8xcYd&qlMI7r1FOw5~wW$Q@(yg$oRc; z7fq8a3c+}elY(=gT+@WBNEv64Mn_g~p+Cw>i6=3MXAsGBAQ#2bcoPTE1>@pqhE&zu z2n8r-!Pp&5?uLcZC0}7PR&W5To#82L@JV=bDv(e!nsdv;ezVlxX&lU-hZrqsx7FP&;|%JrsfT`VlFHwcP8^QfUf24u0TUe|Jxq z`CSXMQ;h{I7FnQ=0*$GYZc!=%cXV2d*_(2yw6XqcUB`UT=@HXg|z!Ackl}&;PynM!Vi!EcMrMFkZr#} zaW)x9?G9*J$x0x$3`h>B!a)2n{EKhMCJ9ACk2sOtm%_mzTY-D+YL$6|>YHm<-vMdu z)R}XaD;rlguU+4|QN4BNZv9@P*}DJW;iJb-ws$(+UjO;-il8jaP*Pm?%F zKWk&Nz3Kk!%UW#?y|tA?Z*6(#(`U|}JHNJe;o_ysg<|PSuBLYL*6k%tPk*X<^Y-2Q z4@c_z`t9I5>*OEQ*g%Gvmier7VNYmEeen7auMxiQkYoM@Zfaz})^SCC)M)P2MGP?j zoL(i)@sZRQoqb=6?fg580-q92kL&)d0_j*dJT*Bzz6hs>531yA5*m%$!*yRyQVReP zMV#Qj2E-X8@)HtUU>1xZ#_#F$;qr5ukh&Sl|MfDdA(hE#T>M$*(6`AdP4Kg}j98^8 ziAV6l#XNAm-UrY-WB`WBP4t3DMemXPb&huw4Sd!f$pdS?CAjadKP194<&)k$g0Sma zzUJkCNAWny_3TqXc;Ejag=FZ&7P52!N#x(G<4hK>ZOakraT z($y|v%O}jtQ!}#~RxN^+JQcZV7PAITU0h6u`SXt-X>ZPG&DDBYElS%@jO%eEn^uf* z&u_ov#59fXLG;FU2}Au@)@JH2IF&VZIqOiy9Bc@)BV> zn^k3TP2l*nDeq0+cb`kV(*A6pp!o>H3dO|u%Kwrx9l0UvZOgEcq;W`>MAD;0IODSG zyG(Ttp3UWn56B=R`nrwq{w#|n$A+aBT!d+Sl%=iMTm@MV*8IBxgX-v`$g)Gy} z>sQxGjz6{^+1Im5pJ?MGYyjgQeuO^1J@uoRWkE-kFHmnzPV0!aI4f^3_chM7R$rrIz=pQX61mQG);&6qjIC@IYrI@5r|4jz2G0_o!Z6k+X* zeRVUsOBsLpTRRIZZ0rD2)I#L%_0D#bH~O0i|K21j=t+er&;QcF=ypO|ZC*;ud)rr% zbwL`;gh@RSUK=9H)xy1CF@lxhc2eat+30-wD!5@iXqjXVVb{m&AU<54T3M-P3#Fyb zBf4IWFI;=!=n>2@C1SbMOzLEF%XWl`8IL@X5fK`5O`5tcpxHlZ?HhP#hL zfvbZ9O;p8RVr-onH7CH3qr#d5#wAbAh_bTuLEAFJZf9vM#vzOoBm%bng@Y8L{2(AG z`c2yciN(@5!jF(#7|Y~^MY1Qfi*9E+nf76NH6iEnmtP<6`*1m(^x^J`Uv9^2QoT-Z z>8tVgK768g!t?v%10}=SZbz?4gT$zIte7AamL7^>%_`w5r^~IJC1yl3I zjG?8FOeP8`#e`K%bc*X=T3eku7;>&8T+qs~Q#gf1X>1x8$BGG(Xy&vmovxHXq!gP5 z;>CJ4m@%+qlbdB@IC~NCxj7`E1TyeBD6KI@2&l3sav0lIi>%cKi8H#LU^9Bd@o+;w z&2Dan^xJPM^~JN$F)Wp)=$e*FJYmQfdc;ni{Axlfm90mIfDljZ-CL@`GcbHJ?&O#R zAx(~!JD!3hOwBS&(oAK5qc1fe^rFfo;?^ALgD_-k<2D$G^TWiy zvT&RS>)nbA%2LLRbTPpwWh^5X-*UlXQpsq@G52BHhackDMb8HV>yXGPdQft4a#XS8 z46S(1C(ue0lVoy+S1Bp|T#4b^@Nym2DrBh-U;SoCX+C=2?W|KOE=HplZ=H;K_o#y4kE1>EV7o0(d0z{)5nH<+N?fmT2D6vii1uYKS*E1g$ww9XIM z?Pul0?FqXbH-1@Hl@bL#SLe2)7ucTH$VLU*DjE zwc<{Bk(*Ka#kj<_U-6{@?9DMOQ74$I0s{}4_~Jtr>u?ik>Su^*iE!=oJa{dPxM5+C&2Uk!ng)?jxPTJ4G|+N! z-fS2&oW%7xZ!)}HNE%y$JCtFthwz%>4*^tR!4 zJHmI$`QR?4@@t?t5=wq~ADXG8fZk5{5+B?JBg+sW_`s^2;l^l;!$xz$Q#3c=J!mk$ zzZ%fORI$0gn!@QBPbi5*s;Rw`mBguhPc>)t7)!w{O7h8&yy)>x2~xsQyWoRBxqq8`b!M7FcRNbpot!HukyU$z#_GYW zoJi0mhy`L+7E}(gf5t7W(A9ftTVbcWye?IwnD+iJY0cNelWIDJm{{qNP-^Vme@VMt zL#FayP)h>@6aWGM2mp6@a5<{GxFgvP004jw000XB0047gZE$R5b1r&maCMhwP!rnI z#zTS<2whsFN$*kxAs|h)yR??@BrNbisUL69z02puUAg-|4~ zI`fYA|KaZWuyf|jGy7$K&z{xS0TI&yfB-PyrY};~wV-1p9s~d!k^%q_007{La7DV< ziQhybJV)RN_jzgRpKLb>D?|_m*ek2~^j6IKnEGdTnC8b2;?q=Wh_UfOUd}|I8tO;r z#R*Qc;`Pg`pvEg{NtSC9INV|@7MCwsXjv%c7iY}e*4o_fg@f%EE9Dp0+Ez;z@T0r7 zDpR6|z%Z4ATG-Z)h=dZp627*%D3%YLq7pj^pHGmy6Jds5i&|Kk_`j@Rx@QBGqZ$Og z)e~6M1QW~rS94vpcr?fa->@*9mds{=4;arweLf0U%Q2)cV;?e6<~nH{#jqk)X4yMp zPy6G9a&E!I5XT*{nGe<$9?sZW^?F5S2Q*8bo#@8zJfJVkrI4XjMK;7I~P9e4+gaL z?u~RDmNlw8EYx0jn(bi4JY5Wh`)45bo`^rFPmQh+p16*4ZI6aKjdeM!3U=d?Q@pm!TDO>EkGZ4_om6Rg;}QXgF2JHPxw#-z-|b)4(B z=oXBJ%Jnb^Y2a#r2G;FAs=iPpvNB2-<* zkDH#DrUZu`^{b~MJ3}M$NeAIo%`xS74S4)6t*V~uVhDg9R@|KlT=s+eKn)pU>Ur=L zf}Kjac52Xv%tZ5fU7@ct$F%*-i1!NxEo$;tWHY`$x^yd zM-lA>Ik1^`8Uh6F?8crPn)lc_#`$NaX6%{KlL)YJoR*gEyXrO_7Zf3SJvL{>G2M0o zCqI}V?D2B-L~~1Ev4ytdd6(0<4TB(}GZj&Oq>^@Zp~6Nis==tbe(cFl3NMCt{a^M5 z<%yWGX@ZO8i+uJVhea%R>co6A7JcP;HF3oR#{b1uyZ~7l_zPPN@V~K@_>FA?+~7C1 zL84;>Bo#>5E*jCQ$!H20o7+=uu>%Vi^6S$PiDcW}ln{7j%p$TCyv%AhsBM`in(2aG zTf|{~PzPHjM^sG{`cNyS_Y`e}v@VbK=tl`+&n0toc^Q|jJ6H9P$7fTYp$n<}!lC1o zo7GF&kni+|FWwRf`N02qkT$(>Mbf`K1F>2c`Cmg0^uO%;328NlLlo|zl;z*(&4GLiXigJ?K8=A%`Y*AB`1il zdglS*0z)K4@aM&b4Fk#p*P_6><> zo767dTnEAaQ@w;@RQED(HpOjz&YP&Z51Li1=0arky+KViYBQu0INyOdv8|tgP}Szw zbK07M>8t!3;~4viv=}j;w*z9FrMU_UlYD12)nkG%rS_kd;X`VU;^f%-d86J3lDYw* zisO9b%&1Yj;8F7R^W?k=A<;?0gM8Wnt34N@@+H@?yVWWE(-s1Os>Ktq;MR>f>Mv8o zSrOa)5b+_FwSzZZ!9>It@F1*Gk!_0^gbs6aDFT#Ejx33V`CpwkDqaf7{x~KB`T!L! z0`0;Qs!CMr{P~CaCVoE8q}2XQdRk_L5g5|&-m)5p*wGQ)db->;49BZBg{f_R$1z;p za$_>@6+RntPB}&?)2?|r>1>liP`yxO0bVhwUqp>0)??1^1<*o_4O0Pw5-rd09|rN##Cb7Is%Rg(nd#2DBxk7#JRJFU@xt=uuAzF?1t z!**4tI%75w8=oId=zx`M8pplq{{24m7VypP4>!5rZ5Em%Yl9gJBe{`73R41>B95N;ibeTE;7Lnx;mSo5}t zeP9^KbKq37$lt!R?0pz!ll*}J(b$iV_y+x0*KO>0HIH`Sa6gdPE#~?&6IqPc*m3+A z<@RTe;MMylgy;kF8gAkJKIgGY-gurXk;N732elW?iNe%6>%N=z3nwIu02}J*=${fh zKh6s2(}<=0BgMk==+zKHJ4qDi2-{6tuG$$}ca`{W2Nm>IuTCr^lp8r>2DzcHd9t-Y zMuR^Fn&)FG1w$@@LzOl3*?#H61!kXf%+Kv6g^Mc=0C3j8p?d+6I8LB^IVZqof|?99 z0k;OL zVGeh*W?{ocT&a+)@?k&fxZ8QieQ{LX*=KK0Ame6J{t2;OE=L8}^NNPK63fFVNjT}F z&-!N=xM0zvS-|+^^oLqs@GM7=4a{r)@kWwRseP~Vh0=9wk9&}VZ-bBDH|D=htMqHM zPzj7A=@0_|73BYJTB+Yn+iqf@$0b7@q_L`q0U5sD<$a^CR8nLtLR_>Z_=B68N+J6d zHe2_d%h!~>c1z0jPM?8YT?Rva3x^esB^*X(IUonOuj&)414^$s+?}GZd}yii)`NI* z{5^zlr~fdsiwuEWfbE}*N=K4JlI;0Jk{nXHZ4QMP4Tq{^ffd7VNeZRv%XwK~Qoeac z697i*h!AIzC4J6a`QFLTO3zg!i&MbkMVj|%eiUikB*n`*NvoTT=ngoZCFvx%Ci3>I zQAX{O-!fkjujHqv9G-kZFLz5P?Y%+^P0gdx6!=o4S5_)Qut)561xvTBE>PiPtzBx0 zxu2bsDP7sivR9D9kpB3o5|(h)u>r0aLr+?mlghly$p(-MhS&VloDNs%nZ%db;+@o@C4E7ZpIpLb53#L>9BV$6W85Nk^4U zg{E`Q+n2t4hvXJ!LC!hw9#7bB41ZM*)bO|?w|#QX2se+) z9Atm6`BIXN+YPUKO|V>fFp`2y#Jt9TAw07C)p-lg=43(wnPwWjicALi?`ydC;@VWRCiL=#NC+QC>ZR71^6g`R2= zOar{l)<)_aQKp{6*-~Uni-~u6{&979;r2Zli+qnsRdigAz#d5297gQd1)Y18_cNu& z(Nu>}$?55c#xiT%OH|>aB_FNuDzeWs^>(_ulvnD{>81E-XjzgV4Np6)Ox2GgwRvzU zh<%kCwEy5_N}4DPcExkiZE9Vp=drzNmIY~*AUN-I#73c|;EvrXP|4!;QgWhM#yf@P zU1Q}6S%Xapeov>2=Wqs$c-~I_{r>w@qq%9~KIkXW;A-((*0%4o3{QDlo@5lbB)PlJ zP6$oUUGiM*d6v&y(0*gS13Bt2t?ybgpW~r>36t5c@ZD(DFjJ@<4VKfl36R&ncP+Y; zt<*2{@x82!0b=@K&rl{iLJC7(k1k)_v5Mo)o=ldsZvbnXRIqT6&kS~LZmaJn)Hlck zg)cW_#VV#x5u9n)JJb5aJ65>kaquM5HYeKMhyXbO7sHW=cg>M|#af9!w(6`ewz&F1 ztCy^W-^u;jA6673LUquafoyf%0!2^Gqc7ieP&Yhd@ZZDvPy7*Dk^CLie=Gi{LH?~sOZL|;{|K*K{ryP%>#Y6C5tP4g{|8V@ z0|XQR000O8eO!}D_?_^qd=LNtPC)Mc8S#59IHW2T=5-B2-}CTzcRU`i ztslSE=i6_-{RSpeXM8}crat&=6GTBC#8Cz~1#u$A0(U)qcQd=5 zUQOpKN8(mXt21cBMDI)ny~(gM(T(0j?{_AK)rO1ZxDD@@ZD_5QAM~!))4Nvte0*;9 z`p1IsJxeoW2bj1y1MwLZ`F)(y_$u~;P2jm)1C;L22WX& zGKfCnFk#F`%3u>!j6`S=;prj5$@Fshb_PGggoVj{U>eYhV)+Z`-yIW!Eo3>okAG?m zBs(Cg3O`2HG;r@iMifKx0%}f%P$|x5E8RZh=fmarqYDZnU90wBG%!w{23~#{ zM_ZDuB1rtHS!M|CN4GSPp=lOj4C3eHukeel;duj;Bb-UN0paQqwT<%_;%Hyu2-ANB zLxHUz^SClb#&YhXj96p@4G*!r9XYqN`O5CM#qi4cwGFq~c1r5|YA69}u#+@W^qd^1$g7EhwlrT|HVZ$BVhshQv)p8dzPe+B}6>kQE6J zKH?bCMzup66EckqQMB86hfb`a$(2Qr*|n9=oz?Ydyy{J+7bA>VLg*F3Xdo_vzrgX_ z=pN$+{w#v@BVi1(g?}v7ht2|^ng^zMpgHOgvU--`cr&y_u6`D*J z_aP1pVmPf5_FVC zMpy6BC1Yv?H&Kl`T$o^)#@>53J%hK%!BVlQ1m~Dvq^wGT8IkE^7;fk~nR4J%!x#iK z$U|sR?T{8Qi*gpi$hq3ZK7%+4pSX+0%bS^bYS;Z^nlkMP>kbZG4Rj;$3*l%jk69av z2wAF#;$L-$uTR^eq;z_~TOuowtc+Ri)`sl+!SeFPX)Bl)rnr^Hkl{K&D;`{KJi4Bk zQg%=-r|S(_tf$EP==ULspH@3Dko~1NCMiG?aQ#1uEZ?yxmtGx~H;+)MvBokiNU*P! zIaJpgg6HTwXz{;w8*tO-L2eqygwy3F2-n>30eUg;p=~v!_bh!CXPYLF|3L-tHFVG?O|FU zU0W6Dt}7K4@>3yYD65ao!4u+ zeU@TOFssTR!!KIe6w8{Lb_{PE=H_|G-Vl=vNn0pjf1asNOgd*eXK5HjlIXb@N5c&c zCWd8^vZb4OZpg`$xFH4^r@ByO@Of1%QpMn^tm2PPF>3PTSNouY_OROIi#It|lnii;MchNclkyuk>jc@G zHarH{J}Gi=qbEFCNy@T}-_#=Mp&SBJH_D&7$To}kNn{T!$`KZZkl!aQswOFp|*cECoS&ID!(dfbNwp;;JC675{ z95EaTu!?+MF)7j{&R83Hg2)RCpD*jhyB$kC{xoxwB$O?ptc?gF4s(W^&c*L3^Mfo; zgS#SUIEO@=l(F!sjp1|m2lH}7;NpDAFpM9OA0Zsz3DPsM2fYg`6p7JMLDbkM?6BHG zYv$Z;xYv|%%QL>upWrDjs_&5rKVIktJ7jQk@#SM0qh@(U?}pC?gxN;OGz}C)MCS4+ z@Cz^Jy9d|%7{!kv^S8YCLm|N{CBTopg3k+c!DC#6K58s^64V(@%6)^TLRX0mrHnr+ znNO}Xx-jClMVTxvQje7#vW&Kf+fQ(Fytc<)(?=9@QRTwBC)X%uqD56(k?$cTpU9jBwqfg40p=i7c z?jMw+r}X|=j^3okiEu79c27=J@n3n#qtgC*BHw9c;(kHi=MSp}IrO~?AW$#+jcs(ZQHhO+v(UgI<}p3tetiu!-pGg%B%Q32KcFZ7nL6+1Q0Q>SlP0Sb=<;z8Q61uat_pjkUbO))r!b_M7HQ-xwnUxGX$J|6B^iw(wJN{&*wBt zM~O85V0e_4Dl${LS5AISV?Hpy_$HHhuia1i)Zqy{E~vLJ>8|S9?}2U_*+M(0`dWMs zAgA0~yU3`RR4(KeQ3D5IQyIq5Kgg@T-=HdH?+uVO$7A50d5E4Lt4xi#vBcIlnV0Vk zVKXGZTUN-k!=3Q8>5)zMW%NstBw><1zIm?Y(nBO~>NmyRNyU-z=p#x^@A&`#Xy3;yb_K(Qozk z=D4PM)B*$Y8B5z z@XN4olD#cgc-^P6OodrrzW}*(2Ai+xA2%+!k^3KT`j2ME+XoD|-obM8l@zpg*4Sn& z4qC>-&S*oIkPzGMPF7J-TgC3o!cJR7pD+rVA~`Br@)Ok1&YMy^HRXebBEb}J+mw$P zVwV^hEVu8NRKc+MpD677dVjUn&Qo0FaoO#L~h(2ANSvP1(E}Bz&S8oxm1Dcs)W!y~PePdvM`$2`w3&CCk zZVRXGr%TZ-U=ff@L9@-Ij}qcb5a7xZ(%Sit`CTExEgrrY-*TE^je698!@IYI`mVaV zIirWRvV?=-y%XSJG3Dp7Q7Y zQ<$_&2rx+YThGHfiQ=~K)+QiH7SlheYadZR8)u~w+oN7XZU_|SB+vl9QI9d{h@k+ zVhVfi{VnmL_34#ye3!JpCQVa&z@w(<<&ZOCkNVBb>#M2`wf*MIRWax5@lKbE=J9Ql z4kaFUxg*2OQ*dT-VIb?FV7)zGFZ0s~59uBId6dwJJoGL=2C9_e467Sl{yGE`Z@3@* z!~$^+S3B=Ytw&_t7CYO^i6857`Ibl&3_dek+_{5p%o-!gx|;ITIa^Kw{+uRR?lSpkU0Tj<3MLIl|-ZnfpXViJU9GO3T|7 z&FkS7Kd#-k`QFa&`_V8v9LB;s^au1FnlO)^Zd?Cy_Y6$C)y&ZCrQ^@|(BD7m9zucN zN67J$_G$7WDxu*$)QN3Ytg&(bQi$hNx}vIc4LwnOwj0?C+a&21XwZ`mrk{CK^{&S) z?|+kdc_Z>C`s7B4EJUhr6Fc;9+C~Udap&WWm#@Ec8hagStkrwH82;N=k_n?FB|&~x z&wWGLTj%cG4mt}2K_9!ttI^SBN!hXOTjqXZ7H&Vu*?BtDGkiKDkA`b8+KmS@B;k&g zKB@oCwq68vLbf+WWGansXnx2z1WkrvDv7sX{P%FE42=O{EJye-d?@{KXEoAPO<_#R z9B3rMNnl4Q^2RePL!O5yMo?N)m`;k?^nyoD5N6~nN+>EfL7pKWH3Z36*3FvXjH26zty1z))DW2(`DA6t^9qxH#%7-651K zX_xPQYF3duL*h<^KEL!c&f(LIQM+l;gk&K4t2Qkp`?KHf-0`PSZKVxV@^4U)LsKqw zZ1#<@ZtWk=38OI1CYc@ghHw1nq-8b}&ETbGj#?~g%o919;hPJ$RsID3p8>_0QHCIS z9TM!;j|dEz;J@=5o%Me7Uq*&T|MARhs^8fy2%vmz4SnyCvH|S}l)zF@h?$TOj&wlI zlZ?badE%xCZZxx#)4lKb=*h3x%!inqFNONruRizq-fSH_dah(w4Jf3RiKCQpc4tqS ze^}C-s?5un(9XJWpTOhucmtw%elL3WlUd)PB$>sQu6g&e@?s1^9&jizcJuJy^zx?P z;ml_s8)vK;M;d3MoJr*j%8@3-O6MgBq1JD_`RX^iIkoR|EJsYm^p!gjL8~+X$|(HC z6`(b%9`}b%Q}WfFdX$oZ`5`!`MlB4N(3y)lhc^0^wbKt@<5}Y3RNx?n=003TJu=uU z3X`v_Yz{ya|qH^K0;)zgsl?|0`9bPz8%6GvsP;KY|&#hZ7y?PZ9hQ8+P&nGWG><|>H@}Ti@giP<#<#08Hc$JTz9A!ggCL@xb*= zYop%SN{z7&fS&`p1nTt1%lAVpTfNeWXj=TL+uzKX3VZ!gItclLiU7cVY^X{==z8J%k)=z`A=hDvdgY4h^kj$%nOhc_O-w{)~lskmNhDl#;GpS zn-r^(bU~Z+Ii)ud))$^FQb&xl22Yws9%YxkPlXK%%hD5Qy>-SuiDM(?SidUBM$Wjr zidG)c;~xr_h|A~nRIyek6^jh0EjB#p!Vz2XVzrqlTmGPw(A*Y%i3}nh2_ltTaH;1$ z(ni?#gPW${IGd^ zfY8N&b2gysrNfaibIQa`yy={d{YH8(B>#(_!j`rJZ@tlT_Sgp#vZxM>&3E~XbA2P% zcQAHvvu&%zPp+TXZYSxjr|)$>_M5}Y+m(a~9B%`})|2oSHR=qK+?iGng#mr`@hN!m z(G`W*2MrjQOvst<8}D|_OtJD0vE-}~Fqu+-tZ16Nd?QjZbv2QY>UQ(vO-FV>xQ9@9 zBWB`GWK$|mg#kso_&!{de$Y@e4tMJYy8d7wGe?6{;95*Ow}bEk}HWUs0U%HaB}fphv&-rz-JuS=xzIzX*hf>IDEuukls zdpJM3?j&l>MWju1SrTB93|xmTvxO#0q=ZPqYZZkQQwyfYX~;%W&OI|li=w*ZkbTV% zn{zPcoc_N+nF8d-rXFbvmi4GchW?{8_QQ}u?AquO`Q?g2Zh#eUR8&6{RMVyTc(#4PjP^i%*lC)msq~pa zf<^~TzPB~V#(F{K=3lHM(dXqhzWQ`-bl7I1!J1|BpG6J56=k%UliQ51mIxidn;NWZ zB1RRCZ1JHhNZjE@137O#bn7i5F;Ao|sPpBb{Ut|?F`_*>qNF&YCPqVl%@u7|WX=_< zQ!P_St&W#OGe>?+IsX!{68?P$QJzslX~Ak`1n<%s%4Pz_YR3E1=~I>y*3lahNPcI} zPGN?+9C~qKYV(c=7(7BDsfCBOY3%HBx7pD~nZsIg@G4MSDOaK6u$-lvydHwu;vnX` z;V-DRd&hO`x?H8lXNHq|niBW$^9*x8;0E=5#SF9DjO2aO_44X`dpwj!&U-?AY5%t9 z>+S0C{&scQj%@jOGkt;2Y2iC+zV>-@aQhRM@yg2_u*1lWpmZ5Ms_{M8ahs)gCqDD4 zMcLiXdz5{-wZn;yXUcYy&fCv9h&bky6V>~&_a#0P!c94RMMhLx!_<4Q`0E5b(4NX;r^2Q`Uv#? zv>tH_v|cn$dBa8`qjcDM#ySJ%bsUed&1KMOv%}-}{5Umd&f?xi5t}`lypR(qZMqxJ zg1?sKgHPijnOVztzZ*okf$X?`*{I>L=7dUgPpf{7X+F4Pf@aS9jJ-+Dx&MsR&of;> zoi#y$sF*t}zNNJ0m+!v&gDHid;{!PvvQk%{+jh$+g#kJXZ!BWvRtjI z16taIeNeaA`mlh5RY>?6rDHGaRafMqT3N#__p|$ij61=f{+W_|(Y#6Lp@U}fm>3jkpogrH_>)< zxg}N_2n75T1o^ij6N&f#C*k%SX704*1}N zLoRqOaH9#z=^d};NEoxHUu*g1V`1`biSm0Oxy~|PS&V`oMnaWbNauv(^U#U+4~v6m zaC_Yi{y9IE%e0OYyZ6T+CKzb;wbyBX9Kl%b3O$WrY~8@3N?pjEWuJ=GHgU*RU?;rU2xiKz(VJO)y*SH#l5Qf;|zjVIm~n$9+WMr91D= z_vh@V2fuS_8AVVs6GckDxk$bJFNeaPLxB&y;`~h7af_>&``=(Z9+4|M!8ylqTgWp<>j+8YW{6D}k@DJeTYtCHViRls+5fNmW<#+uUgLKshC=$aPLEl?97npzh z1BQJVIG0aUwyJXBNTIVGr<$~?Us=dCb=bosj5u+*dxsX;65I|P^q*#rg|+mnQ7gE zs)|b*erE>Zi~p89j^JUA=4Q8a0=L+g_`VlW6Tr37CKcJ0qN*=s4P}_@X-%TG?GaO% zBy23qbXQYj+F^afkB}J^D08~fx0Yey0#%noWyv9ji!Fy6!mLa%)S2+7gn88#Ia$+4 zD3DEyG_;{&1Tiwr3sGlOsSs`197rE7$pKk}5fzMs)D3ar;>u}oreGx>SBNBFPvlY} zNkmfxS9OfIiMQ8eL0cJIM;n(IO2NGTC*ZAOY%zeg?0jE6bDD&mVQgDQC zW}O+KEX9p5Ei74*S#2}@OS*xHQY71;`ZtbBO|rmHNV%_Wv9-QY{DE!>(x2kw-^G}? z2FQ6w zRl+0UiP~l4vp%ErQHWSJ#P9ElQ5gmjtGev69V3rQc3upJw1M`S8FXrwiWtHE1D{Z%DToQ8T< zY^=JPQSmaaafB7J}B3E1lWDOA`{14=OlcatLH z)KN0Xk-$|Uy?6Dq{9B!U^YKMVw3`Lz#w$g0+;4b+PmwHytdDB_Y8J~6@@VsuiNfDy zbnDRl2GB-iKydvc6!e6?|7GO|uB54>O@WK+yO*dO^!J_(c7y)90A_)Y;$Bb#M(DGn zZxgr$hK7d0(VweX-~hM^sG?+`e& zZOwV zrmfdYh&{!%OMaWM<);nw-3^o+faa##CIQOu)A|a#tAd%uwJMBlG5%T_PtK9)AC%GF zAb=qd2t@hf!wV*F%ZUJS2VQ25@uS4Z0Fw~BnLR~%c#(Gkc-jdL^n3g?Yh7({ z7i-OE@33stl1u#BU~O;ryFvdSI{crh&}^S_Pc|3;5P98rsf9UX$#zk$?Pm+q= zKDP{!O)-@8QRkE!LHy+uV!xl;tU7O{<;;KyY zgw_r?qwepxbjG_FUTYDFkSv|1xTf!=$Pf|em+xOp66j<)IY;HO2@d`0L}rkhtX0d| zhfOj;{9J+%McRJU-^!5?gZ4)9pqtHB&yPLjDW@tpt5IYs?bOpG!A_bUGdN{ZCl-?bJULUd$blTkcRa3>3m9WOf9F{RTWpvDp%?!i0 ze)e*Znp68JzqY2KF*Zm(1=bJ{WI<8gLV zII~p)UFasz#iZ)4Sfu7l$oUy6;aZp-J;Pg(FDXRQsx(AG-DT=>-n>AKeAq%yo`d3m zTwb(xgMMDl&ZFA-%=eOZsTtY%q00}ugeQGF22)@*+hp?5r{z-bB%>}(IjdQ6r;_F@ z%`GTEuC()c$y2&$aZTz7C_3vK9( z9j9AR>nY1~x%PJO!&n7qIZC81Qp5_UR!a%p0pYoWg7!3oi`ZA8Vq~dagW4iBgL06= z6l2s)-C{lr;ZW8P96poeae(Eedd$W~3zbgea;TDaOV=6$;UaOkpl?%YLw_ZwzZq8# z4bWgaIXExJHV5Gwe>@cLOL!dIBdPBz+_!CzEF7ij&o0?qIIP2Pc(AISOHA0w8?rx zzi7BZ`+P2Ud9I)MEFmc*fon*DfxDQonHYb;A5I9WCU>r0Zj=N=>uWED)6~$T&4rj5 z&9Zox5o2HiLsI(_wbBhef}#MD@42ZkxfKwE1kBZ62*iP*{!m-e><4eR;bR&ZvWMn| z3tGTS0^zb%t8De1VsvoPK_v(CT^lL*Tm30Q$}-xsqOJz4B33sz;0_GrQzv5dRDV!w z-1%i%stK-7%nyVw%Mzkpa2T05^VjD85+DBOE57T&MSAly+o$?}X8Wdw|M`j^{V4bU*Z!wQy4=Gxw6Uok|eXuo71rfYFu zyr%|s>(*1_mr*6GLs}_t{a9V-IZG*Ojk}QQ2eP!9u`-gc1&ht9SSB zwF70vVG4z!1{sHA#1kHKHZP6%#$@h%Z!KklKWGc?GQPn2go10*(8Q!Cm*y58axsf%6Lp2YvY?;v8ulf!V^HYVQ#aGRyk6aZlpZ%syNhyog zI;@5xr%Ola0urGleU$4C8-zM#h*;3cYBuwU67U{8){jVQE>|t!=opzlU-GF_uAqDG zS-QwQ(x|48kFi;~JncMoNrT&^YEuH|+r?`?AYzG;q1+(Yc}jw|HD~3gK`VfrAX!?PE^O-=-Vt< z>>3#I3$%c>P)W}}3r!Qb=R0Jo-1<9uYD@>vk5AB)II%<2lz78W#Eg9`#;+c$YFmj< zJ=*jNd|XFhzh%qs4x9YQJAntCb-o(0#a;Wxai>0jS+Kh*>$~CnA;3Y{LYy}@CykvP%jo26XwL<*JqqrEfMow-6s}Q!uV}Kqk~NsMTzDd8xPWKmz{(dglGVW z0>KP@?lIk$m?$JDRIultDQ$tl1X%yGG^a&z(>UT98hU@ z5~vI+v#2M@I9*ceYlLC^t=uAhD=H0-D5QwGCrkmn^;Y&qKGCzUd-ES(`hS3tW>yEF1p)w6|0JKl{`k`Wd+F`?UqO*usvEZJ0th~F$v;i!5&;vE zK2Z7+T42#dVv399g6G1jghud7(0|7`WX*?q-Dc?E+9|0lJr%83!nRDFrZU$0z5M15 zG~^a(aOWAO%dhkh$qm@@j%SJ0cEGoo)=JN4T-{vVb~C_`&mV`Ez1%#ahu^!?YdyCH zn_%o3vf+vGl-}ns@w&0lO4_uv_8Wk`3y1}<3gFJUk1f_NOM7sw_@$hz7}ITL{n+*a!TykafMuNB z2T$`&alZ&QPu-MK;<TQE}%$nYz%Y{vbR4Qsy{*}Ebp@ZtnDcme4Eh$;`c1tl!L2j|0OH`V!RAs2K zp+lDZtt6jusyRuW{!c|YVPa^t&C{e}g#cGGt+De`qWG#L=?ptpMXoE?kVg>@erml} z6Rm~hq@3jZo%>hBq9glq=On+DmA$?fr!=jBQ|cRN>ty33e~QT~3A>y6BArQe$TX(i z28urIPve1d7I1WL4JBLi&g@P`*=gK=(pqiz{nCfX1hngEA(EA& zBcB5>9 zZ|WA$+A(&7_HG~HU!6ta#Dm_+#~g`N`2`v!6RETZ|5lA)%HcyxbG`)b(Z}#XEDF?1 z-Hq;CW_Mu?naP|~mV#E3jX;_Wpmu-0T}TE1ED-V3D^Qw=7Xm&Aa39jo+4Tn<3NI*N zbH!fT{JJT1EoX$7!hzTYe)A{p12BL_&wM&V42I_UoaEg<=o{e;jrs%XL4S@f0g#E~ z5>h+l#895Xq#ilg9euuG4rS8&vQ=`t<}k}ezRP57TF#m@k+Kt>P2;T%Cp(m4(LO?m zrb4V2GKmGNiCkSg4x zY#U(Z{R9y6Q-qiHJUbQu3iU@>w5 z!uAu$R8{#(WvP1kBDOG{`dE-pSuCD=gil#q+bnx^y0`wb@r<|6;0h7es8sr8V)ztW z#V4~_QZJ^oTON^AdgM6(-HzMwfrICI+6>Hw6c>#+i_C$cWk6F+-1AOIq?UmBN8KmV zJ#qYBNK11}H-)~|COZ$(N*`~$%qb%xhQ9Fa%)z%&kGPB!92^Ui^P2xCbO6+_zumL6 z!%E`@8!YGz*c&|Wzd1mRpi(i(mjFHQKkSzU^uzD@jOa}&Im_w=VOSax>|=8`GuKyz zAaWV?ZZQ(Zoek$HILy<&3TG)yOE3&PMYt^HeRCvwY=M>F8{F32ZEQiF4vEMC+IEQ3 zONTg$cf-eG;xsScNs>YzP(WYXSTkf;B+oTSeAM8{h7(Fw7}#C2=Cixb6`u zR6R^S0X3J_?1WUhdbVnsrsnB@JJ9`;@fKN$$ke6D+|%MdMWk1F4ZSC#?b3Z4B@FQ)gU5hsTSRH z$>4aKzrx#db%L6#<@yxr-kwLwMt(HK@$HXoZ;uRPHVsxR(sxUm`@Zh}>uhQeC0vtj zPzM2b2QnYm$H&w4D5(w){u`t>hyB`KFOTo*_e6XKW5uc6dI-kt#)tRPN0Zaq6bb1qzEo}qubJ+R`W_yg*lBj6C% zcdXq~MVz%x-m>4btKQ*f-QHV0_?{20RPSO3g|TP@U4>7RFUR?#@ab=$K&bAS2R zv@zRlU&3v0+RbpVC!3CAhDeIdk}GFM>ruQ7upBiX{dGOr|LT5!)=%)D&YT_=p}{k{ z-HbHn@>=8K!_-rmHRvPc<>$ri<;x$uX_$!~SX_x1JMe~+Q{8NMLalLU{WdNvDMV-XNJ0nZ_rjbSm9&1T!d#FU zQiqSbGfXrQjy!ygX67IWJHFwji}YB;@t#N@fmy*P)en^5%M)cp5g`=e@vuzNu$R$m z9J^(zU4<5|r0ifD(pCCid@G%&(qWnqJcfJNq7e@_fm*5XK(TiqB__)Ccz?=|9-0 zlMWBS>w_>C0O$*ZYtWSZ%Eq;jJ83P!m0D>{5%^)WT>ixWCEoNqJahKq_HbSQR?US- z>R`YJ@c6^e`2+g=3pwae?XOWo_zTyq5sygt~bJzZz!MHIsw z{|eok;I7oH#_uvTmZTHK8pu5NOl{;WV=1Z60d2v@XC=j z*?De82;ai4P|BFiox%+Zb3}L|;%EAouo@f?sTxSM8fg5$7!L%Q9_9b)fRphmV!Se} z$bo{IKRGLYU`Ch3RAG7FvX=GAdvXP_m$s*O&pI&J30oJ{!q4$>O(KmH7Yqd|p9`(Z zxm>bnD_aUa-}1V3znC=vFXD?5m1X*t^3lD&U6&EybdZS%2UfUInL+iTQ*y zMv3dV{G!W3mi(34k9oxp^$6sCj8-L6vZ{3#DY_>K=|K56@t!q z3&p^*`!>u1qPp|`-e*%b0}*2SPG|oq#2xja;11Qm-VxXWb(YGv zfFI20*H~yIeIH@&JRW%0F`0Uu*EkJOJ|ne_SdNN2=m=+|>hJ8JoriM0$=LC<8(LudGC_F%Rpx5$1(GC>MAHe&@gYb=0} zATt%222Ke9@M8cgl?t)6TGlwqNMsUcv~JkV7~mR%?6C~c@p=}d(IXygJD zS%D4gOE{7{2AEe{0b94sm@(dl9>!|sIRJ->JGXG%OJ!o}ocCg{R>(9@$kN-r)5NTb z-C8tL(F?!4NM(&KNH>B^8G9_K?;71K`ulnKc)a&sN&Jky z{$TnNY>f?W=$XCW)h{nf4ivL@Te3iES>m|?VCSR1)1!u>XvlV3c zbyht}>8U*Wf<>%j<^n7~eek=l*B*Cs1UGtlEycj3>>ilJ|G-lucN0ulL*M z1@iwai|PKDOGCNEqgVYbidS3z7i5|Jw{~*#x1t@AAc8OZ9sd*v)M|T;8$nGVtCE87 z()#Zq2&1vaHVE{%?#Zo{$l&kmDLm_41x*R7s|Dy%ybO_LTiTt_lvkZcn%UgAge3_l(Z(7y&@PnB=4hv)wizau!#tzqoHr0MkuP zD`AUH%|J5JJd*!N5(o@ah7+n6&14e)CNjvx=#}zBB-|>)Qn+{V5qqF6VFubb~WGnECw}D%XOiAT$ zz8hl^l@AXskclCk_eaYu^}ZkGqRu2ckkZGQ3sJ(^Yi9SadwhS*1#duV}K1Gpr z!5I3hSi6g1R21!+k$b(f$;!NrywEE_YFvON)>x<52siioQV%B?t#Uh*zayy{Hp%gb z4S33Qr3`=frD}r36DC}O+_(gI<5VB$~aB?@LFlXAw;2_j<3AO}qY`i%Tx>8aQzlCWPO zLcU)EV7!UY*8Ouu!N_1JCZ;x6mY9^}%GKJ30+0@osK)K-O{#obr<|JoumZzaB0O>< zj+Y3?N(mPEOjmrr9sKbpr}X1G(25*q3f*A`t@>}a+g?(TK9582IREZdWoG?7 zj?A*Co$m2+ieMu-*0P(|&2q=L_qAL5>w=|%05A|~#g0nNu=}o>;G$ZBtAKIz=-1}G zc%xK-rUredX7E>6q(eJurx;)*!#5#w>0NY^*kefJ_|1rZR-L3FOqJL`yB4ap`27Bo z&3SA9(nCxc1;Q=_U9c!wh|A0qGc+7KM6;3?p_8|Ap>P*|ylg8o0)!5?i%+CPw5-Zu1ue4 zpwZoA?KGP=g1+MmX#Xz9998J;E5&-sKiKj*UK3J{15yF{q=a`f8fTCTr)P;3FCUnrhFRv+`Hz#(k{j44;s;d8?u z`O_Ym`>Az^O#ncsAqlA3?=UU<2f3l7_TSF51Fu|zl^86N4Ms!7{wFu-+5Ax?$9pPMfgDb8NM#7|+x zfUHp%{-T-355Wwa1qv%=V|GfO9J;4~ixA*rhA+;GX-P1U02iaT5@Y57AWuqng<)v< zTkE-)h=7ljMY+ivVH&a5D`U~33oj%DWIn9TL+X+MbJIY51y=&j00(g@4XAvFdSW_O zhUAwhtUW>b*gk~@ID7SwLwGy2#KKll9`!>FSiJ3hK>U;FUAtbbd5(?K17`oUJSY%7 z1b~{}e~5^H1hovQYCLdJzfgi_q8m3YuI=C*&C+k}F0IXo_UnZB z`R!)&&q~e}k@a|FT~^T{KgeH&0VWYoe$1oqyl8QsF1e93e$00fp2y=zCFBz5H$0Z` zZsDrKtRiE2lJcqU`-i!E`soI|lPv;^Lu z**z>|A~O-zrxVUQNYjhXtuiBo0q}>=dobPrLC8zIHZWqErYnkD_I> z0*U${VIqYydzmA{0YfA$LPsbg?L)&>*w;Xh78pQZf*Qss;8Q#UQ7N>@0Jmy1fe~`B zO#$26zDtTyH4~gUKtIvfQ5Olpsu(y(q5FrGRxKJmIj>x z+Fv5wgTgVl{`#W}kqLDDSTU~eCYe)O_`(X3_pTqT0ZU3Y6XAZ=}!&U+?8)K;} zUxGzjpLKyzfb+m@36$=`8dF6Roq!pqxH%du`dsRYsN$M3+ZM!@gH7uLstN0!uq+v4uqzm+f2Cn1yD*wUDzg6UYp!-QoZl@?SFWmC<)rn|rYhpKZ7 zvZd*^b=$UW?6$ji+qP|+yKURHZQHhO?6!UTeZPCp`R?811i=mlZxF-?FDWzx z%6o!CZdkPEH_u;JS2#S`Z2OLvIAMRfrsG;mET`#i?JcKMR&bUu>{U^Lkv_)Nenk+h zf2G0re)G(#G)YVtJnUXB@3Uc{5y4c$L@*KihRN85rmM zRrtef-p3sU4OL7tR}X5O7Da30jrAwAKm!i3aA9%Mx9_Dqrt3Zd6`$VP1IYyIsFA*rOP~j9J`b&e#!Tkedwv=4 z>V*Fmk;m)!nVJ{5?6f(}RC39Ipb2q}OEIi>KWZ{)d~}jO>n%~i&L1@s3DnkaUs>M7 zul)_bhd46zcbPxNa^)T^2!?YAYnZOcBxzzZ4cSS*GbbVLG>GSXSY{J%9>Q7!p`S;3 z8(W!mb}@u--)GP!TcEU!O0W7qJey-uwep#z zqQldYkCI*vhBn=R!h9XrHJq?OQpluAmQsr$oAw2fT_&n|glZIBI44&zp0} zc4LbXreSETn^B0qh~tv;StLm&6eU4ssnJDp}6cAVFy6sOKi+}2gLPNW5#K0#MWHW>oA;RGM2WRzww`>8&&yljtpdk4 z41Bfkrcxd*Z+o1Ev z1H(v?@`Oos@DZ4g>WYcBuI8}p^%vVc{Kv*r;|#~uY{NOv&af+S$*V>+XI9bL4$L^& zcI;laHI+>W+VYH!5gR!lirnEs{W4VUWkALpoyFET5l;O&!4yP z(Qc~Zpesq*&*-+NWFf9en9o7bI@O4&L1s9-^Suc|HY|2sM_$5JpBK02IT-KG& z!rbwpoZzJIf_{|jZ`t|UQAm+`e!*sc1TQrfv|EFkPIp)=h>e2Y=l)T>)Hhp$UGkn4 zlqqqhGJ8izho|y@-EG$&h~Bh-YK(S?yb1_yN~fY(tYFF6e`A>KGIcLwi`!4`E1;pPXV$l-nH-qx zaSyzrOpCJD*y+qv1@9?{BlVdrTEMe`^D+m)5G0Hml9ti=wl%dNI)rgVf%-bBK%ea$0uSeswf<7z1EcI0*Jv5a*3pHR%rmNUd2$`>9nm?;h zti2*?zS8OlU`6y`Ciqm5=Qa(#QH-i=Ct%U#w;x2wN@0%&Sq0kcx(M6FJDwCSqC*`gpV4n@M3rvY8C)eDs#UTt+e@cCL&(jT}X^NLoi8uv7 z-6J~r^SD%asY6cMpfpP3{rwrSRmn{`F3xDc6Td5j8vJ#CC%x*ug}cAh5qmwfSh;Ta zA|)HsIE|r6Gku>cVSgj&9U3qL5u($x+pCI0b!{7q@aOHXG4Hyq(BRjz^Zp2d5m|*p zjAm~Xn+)SfhlZBW)>r7`ei6?Z%t-Dznkak`&)2k_+S*ifJ}?CF&cRY2XT&py>ud%8 zaO=+#TKkS=s7rsrHySDLP)qh1Su#gEdKT`Q!%_HJd6Pf=rcYPDR;&>qa&M9+d1=5g zI=@LD#F$iV-eM;um!8Vub22qqjP_SC4E3@T_Oua%8(|=m(QOQGTihD(){yVitfYjR zuZT_!GiS^r>!T#sHAjGCnaAUfj ze6GGR?fv+4p7!UmMeCX{9|RHD$!fpRyVY90ALVaqQ}QgpM+PPtWU83lj(VjGVPz-k zYD6|ga06k@mU5`RRf7DA9-7wg9;7*z_isMZyY}nvs)ad40K`JSuprpJzJ*%1saHAg z->6^R?TgPB@Ax_#L@!?<{U<=(KFWs_xk&u5|IXAb8z?mQKQrY<`}UMfBUA1^v(Z$N~!e_<7M-LBM~G)7bC{35f6u-=oY{-8=oWKD*j$c3}V0 zlm0(FvmwwBEC2KJkF|KsVgIuxh^M9V|2K$Z)b{_bS;>p@@95bOfe=RjF8OZQEN~Sz98--3!-fq!@Tv)G5 z&KzDCY&3;yO>mG?Z)l4m)K*Dj(;9MZVBAulolApAUZ9$HJ_!-1#5i@3KwagdDxYNo z71O?8v-rC`U?A-6l$T_&(4=gs2D4Zmp+a#@aA3c4dbnpM(@?q`ZG;iO zY&~C<`?UPEs*Ne-DNceQvshU6aga7g-vV#hY7Fe%+1+{NoQAu_qv=v^hG`3-jVAYx zeV9sOgWqh;*V$Wl*?w%yh)vKzo3Gb_snWs`HCWaR@@`Dabk{C;EP|UEGlE1nS=7y2 zEr@2yGS4frn5Zr~38wYR!k$3pUp}wg5WMKMgwzmoHFmCUE++>KGE&E>9NQdn#JLey zq+xj~5;ewLzbelLYL@OT6UDx?N1U3~)pzd^=&(QAUJ0UGV?7xYy0lbhdwj2XkWzwK zQ!UdFF#Y6UJ2V3nh0vp!lf`k|Dx={rx6=WdgiqL66_ln-pDrSzz1Qx9-K9Bl}B?O!<2(rAr~Z86!9dQ zL?mlLZoSVg^U0y}eHS>+^8u;Mg{YCblMq!gK&d>FppjMPF)Z2TbSzL<>1&5rmQJ581<*3>}Z(BVKA_FH{!Q!;7Rj}{o0tn1bSukT+dzyK3oE{loWz9FNsCE1p zELziwJ0S2g-l|(N!yHFGB#D{5F%Sk#RFw1K)CYz~A`_fNo+6VsRMbjuPc3K7QFR<{ zq>sDMSKPHUt!&K5?&b#X(E~5hiY3h~U_bkZN5j?|T2?PLrh|ZKWT`WBg_O$Nh94Oh za%@v6Goe(WUe>4U;gL7{Bs1;fVr=4nLW^T5RxoGS1?N@Vv&vkT(OQP1BrbRU(m4R3 z?`N09YB!lm$TYbW7PTT~bjDN!qLeJ?@`P64zywyZPZ>f`s9WW?dfao)IC>)p#4;W16QaKasIkx+Zagi$)Tqw$WBqHT$PP@iGt z?1iwK0+>F1qwJb$(E&3Af9Pq3%|~pV_eH@a?$s%;;R|sY87P~4!O8AT9bt-_zZ>h0 z<&40h4m?>j2FOVL%+u_}Cc@I>yU^&Rg|q=B~V zV-ynxOdh>%pbMMR^km4Uyl31F$9#5e5-k~EW*N+8tl=X>J)g*8)y&k>y+V$D%l_|6 zt$);s0#^0X`#(Ai?Eh9L+WyBov#ILyuMT5p@R~kM+P76t6ON(;19c|wN1Z5?fZ?dV zPHPpI+*m=bbJf9B1HE!l78t=h6Wm?Dk#?4`)v|D&VkSkG!-MEl zZdR#6yW_m^uXhGCLh6^fLqD07J$}{?7wh)W+|r3V5OLkU(7@y4eCg)sHuXJp8mCPo z?NLHLmCU_e?xa>xyzrp^#IV|7)!J*vp>_rNA2619DyE;xnGlJxw|{E>izCAB~nUwcJYYeuix=2W2o8b>ULg9V|_hhIxi0Uns5^Gxd z#V;pipF@#l0TSXA0|$@WX>3wipd^jeB5u(#h;Ru+7u#wkjp<9p+ptTE7G<$lFl5hW z9Z!K9_#&wdy=-6Nhm56RemA?o7)4)}sslW8VsZHjc-uQplW^f`Q*q?Ht%$YYWQ_t_ zdevG@F!BiSI~SH6zzIN`55A#$BIk=yU{?0{3B}U$*;00iJqgS- z1N`F4x(hH1=mgjm!Tl-I5^uWkUURp}r3P^Sn-8ei7XbkfB^P0Y6!4@T;mg+|p=~Q76z%53Umu~9}w0U zC{BNePvIi_E;AM^6-ndEw$RAR$Gu+Cg!q*_3gh7Ghd-P+a%2e<+RN%*%N-Cw*sM&F zUXn0qq+@+7(HaHkf3h^3m!6GTEv?-QWEj|+$6QdWQENIp5zaT2u-|f*1EZzQyctWZ z0ury&0M&Mlof#z>%NpQ2pn+~)AfYZJ%5HgLh%;7Angtw<%gd*iTwzZMl+3(gQO(K< zfmU-QI6Q-5A znKp_%D~h_mnKTSs{V=}$lUbE)B9mD?zwv49Uq3Nv>pJ)%efT6bsn~=iHM`lwC4KZ< z?JFG}-EHl;v1H9Y!hu$-n*&A$!?q6s%WB&?(`t*nS9JPwph`+Wy5Vl^Phb4(NLq+< zYPLSRk#WcP_p^V@GC(`^G8jK*nHiT>ZM$Zbzw108;bVlw;LWFNM$-Zc0CLIpL0{8v# z{pbtP0wMvH&?507NWr-S3!i}g@F|267Q`As^gse;oh7i2j3}=@FCGq%i; zYNRKnw`K)T9M$P`1{X=>T@wm=KL)`lA3=d;(}$C5-j73bVc-=Xt`+@ZLYG(aQ~&On ze!d@n@%l9jyN%u3$+Q0ql7ToB838d4;RlU1VE&8P1td+GLqv4>0QId>-s6bVLZfgb zMI?&>EWMbxl6008ipRn{UI*Ji10Xeu040@Dr;nmOJAFO@x;Grr$TGK{Z?oD529fxf zrrOLo!gWVU3`7ix%U~PmOx@8x>0Ruqk&tmnfuYF;Tu(ZTU$Ly_@K^h%eRDEk$#WM(uRj`)C8LcY%f9qHBv?X5}1H9Qn~9- z2K{woBuk4t^@w^`^X_x+agV=Dq-b@AfPu9OGnnONINW%W10nBxMO@(6(}gN(?Sgs^0agNFY9w zI=fK+)w>(}+Hx(B`m0b*g+m5Wn&nN0$L8`J4mOMRsA+3!2raLP@L-B71WI*mfyg^G zB2=L(kXSRX=5j4jRl*?Ut>(iyl=P+7M2AG#RpS(`!uibW%Ke&3g@~sp)V9qI3Hvpr zg+2>ZphT)z7W0f~R4aNiQ(D1g+BEu}g6fOP%O%r$=+t$&@qz>+=fB!j<6_`n<5rx&UKd~{XcW3HZ_EW&K};NFm($9-wGLiil}n3AKhwY;9H~JC#2gO7u-_jzZHQVG!uU@QfLIfr@_lj^vDgosaj0c zG_Yrwr!9Fn;(pT?+2uc6S>Un};OD7$<^@02EZ+GT%}HGlHhp|oB*`RxY13-o;#@vI zu5_J1WBqUhUKect|6J&pCq0SqlM7o={!8HDr2nrbap=cKy8h!M{cZle_nUyfolhL7 zpx~T@qEgTT6Zok(T$+%9StDIYoFcdU+v~(J(})!N&snf5?DKn_T_OFL$Fe27n;)ta^G`pw7Gcu z@5_$9R-ZY18S=6Cvr={Ive||5u4Vme;ii%$Wj7X1<-O0)(aJKF zioy0%-A+s&f7gU*b^LDAN3euB_Y-8T&a)$R1LT^wgRdKu7P4orvZ-CF=zyoaJk%hS zDaZWQ<_B9ibQy#>S>-=-<)BYMq;{Cs>KGi|;IjuIMI{a4H6L=3benHV;MS0Eb5rv*ffT~J!x(qN`F1P`ip z2XzoqGsEJYPl6djW&-+MVFkE|3FbAd7}@2AqbGqYpxGCKpHY8a+Ij%Vfh2>&tNN(~ zs=7~X_R_U|`m|dGWa^!N8Hvik2OKvWf$?|3VyJbazy9g~HU-2pWNion$*T3JC~k5g zky7tc$*2dj**YffxP2Jw3*do@N!W-dhILArL}%6HGiB!VV#*|dg@Ws|pB#Y5XW3-O zAz$(4(?6i39lB@FMjfWQU0{h#kDJe)I39duH8H_R*JKBL({UJw`2ej$fZl!EuE!9h z8Hqp?A=fX(aNbHK)MYz+%Wx?MSIXKB!GNsbY@W2QVImOW0A^O=^oN5Ne2e7 zGs!=*8B=MS%#2@AylB)j`_5?7zf^3D3v7aTP;bRM4T^NuaIE_HZz{sSUd6`T^IhXyHbM3PWjcy3;6U>epO~jfP!yvU9xx#iRnl z3-+1!Bys1H<{M*-LV2B1|41Sl}dC@%lp~4XqQz)y~Ou7opmmrTy z=#c}MzY#1^IxcU?7*bERhe6HfK+8wqrV=tZ7C0(BriQTSV=~$DJVOe=REl^Y5 zA=%W&p}Y4yQo_6=@C>15)t_eoPO`kj^Yj<4*v<{gjl*kf#Oi#UQwxIeTsy3C#nDyK zAf?MTf&~RZ=~53taaVa+7er`@^b&h8h9|*?PXuWJBR+1O{fE`6 zGb9W_+Hf*yY6$W_KJ075-l5(2cRBrKE$wjar>-z10 zm%t^gea8MMb-x!aKctfGdu}zLm0P}sO&x4Ozr9f(sD+c*bEJ*E;Zu}%@r!&TR#+Tf zOME9R@&Eaf9Et;Aj!*S8OS~l$`u&A=$GmSI#GU2lK{!K@EkA0BP$NIs@Tzmu5?g{O zOMQ4YxB%@Ab{i?66W|6b{L=FDFvj-3nZvgui$C_^dTsZIBg2LMUztN!-|-)h*OHp$ z4}k#X^M^ptDv-3CFL$JE3Sa;eOIGOo4}ieT0moFxNjkBWkN?AUI!bT@FcQEJDQ-H` zt(*M$vNh)_bMXlC$XL4GTtZn)v6Ff-eLNE`=eI*~@7@PTR!W);jz`Uzo-^x{wyI~h z`@wM(RDTn9$?I8P!rEEi-(RxcSSZXHymbG0Too!r*j$Q|ydnEf9MO(1yy}#i>|e~OMIOxH#)sqDIgIa~$daPE zt(^*cP&}Ypf}3aS0BA4apC=$vwV_iXHCCau-h$} z*2~ZGLkFy5x(Q;6b({8#WT1Yzuq5D*m!$~<@XKHaPT~qcfLIK5K6i`O;Y;J#{4|p< zZ<*Em!;iTVR0;mV2N1{yGT2*K!e~Jeh+WLyicySF4>evGyC63@f+5gH0{#{(E*M8}v45!# zLjdE3j4<9^x2y((1QhWtt}{w~7N9CssVDY1Oy9bfPG&dCbQ55*r1BLX|GMriQY z=-INIV!+u)y&Qzn$bllxcjhe(*yMGqyBn6Tf7v(CQ4QFyz8dPi7z$i;_%D)WkW-$t zFM~epdpw^tEa6gG>>=wu4tv}a$*ti_A{S1e;c_6PqS*m|NB8f&p?=U+c+VLj!YjYZ z77hXk#f@bkJ)nAu2C}wx+j)sne4skoJdjax-x>3U465R88s$}gdf*UnID#k+;mV%R zZtbB1E#n?20ucHB&*k{CZZy(NMpeXdQP!xPV# z$2ynY$t<(#dS_B~Si(&d&EZFW_MhWjx#%vsR$ukII(BPNDJDuXwlfTz2PjrOmr+4? z*5h3&8lD@t2dkF6RjSon2+Ndn*W655sdCw~6Wxnwg01(+{#h{nQ-~h5JIc6yasyIPDb0kzejW)l_$jz3@U0ythzbtRMUYvWxKD zx6&dwE@I$x?Pn>y9g5Ud16_bVvA2D>(Nflw!q+&GN3QiIsK2i1ma7=Rb6@-E*@Rr4 zCFg=UZ7lcEEm~Yy{8BpMx%vxNUd2ZD5B~`{J6aVrQ=lI~z(?*L~^3xYH){-?y z$dxYS(17K+2Pd3J@*Fy})Yf_^_p?Xqrv>Wuza`&p4LM()4Rk#lf2-;{_Hi`d-nj0o0wlc)yN5Vo;Y9~| zWs$pZc-<9y;+#!5?^n&4th2|58|zpfB{sgDbb&ga4ekMsr+BuFmT-4EZ$bZ)3I4I% z^D9|Oo|?S4a{T~y0cid^6Bzy{6KGh=Zb+bg>6CrzJF!&+F4uZTAP*dcqwyIhNh0e1 zQH_veX&%|#&?DZ+Gp_i0_L7-qZn8|4(OAC%Bg2a^&E`1aHrpndoc{ zaM_Kf8@3vyAvdjWcqb1B3GLYv>*Nt*YkN=|kymu`lC>nNDw6>pspn@hWSdqR&!nVB zt?6iE)QL4wIsS6I0^-oDuT(g)_prP?0}?3=ZgKA*Ih3@XvrGICLswol5)9nyFl0UT+_IzcXNM zjKqI;P|EZT+^Zw@s0V2C600jY0|}UFTDvU!DV9?wt$^4c!_2U;QW)kOaQK$Z=j0OA zECms@6FJ8nMHK&}O41u$T`Ku8YSO~#m0ihXNU$UgQ*2VAtP}ez)HYJ0+SDbYWOtoK zA_ad?N@Xpr!?hlHwx2s7@pqJjQdt@C6GV#&Ms7%3&naA8UTa{(lnJO!g*02I%*Zd8 zrf}OOn22)w*qPAEXi&k4zgk%1%e{Mxi=ALpYbRpLTHg`(Zo>q-ar^*KHNej~%_C*$ z4a}q{v-^(i)10ZBAoziP(;{)?k!vL1HU)E&R`0JXOuKG!zWFCu6>LqxSz+<{Oi9T1 z`p#99^@fNsp2yaSA-Pk_dUv^STl6udP+!XcdML?+!glr=Hg?4D#dI5mf}B!C)%E#) zM+%iU@MA>sf*)Jr=Uc{9Cd;b3rb$!!QNUMz)Tw5xx6zrx^f?^Uj`ADQZ%wTwH4U)T zDoKQ9%6uTj?n%N$a)Iqq%@N#);H0d*`CbD}7!MnxN0IS!4#C3S^ESf@a{HXtRxmWa z?vFEZ-$G(AOyFL)DxFLX9{jNgaUxn6?gGlli>4qO6V| z5IYC}zQQexR|IpAyv11r5<5Tu0@5`UK@zrL5~J$Uyf`kHbS!rn%>n@2Kah4rNa3_7 zl6vg33Tco7IPQ~@P_efN&ye#F?js0;guj9-gLnk+a{U6h8>K{w<8xQ!HdH;N8V`U0 zcFSs}1n}1nn9*SBwgNF}8pUu)QrsoH3JDc_ji_L56N1H%CydEV2^3NQRKs$^t17D6 z6Di;m7-p~aBbbO|(5MvCEHGowhR!7@gc@A{>RD{q_rje=uF=SgMX7>dN;p814J)>a zhzX&zMKXehr7Cj?IW+NDfhERajyklmL(<{eKp|)+r*hI_&O5KBD$o(LRuj7SShR)z z$*G8K5M_`Bs-AJdYv;}{JkvNX`P;%u>njw!k4Z*QB{gLbVg&@Rih7Tbc*r^LiSY{~ z%8&#-4C}p>DqC5=2h^XNIag&jMxFSkRdRxm@C<=unDuiL&yj& zhQ(2ug-FFK=A=RGylom3gHO;LLI8FIK!MP<(=KK(en{|u2R>nM%}V!-D2Kk(wjHIM z;T1KeOYFR9$+UPRtgNR9fs15rPE2-zIG%!GhcG||k5jy#>zB`{V)He^sK$He@+KjC z$P{oK!a~Z{0^>R>9EE7ef}(xFemjM56;#He$F*;jRbRy2<1CzFggReFA&F=!BAj~WGY!oyO|NT>H^_(p=ehRfwUqUM6R1cHI+TthC8F9Z3hRtV zr$YQwEqA!aw|uYJ5uqNZ3sAEmPB(i~m0M|(?%aaxk!s>Gy=<@kvP&M++PL&|^* zUUbq(+2Cba(|!_XqW(*M@$||Yj-~xRBv(YRN+POfzVx+jQOcW)B_X81q@Icezh-MG zbXoCyRA)1@)Estq=(;=rog7BH+>+E%WHF*hFv1w4xw+xln*ViV7Wa!KQFX2PMv~+7 zF43~lCH%P^pke0_Pcs7c9kTZe%zzDdJ@TvR8-3&=Gd=wh7R&s=JED3k>d*435zV>d zRFWXN_TOofgXzm)4DLKGK~Xl{HqHE|tSy)skZLZOp#+w0OIY9I@UPl+89bGZu)OB2 zHgtSjXV@v#B=CaYDynsF!9Ic$yzq_}6z(W(}v_SwV>DWn~w z(0=Y$=J#?n6gIC~I~4rIhs29t_0#AkLo`Qhj&hiY@HQq$cW!N~^aPoGSPwzLc@QCB zi+=E6M-IU!tD+&~#YfqwcG)XykrF-w<$>|VO2XBH?W53fe7}{;xm8f}#V<7)(<2(r zJ&`wXDsLFms4~+N!qMC`jVHvg(Yf(YH*Xb{jv)yl5BT6HA|5>QiPej4eTeySrfbE64&EJXM{OiOuce_qe z^JS(fP?~?ZcTeEOqiIXDuwuvF4)-fR{SxT;9_af1r;@=Z+UoFu==XnBahUs)%8!50 z@ml@!Cv}JFe{V8f|J`J6{%kT2e@ZU@Y%=@sWA$qEXY7$i_SVa5gTlK3I8P&#l*vcz zTT3PD$Ai(ruXD7CEi)ulSZOzS zxlL82^-lobml*rp8>!tWw!L2ZLhv`k%q9~Uv?4K|>Y?p;K23apx?H)j?@`_ly>^V| z$Ols;|4No!Z^}q^R&`**8JO0@xCrKL?i%4hVReESBoqLjA4YUgoO5q}`(4VGbSQUi zEGA#(;BpnSXQ}AcMX=e0u`C>ozusK;2_T2%lSP2}} zvrx8P|CI}P$c*!G`MP(a>mwbIg5FcHex)Hh^RRhp4nJu3HRAjnG2mdf(DrF)E8aEm zrz(2UlX9J`&~a)MX-Z5POf z8@~GQQpQDfIwz%kCLEVfb4x6%Rm@rQQVZ|hExVMrf%Mqj#&o^x>U8pGK-D6crall^ z0BxQ>E$m5Pm-~rtlEM#QCy^gQT&F5j|`j_IuHcMkRUZlubWYw00|YkOORb; z7Y3~upwz1g%oLCS$|N!OIJt2itT&Qe3`~ZDeIg#`03@2!R|5c+ho1?(MvOj4@eV|sSc5YtkeGcv6h+n$V9JZ1J~lqE4+PDhreOXot&vn2 zwSXU&T|#Pih-x>D9HP9B)=vmyF%ZZaP_AS^iSnMM%wN$pFg%hYaFsxUu+;mf$04ms(D4k8Q>LYfNF%M5%FVZFrG zEHU4VPDR!19y~1zBF=2Xs&qvxX~-mj==)yn_~AUr`a z1^~dPcmzq*Cw`#BK4vAbuGs`yt6#3x@LQSrr6__FL-DSpwQO(wNgB1vjF&atK?NW- zQOUgi0g?(Gu}T+on3xI*iH6!U!umXu@`RaPqMU-m=BcPt5Mp~l? zNY%QHdM=TOJHNloQ&|SFceX&q-&NKe_k15RqaH~tgEfM=(6wD@Rz_tokt%fYOcJkd z4?1lk7DP)zW{HOGY>RYU9+@7{E7(E^OOaoeDTPOgnx^kNUsGZvgvp-WWPUNL>nwC= z-{>*v4TM4_cAvcT=bAM($A9QrfY(I3foi6#Oh|00#0iybU-C-B<#Q zZn#Jho>g9|1`ifBf#|Vw)v||}7=*@nLqHR=j>Brb-Sa0eh!rJfCVHDOjy`f(*xc?T zYNS^9$Y4r$*LeWxOq7aasgo(^5rMJx^YQ65&-D)rO*zpOcB9E(+w02$2I|X;3z}~( z5bF#DCul)JFeqbae?4@TQvM#keE4VOFbuug6h55+U(c~)m0YW!2d=M%%fkx z^KM`x2Tz$RpE1MXsC90!N++2Pe+z{&hZs zhB=!p{}eiPJb{O}A+-jaD>|WLvn{&DmHBdILw~1Vl~c(?z$0jCQ16}V_%rQP|oh$-@0u3_(7(OD$N^i)cUwT20CBXSzx;nd@5{W_I!FF_vp95qYd>ut_~&L zVOiCTQ!Oq6-lY^*-f|0`Ex*#OokzL_15<2mRs0tf{8t>jW^RpQ#!Q~euxtEnlI$eq z1Rr@7Y1W_bo`j#4qnz-qtJ3#e(9SA2YM5+fSWi*Uu#QrG_$z`0KaeW1B5xcapUswxPXYmwAL)=RPKE3p5)IBVNacl{Ha!ORolkVxofs~7l6}4not7E_vTGlwjnXNp zE7v`^%S24FG7mK`MhHL1NP!#GJO@%dG;}jUg>nuMQ+NV$*qqMFNG0Ex6R(ct_1A2P z+~}w@y!$D{7(t~(?N43udLcRxhE=t#i8Q-GsWY_SVsVmo;2}};p^!bL#DY%hZ-j(C z6&~Mm4`nu5FR^M@C?ucxEN?^6F_)GCg=i&-won<1Z?ygSD?7!jgI$?vd?t|nMZll? zJT9`5Miq@vAjqeN3WH&PLUEF$V8eC=C0jAY5910f7i)S73rT!+cs~=*8??BVw36u} zWa8qAb;M2y3^eNPsOrW-B!B4;W6~uD!4X>d>-i(RrxSeKi9K`ioq2QQA#4$e5g~{p zS1oCq$!yGy*ml@7Ki?H)H7RdJQCqLuFX(imWQx+YP5w51Z&*vk1$*#n46>KDx3&UI z&OeTgVkx%Z~sM4z{Unp_fiwXt&WVdSO4NFQbjV- zgdM6aes70!CJwLu3BZ39!-t|)-&Ja6*t+57080{4bVao%D`4--WawolS`YR2*H0l8 z9fB1MZ#Q(l59xYdpKtj92{|pCq?HEeC3nzuAf2m{>khax8y?WN5Yz&7O3kn8cictY zgPfXNsaMGI8oAg*4>SS0VV#UrH6kJl?}b?SA;GuT>cvOgD;;aVJ_wK8(_WY2;zd75 zns43L8u1*#-VYc*^dS*AY5MYQ&U9~F2IZT)-m1*@vV=V0}d`nr+;|B6;0o<`zROz3h9=HOsOLd79b zk-Y(Gt0?$qfJg}zKtu29k=Y*?(T)T%OAYR}ip0VI%t4N{E=zR!5F907%1QJ}Kh>xA#oK``yyS`a zOJ*8Z^LiM%v4}As@#P9KlVQkHuhxt*NMJ;TG};CpEFyk>`2&2EFqCWeq%G;uK50Hx zEO4ens)CvOa)TRL5w<)wMJu5dXjSAz%~jQO6@XhqJ%@lHy2}_31`RX-&s+~4m?^_5 zIIe;ZcQALGes_h1o3O(c8Ri@odeEDy5q>&O!`QaNHG#^ISzg{Uh=?%-Zh9IXX1ONO zn+;MhoHzK7qu|T{putirC@UEv)Fi54$U0Yj_x(qfY|`W>MelvVNo|{qZz>**PTL5D*dnM*kHdf;tf468(L9~Qg5yiw-UB@AYEAoLPP^0Z z1Zvw*B!rt$uc=n-lBCNlzx5aW)bzICXk!GK zD-!ZnYG(O>`Y2ajb|-En8(uL!pA}(v7neSR{lT17_!e3Y=DPK6JdTb?W8w<^Jsccw zLTM*m&Dq+ZVYjqu#l%#S|*G{J&5l&9MhHkK=!~=Q#BG9a;maDr`FxrP~G@ zdlM(^GuEb7ylzIkP%A$ImxLE_uq5=UqGqpM^#Q?17YLRD51Oy$E8!&cKM3L$SPgGS zr$>VTH_M8yy{`Hl>1wpRjFw6QfE3lI2;;C8F*e|C$fU=waBB1xS`!46$_YiwzUrz$ z?YKxBpu!At9X()qM1W4I;}njr1V#cgw3ZpgzG`*ke?5+8i7``p*y02^TQbraZ4?sm z=%f}V@3^i{h-1Bq(0yusMrA$!VIY7OJ~g6=c+#8?~xE=zbLuqzzK)pa;dFK^ssa^ zLtE&jFqR=QAfPNkQ=I&*ydk@L@FHxWIS<5?K#8QD@X+?$t^=oY61eD9K-kPi(2oug zZ`PaN79S5(09ilRYO#(Nx0JHtZO_!E%bUB_HTB%c-%yqy5#(}}2zMscg5(VqpLmir z3sUrI=sOTo>kXq`{z|A!lgPb_=X!6orXx#oU2%9zc80fIkXLuJSj;yaX=nAb&f*|& zqjrk)uJ}{=O-|>GZD9JRv?aW$R?Gu+oFQLkDUD*rP^Q*=s*hKUZgUU6R#>>pSe}iP z4+C%>%+e_lM^m+cQ3DgZW@ZgIqfQCk*m6&II?QWJr=s~8hkUEYJUfNHqHdZJo)J*R1Q-z z`=avoaQBY=XBtNVDu^FJ_*Zxgs26`11_%o119*KCGFnD>HK^G4c2*V^6FpG4hkEa^ z4ATlE&xJRl`S^*5;9*tdefuoMbUr+11&A2gv7BP~d zefiQ@Bgk2TE!~5dY(l2C)-u;FN&7iq!6GgLt^=y}unf>y1x|(Is03H&F=M3thj{}- zg%|`YN#@CybXFSNdfgvUT)-2T_Ub|y3R!}H%99K`lWm){9L3E3$)RtMG_W+vUHJpK_6wM*e7>&G6Dix?YJI7d_cTJp7$R@V>H zC9>|&&SirFlQ-MSkreh|?V1Q(mp^V7&`LRNDZ>+ztmiEUsoV+WPKj=jlMCg_;i54W z79>CV7UUg|?glUFDgK;2cgQ**|6WbU7~1>U8t9SdiY-c?MboXr6V;_gr>*#T7ss?t=qlYTbJzN< z9iIE20ZOk|OQ@UUXwV^4ou65q#kyyA%rGx-HuvN@A47xFCn?GkdjdtJHCX-cWWJ`@ zG<|_!&Q?BF6gxGGxBKNwu@95#43m+NDB{Y%2#aNcdA4%%v!iXlPXnsnvoW{qxLYVWLfxTAwRK&JMYXpAszXm&358Lbvpt zXN_-UY$h&Gci7%jRsW9Yq>rfHv2Eh%IuCe|Yjnk)+deKT@{)Oe}5L0HOBK^^6i_iaZ2xl= zgaH{;kUzS}JU&a?m7!CFcU=tCfU$@i>TxW%rpjFhTk%vb@!wzOec4m6XH!UXDp5O; zhMsRdsE#%DP8*QdUQ+8)yGnt~?)JRF{V$B_A2JFk5d~M~4~%Mr;Q!V&-K_qBQC(}y z+x)<&yu}XiZiI?SiIPaSMalitI%Sc;vRmlkA!N)CtPs={i*M8fK3roGn`n*a&=r@! z3A1OyYj4}1pX@n1cW=0?rp%K_Pmzf!uAgMj81L8D^1cWn&oP#N*%>?2M1~Nsok16- zCYnjAEL!bsbvwSqm}PgQ9%bdft$z%T9{do3#K~rS3cpJ{mA1fnq0Mg3%DCJd15AZ? zEpE()N{K{u5MvX=wjsDsKlJHsks?LG#kLFjGd-nP6B)1~E7HGR@wr_XEwyw9)}-1A zZj6Y`Kc9q=+EdQqIVlWw^Mz1?q<6DxXHcee)JFSgL zYM-`|V>_LIa?!z_#By$T&0V@gRIGY7ih17pUTA`UiG0znAFl_6Dx|vYhWLTM0ssdD z>&3biZzaeOHe$8(l_$McYD%{&Ou=B-b$m@ZJ9 zfk^jCOFM%gl|8*nuG?8?5IqW2EmGHP5S%@PUqHUjnjy|Bb7QHgcCRdvl@>?eM9OB))h?=mm6G-S43B!?78zp&=q zFK=!Hz98U&Gepop|A~KpvV}|XR<@CS)fAA7v#uJXUcGiU3%=s_z2DhGXOm>z%rXm{ zS_WIIi)7S|xDR9$MBqhg6sU)A1LS{bx0D~;5!fX==7k9#c2FvzRm$Tm-zfFsx|26i z;hcyjrO70_W;MQ%TXk}X|Bg4B@B%psR#lsisUurHRaetYbjUFUc*sf()d=OFFi=j$ zKh`nJiD`M#mP|Rq;ictXBrPDNS9Ia^ze>c-N=9<@ez)$cwT3jdL#~?+_qh=g@P6yF zFSQp>>Ml;Y)RjofSXW>b#L2+~cVJQ^O2Biq}GNPz?FI*Z_$Jo3))G!%JOtNx9i`)!y z<+mjyElShUrOnW);HjFrl$p}kCV14cn8QdNV%YoJV2f5*2em_R%6KpmkvY!WMjUbl|Azg}<^D;ohyrA1y-IKx_)3``aj zx6ayAx85p^WlOa+D<(~40FO&D&a)z|w6K1LA83=GwL6G@O5{M3{yT)7KfxX#Zy$hF z_3TSNkIyz~DLa4s#~h(E*vqCv2PK{C-Af_rkXVlYoAA_)laO$}(zrQ9?=dkxOzgrD z<>UG~^vOH*a?Y+~?MTm6lQed(1{O*>3aY3Y6;0GdeU%Q%sXum5J(hXaF>%>DpNvhk z;c&#?Q4Y#%0$&ax`+;M9c+v%H{qx>fFmJ^AI6N@GedH_Ee(DGFSq@;Vms6`P)q{hZ zw}_V{mC*YunqbE&JY8wf@oTZ8gjE4c%9+2WeAw)PIN2-F1#T`A3-)P4qByY4H93EE z{LZusUE>WfoD;A&4BnR9_8PTD%o+FfVR94g(Q^}D!_eJr zkfYC~#^}my!i)>P_&-H>VJb{-r|k>%xLgdsSvtLZ!^|6)g&cs}PbL1W$);GlA7al= zcGoat9>E?(YCluSX&v5V-~KNG>K`M19p~f2{==fU#rT&IH#9Ibbo#I6)U~>`?dCtt zsk|Q+1$x~wV~Ec6nso%LEEvf6M!}4t-k{zXaxz3Rg@8eV$1B>M0xbcR;$O5k zpKo$_-QRPCWOe5zH)Vkq7X!cMH^;UAVv7-mu-)#;?Q~}!aQSV@rk!4p zqV+MUo0PW^{ivK1*ErEiDOhk+e<1YpW+hN+uZAB58$22%Mcvsh4*mdXFOuEeQ;;th zrFTO~;1)^X+qt+BE+S}xMKmI&=hvb#elR^k3NvFED%hANn zeg{#9yhS5Ed9~vCr2Da9ww)#S>ownF9W5KJ7L6cuh z970dv(CD44f6`HUA6A3%)X!a8tpJegw#GmjAn6e!uS3y$?+NRwpvjpHF`$J4TXK|C^a$1R3* z^~tIE<`+B~Y{Z5KGum%=*H^7j7vZ;n7kfXyPCn5ePx)oi^GY@J8kozjyW#Kk<~fV^ zFx_fN7`TC1dlFJ>Y^`M1BUaNS;~m>$@y^(Kyp^19H!+9 z7AzLEQrN2kezb{ITq7}M*wmo5^Y6<22aLZZaw00MDrIcbKS}c7Nq!}@P>pyXe4Skp6ib>Q=*;&z8>G%<+s~S4l5ZupSSNmD>Ah z=BegaS3p}IWNPWlb!jEZv@Lst$M<<+@Be{6a2ury^d@D@zx{X^awGtNf1tKbx`x*J zhW{i9-Kv{5i$6oHYL|T1Ld9kJWV(8|0Dykdmf#=g2Y;Ey=H<{*J(1^PQ{ERBQ;tkF zsqiacyoI4DkLStHNUQVr)&2G=luXs*B1EQ?6cjE_cORoVA8tLVacN((^b%8g_07#^Z8LY zQ~J@h+MKl6w->uXGlj_v-1vLdyVvll{l=+? zHbpRuxdP|IS<_k_Ts$_V>!Z{vMdDs4yO1XP5gHdDW2#wUg#8uZ$KsP2Fme z^=zRbupJf)YkRKv#>iR9Ni2*HxaXIh$;=JCMh^pe1!C!NNU0!1J4XuW6qRGEu3om^ z7QDF8DU-)_YT_K!Lq%N(p^^Dvp?oKWTEb7_#!_l*l%|BZ<&`HBaLdc`+El_lz~Psa zxTxyYA&Gx1n01BSQK6FsVno@Yk)Fuur-iuO7&y7Q=UNBd6K-yK(DALON(c04k6~MZ zSWOBlhNjsZ*^h2qt8&joC7y$xJXMSyz04ompa+>eRP-J}K4q!fJj!Nv`FH^F%jNI^ z0n+m4Bb5qI`|1t>CCkTyRyZ*xd*n#t_(xbh;w9X|0jSd+unSK$aK?xD{fGbn^ql~= zLg~HmNw#C~bAA#@Vo-_wfjR@d00$9E1ofI$-1zBRu_J#&F2F1ZiFm{8bIMf3ttOJR} z6*U;>nv*?5UE2VWjf*eE=o2Rf_+gQ=nhychpxOv*2;|F|w|=6o?SQy&u=t4&h?gH- zhph##)z_H_rn#1VdM80<4|q``s0lebMlz9sCMu_D0|^0;wHdIiXR(h0;H)7h(wUXI z)0p-YJB0Oz0-O+;0{xJ%wo_z~q1p$RlZnINyckyc%>7%Hf6+T<;6NGVle4aH*0TXC z^3;jDQ;h4w_cN^n*_KnY2bErK56vXSC74L6inZ#X;kYSBmCMYq>ng2pD6Tj4`L2OY z5pAGQ2ueufC+9=ow9f>Eq97MsxMo$;Bv<<(i-NP#I!VOglK>J{Svm!QAfkIfkI19kU;2Vlbwb%`-vW5)}+nzttHCf*-L2)W=R_{KhRAGEWm|m{>%{PL4PdooPrD zjvLaXQMfo*F}EfQv{2Eh4W0IeKQbWoP$Ic?js(Yp%8kdB!Qc%?LaV@L-5AwThIyN5)|8Kwl^VpyW>d`mnnnwfWotJ}xptU)cg;Y>zYx?1 zeU-uDJbt=>NCdp3d^L{jsaL~{-N~t!v>DL9^8Wg&DG4{z$?3 za|?FZ+2({`mknKiPFoUkLrd1*QoPon>Dwt*+f-_5Oc<~7ZPrJ<==5uU(oi?Fwq#jZ zIXnR0r5metj()gjtYT)uVCokP3}gxIW0I)ZuE}QbZLHW@!k)2(i=4-A z7PW_A>A+usb3k?`Mj2ez?P4un#*^LIEiog_DlIcMT0iVgPvc9D=xd%!__z$Z=`+K?M1QqwwRGWgRVO6v-a785(Z5p3b;G0Tzn)l}O=y+_>`X zuA82kxJI@6OP4BzDZ!eO;bFgq*!^+oIPJW-d;aRix_jP(O^|GYFh9BiV$6pvVu)Jg z&_ZVyA$h=Q$&T8+j^>N1PVNOKlW3q?wyB5%C(tRI8&f`BS;l_Ql14yOR$>Y~Btmba z8~gLcV^TPbJ%ZHm2d@3Hgk;~qtK;Q!IdSt3PYiuX;===3t**8_UZ0GVQF{9fyx^aB zQnyKuGC~Z^OpzFl%ik@xkXNvdpkE)PzssTrZKDzHoX89ZoUA58PDy6SY@?;a(7$z| zrhg=MC!+Ah$Lr-m&$oMDTrCF?4Vva4LL6Mo(r>=(4cJ*jtWDjPpTzK+P*-!iy1Q$> z(`5oJ1MNVre?*jMR*CK=7>ix-BGca(1P)Z-v&Q`nR*&=AhC+ud!im5pSSk8|siloNAsmq5f+!@S_wWz?awLgHhD>Zh9gb-Ndw4|L zd|swFNt(P(8?m-fgB^Was4=h*4$;XEZa%pAk3Gl5XCW zbWTX;#B4$iBif1rLNNEao+m7Vk{nGun!L_3c_V$PjKs9mK@h0Az>L0R;bS}Clmi(J z@2It>NDMudE(mNsiJ9cV0Y2C>Wp7ica9p6H+fpl3uO^Uh{)spo!_n8v0@X}~e4>%P z8UeRGIy<_f_lC~N=Wfs1iM^ypwcnRr~G-zd3*49@NaHz3!y~OpE0ss zI;-HRAysCvr*riOOgx$a;))`c#dG}CnVf4wA*!1T z95=8l7R{&pmw95bKEkm!(y_R$1Ae$+k9L8(saGmi1Zq4ti-Rw3$(r?(zuHJVh9?xt zI|AkXuC$a>x@mcUY#?*r7@GBMp#`@+4E*<2cpIV48PMm51aZTl1RKTa5FA1)gADq8 zfJu=V@(DtN7~($OwQ=FIb8%6gpQ&#;PDlmi?5`UpHOqA9jmPdZxtL_Qm}Rn43yESc zy{sElZkQg96F;Xw#RB9J>Z2zU5LSq;J<5Pp%TGom8P==T5)*^d*DXE*Vt(;*kXOsL z50|go<0`0C{<3h%nqppbh`>+|{=09lu)aEpgXe{%!@+B{MDWoZ(cb@vJUGs^)IfeD z1A4)(+ggnC74^(I#3o(^zgslJ;z_!MOpvq=!=j1`PCE|&N4-OwFf3Tws-Qtw+_Sb^ z6euW|@tiP=z$=x7X$!X+!@LOJ7oVnMJ^B~xTlN~s|BZ1>78N# zcG}t+n0d*t4xp38K6_0mCf-E(2&B6X_nWd&@j*?m->3N*9Q1=%pCZ<@9MKT;_A3Iw zfVu=*=?=}5STB6?yf7JBG767(s=?CN>)sKB$L?2P-scN4RtsFy0hJg%0sL~wBwvxd zfsr&wf)x{UF+*#B2|j*3H}FO=!qCW2WoOH6YUow)4_?VlP5p{h@in;8#SN(0ckko6 z&{b7(+IawcAG^?QLyVbg08%apX^|J!{QB;R4^LKFpy99;p9~rQl`xAKX@+1raHuc~ z*Nzkg+>>?TK+t)$XItggS9H=cqOJ78Wn*_mwm8iAio8$`Yb@wcVJQ*BodGAtz)BsahGNS^ zwdY7O-(f{1Z1EJoxzviW?6zvh0!+{bG*6wQ@@0E9!{HhNGAZESpb}=KR|pNk<$S=C z`vDa!<@1m5EK|C*s2Q2@RdLFBR7|1IxDgdx;wm@dDIz&GcdxWv%o@P`ca{AL!rx66 z{FE0EX8rOe>dQ8;P?<*@6d9UhY-@1$NY66wPve@D_U|lfDrXm{SH-ZSr?p@ds@aI! zU&|z}4d6>3dyG7yvQ#Kn6gp#09>EqSrJ{Rk)Z{*x(*a?M!&n<;}$t?f^dugYIcm0d9oifq^J z*=Cb_d@*P-BVG}Uy3G5%rDN#yMNv+)wAQn=F1!JbFI!hYJ?8SDN0<{fL@5fai=O4F3Y6c#f2Xy{d)aPe)0xZ z2`Ev%H7^J$-4lFjfz0crM^HS^QIGrXi<~|GnSLrCc7+ zo$Edfk7=^Q%Yv&tBgIcwL>|j|L?MA2kNn}Dkdt?Q9>;{5Id)KQV!uzEZ3#e$~;P-r4Q_b8fBwGaVgswRwUUg4nX z+LP*}OG5TNXlJ%ri~cLjM`$qLnosx5eX0}lSEWLdm^V!53p;j}DlGUZ&Cdlo*zc}8 zs815{r!02=P9=2k6Zb(04l9Y%>-hHQVda2Joy-4fkx*&Fr6jMOIA!5|1MfeRCjpe~ z6-*ESfF_iG9Vt^sI|fGf|2k4?-*Q-N$lu+F--C%k!e+5{u7>K)eZ*t_%GIFCjMj*P zXFXleC$!Jgr^q(s-yfe>LnP)c$lEY8VIu*4`>e-Io% zqtFIGObnEztT3l!c3M=V?c^mi2%OXa$4i5LKUyo5YIq)NbYQYJ({@Nrd^m%h2DW|N z6!E3|&^b`=?Oj#*dN|ZL1H4>HXjis~YR9t`3_!jS%&PAju!G{{K9vHJ*`~b4P2Q@O zHfL~d({M&(S&cC}e#y8#+4Ju_x=u2SA7g-{fiSOB`rFJfEyO?9D@GA(OAU*XT^N;+3MeL>{yjfm=eQEu`xyC9B9zE3?}Py3)Yr8Oc9q=pOQ8%9o+#?R>)gf* zkb(y-svgkB0%AR?LsU0cekz#w+O_4`-W{s43*oqKj)k0!RsZeG3?(ijW44xy-d`Q} zc2X0VO3H*U(Aw#9_0cm3BvFCpSrxprugB`2qJ+&TTOlZ3y#vP&sRZPZ->6e374|G} z!8=rj^tD!)F-Gx67eFV<-Gr5o#!!Lhr^H08Y?={2y04sII|n+@efCLwsx@l23+|8|ubjmq-)`82cMo&>^| zhO=0q?H(~Ky9;%I&5w0(=V)w`=5VwGiYhnLLvcxhQ%CDHdB4jdMbRcpfEa4)YR--z z@a6)I6+Y;)O1SZDPv{lOLD1ua3r(=&14l=yI!h+fx4o|2{C&;sh?x_?fL_>f=`p5E zv`tu3PGeGv;j~lH-Y57-sFNr_jBP8m{A*8jJvM)BQWS3b5Knb>mXHzjnd)~_pSXIV z;y|{3Qsz~}f$yMvhOb@>%)>YY$IZeY$J5!k1!`_vb*THnLSQ^ zXVKrwFwZtQ>4UMxL(_&nv9>uUFK#SIss*|;BA!gHt2V$h+By0tQ^rZ&8B@EB)U$sK z=wOH5PJ7tAl)&Ypc8B_r4wZ1ZE17&}8@MN>x^KLW`wz`@H<0>G#=E!!*B?aJu5acR zLx|e!DZ0BpO;h1Q0q%;WXh+P0pDAVO95)IT67KhhXO0gp#WAjL&-^rNK!TvJ2CfQ< zQWM%!BUih#*C8I#c}9v|sI|K?mklBoiq&oe@k?n1Zk@lcRt>{_qvB1kTg+{_*e|B5 zr6g*Yy}@&lvB);Tv5Z`AT~BPL6ZVZ1)=N_-1rjiU=Z-i7c`v{uRHNO17q-o zd1ikxcw7qbBGqM?mjDS66F_lq+B18`U(|HJL;t5+p3qnyW&N=sG^qc_h8PYOloj5dP*FfPJhI;~k#RhnuGXgcd$Z$ci)-1r4qKtp z6nu2jh4n!97Z5b$l%vnj~3HK%%B&b zw_akX-uVy;XEJBJM`Xu(19wo~LPW?X3OocL5SO@?*--CC4or7%a2$v2%$Ji^Eel?h z9tuYee-q8G^_aZsO*n%qVz=Qu?J8F7{dTaUIaLW>uye2LLs>;F=CLF zh)t@$MCFXA$a&S|5L{SF#kg^k8hNOEB&a$mcnHH}fHIJ4tW2hzP_j#$@EZw?=eH!k zxsH>uU5G|=agOZ6={qpe(#tC1un3*5bzqx>6MzQyYqy`4b zV=Nh=?~>)l3U1eeAP@Dud!=VzB806Ly`0R{Rnno|dakb2Xg?Wa#j)Zn@jes;i*OGU zyz~O~CP0IvHFzRt^4$TnM*2lrPTz3fhJu)V1rECH5yQer_`7Xn0?`{YuHx~+sb||D z8KjJc3Z%0g;%C>yYC2hAsRL_TIyhxOsfH0-2(X11!!*{)CFNBzy)Y{vs>CimynX$% zBN8$rvM?0V%^Z8A2=kvUu6fksQ`s230$KHF*8|UvsUqQX`1dpU`-uGQ6+O3p=7)%A z#x_&-^+g72T;TGDN10PvECd6VDV54bz+BD)^|fho-lO04J(f( z=#15JPbiJp4BvW_Gpnsmm&O^sPkXVx^7{`D_!!)@wvP7HZQpuP(7tniKEVN(gZ#+P zf!L7L3j#zQ#fmY%S(q0EwL`?f+`l^|#M=evs}LU>@rhbaDw8cMTcF|4a9e#imFi34 zW|46vXM%9jF$I(`OworJcpy2)2EfE`tR6INCj%Mo0jND<5 zxi#(Ll&!S7!~r(aeGYmryuE&b{hPI0Zo!4IRHUW7PIWR>=UxX*kVzci-^grA&yKZ_ zK0kmlli0m&z!VI+JB;+ z_1IE0;Ss-ml9SJ5*+Y*{jml0<{uc1LP+)#~YIHIP&iDU?{cdqCR|-Gf8+Yey4cX(utvn@Jq;Z;Q z>*c=80VpWbB(Z?`vFr&{k7&!&oY;b6g}h=$prMK@F;L>EniPB_o)Z%<^}NfVq&{WC z`&Qr;J46q>zXo@wG8C|d6PT@al~;u$r|jH5AOC<_khc>hJ2MugMmm-Z3jSOzI`;io zBK+B-`Dq?}V!@&P;RJvW{En8cq%+Ucs+W4<>dpg27Mxo-oiahOpO8W_?HII6p>*=G zJ7A)9Vr#RgY+C8C83AP&;Q0;=r=lPnF&1X85HRY_qu!m@eQ|16wG>!9f{?>o;N5%E z3-S%-m#oxsmE1()M))O`yQ0b>_yzs+#gnUuMny&-AkW^=Bh2;g z2(Vl7)MR7+M2T}R!CMD`d#zLhuL5kYudGz6V)M&+!B+bqL-TT|getjrrgEwZmNRhq zuj&-FQa*{4X_OJE)r`y(J~b)7bBlL3YC4_XrO%8V$c#ILXBSm3V9UAvIT;E!Dg=EJ zQe}n1dFXFZtX69*`RzMRtu;P4^;90e;{{kfwnbf`&4IrNb)?qw2YVlTEq_~9cVNAt zCywuGIQv^GJ8Vh2b#@_}bbO26AmH5Apu-J4b;bxMVbKwS+Nqm@galL5{7oBnYz(p0 z26K=&l;5{V{D-UX8v=erF$aPv$|a7{8BCnk203Ck1mB0CyT^zCNe1=@SY`MMhG3fQ z6Q59^rZu(s;IA*E)S@x}q(b`}FWvR1@&D-eiO}Kyg*>oaLm6L#NccF)30%DTkiFogZbS6l&y{*I|9_%t6Io@h;=~(^0deqtU%W!dQno6 zOgpr->$xHAx^C0%WKn1%(L;aR44`|l{#|CurzWYs;EFv{bSg&u7zWWj2T9Igy(@Na z;8dMtkT2!7$Np=7NPvRK2OeUype8mMJ;lhf7@3SQK@oA5gqe71f54EJNK2!pj>35+ zmC5U~RbBG04hPbO7srQYMESSQOiP|_cB^k;9%Qq&z(?>vWp#y*zBC72V z8D=9VsX3rah9iM3!9`Ko^OYT1dyYO&`TlXKsYeV|4z|Pvx$;A185b8hjZvP_@%`9VqkZ-{? zFMz&?Pov4IH$S!pol(Ku-V(xGgY6n9^ZAmk6bd4!S)Uvu!J>GP+WGKy&*9^Av?_ZE zAqmc%0Fgo__=|Rgkyb$U4iLfx6BIYZa<`kl=F>{VkP6vg8=F zSSp`UIiLAkbYSczv4r3z;-{BwBuSp5Zd&MhknmGR48<=g79+eXuMlgumiG4I4BOFZ z8A?Otl@nE3q$6(_Q6T@=BRk?r3MeRp7evI?8kJx5koCw7 zgB7h^d@e{y81$_KGhRJ%pPDN+k%BUZ?||mS=x-3n!q!%Blz+4mx-h4mmKZjT8EJE! z&&&tlXankRCq&_hkaL95Jp=_)q1gu`)BXyJ4<)j%_yN!#E}22<2jECt<3YtO41H!kRe!T zAtK#GCf`tx#_!KIud7k?xL4flVl{Uml>&|Q6SUJ89G8Dj=ke=7o2Wc_r3N_4Z(^Bi z0ec%!nLESc<|`O{qI|#vdd6Y3QLx*}>N>`34ndXF=UJ}np&8(eQ3p*+wh=}cGHON> zN>>X#Qm{PY&w@2X7@N8PL5JqIATRB=kP#?A9|7n=D+Eh*Z8W!df_=cWYjzHh$=**~ zv<;Hd;5rS^E8I|#b#1iyVRCLkx#cuMaAd}*Id3IK|F&k+C3SD^$p5?WRA4FsQogi` z#gs)u`<>C6-sx)JvNE@GF=FM~=%F$>jNH7ivvqtl%y4O(N|Cfs>F?nL4GUJK~JHOc9-Ibz|4cK z=X6QDE+cJvZ8B@}R}?PzT)3;5hwsR~B|5`@i|yO&0OSjS`fW79_h?NJ>2#Ve?4n z5z;4sOK{PWfS1<@sE8yXMdm<4BznHjO+;#Vze^x`wwKLOQMH_!$YXakq94YY6o(a1 zua9+hwMRP1Rhw5i6|uTHWMI)W(MXX#rIik?$?G)IX!^b`3BFWw+~b@%Xp3P1uQ{X+xdd@N;_L@%m%U5X zGEHA?PrgL%-JmGWHAGPHETj(_K+~Z#(iLvHNKO9xQVTfo1yvT?v8PnLjOL^OM&a_< z@y3pA@CPy3AgF@rdtB;kSME(%UNkAG6y^BT_CM=)8z@ zr=G#LV$ERD9WvV^?Z^8dV+bWruvPaQraw5k2cVx43+Sj$&4_V#rx3o?oW8mg4ox$aqif#H`HffHSMum`T8?(}zSKt|;;3_2 zzdlmY47GsW*6tIDcS)$G^Y{80S@xq;QRp1JCF4RZBzCo`j8^QZxq_z`9)Ruq!p zBM=1@1j!{KL?HJgJ|RNDq32Fg7+Ry-4W~3YUn%@QGr|V+nh$;&VyIOIW)g+i3^T7q za(=?@9l@4-hhU+>;VSQp$h}~dLO6T(G;7Y|yN#RmeSCf*Se&dAl)Y^Mmth4l6Lb-X zif>O8lc>yVR0sQW4 zv>9)*P>ST+q}^G%A+{flql_SENz(uZ6|)uyeV}t{`bz)h-jy2kdsa00*uu_1xxQoX zLa;mF&?3sBjP`(q0nA4fAXYMk*ceSL#zTt*l;4LLj*Oa1JEt+AljLh_$)toe(8^q6 zSleG!2FK)rek{J^_ZEuVa?`N1{lJjaBIOP0Ya~^S@Ag427oTxSspGwtZU^?zGU8#YywF=ugeJh52CO9`7>QHjC!pz2-DYr{fMbYJoQf3(z=pT>)FHWKIru z6(zqzP=)YA-y8QGa*^I_!pn_#Z@VHolh*p>MVTp(xC_LY=`EZ)PCEVk>Kn>Y=*P&sWc^F2q88LSYZUVA|-DHb*;Usy0+c7>+C%*b6CFN4F{yk@ko ztZg}oO7w@oGwR2dxe1|_$4iMSfOU=Efr|)OGIxlL(B0UG>z+x_jO$jd-!)sX_VW>E zt`2gW)IK>E>$Orf%LCaJ0mT^1EBdDZt$nACMotP%NfuUKZV1kLec#aiZ)`9011nEf z?WU;(2LSN@AujzltlairuyVEanjak5Kitz#`EWu(EG`$+XYDI|)O$a82ZK`BCW&N_ z3Bs@J^eBR2^E`vfqfBO3uOCGDVf(~iujh1Yjh6CC(8DQi5 zhd)E(Na*sHES}GpL^Fqlvxxyb-Y$kNr~6NIH=Z_DGc~+EUVrBYOYfrUXOX(soAB6D zjDN2yQ+0*RfFC_}Xmk>@92iYZYfs`}v2RbWwE|bKbAPok>4g>(Nf;Q+4 zL8^C#g~N2=Su^Fg;HMI8)wIGlCw@Kf>@c z77HLomGqz1m&Ga$pxP>|Uat3s@`|O70w5T#+S`$&zEzXKcf1)oUL)cb&#7>kGQS*`Q>#qkUyde{6rx%+x5 zh0q#!9Z3&lazGK1F~1z`n4C46nzn38T)-c#&r#BlL_x?~2zg8aDR0WlH1 z;U3iF>z!6-kvbgpvp*~&6b`W32#_BsEO4$$$v)*B`J#k0VMA<~$DSUZnms0Qd2sUL zJfxyQ>fVviEyWI(bR4E|BTWn^>C zdi~jSIAz(oSCBr!BWZqAnWK@;SV02UHcF`g;XX9WXk$2Td5)144j1w;eg!)pGlSdF zA`fbDcS{O=n1HtyaNM#gf=2t(kx@ufaS6WCN+%*M{eZZsH1MRT2b|<#eq&w!uOhm% zQl}1wpoTU6hWvm>Y_5GRBShuDT&4{2>O)2Jq!4z6gaQXyKYEd?X%LX;YB%Jj+esJx z!~8HZ!|CWXS?@K1m@n!0aHng4vSiG`$^8e|zi<7)DK%w#;IlRgh-Iqh3f@6bEnZyZ z+V=+;Y)k?Eo?Ib>n#$3ip*@pNhlLFdl9j6}#y=S5zL(TFFgIr^jK2Vj^?h4BgBa)q z0kC#9UXI>uVRj+f1?w|#<_QT{Bj;W3_ z>LpaQd6&(%C~s2^Yfd5K6}u!E)^3=SIHbZ z6hpUnlP;IAv^|6}&y^qMNxHY%n%5~6_0VKn4LK^m+a1XfJ(5WmE?k8(yMwM!OC#Z4 zUJx?m?Z@N6VU`;H04vcK+bY5qZ~9lMsit zb|8*G@%m~U!;D0~>r8}fWxH+bYJX8z^QE$q1Gd92G80QUZf3=U$jsLb^j*8E59SRt z!-qW*Fl>J%@R5kLzVvq9zt{>{gAY1ABF-{OjNhr&U2h)=C|Nz|2i6Q;WC7treJ6W$ zMn}u%baeIdGM`PHd+XOZ-Gb9u znp?idcHud1++EI9kKSKmOoY&ah&9%eu0VsTy;*%Z=#qc>#XVw5U(a|Zrh4m={%s(3 zSA+lFw#jT?dWiMxZuUz0`|TMGXPVmWb5x`mM}hlpG8g``IOoP&-EUlT#r8h(%RyheqR6{20#nFE!T&89&MA7|Dg3@8@S*!`bN6jW zxXl0i=s=MDH@)SL9?K(rKV(vm@7yfwZW%~?E%;wF!jM6rB%r7S(tn%!Y;0`6k4o}Y zMoVJ^vE8fMy-2hT1~iM_@X;81`z6BV_~lzY(?wh$AQ4nauufRD%^slZsN1*5UY2_I zfNF~kQ{*kNbDrR|O+2nmZmu2AaPX(vUAZ5AZzZ5Z@G!F1_=8Ojn0TGN@uyCm_gXp$ zbzm~9K5q%6lW$q`Oo+u4raqi&W%THvz!{cP-tlLC-O9OnZaI0B86(U2)&9vA(TUhF z#;^lDj=dufnyqHjPhre4*Fv>lc%n&$^E(bf1_tPseC1JPU14obqME)oe0Fmv=P4y_ z*`ndgJ`ttG9_kGJoYm<8N^{d+Y{N)u43X6^1sE<;p*3VV>d&Hu$V{KGTfdCj+l+o; zzH`zfxtYvBZvEsFjSA1gYFc04r}NCbwLycfJ9VfgqEX!f?s%@XjU+osDhutDySonb6WbvbudQffweI5qz6~^JC$Aqx*JC8-2yrot%63Esh46)wi$r2f0)d!;?rL%;yfyoT(amM`RE47P>B_by9$dBlFfE$ZA{g>9Cw*#%tB_BdY%watMR+-s0Zn=}ci#141ek)?mFk~Q!8d+UyW zkEc<|>%eH%chfJMrxo&95VlJfqC_c$r;n3rdDRsICDy*s z>BgC!sY1hl7l9{ow_1}R=&i#JBPUl%+DSb$xkStKASvJkfr5!Q$I@t z&i^&z7Y?;PYTGYk@{c@6L%F;VLYhA^UcV>y){IuD&uuY6uSg$xRn>*|+2drlZ5&)( zetO~L3s0ZW%{uoelIlz%k-IALIy0Of9FWh~+I={}e!0OizIdWGvvzO}8+;z?QnLGs zWF^crRj@K1CiX)5iDQUUgZFDYY1dMpBO!X` zIg)N<4}H&aEKN(B@~}-dKZ^#q&+4#b%}6D>N7;o{AJifg(3*`Z%_zh+t9TGh6>!NX{J$PT ziN&#>rD?vCHgxbR&&EScULahS?W4;r{T$Z3JD%-9uY!%S({)1XI%MC;HaDrxscl8wd)5C&G z1G+T>v#z_ooy52g_7HI&Y6IXh-yy@uUg z>FeVm%xAMCGBi#&c3AIYCZOL7%LlBY{bCS`PPSZQQq_YaRXrdRTSyrQXbcM$jk>Rd zn3GRND@68a824^I>o`f~#GR%^4}5XIJeg6fUV#VSV8x%|Rm}PZ z@W9KcqKxHK{K#qlsm?lFKynnFw>n%)_(h3R z-RXUcTun7vk{hD#VMaysbTmgCm$mrA;KV8fiU%BZ@)p<*K~X)B)GGO7-5D4)rS z1*)a&xuUK{;JakDy{Rlcnpa+N9JUmXh}sA5`$GGN5&F?^_{@%U>Bm!1imT&ez9S-* zEa;JWe$O%Ek~QpH<}y{Wp%Nuxldidcr~AbzaP+{_)~k*@Sld2rc)6!vpMa$XfyFO^ zwzmniW}L^k%!e>VZ8N9`#ckZh;(5 zqE%ZHMAKfyUfbKf^V!|04bCTP2Me9!FSi8T&;0a%#5l*6ZngH;C7#pdxnArU?yL`R zjOWlg#oF8$N=-3#Aj-BbV zP#n%)sEwX&Ug7bhC*r+t#l|Hogh@BT8o7Z@>sp+QD+93|EU(;hgCDp}k;~Pa)5KWWlNDct^71bJas{w@rrOLIunK1nQ_5s|Ob(w>DfVX~5X`=(@rNc{gFZtPOSd07T&C0-=){p=K?f{ z119`cKFpLKFNCEfS+g1%6x8%HrR;vV+7v=@A5}Mu{F=x7Bt@n?AzB? z^b^yYd%km;T2*DsZLj%uKBcT&R!$snX+3DurW!m5Gd{Y_v90Gu__<&2EAI3d{EXw5 zy}q1%ppedXU2X{N@dc&)s)YUiev9RC@klGV=o&WCxf2^jAm9hgr|WJ{j2 zby;A^>RH(f`w!4Pa5W4Gwc334Qo_HEcQ6cF!u4K@dX}eBAbu{LgcU)300v($ITf`K za5&)mD@DrKoll4_6XRK1%ja_5EE|fpJ?(yPTz7Vd2wv10?q@*t%*Zvy^}wFiUS|%ESSX?H$(-2XjQIrcIV#(gnp=uTM<0| zufRiMU>tN@$RRYWm?EXLbI^dK(#o@3I>XSEd^IOk?I+P9Cr1zFBdxpz3D}fz!-jtR z;9}utXCL-Z$7^?V$~y5wtL6JOw$)2PD6Y`2l*lQGEP@-&kEn?3;dQihQnuWUb8-$< zdX&FB7Lqe8P?%CDP*Z(gD5B6i3siInJmNbJD&$LDUZP8&XnaGt+p_fC0XvV&_<38? zBG(3Pq{l{gI<75UxgNvX-NhfW^_x56RrbS-%gbuXw6ZcTq|SDP{l!*{P#!NR7BVn7xi0qOxO7e8cI@eaJFD=IUR)AxEs7ZzHO1zVJZ^J}PN} zXzux5p0#Je5TegkEG>aHJ{Pr32Ww1|VGYTLGNcrTS}ktWH$vk`7rR@0B;W2JbGhv4Yf6xtvU6z%lu!q@zUbWBtIzPgOwt!=;VDc+nK}x4OitbtMW6aHsDW>w?hpUO1t&XRq*CL487p^6cNIzl$#l(pOPQRhYYM_8+V9 zN44mB`n7<#!X5`wW8mMrP%{*iAS=@HqAvBl2e**71DN8!i$BQ8^QNqt9Xd+_0$2c0R}(^jf>c8wPGp=0V{2#3iEV zD@?W-!C)){9|W}C#0Z%hy3ZVAZkgv^gg>XZ%Fp&vaK?v+iIJY#?d*7ZraVrPRC?Jh zh2SHvII-TXqH^bX?5x0GQV#)Y1G!d}$XnWKtmNgzt@ZbQTfX~8RkR1|{du17WWiGD zeJdzbA)T|kzm8MyD3IP2H@p)k0#r}2Kua*8lV}#Ch@w>@Ncmz|!ljv-LlFlZ^)yS) z%mF^8dCA5lt5gZ?DQ1%JhhBUsoaC>INpuR7w;ITm7`)v8)!^+0YLw7#H9(+1eyag< ziO$;%P*&V-pmN~02HXnNw;EWJn7rLU!ob5nKQP?trd_{0NPPICxjY&#Amh;qW9|Kj zM+Z7hWZ}BDBk(xTyt^a@5tLdf52+jKek~4qHRX9t8@YKhmZ9_e*|7^@n8%*8mrqc6 zEfpZmYRP^gg?Ut@kCW2JFQJMo#fnTO{d`7c|1*4J|EjQi2Yp?q-%7=0vlz$NdzB)L zq`STdv?t3SoFbqGd$v-7WC>jz6>>n;ZWzm`KNdI|pMSEAkm!;WYZ#_E3g|Ht?V|I} zUMTWxHep?MNT+1#MGtdBYkU|uMVxM#5_%*$of^@vw$!U7_<{je@hu$m@mQJ=@;ImY z1Ab4|1->A?C#GqY9<)v0Mn~*)?%UQuIT^WB_r4E{1%%Zga3k)kxQh}rt)2`jFNGEO znNe}C%ShRGtz-pbWl3PV?wCv!OfX_bw1YCu#grH~=;2(l5RWyK?CY~JmotQZS~H%-+Ui=Dczg8k;r(zcu9y}@68_}`er0UJuer^72TAW(t6D~84UH|plf&imf3JgK{v*HsFhrH-s**$8#i?)Dw`wXtryJbgOU3GlTJ}D4)x1$uLNw?LWHPXVjd>!b;Mb7GHc-Kpk*g2=s(i#h+z< z;$6}FaMK8sknUN*)i7Z4Ja**fL~g4)5tk^AwLh zj*38YEUWEy%N^S0jlwG>m>z7pWKeY8b^2^mAhW>9un*&h?=OPnW>xf>%EyCX}vrsW9?2MHBDVmQ$Na+-s8OU1GGz}7?F-g-k zg{%GS&`*sM$VCxhW;+%@XY4lj8*MJhpRPQlCB-u0P}q$$O?7%X5Mp7VI=Yy8DIV*_ zh%x1S(2~cYeg4q-;8YS;K)HiRkHR9Da)*MXa6pWM0Rgtx5cpO9b8_7)k^o z^UFPVz9~A6TjkvuDi`Ec_zE>_HJ3u{`oPvPOavK zk)yIB(mCyRq!?@Jc&L_&1C^Z2S+#N%@}P#@d_-QVGNpkd%am_L7 z;^1^X<9TOIm+ofD^JceOeEF1gBd)`XJ9ZKtty+8{cdhVgW05LT=`Vw(l%H{g7U<7P z@5`w4Z?93HqXp@qU>bF*BKnTKia6sCp z!|EV3@?2E*8O?|$qYOKYW2bpGtK>})LT!dKaXKk~Tp$-vV8dv;<3nTF%be9|!Ve=h z3valUzQ#OwWMxS!{dk=fubMcd0>gAc%apNpi9bAMZX#EkvPW83-c?z;E2m!7wRdD3 ze%J$(58;69rv_nc1@T+`chRrf_^sclt+^l!k%;eol-#!)3O3qhJrLI|w~BmBt~2!b zB5Fsw%v-VFd^>%QDXKr9@aK5$Q*GsVdwOK4k7*YSspN}FgHaFmKbevtX8H~1VI@Qz zCy_72kL;5z5}v5+rJ#&C$D#&oNl97Q!^vjG*ghJie+e^fOGD z+NA{wG_$!>PK(Atb30+RIk!!`SMh)JR)9w1`>)5W)bDvzf|u4u{c1U^%p3)cStmC# z4R=Vs?`Mm6?VN|#Uv?3EsXZc?trt1IoSMHJf8lp_QgzG$+g{AZ=I)4UaA4q)vMOy_ z4TYD*+x^m+-}AdyWABd^=+0g?9>VO@ALG_Z~z^J^oq3WdefXSQHH%nyP2U>4oL#na$q z*r`h!K?v`4Q*H28<450sO2OVq)t=sMLgW2&gJicLkAOrSu$ar;o7Gs%)BCP!{E(ED1MC|>wmyqaJ?wbxJ|mCXLg^8QYc zHdAlXiqyW*(_yK7P;Up#Q;sJ-Yua2|GWewFG`6E8vi_CF#rNZ4P(A<^=+c%(6}K2Z zTE%?aX)8?HkaD6rWiCySIs}a}_O@9CKu>x^%T+gBK6;IL0R5As6iG58!2KCV_T7&L zW)AjkjFUOBL=oGRSgA-2Y)#$oPQ0iG`WO7n(LGJWgDV82A1seEp$(3F-ck9%CpKBe zqWHa@P^U$7kgj~$G%Gc+=}s}~x%@oKS>0Su3|ls#7)RS%!S_~?wL-J-W2h1}#>?lM zf7C=s@<)_BWa~2&1L_D717F7wfyXC02G*7~dUlr0vAr*v!1WOJR43$g4F=GTN^#-t zO@=(l@vX;hUwkv>VBBDZsKT?v6{R-Sxv=}zBl16EvYM$^30Kp z5R=@T&=)(X6}`{TD^1jvvw7pj7G52N-R&6MLyYV0S^d&w;V-8|AQn5l`y-_XK>L0`||8Uw#~9HGEkat7~p z&;n4pVh`B70_~eH+OkPCwcHBoN3r`}d~%8w$z-pe(FSbO2e9WV36M z(A(F1*rMRy5tt##3pgkc0O{!K*&Bf$2L37YDD9N@l-j{D2J!8 z@)`sOqCJIJbmq=>C^{Ml#0UiNwogg!Ux5aekP_1YiMB|%v(`Z9GzlR=HM%R%SRWGn z3V@GuENWo^w|}@guzus7ZQ!+gU?UBT_5VA*{->_ZX=l6=4hX%@z-fk&yO8dAzF!R}87fkV<_lq3|?)v`1O#Pab~ zMd}-odCI>*LnDJ*B-l)4Z63bFd`;eYz_nC=#iU64iUfwEp^e?Ou3(W?02o!vJ~|AH zEO!9D-3w}sZa}-65dsEtf$n4fOLUJJFjAP~FVOTi2oyK_(@3zY80n|HREb9Y(SToF zh#^57$1Bj_ukOv6;&=!tu09(viE>K{07ae9R90UckNfOm0&VwJ2c!C69fu0g(L?m z|4%wW`ez&%CC=gcN2fqE7y&bHN5uL2Z_@hq@B&99JN=B;QOQS%5SX1tftlcTSAW}c z1^#1@;AO(|?Mw`%OBy z*!(qb!DO8Biq0;sHvxmPgBsGzjMd-d)i0@kdX`%)Nu-e3$*U3Y4<#<-lpeMR1=0u0 z`>%xiH3xQ&eH|yqw^4*h8z4W}0+xf@OM&ArC=fVV(6P4xj=o=W;7IPO#7I=~B^)3C zGl(G2^?>Q}>LLN|sApi##>LFaMCYXugM;(`7dtSEmiCi%a!=Gra zq|M(lW#9c|z31X5gba{6e~}1y*CY!wq|7a|Rn~h6!3d85J4I+AW%AztO&b5h&W*BF zR>I>FZEv94^*@0m6UeT}f7l7DWz98Q>h|j?pluqkY~Hq0nCpuChn--V<>@2n9RL{$ zjL+L-G2b=$x1HR8hZMMsbGw0c2$}|x{2&YsGP3%2JdJ^Pw&L*Y9Rl6%$6xVG6}uw; zVJA4AQxt~5;A+0^fU38({j7LJ{=-g2KwJL;8(TMkbo`4Kj5$UTM0BHLZnDlPj zDdu=Z{=?3nKs=XolkvELc!vCy9UMDflYiSe5N#%?i@>#+2&{hDK;ONc!)kg!gDi|p z^eiBU^|FSIBssL<(h49D@2Z&9?>PZHB@n)X23hJ^nHd`ar`#d(%Gu{!e9k{z1Bw9y zk?A3geB=+1MwU8`4rc!y()@E8LdkdJT8fpC4F@``G%(Ww4P0F$z#Sn98f0zbU}kOg zS85q;#>02V&%_K47$bZ@&jV)atBVA_UY0;?gC`hU&%TKP<8IVo^W-t?oSWBs!b7!+}|3V0piI6q!YLM zkR;<3siXH-LLsE|LUP6U_$3c`aQrovmD#RIgIgq6+g`UsA>#SklR`k#T2)AyH3HY< z%fCplhag`(21o}k65uad>6-lg8nSCUulo?>+it+zZ&LL+m;?sORRPIs60GgN-ePb= zR_p#pLS&WK5+RE_-*96l|8f8L`UJKSvP|*~*JcXlu8SsL>j{?kucDYY9H#Yu9AM(_ zhx6Cub?<>JPIyCpvjvkkr3$afYa1bJu-%Zjj$rbpBHJ~2Efccx(haHMaz$R%VS*$f zYpUFkwH{#dy21)12U!x}hGX^p&0QA=xF)ZyggmKwLkNN?r@?S@lZpgb4 zVDkFl(x2SF_Cnuq%kf|iV%fTOD&%&I8!R~kj6r;*0NeMkpAK&@s$!V`|Bxsr2?xwD SAdoWf4+>a?V@rT38T3C;x$0v8 literal 0 HcmV?d00001 diff --git a/Tocsg.Lib/VCL/EncLib/AES/_comparm b/Tocsg.Lib/VCL/EncLib/AES/_comparm new file mode 100644 index 00000000..7a2f2df9 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/_comparm @@ -0,0 +1,174 @@ +#!/bin/bash -e + +# Be sure to have LF as EOL +# and to chmod a+x + +LOG=aes_arm.log + +echo Results for FPC/ARM \(Raspberry Pi 3/B\) > $LOG +uname -a >> $LOG +echo -e -n FPC version \\x20 >> $LOG +fpc -iW >> $LOG +echo ====================================== >> $LOG + +SRC=t_aescbc +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aescf8 +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aescfb +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aescrp +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aesctr +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aesecb +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aesofb +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aes_as +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aes_cs +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aes_ws +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC test >> $LOG + +SRC=t_aes_ws +fpc -dAES_ComprTab $SRC +echo >> $LOG +echo Result of $SRC with AES_ComprTab >> $LOG +echo -------------------------------------- >> $LOG +./$SRC test >> $LOG + +SRC=t_aes_xl +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_cbccts +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_cmac +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_cprf +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_eax2 +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_ecbcts +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_fbmodi +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_omac +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_xts +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aesccm +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_aesgcm +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + +SRC=t_ppp +fpc $SRC +echo >> $LOG +echo Result of $SRC >> $LOG +echo -------------------------------------- >> $LOG +./$SRC >> $LOG + diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_base.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_base.pas new file mode 100644 index 00000000..c704a497 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_base.pas @@ -0,0 +1,385 @@ +unit AES_Base; + +(************************************************************************* + + DESCRIPTION : AES basic routines + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [1] http://csrc.nist.gov/fips/fips-197.pdf + [2] rijndael-alg-fst.c V2.0/3.0: Rijmen et al Aug1999/Dec2000 + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.23 16.08.03 we From AESCrypt + 0.24 16.08.03 we new xor_block + 0.25 18.09.03 we Static tables, GF routines moved to aes_decr + 0.26 21.09.03 we routines as functions + 0.27 27.09.03 we FPC/go32v2 + 0.28 05.10.03 we STD.INC, TP5-6 + 0.29 07.12.03 we BugFix: exit if invalid key length + 0.30 27.12.03 we BASM16: xorblock + 0.31 01.01.04 we RotWord inline via shl/shr, SubWord function + 0.32 15.01.04 we Keysetup like [2] + 0.33 15.01.04 we BIT16: Keysetup with byte arrays + 0.34 06.03.04 we removed exit in 128 bit key setup + 0.35 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.36 12.10.04 we key setup with pointers + 0.37 29.11.04 we FastInit + 0.38 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.39 24.12.04 we Helper types PWA4, PLong + 0.40 24.12.04 we FastInit, AES_Get/SetFastInit + 0.41 09.07.06 we Checked: D9-D10 + 0.42 25.12.12 we {$J+} if needed +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2012 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +{$i STD.INC} + +interface + + +uses AES_Type; + + +{helper types} +type + TWA4 = packed array[0..3] of longint; {AES block as array of longint} + TBA4 = packed array[0..3] of byte; {AES "word" as array of byte } + TAWk = packed array[0..4*(AESMaxRounds+1)-1] of longint; {Key as array of longint} + PWA4 = ^TWA4; + PAWk = ^TAWk; + +{-AES static tables} +const + SBox: array[byte] of byte = + ($63, $7c, $77, $7b, $f2, $6b, $6f, $c5, $30, $01, $67, $2b, $fe, $d7, $ab, $76, + $ca, $82, $c9, $7d, $fa, $59, $47, $f0, $ad, $d4, $a2, $af, $9c, $a4, $72, $c0, + $b7, $fd, $93, $26, $36, $3f, $f7, $cc, $34, $a5, $e5, $f1, $71, $d8, $31, $15, + $04, $c7, $23, $c3, $18, $96, $05, $9a, $07, $12, $80, $e2, $eb, $27, $b2, $75, + $09, $83, $2c, $1a, $1b, $6e, $5a, $a0, $52, $3b, $d6, $b3, $29, $e3, $2f, $84, + $53, $d1, $00, $ed, $20, $fc, $b1, $5b, $6a, $cb, $be, $39, $4a, $4c, $58, $cf, + $d0, $ef, $aa, $fb, $43, $4d, $33, $85, $45, $f9, $02, $7f, $50, $3c, $9f, $a8, + $51, $a3, $40, $8f, $92, $9d, $38, $f5, $bc, $b6, $da, $21, $10, $ff, $f3, $d2, + $cd, $0c, $13, $ec, $5f, $97, $44, $17, $c4, $a7, $7e, $3d, $64, $5d, $19, $73, + $60, $81, $4f, $dc, $22, $2a, $90, $88, $46, $ee, $b8, $14, $de, $5e, $0b, $db, + $e0, $32, $3a, $0a, $49, $06, $24, $5c, $c2, $d3, $ac, $62, $91, $95, $e4, $79, + $e7, $c8, $37, $6d, $8d, $d5, $4e, $a9, $6c, $56, $f4, $ea, $65, $7a, $ae, $08, + $ba, $78, $25, $2e, $1c, $a6, $b4, $c6, $e8, $dd, $74, $1f, $4b, $bd, $8b, $8a, + $70, $3e, $b5, $66, $48, $03, $f6, $0e, $61, $35, $57, $b9, $86, $c1, $1d, $9e, + $e1, $f8, $98, $11, $69, $d9, $8e, $94, $9b, $1e, $87, $e9, $ce, $55, $28, $df, + $8c, $a1, $89, $0d, $bf, $e6, $42, $68, $41, $99, $2d, $0f, $b0, $54, $bb, $16); + + +{$ifdef CONST} + +procedure AES_XorBlock(const B1, B2: TAESBlock; var B3: TAESBlock); + {-xor two blocks, result in third} + {$ifdef DLL} stdcall; {$endif} + +function AES_Init(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} + {$ifdef DLL} stdcall; {$endif} + +{$else} + +procedure AES_XorBlock(var B1, B2: TAESBlock; var B3: TAESBlock); + {-xor two blocks, result in third} + +function AES_Init(var Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} + +{$endif} + + +procedure AES_SetFastInit(value: boolean); + {-set FastInit variable} + {$ifdef DLL} stdcall; {$endif} + +function AES_GetFastInit: boolean; + {-Returns FastInit variable} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{$ifdef D4Plus} +var +{$else} +{$ifdef J_OPT} {$J+} {$endif} +const +{$endif} + FastInit : boolean = true; {Clear only necessary context data at init} + {IV and buf remain uninitialized} + +const + RCon: array[0..9] of longint= ($01,$02,$04,$08,$10,$20,$40,$80,$1b,$36); + + +{$ifdef BASM16} +{---------------------------------------------------------------------------} +procedure AES_XorBlock({$ifdef CONST} const {$else} var {$endif} B1, B2: TAESBlock; var B3: TAESBlock); + {-xor two blocks, result in third} +begin + asm + mov di,ds + lds si,[B1] + db $66; mov ax,[si] + db $66; mov bx,[si+4] + db $66; mov cx,[si+8] + db $66; mov dx,[si+12] + lds si,[B2] + db $66; xor ax,[si] + db $66; xor bx,[si+4] + db $66; xor cx,[si+8] + db $66; xor dx,[si+12] + lds si,[B3] + db $66; mov [si],ax + db $66; mov [si+4],bx + db $66; mov [si+8],cx + db $66; mov [si+12],dx + mov ds,di + end; +end; + +{$else} + +{---------------------------------------------------------------------------} +procedure AES_XorBlock({$ifdef CONST} const {$else} var {$endif} B1, B2: TAESBlock; var B3: TAESBlock); + {-xor two blocks, result in third} +var + a1: TWA4 absolute B1; + a2: TWA4 absolute B2; + a3: TWA4 absolute B3; +begin + a3[0] := a1[0] xor a2[0]; + a3[1] := a1[1] xor a2[1]; + a3[2] := a1[2] xor a2[2]; + a3[3] := a1[3] xor a2[3]; +end; + +{$endif BASM16} + + + +{---------------------------------------------------------------------------} +function AES_Init({$ifdef CONST} const {$else} var {$endif} Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} +var + pK: ^TAWK; + i : integer; + temp: longint; + {$ifdef BIT16} + s: TBA4; + t: TBA4 absolute temp; + {$endif} + Nk: word; +begin + AES_Init := 0; + + if FastInit then with ctx do begin + {Clear only the necessary context data at init. IV and buf} + {remain uninitialized, other fields are initialized below.} + bLen :=0; + Flag :=0; + {$ifdef CONST} + IncProc := nil; + {$else} + {TP5-6 do not like IncProc := nil;} + fillchar(IncProc, sizeof(IncProc), 0); + {$endif} + end + else fillchar(ctx, sizeof(ctx), 0); + + if (KeyBits<>128) and (KeyBits<>192) and (KeyBits<>256) then begin + AES_Init := AES_Err_Invalid_Key_Size; + exit; + end; + + Nk := KeyBits div 32; + Move(Key, ctx.RK, 4*Nk); + + ctx.KeyBits := KeyBits; + ctx.Rounds := 6 + Nk; + ctx.Decrypt := 0; + + {Calculate encryption round keys, cf.[2]} + pK := addr(ctx.RK); + +{$ifdef BIT16} + {16 bit: use byte arrays} + if keybits=128 then begin + for i:=0 to 9 do begin + temp := pK^[3]; + {SubWord(RotWord(temp)) if "word" count mod 4 = 0} + s[0] := SBox[t[1]]; + s[1] := SBox[t[2]]; + s[2] := SBox[t[3]]; + s[3] := SBox[t[0]]; + pK^[4] := longint(s) xor pK^[0] xor RCon[i]; + pK^[5] := pK^[1] xor pK^[4]; + pK^[6] := pK^[2] xor pK^[5]; + pK^[7] := pK^[3] xor pK^[6]; + pK := addr(pK^[4]); + end; + end + else if keybits=192 then begin + for i:=0 to 7 do begin + temp := pK^[5]; + {SubWord(RotWord(temp)) if "word" count mod 6 = 0} + s[0] := SBox[t[1]]; + s[1] := SBox[t[2]]; + s[2] := SBox[t[3]]; + s[3] := SBox[t[0]]; + pK^[ 6] := longint(s) xor pK^[0] xor RCon[i]; + pK^[ 7] := pK^[1] xor pK^[6]; + pK^[ 8] := pK^[2] xor pK^[7]; + pK^[ 9] := pK^[3] xor pK^[8]; + if i=7 then exit; + pK^[10] := pK^[4] xor pK^[ 9]; + pK^[11] := pK^[5] xor pK^[10]; + pK := addr(pK^[6]); + end; + end + else begin + for i:=0 to 6 do begin + temp := pK^[7]; + {SubWord(RotWord(temp)) if "word" count mod 8 = 0} + s[0] := SBox[t[1]]; + s[1] := SBox[t[2]]; + s[2] := SBox[t[3]]; + s[3] := SBox[t[0]]; + pK^[ 8] := longint(s) xor pK^[0] xor RCon[i]; + pK^[ 9] := pK^[1] xor pK^[ 8]; + pK^[10] := pK^[2] xor pK^[ 9]; + pK^[11] := pK^[3] xor pK^[10]; + if i=6 then exit; + temp := pK^[11]; + {SubWord(temp) if "word" count mod 8 = 4} + s[0] := SBox[t[0]]; + s[1] := SBox[t[1]]; + s[2] := SBox[t[2]]; + s[3] := SBox[t[3]]; + pK^[12] := longint(s) xor pK^[4]; + pK^[13] := pK^[5] xor pK^[12]; + pK^[14] := pK^[6] xor pK^[13]; + pK^[15] := pK^[7] xor pK^[14]; + pK := addr(pK^[8]); + end; + end; + +{$else} + {32 bit use shift and mask} + if keybits=128 then begin + for i:=0 to 9 do begin + temp := pK^[3]; + {SubWord(RotWord(temp)) if "word" count mod 4 = 0} + pK^[4] := (longint(SBox[(temp shr 8) and $ff]) ) xor + (longint(SBox[(temp shr 16) and $ff]) shl 8) xor + (longint(SBox[(temp shr 24) ]) shl 16) xor + (longint(SBox[(temp ) and $ff]) shl 24) xor + pK^[0] xor RCon[i]; + pK^[5] := pK^[1] xor pK^[4]; + pK^[6] := pK^[2] xor pK^[5]; + pK^[7] := pK^[3] xor pK^[6]; + pK := addr(pK^[4]); + end; + end + else if keybits=192 then begin + for i:=0 to 7 do begin + temp := pK^[5]; + {SubWord(RotWord(temp)) if "word" count mod 6 = 0} + pK^[ 6] := (longint(SBox[(temp shr 8) and $ff]) ) xor + (longint(SBox[(temp shr 16) and $ff]) shl 8) xor + (longint(SBox[(temp shr 24) ]) shl 16) xor + (longint(SBox[(temp ) and $ff]) shl 24) xor + pK^[0] xor RCon[i]; + pK^[ 7] := pK^[1] xor pK^[6]; + pK^[ 8] := pK^[2] xor pK^[7]; + pK^[ 9] := pK^[3] xor pK^[8]; + if i=7 then exit; + pK^[10] := pK^[4] xor pK^[ 9]; + pK^[11] := pK^[5] xor pK^[10]; + pK := addr(pK^[6]); + end; + end + else begin + for i:=0 to 6 do begin + temp := pK^[7]; + {SubWord(RotWord(temp)) if "word" count mod 8 = 0} + pK^[ 8] := (longint(SBox[(temp shr 8) and $ff]) ) xor + (longint(SBox[(temp shr 16) and $ff]) shl 8) xor + (longint(SBox[(temp shr 24) ]) shl 16) xor + (longint(SBox[(temp ) and $ff]) shl 24) xor + pK^[0] xor RCon[i]; + pK^[ 9] := pK^[1] xor pK^[ 8]; + pK^[10] := pK^[2] xor pK^[ 9]; + pK^[11] := pK^[3] xor pK^[10]; + if i=6 then exit; + temp := pK^[11]; + {SubWord(temp) if "word" count mod 8 = 4} + pK^[12] := (longint(SBox[(temp ) and $ff]) ) xor + (longint(SBox[(temp shr 8) and $ff]) shl 8) xor + (longint(SBox[(temp shr 16) and $ff]) shl 16) xor + (longint(SBox[(temp shr 24) ]) shl 24) xor + pK^[4]; + pK^[13] := pK^[5] xor pK^[12]; + pK^[14] := pK^[6] xor pK^[13]; + pK^[15] := pK^[7] xor pK^[14]; + pK := addr(pK^[8]); + end; + end; + +{$endif} + +end; + + + +{---------------------------------------------------------------------------} +procedure AES_SetFastInit(value: boolean); + {-set FastInit variable} +begin + FastInit := value; +end; + + +{---------------------------------------------------------------------------} +function AES_GetFastInit: boolean; + {-Returns FastInit variable} +begin + AES_GetFastInit := FastInit; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_cbc.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_cbc.pas new file mode 100644 index 00000000..65a3a8a7 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_cbc.pas @@ -0,0 +1,280 @@ +unit AES_CBC; + +(************************************************************************* + + DESCRIPTION : AES CBC functions + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [3] http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + [1] http://csrc.nist.gov/fips/fips-197.pdf + [4] Cipher text stealing: Schneier, Applied Cryptography 2.ed, ch.9.3 + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 20.09.03 we initial version + 0.20 21.09.03 we Cipher text stealing + 0.21 21.09.03 we with Flag, functions, error codes + 0.22 27.09.03 we FPC/go32v2 + 0.23 03.10.03 we 3-para encr/decr + 0.24 03.10.03 we Fix overwrite source bug for decrypt + 0.25 05.10.03 we STD.INC, TP5-6 + 0.26 12.06.04 we uses BLKSIZE constant + 0.27 12.06.04 we check for nil pointers + 0.28 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.29 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.30 01.12.04 we No more processing after short block + 0.31 09.07.06 we Checked: D9-D10 + 0.34 16.11.08 we Use Ptr2Inc from BTypes + 0.35 27.07.10 we Longint ILen in AES_CBC_En/Decrypt +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr, AES_Decr; + +{$ifdef CONST} + +function AES_CBC_Init_Encr(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + {$ifdef DLL} stdcall; {$endif} + +function AES_CBC_Init_Decr(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + {$ifdef DLL} stdcall; {$endif} + +{$else} + +function AES_CBC_Init_Encr(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_CBC_Init_Decr(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +{$endif} + + +function AES_CBC_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CBC mode} + {$ifdef DLL} stdcall; {$endif} + +function AES_CBC_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CBC mode} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------------------------------------------} +{$ifdef CONST} + function AES_CBC_Init_Encr(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +{$else} + function AES_CBC_Init_Encr(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; +{$endif} + {-AES key expansion, error if invalid key size, encrypt IV} +begin + {-AES key expansion, error if invalid key size} + AES_CBC_Init_Encr := AES_Init_Encr(Key, KeyBits, ctx); + ctx.IV := IV; +end; + + +{---------------------------------------------------------------------------} +{$ifdef CONST} +function AES_CBC_Init_Decr(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +{$else} +function AES_CBC_Init_Decr(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; +{$endif} + {-AES key expansion, error if invalid key size, encrypt IV} +begin + {-AES key expansion, error if invalid key size} + AES_CBC_Init_Decr := AES_Init_Decr(Key, KeyBits, ctx); + ctx.IV := IV; +end; + + +{---------------------------------------------------------------------------} +function AES_CBC_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CBC mode} +var + i,n: longint; + m: word; +begin + + AES_CBC_Encrypt := 0; + if ILen<0 then ILen := 0; + + if ctx.Decrypt<>0 then begin + AES_CBC_Encrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_CBC_Encrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_CBC_Encrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + n := ILen div AESBLKSIZE; {Full blocks} + m := ILen mod AESBLKSIZE; {Remaining bytes in short block} + if m<>0 then begin + if n=0 then begin + AES_CBC_Encrypt := AES_Err_Invalid_Length; + exit; + end; + dec(n); {CTS: special treatment of last TWO blocks} + end; + + {Short block must be last, no more processing allowed} + if ctx.Flag and 1 <> 0 then begin + AES_CBC_Encrypt := AES_Err_Data_After_Short_Block; + exit; + end; + + with ctx do begin + for i:=1 to n do begin + {ct[i] = encr(ct[i-1] xor pt[i]), cf. [3] 6.2} + AES_XorBlock(PAESBlock(ptp)^, IV, IV); + AES_Encrypt(ctx, IV, IV); + PAESBlock(ctp)^ := IV; + inc(Ptr2Inc(ptp),AESBLKSIZE); + inc(Ptr2Inc(ctp),AESBLKSIZE); + end; + if m<>0 then begin + {Cipher text stealing} + AES_XorBlock(PAESBlock(ptp)^, IV, IV); + AES_Encrypt(ctx, IV, IV); + buf := IV; + inc(Ptr2Inc(ptp),AESBLKSIZE); + for i:=0 to m-1 do IV[i] := IV[i] xor PAESBlock(ptp)^[i]; + AES_Encrypt(ctx, IV, PAESBlock(ctp)^); + inc(Ptr2Inc(ctp),AESBLKSIZE); + move(buf,PAESBlock(ctp)^,m); + {Set short block flag} + Flag := Flag or 1; + end; + end; +end; + + +{---------------------------------------------------------------------------} +function AES_CBC_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CBC mode} +var + i,n: longint; + m: word; + tmp: TAESBlock; +begin + + AES_CBC_Decrypt := 0; + if ILen<0 then ILen := 0; + + if ctx.Decrypt=0 then begin + AES_CBC_Decrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_CBC_Decrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_CBC_Decrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + n := ILen div AESBLKSIZE; {Full blocks} + m := ILen mod AESBLKSIZE; {Remaining bytes in short block} + if m<>0 then begin + if n=0 then begin + AES_CBC_Decrypt := AES_Err_Invalid_Length; + exit; + end; + dec(n); {CTS: special treatment of last TWO blocks} + end; + + {Short block must be last, no more processing allowed} + if ctx.Flag and 1 <> 0 then begin + AES_CBC_Decrypt := AES_Err_Data_After_Short_Block; + exit; + end; + + with ctx do begin + for i:=1 to n do begin + {pt[i] = decr(ct[i]) xor ct[i-1]), cf. [3] 6.2} + buf := IV; + IV := PAESBlock(ctp)^; + AES_Decrypt(ctx, IV, PAESBlock(ptp)^); + AES_XorBlock(PAESBlock(ptp)^, buf, PAESBlock(ptp)^); + inc(Ptr2Inc(ptp),AESBLKSIZE); + inc(Ptr2Inc(ctp),AESBLKSIZE); + end; + if m<>0 then begin + {Cipher text stealing, L=ILen (Schneier's n)} + buf := IV; {C(L-2)} + AES_Decrypt(ctx, PAESBlock(ctp)^, IV); + inc(Ptr2Inc(ctp),AESBLKSIZE); + fillchar(tmp,sizeof(tmp),0); + move(PAESBlock(ctp)^,tmp,m); {c[L]|0} + AES_XorBlock(tmp,IV,IV); + tmp := IV; + move(PAESBlock(ctp)^,tmp,m); {c[L]| C'} + AES_Decrypt(ctx,tmp,tmp); + AES_XorBlock(tmp, buf, PAESBlock(ptp)^); + inc(Ptr2Inc(ptp),AESBLKSIZE); + move(IV,PAESBlock(ptp)^,m); + {Set short block flag} + Flag := Flag or 1; + end; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_ccm.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_ccm.pas new file mode 100644 index 00000000..296712fb --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_ccm.pas @@ -0,0 +1,377 @@ +unit AES_CCM; + + +(************************************************************************* + + DESCRIPTION : AES Counter with CBC-MAC (CCM) mode functions + + REQUIREMENTS : TP5-7, D1-D7/D9-D12/D17-D18, FPC, VP, WDOSX + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REMARKS : - The IV and buf fields of the contexts are used for temporary buffers + - Tag compare is constant time but if verification fails, + then plaintext is zero-filled + - Maximum header length is $FEFF + - Since CCM was designed for use in a packet processing + environment, there are no incremental functions. The ..Ex + functions can be used together with AES_Init_Encr to save + key setup overhead if the same key is used more than once. + + REFERENCES : [1] RFC 3610, D. Whiting et al., Counter with CBC-MAC (CCM) + http://tools.ietf.org/html/rfc3610 + [2] NIST Special Publication 800-38C, Recommendation for + Block Cipher Modes of Operation: The CCM Mode for + Authentication and Confidentiality + http://csrc.nist.gov/publications/nistpubs/800-38C/SP800-38C_updated-July20_2007.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.01 17.05.09 we Initial version + 0.02 17.05.09 we Process full blocks, procedure IncCTR + 0.03 17.05.09 we Remove adjustment of nLen + 0.04 18.05.09 we Check static ranges and conditions, simplify ecoding of L in B0 + 0.05 18.05.09 we Check nLen + 0.06 18.05.09 we Simplify encoding of l(m) + 0.07 19.05.09 we Use ctx.IV, ctx.buf, ctx.bLen + 0.08 19.05.09 we TP5-6 + 0.09 20.05.09 we Simplified functions + 0.10 20.05.09 we If verification fails, ptp^ is zero-filled + 0.11 21.05.09 we Special length check for BIT16 + 0.12 21.05.09 we ctx as var parameter in Ex functions + 0.13 28.07.10 we Fix: Check ofs(dtp^) for 16 bit + 0.14 31.08.15 we constant time compare in AES_CCM_Dec_VeriEX +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2009-2015 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +{$i STD.INC} + + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr; + + +function AES_CCM_Enc_AuthEx(var ctx: TAESContext; + var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {$ifdef DLL} stdcall; {$endif} + {-CCM packet encrypt/authenticate without key setup} + + +function AES_CCM_Enc_Auth(var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + {$ifdef CONST}const{$else}var{$endif} Key; KBytes: word; {key and byte length of key} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {$ifdef DLL} stdcall; {$endif} + {-All-in-one call for CCM packet encrypt/authenticate} + + +function AES_CCM_Dec_VeriEX(var ctx: TAESContext; + ptag: pointer; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {$ifdef DLL} stdcall; {$endif} + {-CCM packet decrypt/verify without key setup. If ptag^ verification fails, ptp^ is zero-filled!} + + +function AES_CCM_Dec_Veri( ptag: pointer; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + {$ifdef CONST}const{$else}var{$endif} Key; KBytes: word; {key and byte length of key} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {$ifdef DLL} stdcall; {$endif} + {-All-in-one CCM packet decrypt/verify. If ptag^ verification fails, ptp^ is zero-filled!} + + +implementation + + +{---------------------------------------------------------------------------} +function AES_CCM_Core(var ctx: TAESContext; enc_auth: boolean; + var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + pnonce: pointer; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length, hLen <$FF00} + stp: pointer; sLen: longint; {source text: address / length} + dtp: pointer {dest. text: address} + ): integer; + {-CCM core routine. Encrypt or decrypt (depending on enc_auth) source text} + { to dest. text and calculate the CCM tag. Key setup must be done from caller} +var + ecc: TAESBlock; {encrypted counter} + err: integer; + len: longint; + k, L: word; + b: byte; + pb: pByte; + + procedure IncCTR(var CTR: TAESBlock); + {-Increment CTR[15]..CTR[16-L]} + var + j: integer; + begin + for j:=15 downto 16-L do begin + if CTR[j]=$FF then CTR[j] := 0 + else begin + inc(CTR[j]); + exit; + end; + end; + end; + +begin + + {Check static ranges and conditions} + if (sLen>0) and ((stp=nil) or (dtp=nil)) then err := AES_Err_NIL_Pointer + else if odd(tLen) or (tLen<4) or (tLen>16) then err := AES_Err_CCM_Tag_length + else if (hLen>0) and (hdr=nil) then err := AES_Err_NIL_Pointer + else if hLen>=$FF00 then err := AES_Err_CCM_Hdr_length + else if (nLen<7) or (nLen>13) then err := AES_Err_CCM_Nonce_length + {$ifdef BIT16} + else if (ofs(stp^)+sLen>$FFFF) or (ofs(dtp^)+sLen>$FFFF) then err := AES_Err_CCM_Text_length + {$endif} + else err := 0; + + AES_CCM_Core := err; + if err<>0 then exit; + + {calculate L value = max(number of bytes needed for sLen, 15-nLen)} + len := sLen; + L := 0; + while len>0 do begin + inc(L); + len := len shr 8; + end; + if nLen+L > 15 then begin + AES_CCM_Core := AES_Err_CCM_Nonce_length; + exit; + end; + {Force nLen+L=15. Since nLen<=13, L is at least 2} + L := 15-nLen; + + with ctx do begin + {compose B_0 = Flags | Nonce N | l(m)} + {octet 0: Flags = 64*HdrPresent | 8*((tLen-2) div 2 | (L-1)} + if hLen>0 then b := 64 else b := 0; + buf[0] := b or ((tLen-2) shl 2) or (L-1); + {octets 1..15-L is nonce} + pb := pnonce; + for k:=1 to 15-L do begin + buf[k] := pb^; + inc(Ptr2Inc(pb)); + end; + {octets 16-L .. 15: l(m)} + len := sLen; + for k:=1 to L do begin + buf[16-k] := len and $FF; + len := len shr 8; + end; + AES_Encrypt(ctx, buf, buf); + + {process header} + if hLen > 0 then begin + {octets 0..1: encoding of hLen. Note: since we allow max $FEFF bytes} + {only these two octets are used. Generally up to 10 octets are needed.} + buf[0] := buf[0] xor (hLen shr 8); + buf[1] := buf[1] xor (hLen and $FF); + {now append the hdr data} + blen:= 2; + pb := hdr; + for k:=1 to hLen do begin + if blen=16 then begin + AES_Encrypt(ctx, buf, buf); + blen := 0; + end; + buf[blen] := buf[blen] xor pb^; + inc(blen); + inc(Ptr2Inc(pb)); + end; + if blen<>0 then AES_Encrypt(ctx, buf, buf); + end; + + {setup the counter for source text processing} + pb := pnonce; + IV[0] := (L-1) and $FF; + for k:=1 to 15 do begin + if k<16-L then begin + IV[k] := pb^; + inc(Ptr2Inc(pb)); + end + else IV[k] := 0; + end; + + {process full source text blocks} + while sLen>=16 do begin + IncCTR(IV); + AES_Encrypt(ctx,IV,ecc); + if enc_auth then begin + AES_XorBlock(PAESBlock(stp)^, buf, buf); + AES_XorBlock(PAESBlock(stp)^, ecc, PAESBlock(dtp)^); + end + else begin + AES_XorBlock(PAESBlock(stp)^, ecc, PAESBlock(dtp)^); + AES_XorBlock(PAESBlock(dtp)^, buf, buf); + end; + AES_Encrypt(ctx, buf, buf); + inc(Ptr2Inc(stp), AESBLKSIZE); + inc(Ptr2Inc(dtp), AESBLKSIZE); + dec(sLen, AESBLKSIZE); + end; + + if sLen>0 then begin + {handle remaining bytes of source text} + IncCTR(IV); + AES_Encrypt(ctx, IV, ecc); + for k:=0 to word(sLen-1) do begin + if enc_auth then begin + b := pByte(stp)^; + pByte(dtp)^ := b xor ecc[k]; + end + else begin + b := pByte(stp)^ xor ecc[k]; + pByte(dtp)^ := b; + end; + buf[k] := buf[k] xor b; + inc(Ptr2Inc(stp)); + inc(Ptr2Inc(dtp)); + end; + AES_Encrypt(ctx, buf, buf); + end; + + {setup counter for the tag (zero the count)} + for k:=15 downto 16-L do IV[k] := 0; + AES_Encrypt(ctx, IV, ecc); + {store the TAG} + AES_XorBlock(buf, ecc, tag); + end; +end; + + +{---------------------------------------------------------------------------} +function AES_CCM_Enc_AuthEx(var ctx: TAESContext; + var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {-CCM packet encrypt/authenticate without key setup} +begin + AES_CCM_Enc_AuthEx := AES_CCM_Core(ctx,true,tag,tLen,@nonce,nLen,hdr,hLen,ptp,pLen,ctp); +end; + + +{---------------------------------------------------------------------------} +function AES_CCM_Enc_Auth(var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + {$ifdef CONST}const{$else}var{$endif} Key; KBytes: word;{key and byte length of key} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {-All-in-one call for CCM packet encrypt/authenticate} +var + ctx: TAESContext; + err: integer; +begin + err := AES_Init_Encr(Key, KBytes*8, ctx); + if err<>0 then AES_CCM_Enc_Auth := err + else AES_CCM_Enc_Auth := AES_CCM_Core(ctx,true,tag,tLen,@nonce,nLen,hdr,hLen,ptp,pLen,ctp); + fillchar(ctx, sizeof(ctx), 0); +end; + + +{---------------------------------------------------------------------------} +function AES_CCM_Dec_VeriEX(var ctx: TAESContext; + ptag: pointer; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {-CCM packet decrypt/verify without key setup. If ptag^ verification fails, ptp^ is zero-filled!} +var + tag: TAESBlock; + err,i: integer; + diff: byte; +begin + err := AES_CCM_Core(ctx,false,tag,tLen,@nonce,nLen,hdr,hLen,ctp,cLen,ptp); + if err=0 then begin + diff := 0; + for i:=0 to pred(tLen) do begin + diff := diff or (pByte(ptag)^ xor tag[i]); + inc(Ptr2Inc(ptag)); + end; + err := (((integer(diff)-1) shr 8) and 1)-1; {0 compare, -1 otherwise} + err := err and AES_Err_CCM_Verify_Tag; + end; + fillchar(tag, sizeof(tag),0); + AES_CCM_Dec_VeriEx := err; + if err<>0 then fillchar(ptp^, cLen, 0); +end; + + +{---------------------------------------------------------------------------} +function AES_CCM_Dec_Veri( ptag: pointer; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + {$ifdef CONST}const{$else}var{$endif} Key; KBytes: word;{key and byte length of key} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {-All-in-one CCM packet decrypt/verify. If ptag^ verification fails, ptp^ is zero-filled!} +var + ctx: TAESContext; + err: integer; +begin + err := AES_Init_Encr(Key, KBytes*8, ctx); + if err<>0 then AES_CCM_Dec_Veri := err + else AES_CCM_Dec_Veri := AES_CCM_Dec_VeriEX(ctx,ptag,tLen,nonce,nLen,hdr,hLen,ctp,cLen,ptp); + fillchar(ctx, sizeof(ctx), 0); +end; + + + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_cfb.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_cfb.pas new file mode 100644 index 00000000..4058fa75 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_cfb.pas @@ -0,0 +1,219 @@ +unit AES_CFB; + +(************************************************************************* + + DESCRIPTION : AES CFB128 functions + Because of buffering en/decrypting is associative + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [3] http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + [1] http://csrc.nist.gov/fips/fips-197.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 16.08.03 we initial version + 0.11 21.09.03 we functions, error codes + 0.12 27.09.03 we FPC/go32v2 + 0.13 03.10.03 we 3-para encr/decr + 0.14 05.10.03 we STD.INC, TP5-6 + 0.15 01.01.04 we Handle full blocks first + 0.16 01.01.04 we Decrypt: bugfix for ctp=ptp + 0.17 12.06.04 we uses BLKSIZE constant + 0.18 12.06.04 we check for nil pointers + 0.19 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.20 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.21 09.07.06 we Checked: D9-D10 + 0.22 16.11.08 we Use Ptr2Inc, pByte from BTypes + 0.23 27.07.10 we Longint ILen in AES_CFB_En/Decrypt +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr; + +{$ifdef CONST} +function AES_CFB_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + {$ifdef DLL} stdcall; {$endif} +{$else} +function AES_CFB_Init(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} +{$endif} + +function AES_CFB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CFB128 mode} + {$ifdef DLL} stdcall; {$endif} + +function AES_CFB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CFB128 mode} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------------------------------------------} +{$ifdef CONST} +function AES_CFB_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +{$else} +function AES_CFB_Init(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; +{$endif} + {-AES key expansion, error if invalid key size, encrypt IV} +var + err: integer; +begin + {-AES key expansion, error if invalid key size} + err := AES_Init_Encr(Key, KeyBits, ctx); + AES_CFB_Init := err; + if err=0 then begin + {encrypt IV} + AES_Encrypt(ctx, IV, ctx.IV); + end; +end; + + +{---------------------------------------------------------------------------} +function AES_CFB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CFB128 mode} +begin + AES_CFB_Encrypt := 0; + + if ctx.Decrypt<>0 then begin + AES_CFB_Encrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_CFB_Encrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_CFB_Encrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + if ctx.blen=0 then begin + {Handle full blocks first} + while ILen>=AESBLKSIZE do with ctx do begin + {Cipher text = plain text xor encr(IV/CT), cf. [3] 6.3} + AES_XorBlock(PAESBlock(ptp)^, IV, PAESBlock(ctp)^); + AES_Encrypt(ctx, PAESBlock(ctp)^, IV); + inc(Ptr2Inc(ptp), AESBLKSIZE); + inc(Ptr2Inc(ctp), AESBLKSIZE); + dec(ILen, AESBLKSIZE); + end; + end; + + {Handle remaining bytes} + while ILen>0 do with ctx do begin + {Test buffer empty} + if bLen>=AESBLKSIZE then begin + AES_Encrypt(ctx, buf, IV); + bLen := 0; + end; + buf[bLen] := IV[bLen] xor pByte(ptp)^; + pByte(ctp)^ := buf[bLen]; + inc(bLen); + inc(Ptr2Inc(ptp)); + inc(Ptr2Inc(ctp)); + dec(ILen); + end; +end; + + +{---------------------------------------------------------------------------} +function AES_CFB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CFB128 mode} +begin + AES_CFB_Decrypt := 0; + + if ctx.Decrypt<>0 then begin + AES_CFB_Decrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_CFB_Decrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_CFB_Decrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + if ctx.blen=0 then begin + {Handle full blocks first} + while ILen>=AESBLKSIZE do with ctx do begin + {plain text = cypher text xor encr(IV/CT), cf. [3] 6.3} + {must use buf, otherwise overwrite bug if ctp=ptp} + buf := PAESBlock(ctp)^; + AES_XorBlock(buf, IV, PAESBlock(ptp)^); + AES_Encrypt(ctx, buf, IV); + inc(Ptr2Inc(ptp), AESBLKSIZE); + inc(Ptr2Inc(ctp), AESBLKSIZE); + dec(ILen, AESBLKSIZE); + end; + end; + + {Handle remaining bytes} + while ILen>0 do with ctx do begin + {Test buffer empty} + if bLen>=AESBLKSIZE then begin + AES_Encrypt(ctx, buf, IV); + bLen := 0; + end; + buf[bLen] := pByte(ctp)^; + pByte(ptp)^ := buf[bLen] xor IV[bLen]; + inc(bLen); + inc(Ptr2Inc(ptp)); + inc(Ptr2Inc(ctp)); + dec(ILen); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_cfb8.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_cfb8.pas new file mode 100644 index 00000000..ef013529 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_cfb8.pas @@ -0,0 +1,177 @@ +unit AES_CFB8; + +(************************************************************************* + + DESCRIPTION : AES CFB8 functions + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [3] http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + [1] http://csrc.nist.gov/fips/fips-197.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 25.12.07 W.Ehrhardt Initial encrypt version + 0.11 25.12.07 we AES_CFB8_Decrypt + 0.12 16.11.08 we Use Ptr2Inc, pByte from BTypes + 0.13 27.07.10 we Longint ILen in AES_CFB8_En/Decrypt +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2007-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr; + +{$ifdef CONST} +function AES_CFB8_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, store IV} + {$ifdef DLL} stdcall; {$endif} +{$else} +function AES_CFB8_Init(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, store IV} +{$endif} + +function AES_CFB8_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CFB8 mode} + {$ifdef DLL} stdcall; {$endif} + +function AES_CFB8_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CFB8 mode} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------------------------------------------} +{$ifdef CONST} +function AES_CFB8_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +{$else} +function AES_CFB8_Init(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; +{$endif} + {-AES key expansion, error if invalid key size, store IV} +var + err: integer; +begin + {-AES key expansion, error if invalid key size} + err := AES_Init_Encr(Key, KeyBits, ctx); + AES_CFB8_Init := err; + if err=0 then ctx.IV := IV; +end; + + +{---------------------------------------------------------------------------} +function AES_CFB8_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CFB8 mode} +begin + AES_CFB8_Encrypt := 0; + + if ctx.Decrypt<>0 then begin + AES_CFB8_Encrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_CFB8_Encrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_CFB8_Encrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + {Encrypt ILen bytes from ptp^ to ctp^ in CFB8 mode} + while ILen>0 do with ctx do begin + AES_Encrypt(ctx, IV, buf); + {encrypt next btye} + pByte(ctp)^ := buf[0] xor pByte(ptp)^; + {shift 8 bits} + move(IV[1],IV[0],AESBLKSIZE-1); + IV[AESBLKSIZE-1] := pByte(ctp)^; + {increment pointers} + inc(Ptr2Inc(ptp)); + inc(Ptr2Inc(ctp)); + dec(ILen); + end; +end; + + +{---------------------------------------------------------------------------} +function AES_CFB8_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CFB8 mode} +begin + AES_CFB8_Decrypt := 0; + + if ctx.Decrypt<>0 then begin + AES_CFB8_Decrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_CFB8_Decrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_CFB8_Decrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + {Decrypt ILen bytes from ctp^ to ptp^ in CFB8 mode} + while ILen>0 do with ctx do begin + AES_Encrypt(ctx, IV, buf); + {shift 8 bits} + move(IV[1],IV[0],AESBLKSIZE-1); + IV[AESBLKSIZE-1] := pByte(ctp)^; + {decrypt next byte} + pByte(ptp)^ := buf[0] xor pByte(ctp)^; + {increment pointers} + inc(Ptr2Inc(ptp)); + inc(Ptr2Inc(ctp)); + dec(ILen); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_cmac.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_cmac.pas new file mode 100644 index 00000000..cc84fce2 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_cmac.pas @@ -0,0 +1,117 @@ +unit AES_CMAC; + +(************************************************************************* + + DESCRIPTION : AES CMAC routines + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [1] NIST Special Publication 800-38B, Recommendation for Block + Cipher Modes of Operation: The CMAC Mode for Authentication + http://csrc.nist.gov/publications/nistpubs/800-38B/SP_800-38B.pdf + [2] OMAC page: http://www.nuee.nagoya-u.ac.jp/labs/tiwata/omac/omac.html + [3] T.Iwata and K.Kurosawa. OMAC: One-Key CBC MAC - Addendum + http://csrc.nist.gov/CryptoToolkit/modes/proposedmodes/omac/omac-ad.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version, wrapper for OMAC + 0.11 09.07.06 we Calls to AES_OMAC_UpdateXL, AES_OMACx_Final + 0.12 28.07.10 we AES_CMAC_Update with ILen: longint, XL Version with $define OLD_XL_Version +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2006-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +{$i STD.INC} + +interface + +uses + AES_Type, AES_OMAC; + +function AES_CMAC_Init({$ifdef CONST} const Key {$else} var Key {$endif}; KeyBits: word; var ctx: TAESContext): integer; + {-CMAC init: AES key expansion, error if inv. key size} + {$ifdef DLL} stdcall; {$endif} + +function AES_CMAC_Update(data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-CMAC data input, may be called more than once} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_CMAC_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate CMAC=OMAC1 tag} + {$ifdef DLL} stdcall; {$endif} + +{$ifdef OLD_XL_Version} +function AES_CMAC_UpdateXL (data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-CMAC data input, may be called more than once} +{$endif} + + +implementation + + +{---------------------------------------------------------------------------} +function AES_CMAC_Init({$ifdef CONST} const Key {$else} var Key {$endif}; KeyBits: word; var ctx: TAESContext): integer; + {-CMAC init: AES key expansion, error if inv. key size} +begin + AES_CMAC_Init := AES_OMAC_Init(Key, KeyBits, ctx); +end; + + +{$ifdef OLD_XL_Version} +{---------------------------------------------------------------------------} +function AES_CMAC_UpdateXL (data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-CMAC data input, may be called more than once} +begin + AES_CMAC_UpdateXL := AES_OMAC_Update(data, ILen, ctx); +end; +{$endif} + + +{---------------------------------------------------------------------------} +function AES_CMAC_Update(data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-CMAC data input, may be called more than once} +begin + AES_CMAC_Update := AES_OMAC_Update(data, ILen, ctx);; +end; + + +{---------------------------------------------------------------------------} +procedure AES_CMAC_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate CMAC=OMAC1 tag} +begin + AES_OMACx_Final(false, tag, ctx); +end; + + +end. + diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_conf.inc b/Tocsg.Lib/VCL/EncLib/AES/aes_conf.inc new file mode 100644 index 00000000..56153559 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_conf.inc @@ -0,0 +1,69 @@ +(************************************************************************* + + DESCRIPTION : AES configuration include file + + REQUIREMENTS : TP5-7, D1-D7/D9-D10, FPC, VP (Undef BASM16 for 286) + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version + 0.11 09.07.06 we Common defines for encrypt/decryt tables + 0.12 19.07.06 we Cond. defines AES_Diag, AES_Encr/Decr_DummyAlign +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2006 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +{Use additional 1K expanded able Te4/Td4 for last encryption round} +{.$define AES_LONGBOX} + +{Use 2K tables TCe/TCd instead of four 1K tables Te0 .. Te3, Td0 .. Td3} +{.$define AES_ComprTab} + +{Interface some diagnostic data, eg Enc/Dec table offsets mod 16} +{$define AES_Diag} + +{Use to align TCe to 8 byte boundary, inserts dummy longint} +{Inspect the map file and/or use AES_Diag/TCe_Diag} +{.$define AES_Encr_DummyAlign} + +{Use to align TCd to 8 byte boundary, inserts dummy longint} +{Inspect the map file and/or use AES_Diag/TCd_Diag} +{.$define AES_Decr_DummyAlign} + + +{---------------------------------------------------------------------------} +{Consistency check - do not change!} +{$ifdef AES_ComprTab} + {$ifdef AES_LONGBOX} + {$undef AES_LONGBOX} + {$endif} +{$endif} + diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_cprf.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_cprf.pas new file mode 100644 index 00000000..85b3b53b --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_cprf.pas @@ -0,0 +1,137 @@ +unit aes_cprf; + +{Variable-length key AES CMAC Pseudo-Random Function-128} + +{$i STD.INC} + +interface + +uses + AES_Type, AES_OMAC; + + +(************************************************************************* + + DESCRIPTION : Variable-length key AES CMAC Pseudo-Random Function-128 + + REQUIREMENTS : TP5-7, D1-D7/D9-D10, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [1] RFC 4615: The Advanced Encryption Standard-Cipher-based + Message Authentication Code-Pseudo-Random Function-128 + (AES-CMAC-PRF-128) Algorithm for the Internet Key + Exchange Protocol (IKE) + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 28.05.07 W.Ehrhardt Initial version + 0.11 28.05.07 we function returns OMAC results + 0.12 16.06.07 we AES_CPRF128_selftest stdcall +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2007 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +function AES_CPRF128({$ifdef CONST} const Key {$else} var Key {$endif}; KeyBytes: word; + msg: pointer; msglen: longint; var PRV: TAESBlock): integer; + {Calculate variable-length key AES CMAC Pseudo-Random Function-128 for msg} + {returns AES_OMAC error and 128-bit pseudo-random value PRV} + {$ifdef DLL} stdcall; {$endif} + +function AES_CPRF128_selftest: boolean; + {-Selftest with RFC 4615 test vectors} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------------------------------------------} +function AES_CPRF128({$ifdef CONST} const Key {$else} var Key {$endif}; KeyBytes: word; + msg: pointer; msglen: longint; var PRV: TAESBlock): integer; + {Calculate variable-length key AES CMAC Pseudo-Random Function-128 for msg} + {returns AES_OMAC error and 128-bit pseudo-random value PRV} +var + LK: TAESBlock; {local 128 bit key} + ctx: TAESContext; + err: integer; +const + ZB: TAESBlock = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); +begin + if KeyBytes=16 then begin + {If the key, is exactly 128 bits, then we use it as-is (copy to local)} + move(Key, LK, 16); + err := 0; + end + else begin + {If key length is not 128 bits, then we derive the local key LK by + applying the AES-CMAC algorithm using a 128-bit zero as the CMAC key + and Key as the input message: LK := AES-CMAC(0, Key, KeyBytes)} + err := AES_OMAC_Init(ZB, 128, ctx); + if err=0 then err := AES_OMAC_Update(@Key, KeyBytes, ctx); + if err=0 then AES_OMAC_Final(LK, ctx); + end; + {PRV := AES-CMAC(LK, msg, msglen)} + if err=0 then err := AES_OMAC_Init(LK, 128, ctx); + if err=0 then err := AES_OMAC_Update(msg, msglen, ctx); + if err=0 then AES_OMAC_Final(PRV, ctx); + AES_CPRF128 := err; +end; + + +{---------------------------------------------------------------------------} +function AES_CPRF128_selftest: boolean; + {-Selftest with RFC 4615 test vectors} +var + PRV: TAESBlock; + i,j: integer; +const + {Test vectors from RFC section 4, Message is fix} + msg: array[0..19] of byte = ($00,$01,$02,$03,$04,$05,$06,$07,$08,$09, + $0a,$0b,$0c,$0d,$0e,$0f,$10,$11,$12,$13); + {Base key is fix, but test three diffenrent length >16, =16, <16} + key: array[0..17] of byte = ($00,$01,$02,$03,$04,$05,$06,$07,$08,$09, + $0a,$0b,$0c,$0d,$0e,$0f,$ed,$cb); + KL: array[1..3] of word =(18,16,10); + {PRF outputs} + PRA: array[1..3] of TAESBlock = (($84,$a3,$48,$a4,$a4,$5d,$23,$5b,$ab,$ff,$fc,$0d,$2b,$4d,$a0,$9a), + ($98,$0a,$e8,$7b,$5f,$4c,$9c,$52,$14,$f5,$b6,$a8,$45,$5e,$4c,$2d), + ($29,$0d,$9e,$11,$2e,$db,$09,$ee,$14,$1f,$cf,$64,$c0,$b7,$2f,$3d)); +begin + AES_CPRF128_selftest := false; + for i:=1 to 3 do begin + if AES_CPRF128(Key, KL[i], @msg, sizeof(msg), PRV)<>0 then exit; + for j:=0 to 15 do if PRV[j]<>PRA[i][j] then exit; + end; + AES_CPRF128_selftest := true; +end; + + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_ctr.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_ctr.pas new file mode 100644 index 00000000..35eebd25 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_ctr.pas @@ -0,0 +1,350 @@ +unit AES_CTR; + +(************************************************************************* + + DESCRIPTION : AES CTR mode functions + Because of buffering en/decrypting is associative + User can supply a custom increment function + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [3] http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + [1] http://csrc.nist.gov/fips/fips-197.pdf + + REMARKS : - If a predefined or user-supplied INCProc is used, it must + be set before using AES_CTR_Seek. + - AES_CTR_Seek may be time-consuming for user-defined + INCProcs, because this function is called many times. + See AES_CTR_Seek how to provide user-supplied short-cuts. + + WARNING : - CTR mode demands that the same key / initial CTR pair is + never reused for encryption. This requirement is especially + important for the CTR_Seek function. If different data is + written to the same position there will be leakage of + information about the plaintexts. Therefore CTR_Seek should + normally be used for random reads only. + - Default IncProc changed to IncMSBFull in V0.30, for old + defaults call AES_SetIncProc(AES_IncMSBPart,.) after AES_CTR_Init + or (less flexible) set DefaultIncMSBPart := true + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 16.08.03 we initial version + 0.20 15.09.03 we use IncProc, with IncLSB, IncMSB + 0.21 20.09.03 we fixed obscure FPC @ bug + 0.22 21.09.03 we functions, error codes + 0.23 27.09.03 we FPC/go32v2 + 0.24 03.10.03 we 3-para encr/decr + 0.25 05.10.03 we STD.INC, TP5-6 + 0.26 05.10.03 we SetIncProc, Init without IncP + 0.27 05.10.03 we Bugfix for FPC: @ and IncProc + 0.28 01.01.04 we Handle full blocks first + 0.30 11.06.04 we 4 IncProcs, default IncMSBFull + 0.31 12.06.04 we uses BLKSIZE constant + 0.32 12.06.04 we check for nil pointers + 0.33 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.34 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.35 01.12.04 we AES_ prefix for increment routines + 0.36 09.07.06 we Checked: D9-D10 + 0.37 23.06.07 we Use conditional define FPC_ProcVar + 0.38 21.06.08 we Make IncProcs work with FPC -dDebug + 0.39 16.11.08 we Use Ptr2Inc, pByte from BTypes + 0.40 19.06.10 we Initial version of AES_CTR_Seek + 0.41 20.06.10 we AES_CTR_Seek: calculate IV if IncProc is known + 0.42 20.06.10 we AES_CTR_Seek64 + 0.43 21.06.10 we AES_CTR_Seek: Fix loop for user-defined IncProcs + 0.44 27.07.10 we Longint ILen in AES_CTR_En/Decrypt + 0.45 31.07.10 we AES_CTR_Seek source moved to aes_seek.inc +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr; + + +const + DefaultIncMSBPart: boolean = false; {if true use AES_IncMSBPart as default} + + +{$ifdef CONST} +function AES_CTR_Init(const Key; KeyBits: word; const CTR: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if inv. key size, encrypt CTR} + {$ifdef DLL} stdcall; {$endif} +{$else} +function AES_CTR_Init(var Key; KeyBits: word; var CTR: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if inv. key size, encrypt CTR} +{$endif} + + +{$ifndef DLL} +function AES_CTR_Seek({$ifdef CONST}const{$else}var{$endif} iCTR: TAESBlock; + SOL, SOH: longint; var ctx: TAESContext): integer; + {-Setup ctx for random access crypto stream starting at 64 bit offset SOH*2^32+SOL,} + { SOH >= 0. iCTR is the initial CTR for offset 0, i.e. the same as in AES_CTR_Init.} +{$ifdef HAS_INT64} +function AES_CTR_Seek64(const iCTR: TAESBlock; SO: int64; var ctx: TAESContext): integer; + {-Setup ctx for random access crypto stream starting at 64 bit offset SO >= 0;} + { iCTR is the initial CTR value for offset 0, i.e. the same as in AES_CTR_Init.} +{$endif} +{$endif} + + +function AES_CTR_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode} + {$ifdef DLL} stdcall; {$endif} + +function AES_CTR_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CTR mode} + {$ifdef DLL} stdcall; {$endif} + +function AES_SetIncProc(IncP: TIncProc; var ctx: TAESContext): integer; + {-Set user supplied IncCTR proc} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_IncMSBFull(var CTR: TAESBlock); + {-Increment CTR[15]..CTR[0]} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_IncLSBFull(var CTR: TAESBlock); + {-Increment CTR[0]..CTR[15]} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_IncMSBPart(var CTR: TAESBlock); + {-Increment CTR[15]..CTR[8]} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_IncLSBPart(var CTR: TAESBlock); + {-Increment CTR[0]..CTR[7]} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------------------------------------------} +procedure AES_IncMSBPart(var CTR: TAESBlock); + {-Increment CTR[15]..CTR[8]} +var + j: integer; +begin + for j:=15 downto 8 do begin + if CTR[j]=$FF then CTR[j] := 0 + else begin + inc(CTR[j]); + exit; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure AES_IncLSBPart(var CTR: TAESBlock); + {-Increment CTR[0]..CTR[7]} +var + j: integer; +begin + for j:=0 to 7 do begin + if CTR[j]=$FF then CTR[j] := 0 + else begin + inc(CTR[j]); + exit; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure AES_IncMSBFull(var CTR: TAESBlock); + {-Increment CTR[15]..CTR[0]} +var + j: integer; +begin + for j:=15 downto 0 do begin + if CTR[j]=$FF then CTR[j] := 0 + else begin + inc(CTR[j]); + exit; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure AES_IncLSBFull(var CTR: TAESBlock); + {-Increment CTR[0]..CTR[15]} +var + j: integer; +begin + for j:=0 to 15 do begin + if CTR[j]=$FF then CTR[j] := 0 + else begin + inc(CTR[j]); + exit; + end; + end; +end; + + +{---------------------------------------------------------------------------} +function AES_SetIncProc(IncP: TIncProc; var ctx: TAESContext): integer; + {-Set user supplied IncCTR proc} +begin + AES_SetIncProc := AES_Err_MultipleIncProcs; + with ctx do begin + {$ifdef FPC_ProcVar} + if IncProc=nil then begin + IncProc := IncP; + AES_SetIncProc := 0; + end; + {$else} + if @IncProc=nil then begin + IncProc := IncP; + AES_SetIncProc := 0; + end; + {$endif} + end; +end; + + +{---------------------------------------------------------------------------} +{$ifdef CONST} +function AES_CTR_Init(const Key; KeyBits: word; const CTR: TAESBlock; var ctx: TAESContext): integer; +{$else} +function AES_CTR_Init(var Key; KeyBits: word; var CTR: TAESBlock; var ctx: TAESContext): integer; +{$endif} + {-AES key expansion, error if inv. key size, encrypt CTR} +var + err: integer; +begin + {AES key expansion, error if inv. key size} + err := AES_Init_Encr(Key, KeyBits, ctx); + if (err=0) and DefaultIncMSBPart then begin + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncMSBPart, ctx); + {$else} + err := AES_SetIncProc(AES_IncMSBPart, ctx); + {$endif} + end; + if err=0 then begin + ctx.IV := CTR; + {encrypt CTR} + AES_Encrypt(ctx, CTR, ctx.buf); + end; + AES_CTR_Init := err; +end; + + +{---------------------------------------------------------------------------} +function AES_CTR_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode} +begin + AES_CTR_Encrypt := 0; + + if ctx.Decrypt<>0 then begin + AES_CTR_Encrypt := AES_Err_Invalid_Mode; + exit; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_CTR_Encrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_CTR_Encrypt := AES_Err_NIL_Pointer; {nil pointer to block with nonzero length} + exit; + end; + end; + + if ctx.blen=0 then begin + {Handle full blocks first} + while ILen>=AESBLKSIZE do with ctx do begin + {Cipher text = plain text xor encr(CTR), cf. [3] 6.5} + AES_XorBlock(PAESBlock(ptp)^, buf, PAESBlock(ctp)^); + inc(Ptr2Inc(ptp), AESBLKSIZE); + inc(Ptr2Inc(ctp), AESBLKSIZE); + dec(ILen, AESBLKSIZE); + {use AES_IncMSBFull if IncProc=nil} + {$ifdef FPC_ProcVar} + if IncProc=nil then AES_IncMSBFull(IV) else IncProc(IV); + {$else} + if @IncProc=nil then AES_IncMSBFull(IV) else IncProc(IV); + {$endif} + AES_Encrypt(ctx, IV, buf); + end; + end; + + {Handle remaining bytes} + while ILen>0 do with ctx do begin + {Refill buffer with encrypted CTR} + if bLen>=AESBLKSIZE then begin + {use AES_IncMSBFull if IncProc=nil} + {$ifdef FPC_ProcVar} + if IncProc=nil then AES_IncMSBFull(IV) else IncProc(IV); + {$else} + if @IncProc=nil then AES_IncMSBFull(IV) else IncProc(IV); + {$endif} + AES_Encrypt(ctx, IV, buf); + bLen := 0; + end; + {Cipher text = plain text xor encr(CTR), cf. [3] 6.5} + pByte(ctp)^ := buf[bLen] xor pByte(ptp)^; + inc(bLen); + inc(Ptr2Inc(ptp)); + inc(Ptr2Inc(ctp)); + dec(ILen); + end; +end; + + +{---------------------------------------------------------------------------} +function AES_CTR_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CTR mode} +begin + {Decrypt = encrypt for CTR mode} + AES_CTR_Decrypt := AES_CTR_Encrypt(ctp, ptp, ILen, ctx); +end; + + +{$ifndef DLL} + {$i aes_seek.inc} +{$endif} + + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_decr.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_decr.pas new file mode 100644 index 00000000..6473e2c4 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_decr.pas @@ -0,0 +1,191 @@ +unit AES_Decr; + + +(************************************************************************* + + DESCRIPTION : AES decrypt functions + (not needed for CFB/CTR/OFB mode) + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [1] http://csrc.nist.gov/fips/fips-197.pdf + [2] rijndael-alg-fst.c V2.0/3.0: Rijmen et al Aug1999/Dec2000 + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.22 16.08.03 we longint statt word32 + 0.23 16.08.03 we separate aes_decr + 0.24 16.08.03 we new xor_block + 0.25 18.09.03 we Static tables, GF routines from aes_base, D4+ + 0.26 20.09.03 we optimized round code, no more move/if + 0.27 21.09.03 we with Flag, functions, error codes + 0.28 27.09.03 we without GFMul and -tables + 0.29 27.09.03 we FPC/go32v2 + 0.30 28.09.03 we reorder round loop: gain 1 transformation t->block + 0.31 28.09.03 we merge last xorblock + 0.32 28.09.03 we two rounds in each loop + 0.33 03.10.03 we 3-para encr/decr + 0.34 03.10.03 we two local blocks if partial unroll + 0.35 03.10.03 we BASM for BP7 + 0.36 04.10.03 we remove add di,4 + 0.37 05.10.03 we STD.INC, TP6 + 0.38 05.10.03 we TP5,TP5.5 + 0.39 28.12.03 we DPerm removed + 0.40 29.12.03 we BASM16: Bugfix if seg(BO)<>ds, xorblock in asm + 0.41 29.12.03 we Delphi/VP: Pointer version + 0.42 29.12.03 we InvMixColumn with SBox,T5..T8, Bugfix + 0.43 29.12.03 we InvMixColumn with TBA4 if not BIT32 + 0.44 15.01.04 we InvMixColumn inline + 0.45 16.01.04 we MakeDecrKey as BIT32, BASM16, BIT16 + 0.46 14.08.04 we UseLongBox/Td4 + 0.47 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.48 24.12.04 we STD code and Td0..Td3 like [2], AES_DECR ifdefs + 0.49 24.12.04 we New ifdef logic, move replacement code to inc + 0.50 24.12.04 we TP5/5.5 with round key pointer + 0.51 24.12.04 we Fully unrolled 32 bit in dec_full.inc + 0.52 24.12.04 we BASM16: lea trick for 4*bx + 0.53 25.12.04 we BIT32: rearrange loop for descending key access + 0.54 27.12.04 we All: rearrange loop for descending key access + 0.55 04.03.05 we FPC 1.9.8, STD.INC V1.10, StrictLong + 0.56 05.05.05 we $R- for StrictLong, D9: errors if $R+ even if warnings off + 0.57 09.07.06 we Compressed tables, code in INC files + 0.58 19.07.06 we TCd_Diag + 0.59 21.11.08 we Use __P2I from BTypes + 0.60 01.12.12 we separate BIT64 include statements +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2012 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +{$i STD.INC} + + + +interface + + +uses AES_Type, AES_Base; + +{$i aes_conf.inc} + +{$ifdef AES_Diag} +{$ifdef AES_ComprTab} +var + TCd_Diag: integer; {offset of TCd table mod 15} + {should be 0 or 8 for optimal alignment} +{$endif} +{$endif} + + +{$ifdef CONST} + +function AES_Init_Decr(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, InvMixColumn(Key) for Decypt, error if invalid key size} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_Decrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); + {-decrypt one block (in ECB mode)} + {$ifdef DLL} stdcall; {$endif} + +{$else} + +function AES_Init_Decr(var Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, InvMixColumn(Key) for Decypt, error if invalid key size} + +procedure AES_Decrypt(var ctx: TAESContext; var BI: TAESBlock; var BO: TAESBlock); + {-decrypt one block (in ECB mode)} + +{$endif} + + +implementation + +uses BTypes; + +type + PLong = ^longint; + + +{$ifdef AES_ComprTab} + {$i dec_cdat.inc} + {$ifndef BIT16} + {$ifdef BIT64} + {$i dec_cp16.inc} {This version is faster for FPC260/Win7-64!!!} + {$else} + {$i dec_cp32.inc} + {$endif} + {$else} + {$ifdef BASM16} + {$i dec_ca16.inc} + {$else} + {$i dec_cp16.inc} + {$endif} + {$endif} +{$else} + {$i dec_fdat.inc} + {$ifndef BIT16} + {$ifdef BIT64} + {$i dec_fp16.inc} {This version is faster for FPC260/Win7-64!!!} + {$else} + {$i dec_fp32.inc} + {$endif} + {$else} + {$ifdef BASM16} + {$i dec_fa16.inc} + {$else} + {$i dec_fp16.inc} + {$endif} + {$endif} +{$endif} + + + +{---------------------------------------------------------------------------} +function AES_Init_Decr({$ifdef CONST} const {$else} var {$endif} Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, InvMixColumn(Key) for decrypt, error if invalid key size} +begin + AES_Init_Decr := AES_Init(Key, KeyBits, ctx); + MakeDecrKey(ctx); + ctx.Decrypt := 1; +end; + + +{$ifdef AES_ComprTab} +begin + {$ifdef AES_Diag} + TCd_Diag := __P2I(@TCd) and 15; + {$endif} + {$ifdef AES_Decr_DummyAlign} + if TCdDummy<>0 then ; + {$endif} +{$endif} + + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_dll.dpr b/Tocsg.Lib/VCL/EncLib/AES/aes_dll.dpr new file mode 100644 index 00000000..83acfb03 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_dll.dpr @@ -0,0 +1,168 @@ +library AES_DLL; + +{$ifndef DLL} + error('compile with $define DLL'); + end. +{$endif} + + +(************************************************************************* + + DESCRIPTION : DLL for AES + + REQUIREMENTS : D2-D7/D9-D10/D12, compile with $define DLL + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REMARK : AES_CTR_Seek/64 will be supplied by interface unit + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 02.07.04 W.Ehrhardt Initial version + 0.11 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.12 01.12.04 we AES_ prefix for CTR increment routines + 0.13 24.12.04 we AES_Get/SetFastInit + 0.14 09.07.06 we Checked: D9-D10 + 0.15 09.07.06 we Added CMAC, updated OMAC + 0.16 16.06.07 we AES_CPRF128 + 0.17 29.09.07 we AES_XTS + 0.18 25.12.07 we AES_CFB8 + 0.19 20.07.08 we All-in-one functions AES_EAX_Enc_Auth/AES_EAX_Dec_Veri + 0.20 21.05.09 we AES_CCM + 0.21 06.07.09 we AES_DLL_Version returns PAnsiChar + 0.22 22.06.10 we AES_CTR_Seek + 0.23 27.07.10 we Longint ILen in AES_xxx_En/Decrypt + 0.24 28.07.10 we Removed OMAC/CMAC XL versions + 0.25 31.07.10 we Removed AES_CTR_Seek (handled in interface unit) + 0.26 27.09.10 we AES_GCM +**************************************************************************) + +(*------------------------------------------------------------------------- + (C) Copyright 2004-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +uses + aes_type, aes_base, aes_encr, aes_decr, aes_cfb8, + aes_ctr, aes_cfb, aes_ofb, aes_cbc, aes_ecb, + aes_omac, aes_cmac, aes_eax, aes_cprf, aes_xts, + aes_ccm, aes_gcm; + +{$R *.RES} + + +{---------------------------------------------------------------------------} +function AES_DLL_Version: PAnsiChar; stdcall; + {-Return DLL version as PAnsiChar} +begin + Result := '0.26'; +end; + + +exports AES_DLL_Version name 'AES_DLL_Version'; +exports AES_XorBlock name 'AES_XorBlock'; +exports AES_SetFastInit name 'AES_SetFastInit'; +exports AES_GetFastInit name 'AES_GetFastInit'; +exports AES_Init name 'AES_Init'; + +exports AES_Init_Encr name 'AES_Init_Encr'; +exports AES_Encrypt name 'AES_Encrypt'; + +exports AES_ECB_Init_Encr name 'AES_ECB_Init_Encr'; +exports AES_ECB_Init_Decr name 'AES_ECB_Init_Decr'; +exports AES_ECB_Encrypt name 'AES_ECB_Encrypt'; +exports AES_ECB_Decrypt name 'AES_ECB_Decrypt'; + +exports AES_Init_Decr name 'AES_Init_Decr'; +exports AES_Decrypt name 'AES_Decrypt'; + +exports AES_CBC_Init_Encr name 'AES_CBC_Init_Encr'; +exports AES_CBC_Init_Decr name 'AES_CBC_Init_Decr'; +exports AES_CBC_Encrypt name 'AES_CBC_Encrypt'; +exports AES_CBC_Decrypt name 'AES_CBC_Decrypt'; + +exports AES_CFB_Init name 'AES_CFB_Init'; +exports AES_CFB_Encrypt name 'AES_CFB_Encrypt'; +exports AES_CFB_Decrypt name 'AES_CFB_Decrypt'; + +exports AES_CFB8_Init name 'AES_CFB8_Init'; +exports AES_CFB8_Encrypt name 'AES_CFB8_Encrypt'; +exports AES_CFB8_Decrypt name 'AES_CFB8_Decrypt'; + +exports AES_OFB_Init name 'AES_OFB_Init'; +exports AES_OFB_Encrypt name 'AES_OFB_Encrypt'; +exports AES_OFB_Decrypt name 'AES_OFB_Decrypt'; + +exports AES_CTR_Init name 'AES_CTR_Init'; +exports AES_CTR_Encrypt name 'AES_CTR_Encrypt'; +exports AES_CTR_Decrypt name 'AES_CTR_Decrypt'; +exports AES_SetIncProc name 'AES_SetIncProc'; +exports AES_IncMSBFull name 'AES_IncMSBFull'; +exports AES_IncLSBFull name 'AES_IncLSBFull'; +exports AES_IncMSBPart name 'AES_IncMSBPart'; +exports AES_IncLSBPart name 'AES_IncLSBPart'; + +exports AES_OMAC_Init name 'AES_OMAC_Init'; +exports AES_OMAC_Update name 'AES_OMAC_Update'; +exports AES_OMAC_Final name 'AES_OMAC_Final'; +exports AES_OMAC1_Final name 'AES_OMAC1_Final'; +exports AES_OMAC2_Final name 'AES_OMAC2_Final'; +exports AES_OMACx_Final name 'AES_OMACx_Final'; + +exports AES_CMAC_Init name 'AES_CMAC_Init'; +exports AES_CMAC_Update name 'AES_CMAC_Update'; +exports AES_CMAC_Final name 'AES_CMAC_Final'; + +exports AES_EAX_Init name 'AES_EAX_Init'; +exports AES_EAX_Provide_Header name 'AES_EAX_Provide_Header'; +exports AES_EAX_Encrypt name 'AES_EAX_Encrypt'; +exports AES_EAX_Decrypt name 'AES_EAX_Decrypt'; +exports AES_EAX_Final name 'AES_EAX_Final'; +exports AES_EAX_Enc_Auth name 'AES_EAX_Enc_Auth'; +exports AES_EAX_Dec_Veri name 'AES_EAX_Dec_Veri'; + +exports AES_CPRF128 name 'AES_CPRF128'; +exports AES_CPRF128_selftest name 'AES_CPRF128_selftest'; + +exports AES_XTS_Init_Encr name 'AES_XTS_Init_Encr'; +exports AES_XTS_Encrypt name 'AES_XTS_Encrypt'; +exports AES_XTS_Init_Decr name 'AES_XTS_Init_Decr'; +exports AES_XTS_Decrypt name 'AES_XTS_Decrypt'; + +exports AES_CCM_Dec_Veri name 'AES_CCM_Dec_Veri'; +exports AES_CCM_Dec_VeriEX name 'AES_CCM_Dec_VeriEX'; +exports AES_CCM_Enc_Auth name 'AES_CCM_Enc_Auth'; +exports AES_CCM_Enc_AuthEx name 'AES_CCM_Enc_AuthEx'; + +exports AES_GCM_Init name 'AES_GCM_Init'; +exports AES_GCM_Reset_IV name 'AES_GCM_Reset_IV'; +exports AES_GCM_Encrypt name 'AES_GCM_Encrypt'; +exports AES_GCM_Decrypt name 'AES_GCM_Decrypt'; +exports AES_GCM_Add_AAD name 'AES_GCM_Add_AAD'; +exports AES_GCM_Final name 'AES_GCM_Final'; +exports AES_GCM_Enc_Auth name 'AES_GCM_Enc_Auth'; +exports AES_GCM_Dec_Veri name 'AES_GCM_Dec_Veri'; + +end. + diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_dll.res b/Tocsg.Lib/VCL/EncLib/AES/aes_dll.res new file mode 100644 index 0000000000000000000000000000000000000000..c99b54903c2ba93ea59c87e6404c2e2835a145a6 GIT binary patch literal 1660 zcmah|&rcIk5dLa6X=99Sj2FF76AwTlK|(a~0>nxoS;2t8BO!`F#I~tRTu)t3Tf(77 zvgyIUqiIZ=*aHXt2oD~-*;`8>tl!M;mW2?Vc6Q!-^UXIi?*{IeF6kd>BvG|0A?UE|1aPu#vlP^jA0fqx(ev3bO3VK?LjR} zA$|hfnga!>p8z`zqza~~{_fGhbzGD!s~h-Dx0be3`=1M;ziZod$8LH<|3Yn0KR9h3 z4*jk>Xg9q>#v@ND)T#%kr%kWNx#YFnL95+v=-d#$yWeiLJntL*EU;@0yw*vB1QHJ21Ftjt_+@QVs1ebJS6&5PkK@nS+r`^RSnTvRj z5@W^{Gl^+-`jk4&8l<9U%#dKOC458~8^nKM*BhK|YQ|B#!343}~fe>PEBf#_EKii2>=h2_Z6`v zvhA@lE7o1WIDwl)UB+D9y=d + [2] http://csrc.nist.gov/CryptoToolkit/modes/proposedmodes/eax/eax-spec.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 11.06.04 we initial version (BP7+) + 0.11 12.06.04 we uses BLKSIZE constant + 0.12 13.06.04 we TP5/5.5/6 + 0.13 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.14 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.15 09.07.06 we Checked: D9-D10 + 0.16 14.06.07 we Type TAES_EAXContext + 0.17 20.07.08 we All-in-one functions AES_EAX_Enc_Auth/AES_EAX_Dec_Veri + 0.18 01.08.08 we Fix for loop in Internal_Veri + 0.19 02.08.08 we Local ctx for AES_EAX_Enc_Auth/AES_EAX_Dec_Veri + 0.20 06.08.08 we Suppress D4+ warning + 0.21 09.08.08 we Check tLen in ANU_EAX_Dec_Veri + 0.22 16.11.08 we Use Ptr2Inc, pByte from BTypes + 0.23 27.07.10 we Longint ILen in AES_EAX_En/Decrypt + 0.25 31.08.15 we constant time compare in Internal_Veri +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2004-2015 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + +{Use TEAXContext for legacy AES_EAX source codes. The new} +{context type TAES_EAXContext should be used instead.} +{.$define Support_Old_AES_EAXContext_Type} + + +interface + +uses + BTypes, AES_Type, AES_Base, AES_CTR, AES_OMAC; + + +type + TAES_EAXContext = packed record + HdrOMAC : TAESContext; {Hdr OMAC1 context} + MsgOMAC : TAESContext; {Msg OMAC1 context} + ctr_ctx : TAESContext; {Msg AESCTR context} + NonceTag: TAESBlock; {nonce tag } + tagsize : word; {tag size (unused) } + flags : word; {ctx flags (unused)} + end; + {$ifdef Support_Old_AES_EAXContext_Type} + TEAXContext = TAES_EAXContext; + {$endif} + + +{$ifdef CONST} +function AES_EAX_Init(const Key; KBits: word; const nonce; nLen: word; var ctx: TAES_EAXContext): integer; + {$ifdef DLL} stdcall; {$endif} + {-Init hdr and msg OMACs, setp AESCTR with nonce tag} + +{$else} +function AES_EAX_Init(var Key; KBits: word; var nonce; nLen: word; var ctx: TAES_EAXContext): integer; + {-Init hdr and msg OMACs, setp AESCTR with nonce tag} +{$endif} + +function AES_EAX_Provide_Header(Hdr: pointer; hLen: word; var ctx: TAES_EAXContext): integer; + {$ifdef DLL} stdcall; {$endif} + {-Supply a message header. The header "grows" with each call} + +function AES_EAX_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_EAXContext): integer; + {$ifdef DLL} stdcall; {$endif} + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update OMACs} + +function AES_EAX_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAES_EAXContext): integer; + {$ifdef DLL} stdcall; {$endif} + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update OMACs} + +procedure AES_EAX_Final(var tag: TAESBlock; var ctx: TAES_EAXContext); + {$ifdef DLL} stdcall; {$endif} + {-Compute EAX tag from context} + +function AES_EAX_Enc_Auth(var tag: TAESBlock; {Tag record} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + Hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {$ifdef DLL} stdcall; {$endif} + {-All-in-one call to encrypt/authenticate} + +function AES_EAX_Dec_Veri( ptag: pointer; tLen: word; {Tag: address / length (0..16)} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + Hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {$ifdef DLL} stdcall; {$endif} + {-All-in-one call to decrypt/verify. Decryption is done only if ptag^ is verified} + + +implementation + + +{---------------------------------------------------------------------------} +{$ifdef CONST} +function AES_EAX_Init(const Key; KBits: word; const nonce; nLen: word; var ctx: TAES_EAXContext): integer; + {-Init hdr and msg OMACs, setp AESCTR with nonce tag} +{$else} +function AES_EAX_Init(var Key; KBits: word; var nonce; nLen: word; var ctx: TAES_EAXContext): integer; + {-Init hdr and msg OMACs, setp AESCTR with nonce tag} +{$endif} +var + err: integer; + t_n: TAESBlock; +begin + fillchar(ctx, sizeof(ctx), 0); + {Initialize OMAC context with key} + err := AES_OMAC_Init(Key, KBits, ctx.HdrOMAC); + if err=0 then begin + {copy fresh context, first use MsgOMAC for nonce OMAC} + ctx.MsgOMAC := ctx.HdrOMAC; + fillchar(t_n, sizeof(t_n), 0); + err := AES_OMAC_Update(@t_n, sizeof(t_n), ctx.MsgOMAC); + if err=0 then err := AES_OMAC_Update(@nonce, nLen, ctx.MsgOMAC); + if err=0 then AES_OMAC_Final(ctx.NonceTag, ctx.MsgOMAC); + {inititialize AES-CTR context} + if err=0 then err := AES_CTR_Init(Key, KBits, ctx.NonceTag, ctx.ctr_ctx); + if err=0 then begin + {initialize msg OMAC} + ctx.MsgOMAC := ctx.HdrOMAC; + t_n[AESBLKSIZE-1] := 2; + err := AES_OMAC_Update(@t_n, sizeof(t_n), ctx.MsgOMAC); + {initialize header OMAC} + t_n[AESBLKSIZE-1] := 1; + if err=0 then err := AES_OMAC_Update(@t_n, sizeof(t_n), ctx.HdrOMAC); + end; + end; + AES_EAX_Init := err; +end; + + +{---------------------------------------------------------------------------} +function AES_EAX_Provide_Header(Hdr: pointer; hLen: word; var ctx: TAES_EAXContext): integer; + {-Supply a message header. The header "grows" with each call} +begin + AES_EAX_Provide_Header := AES_OMAC_Update(Hdr, hLen, ctx.HdrOMAC); +end; + + +{---------------------------------------------------------------------------} +function AES_EAX_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_EAXContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update OMACs} +var + err: integer; +begin + {encrypt (and check for nil pointers)} + err := AES_CTR_Encrypt(ptp, ctp, ILen, ctx.ctr_ctx); + if err=0 then begin + {OMAC1 ciphertext} + err := AES_OMAC_Update(ctp, ILen, ctx.MsgOMAC); + end; + AES_EAX_Encrypt := err; +end; + + +{---------------------------------------------------------------------------} +function AES_EAX_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAES_EAXContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update OMACs} +var + err: integer; +begin + {OMAC1 ciphertext} + err := AES_OMAC_Update(ctp, ILen, ctx.MsgOMAC); + if err=0 then begin + {decrypt} + err := AES_CTR_Decrypt(ctp, ptp, ILen, ctx.ctr_ctx); + end; + AES_EAX_Decrypt := err; +end; + + +{---------------------------------------------------------------------------} +procedure AES_EAX_Final(var tag: TAESBlock; var ctx: TAES_EAXContext); + {-Compute EAX tag from context} +var + ht: TAESBlock; +begin + AES_OMAC1_Final(ht, ctx.HdrOMAC); + AES_OMAC1_Final(tag, ctx.MsgOMAC); + AES_XorBlock(tag,ht,tag); + AES_XorBlock(tag,ctx.NonceTag,tag); +end; + + +{---------------------------------------------------------------------------} +function AES_EAX_Enc_Auth(var tag: TAESBlock; {Tag record} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + Hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {-All-in-one call to encrypt/authenticate} +var + err : integer; + ILen: word; + ctx : TAES_EAXContext; +const + CHUNK=$8000; +begin + {$ifdef BIT16} + if (pLen>$FFFF) or (ofs(ptp^)+pLen>$FFFF) or (ofs(ctp^)+pLen>$FFFF) then begin + AES_EAX_Enc_Auth := AES_Err_EAX_Inv_Text_Length; + exit; + end; + {$endif} + if (ptp=nil) or (ctp=nil) then begin + if pLen>0 then begin + AES_EAX_Enc_Auth := AES_Err_NIL_Pointer; + exit; + end; + end; + err := AES_EAX_Init(Key, KBits, nonce, nLen, ctx); + if err=0 then err := AES_EAX_Provide_Header(Hdr, hLen, ctx); + while (err=0) and (pLen>0) do begin + if pLen>CHUNK then ILen := CHUNK else ILen := pLen; + err := AES_EAX_Encrypt(ptp, ctp, ILen, ctx); + inc(Ptr2Inc(ptp), ILen); + inc(Ptr2Inc(ctp), ILen); + dec(pLen, ILen); + end; + if err=0 then AES_EAX_Final(tag, ctx); + fillchar(ctx, sizeof(ctx), 0); + AES_EAX_Enc_Auth := err; +end; + + +{---------------------------------------------------------------------------} +function Internal_Veri(var ctx: TAES_EAXContext; ptag: pointer; tLen: word; + ctp: pointer; cLen: longint): integer; + {-calculate and verify tLen bytes of ptag^, performs OMAC phase of EAX} +var + err,i: integer; + ILen: word; + atag: TAESBlock; + diff: byte; +const + CHUNK=$8000; +begin + {internal, assumes ctx is initialized, nonce and header} + {are processed, cLen, tLen are with in allowed ranges} + err := 0; + {calculate the ciphertext OMAC} + while (err=0) and (cLen>0) do begin + if cLen>CHUNK then ILen := CHUNK else ILen := cLen; + err := AES_OMAC_Update(ctp, ILen, ctx.MsgOMAC); + inc(Ptr2Inc(ctp), ILen); + dec(cLen, ILen); + end; + if (err=0) and (tLen>0) then begin + {calculate actual tag and compare with supplied tag} + AES_EAX_Final(atag, ctx); + diff := 0; + for i:=0 to pred(tLen) do begin + diff := diff or (pByte(ptag)^ xor atag[i]); + inc(Ptr2Inc(ptag)); + end; + err := (((integer(diff)-1) shr 8) and 1)-1; {0 compare, -1 otherwise} + err := err and AES_Err_EAX_Verify_Tag; + end; + Internal_Veri := err; +end; + + + +{---------------------------------------------------------------------------} +function AES_EAX_Dec_Veri( ptag: pointer; tLen: word; {Tag: address / length (0..16)} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + {$ifdef CONST}const{$else}var{$endif} nonce; nLen: word; {nonce: address / length} + Hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {-All-in-one call to decrypt/verify. Decryption is done only if ptag^ is verified} +var + err : integer; + ILen: word; + ctx : TAES_EAXContext; +const + CHUNK=$8000; +begin + {$ifdef BIT16} + if (cLen>$FFFF) or (ofs(ptp^)+cLen>$FFFF) or (ofs(ctp^)+cLen>$FFFF) then begin + AES_EAX_Dec_Veri := AES_Err_EAX_Inv_Text_Length; + exit; + end; + {$endif} + if (ptp=nil) or (ctp=nil) then begin + if cLen>0 then begin + AES_EAX_Dec_Veri := AES_Err_NIL_Pointer; + exit; + end; + end; + if tLen>AESBLKSIZE then begin + AES_EAX_Dec_Veri := AES_Err_EAX_Inv_TAG_Length; + exit; + end; + err := AES_EAX_Init(Key, KBits, nonce, nLen, ctx); + if err=0 then err := AES_EAX_Provide_Header(Hdr, hLen, ctx); + if err=0 then begin + {First pass through ciphertext, calculated and compare tag} + err := Internal_Veri(ctx, ptag, tLen, ctp, cLen); + {if error or verfication failed, decrypt loop is skipped} + while (err=0) and (cLen>0) do begin + if cLen>CHUNK then ILen := CHUNK else ILen := cLen; + err := AES_CTR_Decrypt(ctp, ptp, ILen, ctx.ctr_ctx); + inc(Ptr2Inc(ptp), ILen); + inc(Ptr2Inc(ctp), ILen); + dec(cLen, ILen); + end; + end; + fillchar(ctx, sizeof(ctx), 0); + AES_EAX_Dec_Veri:= err; +end; + + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_ecb.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_ecb.pas new file mode 100644 index 00000000..b86790fc --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_ecb.pas @@ -0,0 +1,250 @@ +unit AES_ECB; + +(************************************************************************* + + DESCRIPTION : AES ECB functions + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [3] http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + [1] http://csrc.nist.gov/fips/fips-197.pdf + [4] Cipher text stealing: Schneier, Applied Cryptography 2.ed, ch.9.1 + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 21.09.03 we initial version a la CBC + 0.11 27.09.03 we FPC/go32v2 + 0.12 03.10.03 we 3-para encr/decr + 0.13 05.10.03 we STD.INC, TP5-6 + 0.14 12.06.04 we uses BLKSIZE constant + 0.15 12.06.04 we check for nil pointers + 0.16 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.17 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.18 01.12.04 we No more processing after short block + 0.19 09.07.06 we Checked: D9-D10 + 0.20 15.11.08 we Use Ptr2Inc from BTypes + 0.21 27.07.10 we Longint ILen in AES_ECB_En/Decrypt +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr, AES_Decr; + + +{$ifdef CONST} +function AES_ECB_Init_Encr(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + {$ifdef DLL} stdcall; {$endif} +function AES_ECB_Init_Decr(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + {$ifdef DLL} stdcall; {$endif} +{$else} +function AES_ECB_Init_Encr(var Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_ECB_Init_Decr(var Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} +{$endif} + +function AES_ECB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in ECB mode} + {$ifdef DLL} stdcall; {$endif} + +function AES_ECB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in ECB mode} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------------------------------------------} +function AES_ECB_Init_Encr({$ifdef CONST} const {$else} var {$endif} Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} +begin + {-AES key expansion, error if invalid key size} + AES_ECB_Init_Encr := AES_Init_Encr(Key, KeyBits, ctx); +end; + + +{---------------------------------------------------------------------------} +function AES_ECB_Init_Decr({$ifdef CONST} const {$else} var {$endif} Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} +begin + {-AES key expansion, error if invalid key size} + AES_ECB_Init_Decr := AES_Init_Decr(Key, KeyBits, ctx); +end; + + +{---------------------------------------------------------------------------} +function AES_ECB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in ECB mode} +var + i,n: longint; + m: word; + tmp: TAESBlock; +begin + + AES_ECB_Encrypt := 0; + if ILen<0 then ILen := 0; + + if ctx.Decrypt<>0 then begin + AES_ECB_Encrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_ECB_Encrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_ECB_Encrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + n := ILen div AESBLKSIZE; {Full blocks} + m := ILen mod AESBLKSIZE; {Remaining bytes in short block} + if m<>0 then begin + if n=0 then begin + AES_ECB_Encrypt := AES_Err_Invalid_Length; + exit; + end; + dec(n); {CTS: special treatment of last TWO blocks} + end; + + {Short block must be last, no more processing allowed} + if ctx.Flag and 1 <> 0 then begin + AES_ECB_Encrypt := AES_Err_Data_After_Short_Block; + exit; + end; + + with ctx do begin + for i:=1 to n do begin + AES_Encrypt(ctx, PAESBlock(ptp)^, PAESBlock(ctp)^); + inc(Ptr2Inc(ptp),AESBLKSIZE); + inc(Ptr2Inc(ctp),AESBLKSIZE); + end; + if m<>0 then begin + {Cipher text stealing} + AES_Encrypt(ctx, PAESBlock(ptp)^, buf); + inc(Ptr2Inc(ptp),AESBLKSIZE); + tmp := buf; + move(PAESBlock(ptp)^, tmp, m); + AES_Encrypt(ctx, tmp, PAESBlock(ctp)^); + inc(Ptr2Inc(ctp),AESBLKSIZE); + move(buf,PAESBlock(ctp)^,m); + {Set short block flag} + Flag := Flag or 1; + end; + end; +end; + + +{---------------------------------------------------------------------------} +function AES_ECB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in ECB mode} +var + i,n: longint; + m: word; + tmp: TAESBlock; +begin + + AES_ECB_Decrypt := 0; + if ILen<0 then ILen := 0; + + if ctx.Decrypt=0 then begin + AES_ECB_Decrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_ECB_Decrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_ECB_Decrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + n := ILen div AESBLKSIZE; {Full blocks} + m := ILen mod AESBLKSIZE; {Remaining bytes in short block} + if m<>0 then begin + if n=0 then begin + AES_ECB_Decrypt := AES_Err_Invalid_Length; + exit; + end; + dec(n); {CTS: special treatment of last TWO blocks} + end; + + {Short block must be last, no more processing allowed} + if ctx.Flag and 1 <> 0 then begin + AES_ECB_Decrypt := AES_Err_Data_After_Short_Block; + exit; + end; + + with ctx do begin + for i:=1 to n do begin + AES_Decrypt(ctx, PAESBlock(ctp)^, PAESBlock(ptp)^); + inc(Ptr2Inc(ptp),AESBLKSIZE); + inc(Ptr2Inc(ctp),AESBLKSIZE); + end; + if m<>0 then begin + {Cipher text stealing} + AES_Decrypt(ctx, PAESBlock(ctp)^, buf); + inc(Ptr2Inc(ctp),AESBLKSIZE); + tmp := buf; + move(PAESBlock(ctp)^, tmp, m); + AES_Decrypt(ctx, tmp, PAESBlock(ptp)^); + inc(Ptr2Inc(ptp),AESBLKSIZE); + move(buf,PAESBlock(ptp)^,m); + {Set short block flag} + Flag := Flag or 1; + end; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_encr.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_encr.pas new file mode 100644 index 00000000..996941f2 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_encr.pas @@ -0,0 +1,180 @@ +unit AES_Encr; + + +(************************************************************************* + + DESCRIPTION : AES encrypt functions + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [1] http://csrc.nist.gov/fips/fips-197.pdf + [2] rijndael-alg-fst.c V2.0/3.0: Rijmen et al Aug1999/Dec2000 + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.22 16.08.03 we longint statt word32 + 0.23 16.08.03 we separate aes_encr + 0.24 16.08.03 we new xor_block + 0.25 18.09.03 we Static tables, D4+ + 0.26 20.09.03 we optimized round code, no more move/if + 0.27 21.09.03 we functions, error codes + 0.28 27.09.03 we FPC/go32v2 + 0.29 28.09.03 we removed temporary s-Block + 0.30 28.09.03 we two rounds in each loop, merge last xorblock + 0.31 03.10.03 we 3-para encr/decr + 0.32 03.10.03 we two local blocks if partial unroll + 0.33 03.10.03 we BASM for BP7 + 0.34 04.10.03 we remove add di,4 + 0.35 05.10.03 we STD.INC, TP6 + 0.36 05.10.03 we TP5,TP5.5 + 0.37 27.12.03 we EPerm removed + 0.38 28.12.03 we Delphi/VP: Pointer version + BASM16: changed variable order + 0.39 28.12.03 we BASM16: SBox code in asm, + PTR: merge SBox code with XOR RK + 0.40 29.12.03 we BASM16: xorblock in asm, PTR: reorder + 0.41 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.42 14.08.04 we UseLongBox/Te4 + 0.43 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.44 24.12.04 we STD code and Te0..Te3 like [2], AES_ENCR ifdefs + 0.45 24.12.04 we New ifdef logic, move replacement code to inc + 0.46 24.12.04 we TP5/5.5 with round key pointer + 0.47 24.12.04 we BASM16: lea trick for 4*bx + 0.48 04.03.05 we FPC 1.9.8, STD.INC V1.10, StrictLong + 0.49 05.05.05 we $R- for StrictLong, D9: errors if $R+ even if warnings off + 0.50 09.07.06 we Compressed tables, code in INC files + 0.51 19.07.06 we TCe_Diag + 0.52 21.11.08 we Use __P2I from BTypes + 0.53 01.12.12 we separate BIT64 include statements +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2012 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + + +interface + + +uses + AES_Type, AES_Base; + +{$i aes_conf.inc} + +{$ifdef AES_Diag} +{$ifdef AES_ComprTab} +var + TCe_Diag: integer; {offset of TCe table mod 15} + {should be 0 or 8 for optimal alignment} + +{$endif} +{$endif} + + + +{$ifdef CONST} + +function AES_Init_Encr(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_Encrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} + {$ifdef DLL} stdcall; {$endif} + +{$else} + +function AES_Init_Encr(var Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} + +procedure AES_Encrypt(var ctx: TAESContext; var BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} + +{$endif} + + +implementation + +uses BTypes; + +{$ifdef AES_ComprTab} + {$i enc_cdat.inc} + {$ifndef BIT16} + {$ifdef BIT64} + {$i enc_cp16.inc} {This version is faster for FPC260/Win7-64!!!} + {$else} + {$i enc_cp32.inc} + {$endif} + {$else} + {$ifdef BASM16} + {$i enc_ca16.inc} + {$else} + {$i enc_cp16.inc} + {$endif} + {$endif} +{$else} + {$i enc_fdat.inc} + {$ifndef BIT16} + {$ifdef BIT64} + {$i enc_fp16.inc} {This version is faster for FPC260/Win7-64!!!} + {$else} + {$i enc_fp32.inc} + {$endif} + {$else} + {$ifdef BASM16} + {$i enc_fa16.inc} + {$else} + {$i enc_fp16.inc} + {$endif} + {$endif} +{$endif} + + +{---------------------------------------------------------------------------} +function AES_Init_Encr({$ifdef CONST} const {$else} var {$endif} Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} +begin + AES_Init_Encr := AES_Init(Key, KeyBits, ctx); +end; + + + +{$ifdef AES_ComprTab} +begin + {$ifdef AES_Diag} + TCe_Diag := __P2I(@TCe) and 15; + {$endif} + {$ifdef AES_Encr_DummyAlign} + if TCeDummy<>0 then ; + {$endif} +{$endif} + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_gcm.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_gcm.pas new file mode 100644 index 00000000..67ddb955 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_gcm.pas @@ -0,0 +1,1017 @@ +unit AES_GCM; + +(************************************************************************* + + DESCRIPTION : AES GCM mode functions + + REQUIREMENTS : TP5-7, D1-D7/D9-D12/D17-D18/D25S, FPC, VP, WDOSX + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + WARNING : GCM mode (as all CTR modes) demands that the same key / IV pair + is never reused for encryption. + + REFERENCES : [1] D. McGrew, J. Viega, The Galois/Counter Mode of Operation (GCM) + http://www.csrc.nist.gov/groups/ST/toolkit/BCM/documents/proposedmodes/gcm/gcm-revised-spec.pdf + [2] B. Gladman, source code archives aes-modes-src-23-07-09.zip and aes-modes-vs2008-07-10-08.zip + http://gladman.plushost.co.uk/oldsite/AES/index.php, source code archives + [3] M. Dworkin, Recommendation for Block Cipher Modes of Operation: Galois/Counter Mode (GCM) and GMAC + http://csrc.nist.gov/publications/nistpubs/800-38D/SP-800-38D.pdf + + REMARKS : This implementation uses a GCM version with 4KB table. + [A table-less version can be generated if gf_t4k is removed + and gf_mul_h simply uses gf_mul(a, ctx.ghash_h). + Using a 256 byte table is slower than a table-less version, + a 64KB table version is incompatible with 16-bit code.] + + See [3] for recommendations on IV and tag length + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 20.09.10 W.Ehrhardt Initial version: mul_x + 0.11 20.09.10 we Make4K_Table + 0.12 20.09.10 we AES_GCM_Init + 0.13 20.09.10 we gf_mul_h + 0.14 20.09.10 we AES_GCM_Reset_IV + 0.15 21.09.10 we basic gf_mul + 0.16 21.09.10 we AES_GCM_Final + 0.17 21.09.10 we AES_GCM_Encrypt + 0.18 21.09.10 we AES_GCM_Add_AAD + 0.19 21.09.10 we Fix quirk with byte-wise encryption + 0.20 21.09.10 we Fix quirk with IV_len=16 + 0.21 22.09.10 we AES_GCM_Decrypt + 0.22 22.09.10 we $ifdef GCM4KTab, improved gf_mul, mul_x + 0.23 22.09.10 we $ifdef inline_xorblock in gf_mul + 0.24 23.09.10 we word IV_Len, more argument checks + 0.25 23.09.10 we AES_GCM_Enc_Auth, AES_GCM_Dec_Veri + 0.26 24.09.10 we AES_Err_GCM_Auth_After_Final + 0.27 24.09.10 we Fix for aad_cnt >= 2^29 or txt_acnt >= 2^29 + 0.28 26.09.10 we 64 bit counter for aad and auth. text + 0.29 26.09.10 we use int64 if available + 0.30 02.07.12 we 64-bit adjustments + 0.31 21.11.12 we 64-bit fixes (use 32-bit not 16-bit code) + 0.32 31.08.15 we constant time compare in Internal_Dec_Veri + 0.33 08.08.17 we RB for CPUARM +**************************************************************************) + + +(*------------------------------------------------------------------------- + Pascal Implementation (C) Copyright 2010-2017 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +{$i STD.INC} + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr; + +type + TGCM_Tab4K = array[0..255] of TAESBlock; {64 KB gf_mul_h table } + +type + TBit64 = packed array[0..1] of longint; {64 bit counter } + +type + TAES_GCMContext = packed record + actx : TAESContext; {Basic AES context } + aad_ghv : TAESBlock; {ghash value AAD } + txt_ghv : TAESBlock; {ghash value ciphertext} + ghash_h : TAESBlock; {ghash H value } + gf_t4k : TGCM_Tab4K; {gf_mul_h table } + aad_cnt : TBit64; {processed AAD bytes } + atx_cnt : TBit64; {authent. text bytes } + y0_val : longint; {initial 32-bit ctr val} + end; + + +{$ifdef CONST} +function AES_GCM_Init(const Key; KeyBits: word; var ctx: TAES_GCMContext): integer; + {-Init context, calculate key-dependent GF(2^128) element H=E(K,0) and mul tables} + {$ifdef DLL} stdcall; {$endif} +{$else} +function AES_GCM_Init(var Key; KeyBits: word; var ctx: TAES_GCMContext): integer; + {-Init context, calculate key-dependent GF(2^128) element H=E(K,0) and gf_mul tables} +{$endif} + +function AES_GCM_Reset_IV(pIV: pointer; IV_len: word; var ctx: TAES_GCMContext): integer; + {-Reset: keep key but start new encryption with given IV} + {$ifdef DLL} stdcall; {$endif} + +function AES_GCM_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update auth data} + {$ifdef DLL} stdcall; {$endif} + +function AES_GCM_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CTR mode, update auth data} + {$ifdef DLL} stdcall; {$endif} + +function AES_GCM_Add_AAD(pAAD: pointer; aLen: longint; var ctx: TAES_GCMContext): integer; + {-Add additional authenticated data (will not be encrypted)} + {$ifdef DLL} stdcall; {$endif} + +function AES_GCM_Final(var tag: TAESBlock; var ctx: TAES_GCMContext): integer; + {-Compute GCM tag from context} + {$ifdef DLL} stdcall; {$endif} + +function AES_GCM_Enc_Auth(var tag: TAESBlock; {Tag record} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer; {ciphertext: address} + var ctx: TAES_GCMContext {context, will be cleared} + ): integer; + {-All-in-one call to encrypt/authenticate} + {$ifdef DLL} stdcall; {$endif} + +function AES_GCM_Dec_Veri( ptag: pointer; tLen: word; {Tag: address / length (0..16)} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer; {plaintext: address} + var ctx: TAES_GCMContext {context, will be cleared} + ): integer; + {-All-in-one call to decrypt/verify. Decryption is done only if ptag^ is verified} + {$ifdef DLL} stdcall; {$endif} + +{---------------------------------------------------------------------------} +{---------------------------------------------------------------------------} +{---------------------------------------------------------------------------} +{internal/testing} +procedure gf_mul_h(var a: TAESBlock; {$ifdef CONST}const{$else}var{$endif} ctx: TAES_GCMContext); + {-Multiply a by ctx.ghash_h in GF(2^128} + +procedure gf_mul(var a: TAESBlock; {$ifdef CONST}const{$else}var{$endif} b: TAESBlock); + {-multiply two GF(2**128) field elements, a := a*b} + + +implementation + +(* This implementation is based on Brian Gladman's source codes [2] which are + +--------------------------------------------------------------------------- + Copyright (c) 1998-2008, Brian Gladman, Worcester, UK. All rights reserved. + + LICENSE TERMS + + The redistribution and use of this software (with or without changes) + is allowed without the payment of fees or royalties provided that: + + 1. source code distributions include the above copyright notice, this + list of conditions and the following disclaimer; + + 2. binary distributions include the above copyright notice, this list + of conditions and the following disclaimer in their documentation; + + 3. the name of the copyright holder is not used to endorse products + built using this software without specific written permission. + + DISCLAIMER + + This software is provided 'as is' with no explicit or implied warranties + in respect of its properties, including, but not limited to, correctness + and/or fitness for purpose. +--------------------------------------------------------------------------- +*) + + +const + CTR_POS = 12; + BLK_MASK = AESBLKSIZE-1; + +const + gft_le: array[0..255] of word = ( {Table of 'carries' in mulx8 operation} + $0000,$c201,$8403,$4602,$0807,$ca06,$8c04,$4e05,$100e,$d20f,$940d,$560c,$1809,$da08,$9c0a,$5e0b, + $201c,$e21d,$a41f,$661e,$281b,$ea1a,$ac18,$6e19,$3012,$f213,$b411,$7610,$3815,$fa14,$bc16,$7e17, + $4038,$8239,$c43b,$063a,$483f,$8a3e,$cc3c,$0e3d,$5036,$9237,$d435,$1634,$5831,$9a30,$dc32,$1e33, + $6024,$a225,$e427,$2626,$6823,$aa22,$ec20,$2e21,$702a,$b22b,$f429,$3628,$782d,$ba2c,$fc2e,$3e2f, + $8070,$4271,$0473,$c672,$8877,$4a76,$0c74,$ce75,$907e,$527f,$147d,$d67c,$9879,$5a78,$1c7a,$de7b, + $a06c,$626d,$246f,$e66e,$a86b,$6a6a,$2c68,$ee69,$b062,$7263,$3461,$f660,$b865,$7a64,$3c66,$fe67, + $c048,$0249,$444b,$864a,$c84f,$0a4e,$4c4c,$8e4d,$d046,$1247,$5445,$9644,$d841,$1a40,$5c42,$9e43, + $e054,$2255,$6457,$a656,$e853,$2a52,$6c50,$ae51,$f05a,$325b,$7459,$b658,$f85d,$3a5c,$7c5e,$be5f, + $00e1,$c2e0,$84e2,$46e3,$08e6,$cae7,$8ce5,$4ee4,$10ef,$d2ee,$94ec,$56ed,$18e8,$dae9,$9ceb,$5eea, + $20fd,$e2fc,$a4fe,$66ff,$28fa,$eafb,$acf9,$6ef8,$30f3,$f2f2,$b4f0,$76f1,$38f4,$faf5,$bcf7,$7ef6, + $40d9,$82d8,$c4da,$06db,$48de,$8adf,$ccdd,$0edc,$50d7,$92d6,$d4d4,$16d5,$58d0,$9ad1,$dcd3,$1ed2, + $60c5,$a2c4,$e4c6,$26c7,$68c2,$aac3,$ecc1,$2ec0,$70cb,$b2ca,$f4c8,$36c9,$78cc,$bacd,$fccf,$3ece, + $8091,$4290,$0492,$c693,$8896,$4a97,$0c95,$ce94,$909f,$529e,$149c,$d69d,$9898,$5a99,$1c9b,$de9a, + $a08d,$628c,$248e,$e68f,$a88a,$6a8b,$2c89,$ee88,$b083,$7282,$3480,$f681,$b884,$7a85,$3c87,$fe86, + $c0a9,$02a8,$44aa,$86ab,$c8ae,$0aaf,$4cad,$8eac,$d0a7,$12a6,$54a4,$96a5,$d8a0,$1aa1,$5ca3,$9ea2, + $e0b5,$22b4,$64b6,$a6b7,$e8b2,$2ab3,$6cb1,$aeb0,$f0bb,$32ba,$74b8,$b6b9,$f8bc,$3abd,$7cbf,$bebe); + + +{$ifndef BIT16} +{32/64-bit code} + +{$ifdef BIT64} +{---------------------------------------------------------------------------} +function RB(A: longint): longint; {$ifdef HAS_INLINE} inline; {$endif} + {-reverse byte order in longint} +begin + RB := ((A and $FF) shl 24) or ((A and $FF00) shl 8) or ((A and $FF0000) shr 8) or ((A and longint($FF000000)) shr 24); +end; +{$else} +{$ifdef CPUARM} +{---------------------------------------------------------------------------} +function RB(A: longint): longint; {$ifdef HAS_INLINE} inline; {$endif} + {-reverse byte order in longint} +begin + RB := ((A and $FF) shl 24) or ((A and $FF00) shl 8) or ((A and $FF0000) shr 8) or ((A and longint($FF000000)) shr 24); +end; +{$else} +{---------------------------------------------------------------------------} +function RB(A: longint): longint; assembler; {&frame-} + {-reverse byte order in longint} +asm + {$ifdef LoadArgs} + mov eax,[A] + {$endif} + xchg al,ah + rol eax,16 + xchg al,ah +end; +{$endif} +{$endif} + + +{$ifndef HAS_INT64} +{---------------------------------------------------------------------------} +procedure Inc64(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} +begin + asm + mov edx, wlo + mov ecx, whi + mov eax, Blen + add [edx], eax + adc dword ptr [ecx], 0 + end; +end; +{$endif} + + +{---------------------------------------------------------------------------} +procedure mul_x(var a: TAESBlock; const b: TAESBlock); + {-Multiply a = b*x in GF(2^128)} +var + t: longint; + y: TWA4 absolute b; +const + MASK_80 = longint($80808080); + MASK_7F = longint($7f7f7f7f); +begin + t := gft_le[(y[3] shr 17) and MASK_80]; + TWA4(a)[3] := ((y[3] shr 1) and MASK_7F) or (((y[3] shl 15) or (y[2] shr 17)) and MASK_80); + TWA4(a)[2] := ((y[2] shr 1) and MASK_7F) or (((y[2] shl 15) or (y[1] shr 17)) and MASK_80); + TWA4(a)[1] := ((y[1] shr 1) and MASK_7F) or (((y[1] shl 15) or (y[0] shr 17)) and MASK_80); + TWA4(a)[0] := (((y[0] shr 1) and MASK_7F) or ( (y[0] shl 15) and MASK_80)) xor t; +end; + +{$else} + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; + {-reverse byte order in longint} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $86/$C6/ { xchg dh,al} + $86/$E2); { xchg dl,ah} + + +{---------------------------------------------------------------------------} +procedure Inc64(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} +inline( + $58/ {pop ax } + $5A/ {pop dx } + $5B/ {pop bx } + $07/ {pop es } + $26/$01/$07/ {add es:[bx],ax } + $26/$11/$57/$02/ {adc es:[bx+02],dx} + $5B/ {pop bx } + $07/ {pop es } + $26/$83/$17/$00/ {adc es:[bx],0 } + $26/$83/$57/$02/$00);{adc es:[bx+02],0 } + + +{---------------------------------------------------------------------------} +procedure mul_x(var a: TAESBlock; {$ifdef CONST}const{$else}var{$endif} b: TAESBlock); + {-Multiply a = b*x in GF(2^128)} +var + x: TWA4; + t: longint; +const + hibit : array[0..1] of longint = (0, longint($80000000)); + gf_poly: array[0..1] of longint = (0, longint($e1000000)); +begin + x[0] := RB(TWA4(b)[0]); + x[1] := RB(TWA4(b)[1]); + x[2] := RB(TWA4(b)[2]); + x[3] := RB(TWA4(b)[3]); + t := gf_poly[x[3] and 1]; + x[3] := (x[3] shr 1) or hibit[x[2] and 1]; + x[2] := (x[2] shr 1) or hibit[x[1] and 1]; + x[1] := (x[1] shr 1) or hibit[x[0] and 1]; + TWA4(a)[0] := RB((x[0] shr 1) xor t); + TWA4(a)[1] := RB(x[1]); + TWA4(a)[2] := RB(x[2]); + TWA4(a)[3] := RB(x[3]); +end; +{$endif} + + +{Note: At least on my machine inlining AES_Xorblock in gf_mul is slower for} +{32-bit Delphi! The conditional define can be adjusted on other machines,} +{$ifdef DELPHI} + {$undef inline_xorblock} +{$else} + {$define inline_xorblock} +{$endif} + +{---------------------------------------------------------------------------} +procedure gf_mul(var a: TAESBlock; {$ifdef CONST}const{$else}var{$endif} b: TAESBlock); + {-multiply two GF(2**128) field elements, a := a*b} +var + p: array[0..7] of TAESBlock; + r: TAESBlock; + x: TWA4 absolute r; +{$ifndef BIT16} + t: longint; +{$else} + w: word; +{$endif} +{$ifdef inline_xorblock} + j: integer; +{$endif} + i: integer; + c: byte; +begin + p[0] := b; + for i:=1 to 7 do mul_x(p[i], p[i-1]); + fillchar(r,sizeof(r),0); + for i:=0 to 15 do begin + c := a[15-i]; + if i>0 then begin + {this is the inline code of the mul_x8 procedure} + {$ifndef BIT16} + t := gft_le[x[3] shr 24]; + x[3] := ((x[3] shl 8) or (x[2] shr 24)); + x[2] := ((x[2] shl 8) or (x[1] shr 24)); + x[1] := ((x[1] shl 8) or (x[0] shr 24)); + x[0] := ((x[0] shl 8) xor t); + {$else} + w := gft_le[r[15]]; + r[15] := r[14]; + r[14] := r[13]; + r[13] := r[12]; + r[12] := r[11]; + r[11] := r[10]; + r[10] := r[09]; + r[09] := r[08]; + r[08] := r[07]; + r[07] := r[06]; + r[06] := r[05]; + r[05] := r[04]; + r[04] := r[03]; + r[03] := r[02]; + r[02] := r[01]; + r[01] := r[00] xor hi(w); + r[00] := byte(w); + {$endif} + end; + {$ifdef inline_xorblock} + for j:=0 to 7 do begin + if c and ($80 shr j) <> 0 then begin + x[3] := x[3] xor TWA4(p[j])[3]; + x[2] := x[2] xor TWA4(p[j])[2]; + x[1] := x[1] xor TWA4(p[j])[1]; + x[0] := x[0] xor TWA4(p[j])[0]; + end; + end; + {$else} + if c and $80 <> 0 then AES_Xorblock(r,p[0],r); + if c and $40 <> 0 then AES_Xorblock(r,p[1],r); + if c and $20 <> 0 then AES_Xorblock(r,p[2],r); + if c and $10 <> 0 then AES_Xorblock(r,p[3],r); + if c and $08 <> 0 then AES_Xorblock(r,p[4],r); + if c and $04 <> 0 then AES_Xorblock(r,p[5],r); + if c and $02 <> 0 then AES_Xorblock(r,p[6],r); + if c and $01 <> 0 then AES_Xorblock(r,p[7],r); + {$endif} + end; + a := r; +end; + + +{---------------------------------------------------------------------------} +procedure Make4K_Table(var ctx: TAES_GCMContext); + {-Build 4K gf_mul table from ctx.ghash_h. Assumes gf_t4k is zero-filled} +var + j,k: integer; +begin + with ctx do begin + gf_t4k[128] := ghash_h; + j := 64; + while j>0 do begin + mul_x(gf_t4k[j], gf_t4k[j+j]); + j := j shr 1; + end; + j := 2; + while j<256 do begin + for k:=1 to j-1 do aes_xorblock(gf_t4k[k], gf_t4k[j], gf_t4k[j+k]); + j := j+j; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure gf_mul_h(var a: TAESBlock; {$ifdef CONST}const{$else}var{$endif} ctx: TAES_GCMContext); + {-Multiply a by ctx.ghash_h in GF(2^128} +var + r: TAESBlock; + x: TWA4 absolute r; + i: integer; + t: longint; + p: pointer; +begin + with ctx do begin + r := gf_t4k[a[15]]; + for i:=14 downto 0 do begin + p := @gf_t4k[a[i]]; + t := gft_le[x[3] shr 24]; + {preform mul_x8 and xor in pre-computed table entries} + {$ifndef BIT16} + x[3] := ((x[3] shl 8) or (x[2] shr 24)) xor TWA4(p^)[3]; + x[2] := ((x[2] shl 8) or (x[1] shr 24)) xor TWA4(p^)[2]; + x[1] := ((x[1] shl 8) or (x[0] shr 24)) xor TWA4(p^)[1]; + x[0] := ((x[0] shl 8) xor t) xor TWA4(p^)[0]; + {$else} + {$ifdef BASM16} + asm + les di, [p] + db $66; mov bx, word ptr x[3*4] + db $66; mov cx, word ptr x[2*4] + db $66; mov dx, word ptr x[1*4] + db $66; mov si, word ptr x[0] + + db $66; mov ax, cx + db $66; shr ax, 24 + db $66; shl bx, 8 + db $66; or ax, bx + db $66; xor ax, es:[di+12] + db $66; mov word ptr x[3*4],ax + + db $66; mov ax, dx + db $66; shr ax, 24 + db $66; shl cx, 8 + db $66; or ax, cx + db $66; xor ax, es:[di+8] + db $66; mov word ptr x[2*4],ax + + db $66; mov ax, si + db $66; shr ax, 24 + db $66; shl dx, 8 + db $66; or ax, dx + db $66; xor ax, es:[di+4] + db $66; mov word ptr x[1*4],ax + + db $66; shl si, 8 + db $66; xor si, word ptr t + db $66; xor si, es:[di] + db $66; mov word ptr x[0],si + end; + {$else} + t := gft_le[r[15]]; + r[15] := r[14]; + r[14] := r[13]; + r[13] := r[12]; + r[12] := r[11]; + r[11] := r[10]; + r[10] := r[09]; + r[09] := r[08]; + r[08] := r[07]; + r[07] := r[06]; + r[06] := r[05]; + r[05] := r[04]; + r[04] := r[03]; + r[03] := r[02]; + r[02] := r[01]; + r[01] := r[00] xor TBA4(t)[1]; + r[00] := byte(t); + x[3] := x[3] xor TWA4(p^)[3]; + x[2] := x[2] xor TWA4(p^)[2]; + x[1] := x[1] xor TWA4(p^)[1]; + x[0] := x[0] xor TWA4(p^)[0]; + {$endif} + {$endif} + end; + a := r; + end; +end; + + +(* +{Use this for table-less versions} +{---------------------------------------------------------------------------} +procedure gf_mul_h(var a: TAESBlock; {$ifdef CONST}const{$else}var{$endif} ctx: TAES_GCMContext); + {-Multiply a by ctx.ghash_h in GF(2^128} +begin + {Simply compute a*ghash_h, pre-computing the p-array for ghash_h} + {does not hurt, but does not give significant speed improvments.} + gf_mul(a, ctx.ghash_h); +end; +*) + +{---------------------------------------------------------------------------} +function AES_GCM_Init({$ifdef CONST}const{$else}var{$endif} Key; KeyBits: word; var ctx: TAES_GCMContext): integer; + {-Init context, calculate key-dependent GF(2^128) element H=E(K,0) and gf_mul tables} +var + err: integer; +begin + fillchar(ctx, sizeof(ctx), 0); + with ctx do begin + err := AES_Init_Encr(Key, KeyBits, actx); + if err=0 then begin + AES_Encrypt(actx, ghash_h, ghash_h); + Make4K_Table(ctx); + end; + end; + AES_GCM_Init := err; +end; + + +{---------------------------------------------------------------------------} +procedure GCM_IncCtr(var x: TAESBlock); + {-GCM IncProc, only 32 LSB bits are changed (big-endian notation)} +var + j: integer; +begin + for j:=15 downto CTR_POS do begin + if x[j]=$FF then x[j] := 0 + else begin + inc(x[j]); + exit; + end; + end; +end; + + +{---------------------------------------------------------------------------} +function AES_GCM_Reset_IV(pIV: pointer; IV_len: word; var ctx: TAES_GCMContext): integer; + {-Reset: keep key but start new encryption with given IV} +var + n_pos: longint; + i: integer; +begin + AES_GCM_Reset_IV := 0; + + if (pIV=nil) and (IV_Len<>0) then begin + AES_GCM_Reset_IV := AES_Err_NIL_Pointer; + exit; + end; + + with ctx do begin + {compute initial IV counter value Y0} + if IV_len=CTR_POS then begin + {if bitlen(IV)=96 then Y0=IV||1} + move(pIV^, actx.IV, CTR_POS); + TWA4(actx.IV)[3] := $01000000; {big-endian 32-bit 1} + end + else begin + {Y0 = GHASH(IV, H)} + n_pos := IV_len; + fillchar(actx.IV, sizeof(actx.IV),0); + while n_pos >= AESBLKSIZE do begin + AES_Xorblock(actx.IV, PAESBlock(pIV)^, actx.IV); + inc(Ptr2Inc(pIV), AESBLKSIZE); + dec(n_pos, AESBLKSIZE); + gf_mul_h(actx.IV, ctx); + end; + if n_pos>0 then begin + for i:=0 to n_pos-1 do begin + actx.IV[i] := actx.IV[i] xor pByte(pIV)^; + inc(Ptr2Inc(pIV)); + end; + gf_mul_h(actx.IV, ctx); + end; + n_pos := longint(IV_len) shl 3; + i := 15; + while n_pos>0 do begin + actx.IV[i] := actx.IV[i] xor byte(n_pos); + n_pos := n_pos shr 8; + dec(i); + end; + gf_mul_h(actx.IV, ctx); + end; + {save initial 32-bit ctr val for final operation} + y0_val := TWA4(actx.IV)[3]; + {Reset other data} + fillchar(aad_ghv, sizeof(aad_ghv),0); + fillchar(txt_ghv, sizeof(txt_ghv),0); + actx.Flag := 0; + actx.bLen := 0; + aad_cnt[0] := 0; + aad_cnt[1] := 0; + atx_cnt[0] := 0; + atx_cnt[1] := 0; + end; +end; + + +{---------------------------------------------------------------------------} +function AES_GCM_Final(var tag: TAESBlock; var ctx: TAES_GCMContext): integer; + {-Compute GCM tag from context} +var + tbuf: TAESBlock; + x: TWA4 absolute tbuf; + {$ifdef HAS_INT64} + ln: int64; + {$else} + ln: TBit64; + {$endif} +begin + with ctx do begin + if actx.Flag and $02 <> 0 then begin + AES_GCM_Final := AES_Err_GCM_Auth_After_Final; + exit; + end; + actx.Flag := actx.Flag or $02; + {compute GHASH(H, AAD, ctp)} + gf_mul_h(aad_ghv, ctx); + gf_mul_h(txt_ghv, ctx); + + {Compute len(AAD) || len(ctp) with each len as 64-bit big-endian } + {Note: Tag calculation with Brian Gladman's original code will be} + {incorrect if either of the following shifts produces carries: } + {(ctx->txt_acnt << 3) or (ctx->hdr_cnt << 3)} + + {$ifdef HAS_INT64} + {Gladman's code with 64-bit counters} + ln := (int64(atx_cnt) + AESBLKSIZE - 1) div AESBLKSIZE; + if (int64(aad_cnt)>0) and (ln<>0) then begin + tbuf := ghash_h; + while ln<>0 do begin + if odd(ln) then gf_mul(aad_ghv, tbuf); + ln := ln shr 1; + if ln<>0 then gf_mul(tbuf, tbuf); + end; + end; + {$else} + {equivalent code for compilers without int64} + ln[0] := atx_cnt[0]; + ln[1] := atx_cnt[1]; + Inc64(ln[1], ln[0], AESBLKSIZE - 1); + ln[0] := (ln[0] shr 4) or ((ln[1] and $F) shl 28); + ln[1] := ln[1] shr 4; + if (aad_cnt[0] or aad_cnt[1] <> 0) and (ln[0] or ln[1] <> 0) then begin + tbuf := ghash_h; + while (ln[0] or ln[1])<>0 do begin + if odd(ln[0]) then gf_mul(aad_ghv, tbuf); + ln[0] := ln[0] shr 1; + if odd(ln[1]) then ln[0] := ln[0] or longint($80000000); + ln[1] := ln[1] shr 1; + if ln[0] or ln[1] <> 0 then gf_mul(tbuf, tbuf); + end; + end; + {$endif} + x[0] := RB((aad_cnt[0] shr 29) or (aad_cnt[1] shl 3)); + x[1] := RB((aad_cnt[0] shl 3)); + x[2] := RB((atx_cnt[0] shr 29) or (atx_cnt[1] shl 3)); + x[3] := RB((atx_cnt[0] shl 3)); + + AES_Xorblock(tbuf, txt_ghv, tbuf); + AES_Xorblock(aad_ghv, tbuf, aad_ghv); + gf_mul_h(aad_ghv, ctx); + {compute E(K,Y0)} + tbuf := actx.IV; + x[3] := y0_val; + AES_Encrypt(actx, tbuf, tbuf); + {tag = GHASH(H, AAD, ctp) xor E(K,Y0)} + AES_Xorblock(aad_ghv, tbuf, tag); + end; + AES_GCM_Final := 0; +end; + + +{---------------------------------------------------------------------------} +function crypt_data(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; + {-Internal: en/decrypt ILen byte from ptp to ctp} +var + cnt: longint; + b_pos: integer; +begin + crypt_data := 0; + if ILen<=0 then exit; + cnt := 0; + with ctx do begin + b_pos := actx.bLen; + if b_pos=0 then b_pos := AESBLKSIZE + else begin + while (cnt < ILen) and (b_pos < AESBLKSIZE) do begin + pByte(ctp)^ := pByte(ptp)^ xor actx.buf[b_pos]; + inc(b_pos); + inc(Ptr2Inc(ptp)); + inc(Ptr2Inc(ctp)); + inc(cnt); + end; + end; + while cnt + AESBLKSIZE <= ILen do begin + GCM_IncCtr(actx.IV); + AES_Encrypt(actx, actx.IV, actx.buf); + AES_XorBlock(PAESBlock(ptp)^, actx.buf, PAESBlock(ctp)^); + inc(Ptr2Inc(ptp), AESBLKSIZE); + inc(Ptr2Inc(ctp), AESBLKSIZE); + inc(cnt, AESBLKSIZE); + end; + while cnt < ILen do begin + if b_pos=AESBLKSIZE then begin + GCM_IncCtr(actx.IV); + AES_Encrypt(actx, actx.IV, actx.buf); + b_pos := 0; + end; + pByte(ctp)^ := actx.buf[b_pos] xor pByte(ptp)^; + inc(b_pos); + inc(Ptr2Inc(ptp)); + inc(Ptr2Inc(ctp)); + inc(cnt); + end; + actx.bLen := (actx.bLen + cnt) and BLK_MASK;; + end; +end; + + +{---------------------------------------------------------------------------} +function auth_data(ctp: pointer; ILen: longint; var ctx: TAES_GCMContext): integer; + {-Internal: add ILen bytes from cipher text to auth ghash} +var + cnt: longint; + b_pos: integer; +begin + auth_data := 0; + if ILen<=0 then exit; + cnt := 0; + with ctx do begin + if actx.Flag and $02 <> 0 then begin + auth_data := AES_Err_GCM_Auth_After_Final; + exit; + end; + b_pos := atx_cnt[0] and BLK_MASK; + if (b_pos=0) and (atx_cnt[0] or atx_cnt[1] <> 0) then gf_mul_h(txt_ghv, ctx); + while (cnt < ILen) and (b_pos < AESBLKSIZE) do begin + txt_ghv[b_pos] := txt_ghv[b_pos] xor pByte(ctp)^; + inc(b_pos); + inc(Ptr2Inc(ctp)); + inc(cnt); + end; + while cnt + AESBLKSIZE <= ILen do begin + gf_mul_h(txt_ghv, ctx); + AES_Xorblock(txt_ghv, PAESBlock(ctp)^, txt_ghv); + inc(Ptr2Inc(ctp), AESBLKSIZE); + inc(cnt, AESBLKSIZE); + end; + while cnt < ILen do begin + if b_pos=AESBLKSIZE then begin + gf_mul_h(txt_ghv, ctx); + b_pos := 0; + end; + txt_ghv[b_pos] := txt_ghv[b_pos] xor pByte(ctp)^; + inc(b_pos); + inc(Ptr2Inc(ctp)); + inc(cnt); + end; + {$ifdef HAS_INT64} + Inc(int64(atx_cnt), cnt); + {$else} + Inc64(atx_cnt[1], atx_cnt[0],cnt); + {$endif} + end; +end; + + +{---------------------------------------------------------------------------} +function AES_GCM_Add_AAD(pAAD: pointer; aLen: longint; var ctx: TAES_GCMContext): integer; + {-Add additional authenticated data (will not be encrypted)} +var + cnt: longint; + b_pos: integer; +begin + AES_GCM_Add_AAD := 0; + if aLen <= 0 then exit; + + if pAAD=nil then begin + AES_GCM_Add_AAD := AES_Err_NIL_Pointer; + exit; + end; + + {$ifdef BIT16} + if (aLen>$FFFF) or (ofs(pAAD^)+aLen>$FFFF) then begin + AES_GCM_Add_AAD := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + cnt := 0; + with ctx do begin + if actx.Flag and $02 <> 0 then begin + AES_GCM_Add_AAD := AES_Err_GCM_Auth_After_Final; + exit; + end; + b_pos := aad_cnt[0] and BLK_MASK; + if (b_pos=0) and (aad_cnt[0] or aad_cnt[1] <> 0) then gf_mul_h(aad_ghv, ctx); + while (cnt < aLen) and (b_pos < AESBLKSIZE) do begin + aad_ghv[b_pos] := aad_ghv[b_pos] xor pByte(pAAD)^; + inc(b_pos); + inc(Ptr2Inc(pAAD)); + inc(cnt); + end; + while cnt + AESBLKSIZE <= aLen do begin + gf_mul_h(aad_ghv, ctx); + AES_Xorblock(aad_ghv, PAESBlock(pAAD)^, aad_ghv); + inc(Ptr2Inc(pAAD), AESBLKSIZE); + inc(cnt, AESBLKSIZE); + end; + while cnt < aLen do begin + if b_pos=AESBLKSIZE then begin + gf_mul_h(aad_ghv, ctx); + b_pos := 0; + end; + aad_ghv[b_pos] := aad_ghv[b_pos] xor pByte(pAAD)^; + inc(b_pos); + inc(Ptr2Inc(pAAD)); + inc(cnt); + end; + {$ifdef HAS_INT64} + Inc(int64(aad_cnt),cnt); + {$else} + Inc64(aad_cnt[1],aad_cnt[0],cnt); + {$endif} + end; +end; + + +{---------------------------------------------------------------------------} +function AES_GCM_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update auth data} +var + err: integer; +begin + if ILen <= 0 then begin + AES_GCM_Encrypt := 0; + exit; + end; + if (ptp=nil) or (ctp=nil) then begin + AES_GCM_Encrypt := AES_Err_NIL_Pointer; + exit; + end; + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_GCM_Encrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + err := crypt_data(ptp, ctp, ILen, ctx); + if err=0 then err := auth_data(ctp, ILen, ctx); + AES_GCM_Encrypt := err; +end; + + +{---------------------------------------------------------------------------} +function AES_GCM_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CTR mode, update auth data} +var + err: integer; +begin + if ILen <= 0 then begin + AES_GCM_Decrypt := 0; + exit; + end; + if (ptp=nil) or (ctp=nil) then begin + AES_GCM_Decrypt := AES_Err_NIL_Pointer; + exit; + end; + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_GCM_Decrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + err := auth_data(ctp, ILen, ctx); + if err=0 then err := crypt_data(ctp, ptp, ILen, ctx); + AES_GCM_Decrypt := err; +end; + + +{---------------------------------------------------------------------------} +function Internal_Dec_Veri(var ctx: TAES_GCMContext; ptag: pointer; tLen: word; + ctp: pointer; cLen: longint; ptp: pointer): integer; + {-calculate and verify tLen bytes of ptag^, decrypt if OK} +var + err,i: integer; + diff: byte; + tag: TAESBlock; +begin + if cLen <= 0 then cLen := 0; + if cLen>0 then begin + if (ptp=nil) or (ctp=nil) then begin + Internal_Dec_Veri := AES_Err_NIL_Pointer; + exit; + end; + {$ifdef BIT16} + if (ofs(ptp^)+cLen>$FFFF) or (ofs(ctp^)+cLen>$FFFF) then begin + Internal_Dec_Veri := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + end; + err := auth_data(ctp, cLen, ctx); + if err=0 then begin + {Compute/verify tag before doing decryption} + err := AES_GCM_Final(tag, ctx); + if err=0 then begin + diff :=0; + for i:=0 to pred(tLen) do begin + diff := diff or (pByte(ptag)^ xor tag[i]); + inc(Ptr2Inc(ptag)); + end; + err := (((integer(diff)-1) shr 8) and 1)-1; {0 compare, -1 otherwise} + err := err and AES_Err_GCM_Verify_Tag; + end; + if err=0 then err := crypt_data(ctp, ptp, cLen, ctx); + end; + Internal_Dec_Veri := err; +end; + + +{---------------------------------------------------------------------------} +function AES_GCM_Enc_Auth(var tag: TAESBlock; {Tag record} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer; {ciphertext: address} + var ctx: TAES_GCMContext {context, will be cleared} + ): integer; + {-All-in-one call to encrypt/authenticate} +var + err: integer; +begin + err := AES_GCM_Init(Key, KBits, ctx); + if err=0 then err := AES_GCM_Reset_IV(pIV, IV_len, ctx); + if err=0 then err := AES_GCM_Add_AAD(pAAD, aLen, ctx); + if err=0 then err := AES_GCM_Encrypt(ptp, ctp, pLen, ctx); + if err=0 then err := AES_GCM_Final(tag, ctx); + fillchar(ctx, sizeof(ctx), 0); + AES_GCM_Enc_Auth := err; +end; + + +{---------------------------------------------------------------------------} +function AES_GCM_Dec_Veri( ptag: pointer; tLen: word; {Tag: address / length (0..16)} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer; {plaintext: address} + var ctx: TAES_GCMContext {context, will be cleared} + ): integer; + {-All-in-one call to decrypt/verify. Decryption is done only if ptag^ is verified} +var + err: integer; +begin + err := AES_GCM_Init(Key, KBits, ctx); + if err=0 then err := AES_GCM_Reset_IV(pIV, IV_len, ctx); + if err=0 then err := AES_GCM_Add_AAD(pAAD, aLen, ctx); + if err=0 then err := Internal_Dec_Veri(ctx,ptag,tLen,ctp,cLen,ptp); + fillchar(ctx, sizeof(ctx), 0); + AES_GCM_Dec_Veri := err; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_intf.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_intf.pas new file mode 100644 index 00000000..e2ad6496 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_intf.pas @@ -0,0 +1,519 @@ +unit AES_INTF; + +(************************************************************************* + + DESCRIPTION : Interface unit for AES_DLL + + REQUIREMENTS : D2-D7/D9-D10/D12, FPC + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 02.07.04 W.Ehrhardt Initial version + 0.11 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.12 01.12.04 we AES_Err_Data_After_Short_Block + 0.23 01.12.04 we AES_ prefix for CTR increment routines + 0.24 24.12.04 we AES_Get/SetFastInit + 0.25 09.07.06 we CMAC, updated OMAC, checked: D9-D10 + 0.26 14.06.07 we Type TAES_EAXContext + 0.27 16.06.07 we AES_CPRF128 + 0.28 29.09.07 we AES_XTS + 0.29 25.12.07 we AES_CFB8 + 0.30 20.07.08 we All-in-one functions AES_EAX_Enc_Auth/AES_EAX_Dec_Veri + 0.31 02.08.08 we Removed ctx parameter in AES_EAX_Enc_Auth/AES_EAX_Dec_Veri + 0.32 21.05.09 we AES_CCM + 0.33 05.07.09 we external 'aes_dll.dll' + 0.34 06.07.09 we AES_DLL_Version returns PAnsiChar + 0.35 22.06.10 we AES_CTR_Seek, AES_CTR_Seek64 + 0.36 27.07.10 we Longint ILen, AES_Err_Invalid_16Bit_Length + 0.37 28.07.10 we Removed OMAC/CMAC XL versions + 0.38 31.07.10 we AES_CTR_Seek via aes_seek.inc + 0.38 27.09.10 we AES_GCM +**************************************************************************) + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + +interface + +const + AES_Err_Invalid_Key_Size = -1; {Key size <> 128, 192, or 256 Bits} + AES_Err_Invalid_Mode = -2; {Encr/Decr with Init for Decr/Encr} + AES_Err_Invalid_Length = -3; {No full block for cipher stealing} + AES_Err_Data_After_Short_Block = -4; {Short block must be last} + AES_Err_MultipleIncProcs = -5; {More than one IncProc Setting } + AES_Err_NIL_Pointer = -6; {nil pointer to block with nonzero length} + AES_Err_EAX_Inv_Text_Length = -7; {More than 64K text length in EAX all-in-one for 16 Bit} + AES_Err_EAX_Inv_TAG_Length = -8; {EAX all-in-one tag length not 0..16} + AES_Err_EAX_Verify_Tag = -9; {EAX all-in-one tag does not compare} + AES_Err_CCM_Hdr_length = -10; {CCM header length >= $FF00} + AES_Err_CCM_Nonce_length = -11; {CCM nonce length < 7 or > 13} + AES_Err_CCM_Tag_length = -12; {CCM tag length not in [4,6,8,19,12,14,16]} + AES_Err_CCM_Verify_Tag = -13; {Computed CCM tag does not compare} + AES_Err_CCM_Text_length = -14; {16 bit plain/cipher text length to large} + AES_Err_CTR_SeekOffset = -15; {Negative offset in AES_CTR_Seek} + AES_Err_GCM_Verify_Tag = -17; {GCM all-in-one tag does not compare} + AES_Err_GCM_Auth_After_Final = -18; {Auth after final or multiple finals} + AES_Err_Invalid_16Bit_Length = -20; {BaseAddr + length > $FFFF for 16 bit code} + +const + AESMaxRounds = 14; + +type + TAESBlock = packed array[0..15] of byte; + PAESBlock = ^TAESBlock; + TKeyArray = packed array[0..AESMaxRounds] of TAESBlock; + TIncProc = procedure(var CTR: TAESBlock); {$ifdef USEDLL} stdcall; {$endif} + {user supplied IncCTR proc} + TAESContext = packed record + RK : TKeyArray; {Key (encr. or decr.) } + IV : TAESBlock; {IV or CTR } + buf : TAESBlock; {Work buffer } + bLen : word; {Bytes used in buf } + Rounds : word; {Number of rounds } + KeyBits : word; {Number of bits in key } + Decrypt : byte; {<>0 if decrypting key } + Flag : byte; {Bit 1: Short block } + IncProc : TIncProc; {Increment proc CTR-Mode} + end; + +const + AESBLKSIZE = sizeof(TAESBlock); + +type + TAES_EAXContext = packed record + HdrOMAC : TAESContext; {Hdr OMAC1 context} + MsgOMAC : TAESContext; {Msg OMAC1 context} + ctr_ctx : TAESContext; {Msg AESCTR context} + NonceTag: TAESBlock; {nonce tag } + tagsize : word; {tag size (unused) } + flags : word; {ctx flags (unused)} + end; + + +type + TAES_XTSContext = packed record + main : TAESContext; {Main context} + tweak: TAESContext; {Tweak context} + end; + + +type + TGCM_Tab4K = array[0..255] of TAESBlock; {64 KB gf_mul_h table } + +type + TBit64 = packed array[0..1] of longint; {64 bit counter } + +type + TAES_GCMContext = packed record + actx : TAESContext; {Basic AES context } + aad_ghv : TAESBlock; {ghash value AAD } + txt_ghv : TAESBlock; {ghash value ciphertext} + ghash_h : TAESBlock; {ghash H value } + gf_t4k : TGCM_Tab4K; {gf_mul_h table } + aad_cnt : TBit64; {processed AAD bytes } + atx_cnt : TBit64; {authent. text bytes } + y0_val : longint; {initial 32-bit ctr val} + end; + + + +function AES_DLL_Version: PAnsiChar; +stdcall; external 'aes_dll.dll' name 'AES_DLL_Version'; + {-Return DLL version as PAnsiChar} + + + +procedure AES_XorBlock(const B1, B2: TAESBlock; var B3: TAESBlock); +stdcall; external 'aes_dll.dll' name 'AES_XorBlock'; + {-xor two blocks, result in third} + +function AES_Init(const Key; KeyBits: word; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_Init'; + {-AES key expansion, error if invalid key size} + +procedure AES_SetFastInit(value: boolean); +stdcall; external 'aes_dll.dll' name 'AES_SetFastInit'; + {-set FastInit variable} + +function AES_GetFastInit: boolean; +stdcall; external 'aes_dll.dll' name 'AES_GetFastInit'; + {-Returns FastInit variable} + + + +function AES_Init_Encr(const Key; KeyBits: word; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_Init_Encr'; + {-AES key expansion, error if invalid key size} + +procedure AES_Encrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); +stdcall; external 'aes_dll.dll' name 'AES_Encrypt'; + {-encrypt one block, not checked: key must be encryption key} + + + +function AES_ECB_Init_Encr(const Key; KeyBits: word; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_ECB_Init_Encr'; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_ECB_Init_Decr(const Key; KeyBits: word; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_ECB_Init_Decr'; + {-AES key expansion, error if invalid key size, encrypt IV} + + + +function AES_ECB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_ECB_Encrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in ECB mode} + +function AES_ECB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_ECB_Decrypt'; + {-Decrypt ILen bytes from ctp^ to ptp^ in ECB mode} + + + +function AES_Init_Decr(const Key; KeyBits: word; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_Init_Decr'; + {-AES key expansion, InvMixColumn(Key) for Decypt, error if invalid key size} + +procedure AES_Decrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); +stdcall; external 'aes_dll.dll' name 'AES_Decrypt'; + {-decrypt one block (in ECB mode)} + + + +function AES_CBC_Init_Encr(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CBC_Init_Encr'; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_CBC_Init_Decr(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CBC_Init_Decr'; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_CBC_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CBC_Encrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in CBC mode} + +function AES_CBC_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CBC_Decrypt'; + {-Decrypt ILen bytes from ctp^ to ptp^ in CBC mode} + + + +function AES_CFB_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CFB_Init'; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_CFB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CFB_Encrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in CFB128 mode} + +function AES_CFB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CFB_Decrypt'; + {-Decrypt ILen bytes from ctp^ to ptp^ in CFB128 mode} + + + +function AES_CFB8_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CFB8_Init'; + {-AES key expansion, error if invalid key size, store IV} + +function AES_CFB8_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CFB8_Encrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in CFB8 mode} + +function AES_CFB8_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CFB8_Decrypt'; + {-Decrypt ILen bytes from ctp^ to ptp^ in CFB8 mode} + + + +function AES_OFB_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_OFB_Init'; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_OFB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_OFB_Encrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in OFB mode} + +function AES_OFB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_OFB_Decrypt'; + {-Decrypt ILen bytes from ctp^ to ptp^ in OFB mode} + + + +function AES_CTR_Init(const Key; KeyBits: word; const CTR: TAESBlock; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CTR_Init'; + {-AES key expansion, error if inv. key size, encrypt CTR} + +function AES_CTR_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CTR_Encrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode} + +function AES_CTR_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CTR_Decrypt'; + {-Decrypt ILen bytes from ctp^ to ptp^ in CTR mode} + +function AES_CTR_Seek(const iCTR: TAESBlock; SOL, SOH: longint; var ctx: TAESContext): integer; + {-Setup ctx for random access crypto stream starting at 64 bit offset SOH*2^32+SOL,} + { SOH >= 0. iCTR is the initial CTR for offset 0, i.e. the same as in AES_CTR_Init.} + +{$ifdef HAS_INT64} +function AES_CTR_Seek64(const iCTR: TAESBlock; SO: int64; var ctx: TAESContext): integer; + {-Setup ctx for random access crypto stream starting at 64 bit offset SO >= 0;} + { iCTR is the initial CTR value for offset 0, i.e. the same as in AES_CTR_Init.} +{$endif} + +function AES_SetIncProc(IncP: TIncProc; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_SetIncProc'; + {-Set user supplied IncCTR proc} + +procedure AES_IncMSBFull(var CTR: TAESBlock); +stdcall; external 'aes_dll.dll' name 'AES_IncMSBFull'; + {-Increment CTR[15]..CTR[0]} + +procedure AES_IncLSBFull(var CTR: TAESBlock); +stdcall; external 'aes_dll.dll' name 'AES_IncLSBFull'; + {-Increment CTR[0]..CTR[15]} + +procedure AES_IncMSBPart(var CTR: TAESBlock); +stdcall; external 'aes_dll.dll' name 'AES_IncMSBPart'; + {-Increment CTR[15]..CTR[8]} + +procedure AES_IncLSBPart(var CTR: TAESBlock); +stdcall; external 'aes_dll.dll' name 'AES_IncLSBPart'; + {-Increment CTR[0]..CTR[7]} + + + +function AES_OMAC_Init(const Key; KeyBits: word; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_OMAC_Init'; + {-OMAC init: AES key expansion, error if inv. key size} + +function AES_OMAC_Update(data: pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_OMAC_Update'; + {-OMAC data input, may be called more than once} + +procedure AES_OMAC_Final(var tag: TAESBlock; var ctx: TAESContext); +stdcall; external 'aes_dll.dll' name 'AES_OMAC_Final'; + {-end data input, calculate OMAC=OMAC1 tag} + +procedure AES_OMAC1_Final(var tag: TAESBlock; var ctx: TAESContext); +stdcall; external 'aes_dll.dll' name 'AES_OMAC1_Final'; + {-end data input, calculate OMAC1 tag} + +procedure AES_OMAC2_Final(var tag: TAESBlock; var ctx: TAESContext); +stdcall; external 'aes_dll.dll' name 'AES_OMAC2_Final'; + {-end data input, calculate OMAC2 tag} + +procedure AES_OMACx_Final(OMAC2: boolean; var tag: TAESBlock; var ctx: TAESContext); +stdcall; external 'aes_dll.dll' name 'AES_OMACx_Final'; + {-end data input, calculate OMAC tag} + + + +function AES_CMAC_Init(const Key; KeyBits: word; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CMAC_Init'; + {-CMAC init: AES key expansion, error if inv. key size} + +function AES_CMAC_Update(data: pointer; ILen: longint; var ctx: TAESContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_CMAC_Update'; + {-CMAC data input, may be called more than once} + +procedure AES_CMAC_Final(var tag: TAESBlock; var ctx: TAESContext); +stdcall; external 'aes_dll.dll' name 'AES_CMAC_Final'; + {-end data input, calculate CMAC=OMAC1 tag} + + + +function AES_EAX_Init(const Key; KBits: word; const nonce; nLen: word; var ctx: TAES_EAXContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_EAX_Init'; + {-Init hdr and msg OMACs, setp AESCTR with nonce tag} + +function AES_EAX_Provide_Header(Hdr: pointer; hLen: word; var ctx: TAES_EAXContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_EAX_Provide_Header'; + {-Supply a message header. The header "grows" with each call} + +function AES_EAX_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_EAXContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_EAX_Encrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update OMACs} + +function AES_EAX_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAES_EAXContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_EAX_Decrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update OMACs} + +procedure AES_EAX_Final(var tag: TAESBlock; var ctx: TAES_EAXContext); +stdcall; external 'aes_dll.dll' name 'AES_EAX_Final'; + {-Compute EAX tag from context} + +function AES_EAX_Enc_Auth(var tag: TAESBlock; {Tag record} + const Key; KBits: word; {key and bitlength of key} + const nonce; nLen: word; {nonce: address / length} + Hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; +stdcall; external 'aes_dll.dll' name 'AES_EAX_Enc_Auth'; + {-All-in-one call to encrypt/authenticate} + +function AES_EAX_Dec_Veri( ptag: pointer; tLen : word; {Tag: address / length (0..16)} + const Key; KBits: word; {key and bitlength of key} + const nonce; nLen : word; {nonce: address / length} + Hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; +stdcall; external 'aes_dll.dll' name 'AES_EAX_Dec_Veri'; + {-All-in-one call to decrypt/verify. Decryption is done only if ptag^ is verified} + + + +function AES_CPRF128(const Key; KeyBytes: word; msg: pointer; msglen: longint; var PRV: TAESBlock): integer; +stdcall; external 'aes_dll.dll' name 'AES_CPRF128'; + {Calculate variable-length key AES CMAC Pseudo-Random Function-128 for msg} + {returns AES_OMAC error and 128-bit pseudo-random value PRV} + +function AES_CPRF128_selftest: boolean; +stdcall; external 'aes_dll.dll' name 'AES_CPRF128_selftest'; + {-Selftest with RFC 4615 test vectors} + + + +function AES_XTS_Init_Encr(const K1,K2; KBits: word; var ctx: TAES_XTSContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_XTS_Init_Encr'; + {-Init XTS encrypt context (key expansion), error if invalid key size} + +function AES_XTS_Encrypt(ptp, ctp: Pointer; ILen: longint; const twk: TAESBlock; var ctx: TAES_XTSContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_XTS_Encrypt'; + {-Encrypt data unit of ILen bytes from ptp^ to ctp^ in XTS mode, twk: tweak of data unit} + +function AES_XTS_Init_Decr(const K1,K2; KBits: word; var ctx: TAES_XTSContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_XTS_Init_Decr'; + {-Init XTS decrypt context (key expansion), error if invalid key size} + +function AES_XTS_Decrypt(ctp, ptp: Pointer; ILen: longint; const twk: TAESBlock; var ctx: TAES_XTSContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_XTS_Decrypt'; + {-Decrypt data unit of ILen bytes from ptp^ to ctp^ in XTS mode, twk: tweak of data unit} + + + +function AES_CCM_Enc_AuthEx(var ctx: TAESContext; + var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + const nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; +stdcall; external 'aes_dll.dll' name 'AES_CCM_Enc_AuthEx'; + {-CCM packet encrypt/authenticate without key setup} + +function AES_CCM_Enc_Auth(var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + const Key; KBytes: word; {key and byte length of key} + const nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; +stdcall; external 'aes_dll.dll' name 'AES_CCM_Enc_Auth'; + {-All-in-one call for CCM packet encrypt/authenticate} + +function AES_CCM_Dec_VeriEX(var ctx: TAESContext; + ptag: pointer; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + const nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; +stdcall; external 'aes_dll.dll' name 'AES_CCM_Dec_VeriEX'; + {-CCM packet decrypt/verify without key setup. If ptag^ verification fails, ptp^ is zero-filled!} + +function AES_CCM_Dec_Veri( ptag: pointer; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + const Key; KBytes: word; {key and byte length of key} + const nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; +stdcall; external 'aes_dll.dll' name 'AES_CCM_Dec_Veri'; + {-All-in-one CCM packet decrypt/verify. If ptag^ verification fails, ptp^ is zero-filled!} + + + +function AES_GCM_Init(const Key; KeyBits: word; var ctx: TAES_GCMContext): integer; + {-Init context, calculate key-dependent GF(2^128) element H=E(K,0) and mul tables} +stdcall; external 'aes_dll.dll' name 'AES_GCM_Init'; + +function AES_GCM_Reset_IV(pIV: pointer; IV_len: word; var ctx: TAES_GCMContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_GCM_Reset_IV'; + {-Reset: keep key but start new encryption with given IV} + +function AES_GCM_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_GCM_Encrypt'; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update auth data} + +function AES_GCM_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_GCM_Decrypt'; + {-Decrypt ILen bytes from ctp^ to ptp^ in CTR mode, update auth data} + +function AES_GCM_Add_AAD(pAAD: pointer; aLen: longint; var ctx: TAES_GCMContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_GCM_Add_AAD'; + {-Add additional authenticated data (will not be encrypted)} + +function AES_GCM_Final(var tag: TAESBlock; var ctx: TAES_GCMContext): integer; +stdcall; external 'aes_dll.dll' name 'AES_GCM_Final'; + {-Compute GCM tag from context} + +function AES_GCM_Enc_Auth(var tag: TAESBlock; {Tag record} + const Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer; {ciphertext: address} + var ctx: TAES_GCMContext {context, will be cleared} + ): integer; +stdcall; external 'aes_dll.dll' name 'AES_GCM_Enc_Auth'; + {-All-in-one call to encrypt/authenticate} + +function AES_GCM_Dec_Veri( ptag: pointer; tLen: word; {Tag: address / length (0..16)} + const Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer; {plaintext: address} + var ctx: TAES_GCMContext {context, will be cleared} + ): integer; +stdcall; external 'aes_dll.dll' name 'AES_GCM_Dec_Veri'; + {-All-in-one call to decrypt/verify. Decryption is done only if ptag^ is verified} + + +implementation + +{$i aes_seek.inc} + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_intv.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_intv.pas new file mode 100644 index 00000000..27b870c7 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_intv.pas @@ -0,0 +1,534 @@ +unit AES_INTV; + +{$ifdef VirtualPascal} + {$stdcall+} +{$else} + Error('Interface unit for VirtualPascal'); +{$endif} + +(************************************************************************* + + DESCRIPTION : Interface unit for AES_DLL + + REQUIREMENTS : VirtualPascal + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 02.07.04 W.Ehrhardt Initial version from AES_Intf + 0.20 03.07.04 we VirtualPascal syntax + 0.21 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.22 01.12.04 we AES_Err_Data_After_Short_Block + 0.23 01.12.04 we AES_ prefix for CTR increment routines + 0.24 24.12.04 we AES_Get/SetFastInit + 0.25 09.07.06 we CMAC, updated OMAC + 0.26 14.06.07 we Type TAES_EAXContext + 0.27 16.06.07 we AES_CPRF128 + 0.28 29.09.07 we AES_XTS + 0.29 25.12.07 we AES_CFB8 + 0.30 20.07.08 we All-in-one functions AES_EAX_Enc_Auth/AES_EAX_Dec_Veri + 0.31 02.08.08 we Removed ctx parameter in AES_EAX_Enc_Auth/AES_EAX_Dec_Veri + 0.32 21.05.09 we AES_CCM + 0.33 06.07.09 we AES_DLL_Version returns PAnsiChar + 0.34 22.06.10 we AES_CTR_Seek + 0.35 27.07.10 we Longint ILen, AES_Err_Invalid_16Bit_Length + 0.36 28.07.10 we Removed OMAC/CMAC XL versions + 0.37 31.07.10 we AES_CTR_Seek via aes_seek.inc + 0.38 27.09.10 we AES_GCM +**************************************************************************) + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +interface + +const + AES_Err_Invalid_Key_Size = -1; {Key size <> 128, 192, or 256 Bits} + AES_Err_Invalid_Mode = -2; {Encr/Decr with Init for Decr/Encr} + AES_Err_Invalid_Length = -3; {No full block for cipher stealing} + AES_Err_Data_After_Short_Block = -4; {Short block must be last} + AES_Err_MultipleIncProcs = -5; {More than one IncProc Setting } + AES_Err_NIL_Pointer = -6; {nil pointer to block with nonzero length} + AES_Err_EAX_Inv_Text_Length = -7; {More than 64K text length in EAX all-in-one for 16 Bit} + AES_Err_EAX_Inv_TAG_Length = -8; {EAX all-in-one tag length not 0..16} + AES_Err_EAX_Verify_Tag = -9; {EAX all-in-one tag does not compare} + AES_Err_CCM_Hdr_length = -10; {CCM header length >= $FF00} + AES_Err_CCM_Nonce_length = -11; {CCM nonce length < 7 or > 13} + AES_Err_CCM_Tag_length = -12; {CCM tag length not in [4,6,8,19,12,14,16]} + AES_Err_CCM_Verify_Tag = -13; {Computed CCM tag does not compare} + AES_Err_CCM_Text_length = -14; {16 bit plain/cipher text length to large} + AES_Err_CTR_SeekOffset = -15; {Negative offset in AES_CTR_Seek} + AES_Err_GCM_Verify_Tag = -17; {GCM all-in-one tag does not compare} + AES_Err_GCM_Auth_After_Final = -18; {Auth after final or multiple finals} + AES_Err_Invalid_16Bit_Length = -20; {BaseAddr + length > $FFFF for 16 bit code} + +const + AESMaxRounds = 14; + +type + TAESBlock = packed array[0..15] of byte; + PAESBlock = ^TAESBlock; + TKeyArray = packed array[0..AESMaxRounds] of TAESBlock; + TIncProc = procedure(var CTR: TAESBlock); + {user supplied IncCTR proc} + TAESContext = packed record + RK : TKeyArray; {Key (encr. or decr.) } + IV : TAESBlock; {IV or CTR } + buf : TAESBlock; {Work buffer } + bLen : word; {Bytes used in buf } + Rounds : word; {Number of rounds } + KeyBits : word; {Number of bits in key } + Decrypt : byte; {<>0 if decrypting key } + Flag : byte; {Bit 1: Short block } + IncProc : TIncProc; {Increment proc CTR-Mode} + end; +const + AESBLKSIZE = sizeof(TAESBlock); + +type + TAES_EAXContext = packed record + HdrOMAC : TAESContext; {Hdr OMAC1 context} + MsgOMAC : TAESContext; {Msg OMAC1 context} + ctr_ctx : TAESContext; {Msg AESCTR context} + NonceTag: TAESBlock; {nonce tag } + tagsize : word; {tag size (unused) } + flags : word; {ctx flags (unused)} + end; + +type + TAES_XTSContext = packed record + main : TAESContext; {Main context} + tweak: TAESContext; {Tweak context} + end; + +type + TGCM_Tab4K = array[0..255] of TAESBlock; {64 KB gf_mul_h table } + +type + TBit64 = packed array[0..1] of longint; {64 bit counter } + +type + TAES_GCMContext = packed record + actx : TAESContext; {Basic AES context } + aad_ghv : TAESBlock; {ghash value AAD } + txt_ghv : TAESBlock; {ghash value ciphertext} + ghash_h : TAESBlock; {ghash H value } + gf_t4k : TGCM_Tab4K; {gf_mul_h table } + aad_cnt : TBit64; {processed AAD bytes } + atx_cnt : TBit64; {authent. text bytes } + y0_val : longint; {initial 32-bit ctr val} + end; + +{---------------------------------------------------------------------------} +{---------------------------------------------------------------------------} + +function AES_DLL_Version: PAnsiChar; + {-Return DLL version as PAnsiChar} + +procedure AES_XorBlock(const B1, B2: TAESBlock; var B3: TAESBlock); + {-xor two blocks, result in third} + +function AES_Init(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} + +function AES_Init_Encr(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size} + +procedure AES_Encrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} + +function AES_Init_Decr(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, InvMixColumn(Key) for Decypt, error if invalid key size} + +procedure AES_Decrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); + {-decrypt one block (in ECB mode)} + +procedure AES_SetFastInit(value: boolean); + {-set FastInit variable} + +function AES_GetFastInit: boolean; + {-Returns FastInit variable} + + + +function AES_ECB_Init_Encr(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_ECB_Init_Decr(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_ECB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in ECB mode} + +function AES_ECB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in ECB mode} + + + +function AES_CBC_Init_Encr(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_CBC_Init_Decr(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_CBC_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CBC mode} + +function AES_CBC_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CBC mode} + + + +function AES_CFB_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_CFB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CFB128 mode} + +function AES_CFB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CFB128 mode} + + + +function AES_CFB8_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, store IV} + +function AES_CFB8_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CFB8 mode} + +function AES_CFB8_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CFB8 mode} + + + +function AES_OFB_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + +function AES_OFB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in OFB mode} + +function AES_OFB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in OFB mode} + + + +function AES_CTR_Init(const Key; KeyBits: word; const CTR: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if inv. key size, encrypt CTR} + +function AES_CTR_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode} + +function AES_CTR_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CTR mode} + +function AES_CTR_Seek(const iCTR: TAESBlock; SOL, SOH: longint; var ctx: TAESContext): integer; + {-Setup ctx for random access crypto stream starting at 64 bit offset SOH*2^32+SOL,} + { SOH >= 0. iCTR is the initial CTR for offset 0, i.e. the same as in AES_CTR_Init.} + +function AES_SetIncProc(IncP: TIncProc; var ctx: TAESContext): integer; + {-Set user supplied IncCTR proc} + +procedure AES_IncMSBFull(var CTR: TAESBlock); + {-Increment CTR[15]..CTR[0]} + +procedure AES_IncLSBFull(var CTR: TAESBlock); + {-Increment CTR[0]..CTR[15]} + +procedure AES_IncMSBPart(var CTR: TAESBlock); + {-Increment CTR[15]..CTR[8]} + +procedure AES_IncLSBPart(var CTR: TAESBlock); + {-Increment CTR[0]..CTR[7]} + + + +function AES_OMAC_Init(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-OMAC init: AES key expansion, error if inv. key size} + +function AES_OMAC_Update(data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-OMAC data input, may be called more than once} + +procedure AES_OMAC_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate OMAC=OMAC1 tag} + +procedure AES_OMAC1_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate OMAC1 tag} + +procedure AES_OMAC2_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate OMAC2 tag} + +procedure AES_OMACx_Final(OMAC2: boolean; var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate OMAC tag} + + + +function AES_CMAC_Init(const Key; KeyBits: word; var ctx: TAESContext): integer; + {-CMAC init: AES key expansion, error if inv. key size} + +function AES_CMAC_Update(data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-CMAC data input, may be called more than once} + +procedure AES_CMAC_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate CMAC=OMAC1 tag} + + + +function AES_EAX_Init(const Key; KBits: word; const nonce; nLen: word; var ctx: TAES_EAXContext): integer; + {-Init hdr and msg OMACs, setp AESCTR with nonce tag} + +function AES_EAX_Provide_Header(Hdr: pointer; hLen: word; var ctx: TAES_EAXContext): integer; + {-Supply a message header. The header "grows" with each call} + +function AES_EAX_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_EAXContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update OMACs} + +function AES_EAX_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAES_EAXContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update OMACs} + +procedure AES_EAX_Final(var tag: TAESBlock; var ctx: TAES_EAXContext); + {-Compute EAX tag from context} + +function AES_EAX_Enc_Auth(var tag: TAESBlock; {Tag record} + const Key; KBits: word; {key and bitlength of key} + const nonce; nLen: word; {nonce: address / length} + Hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {-All-in-one call to encrypt/authenticate} + +function AES_EAX_Dec_Veri( ptag: pointer; tLen : word; {Tag: address / length (0..16)} + const Key; KBits: word; {key and bitlength of key} + const nonce; nLen : word; {nonce: address / length} + Hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {-All-in-one call to decrypt/verify. Decryption is done only if ptag^ is verified} + + + +function AES_CPRF128(const Key; KeyBytes: word; msg: pointer; msglen: longint; var PRV: TAESBlock): integer; + {Calculate variable-length key AES CMAC Pseudo-Random Function-128 for msg} + {returns AES_OMAC error and 128-bit pseudo-random value PRV} + +function AES_CPRF128_selftest: boolean; + {-Selftest with RFC 4615 test vectors} + + + +function AES_XTS_Init_Encr({$ifdef CONST}const{$else}var{$endif} K1,K2; KBits: word; var ctx: TAES_XTSContext): integer; + {-Init XTS encrypt context (key expansion), error if invalid key size} + +function AES_XTS_Encrypt(ptp, ctp: Pointer; ILen: longint; + {$ifdef CONST}const{$else}var{$endif} twk: TAESBlock; var ctx: TAES_XTSContext): integer; + {-Encrypt data unit of ILen bytes from ptp^ to ctp^ in XTS mode, twk: tweak of data unit} + +function AES_XTS_Init_Decr({$ifdef CONST}const{$else}var{$endif} K1,K2; KBits: word; var ctx: TAES_XTSContext): integer; + {-Init XTS decrypt context (key expansion), error if invalid key size} + +function AES_XTS_Decrypt(ctp, ptp: Pointer; ILen: longint; + {$ifdef CONST}const{$else}var{$endif} twk: TAESBlock; var ctx: TAES_XTSContext): integer; + {-Decrypt data unit of ILen bytes from ptp^ to ctp^ in XTS mode, twk: tweak of data unit} + + + + +function AES_CCM_Enc_AuthEx(var ctx: TAESContext; + var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + const nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {-CCM packet encrypt/authenticate without key setup} + + +function AES_CCM_Enc_Auth(var tag: TAESBlock; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + const Key; KBytes: word; {key and byte length of key} + const nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer {ciphertext: address} + ): integer; + {-All-in-one call for CCM packet encrypt/authenticate} + + +function AES_CCM_Dec_VeriEX(var ctx: TAESContext; + ptag: pointer; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + const nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {-CCM packet decrypt/verify without key setup. If ptag^ verification fails, ptp^ is zero-filled!} + + +function AES_CCM_Dec_Veri( ptag: pointer; tLen : word; {Tag & length in [4,6,8,19,12,14,16]} + const Key; KBytes: word; {key and byte length of key} + const nonce; nLen: word; {nonce: address / length} + hdr: pointer; hLen: word; {header: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer {plaintext: address} + ): integer; + {-All-in-one CCM packet decrypt/verify. If ptag^ verification fails, ptp^ is zero-filled!} + + + + +function AES_GCM_Init(const Key; KeyBits: word; var ctx: TAES_GCMContext): integer; + {-Init context, calculate key-dependent GF(2^128) element H=E(K,0) and mul tables} + +function AES_GCM_Reset_IV(pIV: pointer; IV_len: word; var ctx: TAES_GCMContext): integer; + {-Reset: keep key but start new encryption with given IV} + +function AES_GCM_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in CTR mode, update auth data} + +function AES_GCM_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAES_GCMContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in CTR mode, update auth data} + +function AES_GCM_Add_AAD(pAAD: pointer; aLen: longint; var ctx: TAES_GCMContext): integer; + {-Add additional authenticated data (will not be encrypted)} + +function AES_GCM_Final(var tag: TAESBlock; var ctx: TAES_GCMContext): integer; + {-Compute GCM tag from context} + +function AES_GCM_Enc_Auth(var tag: TAESBlock; {Tag record} + const Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ptp: pointer; pLen: longint; {plaintext: address / length} + ctp: pointer; {ciphertext: address} + var ctx: TAES_GCMContext {context, will be cleared} + ): integer; + {-All-in-one call to encrypt/authenticate} + +function AES_GCM_Dec_Veri( ptag: pointer; tLen: word; {Tag: address / length (0..16)} + const Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer; {plaintext: address} + var ctx: TAES_GCMContext {context, will be cleared} + ): integer; + {-All-in-one call to decrypt/verify. Decryption is done only if ptag^ is verified} + + +implementation + + + +function AES_DLL_Version; external 'AES_DLL' name 'AES_DLL_Version'; + +procedure AES_XorBlock; external 'AES_DLL' name 'AES_XorBlock'; + +function AES_Init; external 'AES_DLL' name 'AES_Init'; +function AES_Init_Decr; external 'AES_DLL' name 'AES_Init_Decr'; +function AES_Init_Encr; external 'AES_DLL' name 'AES_Init_Encr'; +procedure AES_Decrypt; external 'AES_DLL' name 'AES_Decrypt'; +procedure AES_Encrypt; external 'AES_DLL' name 'AES_Encrypt'; +procedure AES_SetFastInit; external 'AES_DLL' name 'AES_SetFastInit'; +function AES_GetFastInit; external 'AES_DLL' name 'AES_GetFastInit'; + + +function AES_ECB_Init_Encr; external 'AES_DLL' name 'AES_ECB_Init_Encr'; +function AES_ECB_Init_Decr; external 'AES_DLL' name 'AES_ECB_Init_Decr'; +function AES_ECB_Encrypt; external 'AES_DLL' name 'AES_ECB_Encrypt'; +function AES_ECB_Decrypt; external 'AES_DLL' name 'AES_ECB_Decrypt'; + +function AES_CBC_Init_Encr; external 'AES_DLL' name 'AES_CBC_Init_Encr'; +function AES_CBC_Init_Decr; external 'AES_DLL' name 'AES_CBC_Init_Decr'; +function AES_CBC_Encrypt; external 'AES_DLL' name 'AES_CBC_Encrypt'; +function AES_CBC_Decrypt; external 'AES_DLL' name 'AES_CBC_Decrypt'; + +function AES_CFB_Init; external 'AES_DLL' name 'AES_CFB_Init'; +function AES_CFB_Encrypt; external 'AES_DLL' name 'AES_CFB_Encrypt'; +function AES_CFB_Decrypt; external 'AES_DLL' name 'AES_CFB_Decrypt'; + +function AES_CFB8_Init; external 'AES_DLL' name 'AES_CFB8_Init'; +function AES_CFB8_Encrypt; external 'AES_DLL' name 'AES_CFB8_Encrypt'; +function AES_CFB8_Decrypt; external 'AES_DLL' name 'AES_CFB8_Decrypt'; + +function AES_CTR_Init; external 'AES_DLL' name 'AES_CTR_Init'; +function AES_CTR_Encrypt; external 'AES_DLL' name 'AES_CTR_Encrypt'; +function AES_CTR_Decrypt; external 'AES_DLL' name 'AES_CTR_Decrypt'; +function AES_SetIncProc; external 'AES_DLL' name 'AES_SetIncProc'; +procedure AES_IncLSBFull; external 'AES_DLL' name 'AES_IncLSBFull'; +procedure AES_IncLSBPart; external 'AES_DLL' name 'AES_IncLSBPart'; +procedure AES_IncMSBFull; external 'AES_DLL' name 'AES_IncMSBFull'; +procedure AES_IncMSBPart; external 'AES_DLL' name 'AES_IncMSBPart'; + +function AES_OFB_Init; external 'AES_DLL' name 'AES_OFB_Init'; +function AES_OFB_Encrypt; external 'AES_DLL' name 'AES_OFB_Encrypt'; +function AES_OFB_Decrypt; external 'AES_DLL' name 'AES_OFB_Decrypt'; + +function AES_OMAC_Init; external 'AES_DLL' name 'AES_OMAC_Init'; +function AES_OMAC_Update; external 'AES_DLL' name 'AES_OMAC_Update'; +procedure AES_OMAC_Final; external 'AES_DLL' name 'AES_OMAC_Final'; +procedure AES_OMAC1_Final; external 'AES_DLL' name 'AES_OMAC1_Final'; +procedure AES_OMAC2_Final; external 'AES_DLL' name 'AES_OMAC2_Final'; +procedure AES_OMACx_Final; external 'AES_DLL' name 'AES_OMACx_Final'; + +function AES_CMAC_Init; external 'AES_DLL' name 'AES_CMAC_Init'; +function AES_CMAC_Update; external 'AES_DLL' name 'AES_CMAC_Update'; +procedure AES_CMAC_Final; external 'AES_DLL' name 'AES_CMAC_Final'; + +function AES_EAX_Init; external 'AES_DLL' name 'AES_EAX_Init'; +function AES_EAX_Encrypt; external 'AES_DLL' name 'AES_EAX_Encrypt'; +function AES_EAX_Decrypt; external 'AES_DLL' name 'AES_EAX_Decrypt'; +procedure AES_EAX_Final; external 'AES_DLL' name 'AES_EAX_Final'; +function AES_EAX_Provide_Header; external 'AES_DLL' name 'AES_EAX_Provide_Header'; +function AES_EAX_Enc_Auth; external 'AES_DLL' name 'AES_EAX_Enc_Auth'; +function AES_EAX_Dec_Veri; external 'AES_DLL' name 'AES_EAX_Dec_Veri'; + +function AES_CPRF128; external 'AES_DLL' name 'AES_CPRF128'; +function AES_CPRF128_selftest; external 'AES_DLL' name 'AES_CPRF128_selftest'; + +function AES_XTS_Init_Encr; external 'AES_DLL' name 'AES_XTS_Init_Encr'; +function AES_XTS_Encrypt; external 'AES_DLL' name 'AES_XTS_Encrypt'; +function AES_XTS_Init_Decr; external 'AES_DLL' name 'AES_XTS_Init_Decr'; +function AES_XTS_Decrypt; external 'AES_DLL' name 'AES_XTS_Decrypt'; + +function AES_CCM_Dec_Veri; external 'AES_DLL' name 'AES_CCM_Dec_Veri'; +function AES_CCM_Dec_VeriEX; external 'AES_DLL' name 'AES_CCM_Dec_VeriEX'; +function AES_CCM_Enc_Auth; external 'AES_DLL' name 'AES_CCM_Enc_Auth'; +function AES_CCM_Enc_AuthEx; external 'AES_DLL' name 'AES_CCM_Enc_AuthEx'; + +function AES_GCM_Init; external 'AES_DLL' name 'AES_GCM_Init'; +function AES_GCM_Reset_IV; external 'AES_DLL' name 'AES_GCM_Reset_IV'; +function AES_GCM_Encrypt; external 'AES_DLL' name 'AES_GCM_Encrypt'; +function AES_GCM_Decrypt; external 'AES_DLL' name 'AES_GCM_Decrypt'; +function AES_GCM_Add_AAD; external 'AES_DLL' name 'AES_GCM_Add_AAD'; +function AES_GCM_Final; external 'AES_DLL' name 'AES_GCM_Final'; +function AES_GCM_Enc_Auth; external 'AES_DLL' name 'AES_GCM_Enc_Auth'; +function AES_GCM_Dec_Veri; external 'AES_DLL' name 'AES_GCM_Dec_Veri'; + +{$define CONST} +{$i aes_seek.inc} + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_ofb.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_ofb.pas new file mode 100644 index 00000000..d77bca34 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_ofb.pas @@ -0,0 +1,170 @@ +unit AES_OFB; + +(************************************************************************* + + DESCRIPTION : AES OFB functions + Because of buffering en/decrypting is associative + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [3] http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + [1] http://csrc.nist.gov/fips/fips-197.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 16.08.03 we initial version + 0.11 21.09.03 we functions, error codes + 0.12 27.09.03 we FPC/go32v2 + 0.13 03.10.03 we 3-para encr/decr + 0.14 05.10.03 we STD.INC, TP5-6 + 0.15 01.01.04 we Encr(IV) in init, handle full blocks first + 0.16 12.06.04 we uses BLKSIZE constant + 0.17 12.06.04 we check for nil pointers + 0.18 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.19 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.20 09.07.06 we Checked: D9-D10 + 0.21 16.11.08 we Use Ptr2Inc, pByte from BTypes + 0.22 27.07.10 we Longint ILen in AES_OFB_En/Decrypt +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr; + +{$ifdef CONST} + +function AES_OFB_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + {$ifdef DLL} stdcall; {$endif} + +{$else} + +function AES_OFB_Init(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; + {-AES key expansion, error if invalid key size, encrypt IV} + {$ifdef DLL} stdcall; {$endif} + +{$endif} + +function AES_OFB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in OFB mode} + {$ifdef DLL} stdcall; {$endif} + +function AES_OFB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in OFB mode} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------------------------------------------} +{$ifdef CONST} +function AES_OFB_Init(const Key; KeyBits: word; const IV: TAESBlock; var ctx: TAESContext): integer; +{$else} +function AES_OFB_Init(var Key; KeyBits: word; var IV: TAESBlock; var ctx: TAESContext): integer; +{$endif} + {-AES key expansion, error if invalid key size} +begin + {-AES key expansion, error if invalid key size} + AES_OFB_Init := AES_Init_Encr(Key, KeyBits, ctx); + AES_Encrypt(ctx, IV, ctx.IV); +end; + + +{---------------------------------------------------------------------------} +function AES_OFB_Encrypt(ptp, ctp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Encrypt ILen bytes from ptp^ to ctp^ in OFB mode} +begin + AES_OFB_Encrypt := 0; + + if ctx.Decrypt<>0 then begin + AES_OFB_Encrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_OFB_Encrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ofs(ptp^)+ILen>$FFFF) or (ofs(ctp^)+ILen>$FFFF) then begin + AES_OFB_Encrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + if ctx.blen=0 then begin + {Handle full blocks first} + while ILen>=AESBLKSIZE do with ctx do begin + {Cipher text = plain text xor repeated encr(IV), cf. [3] 6.4} + AES_XorBlock(PAESBlock(ptp)^, IV, PAESBlock(ctp)^); + AES_Encrypt(ctx, IV, IV); + inc(Ptr2Inc(ptp), AESBLKSIZE); + inc(Ptr2Inc(ctp), AESBLKSIZE); + dec(ILen, AESBLKSIZE); + end; + end; + + {Handle remaining bytes} + while ILen>0 do with ctx do begin + {Test buffer empty} + if bLen>=AESBLKSIZE then begin + AES_Encrypt(ctx, IV, IV); + bLen := 0; + end; + pByte(ctp)^ := IV[bLen] xor pByte(ptp)^; + inc(bLen); + inc(Ptr2Inc(ptp)); + inc(Ptr2Inc(ctp)); + dec(ILen); + end; +end; + + +{---------------------------------------------------------------------------} +function AES_OFB_Decrypt(ctp, ptp: Pointer; ILen: longint; var ctx: TAESContext): integer; + {-Decrypt ILen bytes from ctp^ to ptp^ in OFB mode} +begin + {Decrypt = encrypt for OFB mode} + AES_OFB_Decrypt := AES_OFB_Encrypt(ctp, ptp, ILen, ctx); +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_omac.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_omac.pas new file mode 100644 index 00000000..b8ef8f2c --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_omac.pas @@ -0,0 +1,277 @@ +unit AES_OMAC; + +(************************************************************************* + + DESCRIPTION : AES OMAC1/2 routines + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : OMAC page: http://www.nuee.nagoya-u.ac.jp/labs/tiwata/omac/omac.html + T.Iwata and K.Kurosawa. OMAC: One-Key CBC MAC - Addendum + (http://csrc.nist.gov/CryptoToolkit/modes/proposedmodes/omac/omac-ad.pdf) + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 22.05.04 W.Ehrhardt Initial version + 0.11 22.05.04 we Update with move and second while loop + 0.12 22.05.04 we Update/final as procedures, $R- in mul_u + 0.13 23.05.04 we XL version + 0.14 23.05.04 we More comments + 0.15 30.05.04 we OMAC2 + 0.16 31.05.04 we Update references, more comments + 0.17 12.06.04 we uses BLKSIZE constant + 0.18 12.06.04 we check for nil pointers + 0.19 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 0.20 30.11.04 we AES_XorBlock, AESBLKSIZE + 0.21 30.11.04 we Clear IV if FastInit + 0.22 24.12.04 we Calls AES_GetFastInit + 0.23 09.07.06 we Checked: D9-D10 + 0.24 09.07.06 we Interfaced AES_OMACx_Final, AES_OMAC_UpdateXL + 0.25 15.11.08 we Use Ptr2Inc from BTypes + 0.26 28.07.10 we AES_OMAC_Update with ILen: longint, XL Version with $define OLD_XL_Version +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2004-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +{$i STD.INC} + +interface + +uses + BTypes, AES_Type, AES_Base, AES_Encr; + + +function AES_OMAC_Init({$ifdef CONST} const Key {$else} var Key {$endif}; + KeyBits: word; var ctx: TAESContext): integer; + {-OMAC init: AES key expansion, error if inv. key size} + {$ifdef DLL} stdcall; {$endif} + +function AES_OMAC_Update(data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-OMAC data input, may be called more than once} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_OMAC_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate OMAC=OMAC1 tag} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_OMAC1_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate OMAC1 tag} + {$ifdef DLL} stdcall; {$endif} + +procedure AES_OMAC2_Final(var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate OMAC2 tag} + {$ifdef DLL} stdcall; {$endif} + +{$ifdef OLD_XL_Version} +function AES_OMAC_UpdateXL (data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-OMAC data input, may be called more than once} +{$endif} + +procedure AES_OMACx_Final(OMAC2: boolean; var tag: TAESBlock; var ctx: TAESContext); + {-end data input, calculate OMAC tag} + { interfaced for AES_CMAC, no need for OMAC usage} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------------------------------------------} +function AES_OMAC_Init({$ifdef CONST} const Key {$else} var Key {$endif}; + KeyBits: word; var ctx: TAESContext): integer; + {-OMAC init: AES key expansion, error if inv. key size} +begin + {AES key expansion, error if inv. key size} + {IV = Y[0] = [0]} + AES_OMAC_Init := AES_Init_Encr(Key, KeyBits, ctx); + if AES_GetFastInit then fillchar(ctx.IV,sizeof(ctx.IV),0); +end; + + +{---------------------------------------------------------------------------} +function AES_OMAC_Update(data: pointer; ILen: longint; var ctx: TAESContext): integer; + {-OMAC data input, may be called more than once} +var + n: word; +begin + if (data=nil) and (ILen<>0) then begin + AES_OMAC_Update := AES_Err_NIL_Pointer; + exit; + end; + + {$ifdef BIT16} + if (ofs(data^)+ILen>$FFFF) then begin + AES_OMAC_Update := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + AES_OMAC_Update := 0; + + while ILen>0 do with ctx do begin + if bLen>=AESBLKSIZE then begin + {process full buffer} + {X[i] := M[i] xor Y[i-1]} + AES_XorBlock(buf, IV, buf); + AES_Encrypt(ctx, buf, IV); + bLen := 0; + while ILen>AESBLKSIZE do with ctx do begin + {continue with full blocks if more } + {than one block remains unprocessed} + {X[i] := M[i] xor Y[i-1]} + AES_XorBlock(PAESBlock(data)^, IV, buf); + {Y[i] := EK[X[i]} + AES_Encrypt(ctx, buf, IV); + inc(Ptr2Inc(data), AESBLKSIZE); + dec(ILen, AESBLKSIZE); {ILen>0!} + end; + end; + n := AESBLKSIZE-bLen; if ILen0 because ILen>0 and bLen=AESBLKSIZE then begin + {Complete last block, no padding and use L.u} + mul_u(tag); + end + else begin + {Incomplete last block, pad buf and use L.u^2 or L.u^-1} + buf[bLen] := $80; + inc(bLen); + while blen= 0. iCTR is the initial CTR for offset 0, i.e. the same as in AES_CTR_Init.} +var + i,pt: integer; + carry: word; + TC: TAESBlock; +type + TWA4 = packed array[0..3] of longint; {AES block as array of longint} + TBA4 = packed array[0..3] of byte; {AES "word" as array of byte } +begin + + {WARNING: CTR mode demands that the same key / iCTR pair is never reused } + {for encryption. This requirement is especially important for the CTR_Seek} + {function. If different data is written to the same position there will be} + {leakage of information about the plaintexts. Therefore CTR_Seek should } + {normally be used for random reads only.} + + if SOH < 0 then begin + AES_CTR_Seek := AES_Err_CTR_SeekOffset; + exit; + end + else with ctx do begin + blen := word(SOL) and $0F; + {64 bit shift right (SOH, SOL) 4 bits} + SOL := (SOL shr 4) or ((SOH and $0F) shl 28); + SOH := (SOH shr 4); + {Check if known IncProc} + {$ifdef FPC_ProcVar} + if (IncProc=nil) or (IncProc=@AES_IncMSBFull) then pt := 1 + else if IncProc=@AES_IncMSBPart then pt := 2 + else if IncProc=@AES_IncLSBFull then pt := 3 + else if IncProc=@AES_IncLSBPart then pt := 4 + else pt := 0; + {$else} + if (@IncProc=nil) or (@IncProc=@AES_IncMSBFull) then pt := 1 + else if @IncProc=@AES_IncMSBPart then pt := 2 + else if @IncProc=@AES_IncLSBFull then pt := 3 + else if @IncProc=@AES_IncLSBPart then pt := 4 + else pt := 0; + {$endif} + IV := iCTR; + if (SOL or SOH) <> 0 then begin + if pt=0 then begin + {No shortcut calculation for user-defined IncProcs. Note: SOH is } + {positive here even if the sign bit of the original SOH was set. } + + {The execution of this loop may be very time-consuming because the } + {IncProc is called many times. If the user is able to calculate the} + {value IVo of the iCTR after calling IncProc (offset div 16) times,} + {invoking the function with AES_CTR_Seek(IVo, SOL and 15, 0, ctx) } + {will completely skip the IncProc calculation, but set the correct } + {values for ctx.IV, ctx.buf, and ctx.blen.} + if SOL=0 then dec(SOH); + repeat + repeat + IncProc(IV); + dec(SOL); + until SOL=0; + dec(SOH); + until SOH<=0; + end + else begin + fillchar(TC, sizeof(TC), 0); + carry := 0; + if (pt=1) or (pt=2) then begin + {MSB functions, first fill 128 bit offset vector} + for i:=0 to 3 do begin + TC[15-i] := TBA4(SOL)[i]; + TC[11-i] := TBA4(SOH)[i]; + end; + {64 bit addition} + for i:=15 downto 8 do begin + carry := carry + TC[i] + IV[i]; + IV[i] := carry and $FF; + carry := carry shr 8; + end; + if (pt=1) and (carry<>0) then begin + {"Full" function: propagate carry through remaining bytes} + for i:=7 downto 0 do begin + carry := carry + IV[i]; + IV[i] := carry and $FF; + carry := carry shr 8; + {$ifdef CONST} + if carry=0 then break; + {$endif} + end; + end; + end + else begin + {LSB functions, first fill 128 bit offset vector} + TWA4(TC)[0] := SOL; + TWA4(TC)[1] := SOH; + {64 bit addition} + for i:=0 to 7 do begin + carry := carry + TC[i] + IV[i]; + IV[i] := carry and $FF; + carry := carry shr 8; + end; + if (pt=3) and (carry<>0) then begin + {"Full" function: propagate carry through remaining bytes} + for i:=8 to 15 do begin + carry := carry + IV[i]; + IV[i] := carry and $FF; + carry := carry shr 8; + {$ifdef CONST} + if carry=0 then break; + {$endif} + end; + end; + end; + end; + end; + AES_Encrypt(ctx, IV, buf); + AES_CTR_Seek := 0; + end; +end; + + +{$ifdef HAS_INT64} +{$ifndef DLL} +{-----------------------------------------------------------------------------} +function AES_CTR_Seek64(const iCTR: TAESBlock; SO: int64; var ctx: TAESContext): integer; + {-Setup ctx for random access crypto stream starting at 64 bit offset SO >= 0;} + { iCTR is the initial CTR value for offset 0, i.e. the same as in AES_CTR_Init.} +type + LH = packed record L,H: longint; end; +begin + AES_CTR_Seek64 := AES_CTR_Seek(iCTR, LH(SO).L, LH(SO).H, ctx); +end; +{$endif} +{$endif} diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_type.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_type.pas new file mode 100644 index 00000000..5901c748 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_type.pas @@ -0,0 +1,119 @@ +unit AES_Type; + +(************************************************************************* + + DESCRIPTION : AES type definitions + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : --- + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 1.00 16.08.03 we Sepatate unit from AESCrypt + 1.10 15.09.03 we with IncProc + 1.20 21.09.03 we with Flag, error codes + 1.21 05.10.03 we with STD.INC + 1.23 05.10.03 we with AES_Err_MultipleIncProcs + 1.24 12.06.04 we with AES_Err_NIL_Pointer, const BLKSIZE + 1.25 02.07.04 we {$ifdef DLL} stdcall; {$endif} + 1.26 29.11.04 we FastInit + 1.27 30.11.04 we AES_XorBlock, AESBLKSIZE + 1.28 01.12.04 we AES_Err_Data_After_Short_Block + 1.29 09.07.06 we Checked: D9-D10 + 1.30 20.07.08 we Error codes for EAX all-in-one function results + 1.31 21.05.09 we CCM error codes + 1.32 20.06.10 we CTR_Seek error code + 1.33 27.07.10 we AES_Err_Invalid_16Bit_Length + 1.34 27.09.10 we GCM error codes +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +interface + + +const + AESMaxRounds = 14; + +const + AES_Err_Invalid_Key_Size = -1; {Key size <> 128, 192, or 256 Bits} + AES_Err_Invalid_Mode = -2; {Encr/Decr with Init for Decr/Encr} + AES_Err_Invalid_Length = -3; {No full block for cipher stealing} + AES_Err_Data_After_Short_Block = -4; {Short block must be last } + AES_Err_MultipleIncProcs = -5; {More than one IncProc Setting } + AES_Err_NIL_Pointer = -6; {nil pointer to block with nonzero length} + + AES_Err_EAX_Inv_Text_Length = -7; {More than 64K text length in EAX all-in-one for 16 Bit} + AES_Err_EAX_Inv_TAG_Length = -8; {EAX all-in-one tag length not 0..16} + AES_Err_EAX_Verify_Tag = -9; {EAX all-in-one tag does not compare} + + AES_Err_CCM_Hdr_length = -10; {CCM header length >= $FF00} + AES_Err_CCM_Nonce_length = -11; {CCM nonce length < 7 or > 13} + AES_Err_CCM_Tag_length = -12; {CCM tag length not in [4,6,8,19,12,14,16]} + AES_Err_CCM_Verify_Tag = -13; {Computed CCM tag does not compare} + AES_Err_CCM_Text_length = -14; {16 bit plain/cipher text length to large} + + AES_Err_CTR_SeekOffset = -15; {Negative offset in AES_CTR_Seek} + + AES_Err_GCM_Verify_Tag = -17; {GCM all-in-one tag does not compare} + AES_Err_GCM_Auth_After_Final = -18; {Auth after final or multiple finals} + + AES_Err_Invalid_16Bit_Length = -20; {BaseAddr + length > $FFFF for 16 bit code} + +type + TAESBlock = packed array[0..15] of byte; + PAESBlock = ^TAESBlock; + TKeyArray = packed array[0..AESMaxRounds] of TAESBlock; + + TIncProc = procedure(var CTR: TAESBlock); {user supplied IncCTR proc} + {$ifdef DLL} stdcall; {$endif} + + TAESContext = packed record + RK : TKeyArray; {Key (encr. or decr.) } + IV : TAESBlock; {IV or CTR } + buf : TAESBlock; {Work buffer } + bLen : word; {Bytes used in buf } + Rounds : word; {Number of rounds } + KeyBits : word; {Number of bits in key } + Decrypt : byte; {<>0 if decrypting key } + Flag : byte; {Bit 1: Short block } + IncProc : TIncProc; {Increment proc CTR-Mode} + end; + +const + AESBLKSIZE = sizeof(TAESBlock); + + +implementation + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/aes_xts.pas b/Tocsg.Lib/VCL/EncLib/AES/aes_xts.pas new file mode 100644 index 00000000..435b599d --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/aes_xts.pas @@ -0,0 +1,302 @@ +unit AES_XTS; + +(************************************************************************* + + DESCRIPTION : AES XTS mode functions + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REMARKS : 1. The IV and buf fields of the main contexts are used for + temparary buffers. Tweak context IV holds enc(tweak)*a^j. + 2. Quote from the IEEE Draft: "Attention is called to the + possibility that implementation of this standard may + require use of subject matter covered by patent rights." + Before using this source/mode read the patent section + in legal.txt! + + REFERENCES : [1] IEEE P1619, Draft Standard for Cryptographic Protection + of Data on Block-Oriented Storage Devices. Available from + http://ieee-p1619.wetpaint.com/page/IEEE+Project+1619+Home + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 23.09.07 we Initial version like ECB (BP7+, encrypt) + 0.11 24.09.07 we BP7+ decrypt + 0.12 24.09.07 we TP5-TP6 + 0.13 27.09.07 we ILen now longint + 0.14 27.09.07 we Check ILen+ofs if BIT16 and $R+ + 0.15 16.11.08 we Use Ptr2Inc from BTypes + 0.16 27.07.10 we AES_Err_Invalid_16Bit_Length +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2007-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + + +interface + +uses + BTypes, AES_Type, AES_Base, AES_Encr, AES_Decr; + + +type + TAES_XTSContext = packed record + main : TAESContext; {Main context} + tweak: TAESContext; {Tweak context} + end; + + +function AES_XTS_Init_Encr({$ifdef CONST}const{$else}var{$endif} K1,K2; KBits: word; var ctx: TAES_XTSContext): integer; + {-Init XTS encrypt context (key expansion), error if invalid key size} + {$ifdef DLL} stdcall; {$endif} + +function AES_XTS_Encrypt(ptp, ctp: Pointer; ILen: longint; + {$ifdef CONST}const{$else}var{$endif} twk: TAESBlock; var ctx: TAES_XTSContext): integer; + {-Encrypt data unit of ILen bytes from ptp^ to ctp^ in XTS mode, twk: tweak of data unit} + {$ifdef DLL} stdcall; {$endif} + +function AES_XTS_Init_Decr({$ifdef CONST}const{$else}var{$endif} K1,K2; KBits: word; var ctx: TAES_XTSContext): integer; + {-Init XTS decrypt context (key expansion), error if invalid key size} + {$ifdef DLL} stdcall; {$endif} + +function AES_XTS_Decrypt(ctp, ptp: Pointer; ILen: longint; + {$ifdef CONST}const{$else}var{$endif} twk: TAESBlock; var ctx: TAES_XTSContext): integer; + {-Decrypt data unit of ILen bytes from ptp^ to ctp^ in XTS mode, twk: tweak of data unit} + {$ifdef DLL} stdcall; {$endif} + + +implementation + + +{---------------------------------------} +procedure mul_a(var T: TAESBlock); + {-Multiply tweak block by the primitive element a from GF(2^128)} +var + i: integer; + cin,cout: byte; +const + masks: array[0..1] of byte = (0,$87); +begin + cin := 0; + {Turn off range checking for byte shifts} + {$ifopt R+} {$define SetRPlus} {$else} {$undef SetRPlus} {$endif} + {$R-} + for i:=0 to AESBLKSIZE-1 do begin + cout := T[i] shr 7; + T[i] := (T[i] shl 1) or cin; + cin := cout; + end; + T[0] := T[0] xor masks[cin]; + {$ifdef SetRPlus} + {$R+} + {$endif} +end; + + +{---------------------------------------------------------------------------} +function AES_XTS_Init_Encr({$ifdef CONST}const{$else}var{$endif} K1,K2; KBits: word; var ctx: TAES_XTSContext): integer; + {-Init XTS encrypt context (key expansion), error if invalid key size} +var + err: integer; +begin + fillchar(ctx, sizeof(ctx), 0); + err := AES_Init(K1, KBits, ctx.main); + if err=0 then err := AES_Init(K2, KBits, ctx.tweak); + AES_XTS_Init_Encr := err; +end; + + +{---------------------------------------------------------------------------} +function AES_XTS_Init_Decr({$ifdef CONST}const{$else}var{$endif} K1,K2; KBits: word; var ctx: TAES_XTSContext): integer; + {-Init XTS decrypt context (key expansion), error if invalid key size} + {$ifdef DLL} stdcall; {$endif} +var + err: integer; +begin + fillchar(ctx, sizeof(ctx), 0); + err := AES_Init_Decr(K1, KBits, ctx.main); + if err=0 then err := AES_Init(K2, KBits, ctx.tweak); + AES_XTS_Init_Decr := err; +end; + + +{---------------------------------------------------------------------------} +function AES_XTS_Encrypt(ptp, ctp: Pointer; ILen: longint; + {$ifdef CONST}const{$else}var{$endif} twk: TAESBlock; var ctx: TAES_XTSContext): integer; + {-Encrypt data unit of ILen bytes from ptp^ to ctp^ in XTS mode, twk: tweak of data unit} +var + i,n: longint; + m: word; +begin + + AES_XTS_Encrypt := 0; + if ILen<0 then ILen := 0; + + if ctx.main.Decrypt<>0 then begin + AES_XTS_Encrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_XTS_Encrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ILen+ofs(ptp^) > $FFFF) or (ILen+ofs(ctp^) > $FFFF) then begin + AES_XTS_Encrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + n := ILen div AESBLKSIZE; {Full blocks} + m := ILen mod AESBLKSIZE; {Remaining bytes in short block} + if m<>0 then begin + if n=0 then begin + AES_XTS_Encrypt := AES_Err_Invalid_Length; + exit; + end; + dec(n); {CTS: special treatment of last TWO blocks} + end; + + {encrypt the tweak twk, tweak.IV = enc(twk)} + AES_Encrypt(ctx.tweak, twk, ctx.tweak.IV); + + with ctx.main do begin + {process full blocks} + for i:=1 to n do begin + AES_XorBlock(PAESBlock(ptp)^, ctx.tweak.IV, buf); + AES_Encrypt(ctx.main, buf, buf); + AES_XorBlock(buf, ctx.tweak.IV, PAESBlock(ctp)^); + mul_a(ctx.tweak.IV); + inc(Ptr2Inc(ptp),AESBLKSIZE); + inc(Ptr2Inc(ctp),AESBLKSIZE); + end; + if m<>0 then begin + {Cipher text stealing, encrypt last full plaintext block} + AES_XorBlock(PAESBlock(ptp)^, ctx.tweak.IV, buf); + AES_Encrypt(ctx.main, buf, buf); + AES_XorBlock(buf, ctx.tweak.IV, buf); + mul_a(ctx.tweak.IV); + inc(Ptr2Inc(ptp),AESBLKSIZE); + {pad and encrypt final short block} + IV := buf; + move(PAESBlock(ptp)^, IV, m); + AES_XorBlock(IV, ctx.tweak.IV, IV); + AES_Encrypt(ctx.main, IV, IV); + AES_XorBlock(IV, ctx.tweak.IV, PAESBlock(ctp)^); + inc(Ptr2Inc(ctp),AESBLKSIZE); + move(buf,PAESBlock(ctp)^,m); + end; + end; +end; + + +{---------------------------------------------------------------------------} +function AES_XTS_Decrypt(ctp, ptp: Pointer; ILen: longint; + {$ifdef CONST}const{$else}var{$endif} twk: TAESBlock; var ctx: TAES_XTSContext): integer; + {-Decrypt data unit of ILen bytes from ptp^ to ctp^ in XTS mode, twk: tweak of data unit} +var + i,n: longint; + m: word; +begin + + AES_XTS_Decrypt := 0; + if ILen<0 then ILen := 0; + + if ctx.main.Decrypt=0 then begin + AES_XTS_Decrypt := AES_Err_Invalid_Mode; + exit; + end; + + if (ptp=nil) or (ctp=nil) then begin + if ILen>0 then begin + AES_XTS_Decrypt := AES_Err_NIL_Pointer; + exit; + end; + end; + + {$ifdef BIT16} + if (ILen+ofs(ptp^) > $FFFF) or (ILen+ofs(ctp^) > $FFFF) then begin + AES_XTS_Decrypt := AES_Err_Invalid_16Bit_Length; + exit; + end; + {$endif} + + n := ILen div AESBLKSIZE; {Full blocks} + m := ILen mod AESBLKSIZE; {Remaining bytes in short block} + if m<>0 then begin + if n=0 then begin + AES_XTS_Decrypt := AES_Err_Invalid_Length; + exit; + end; + dec(n); {CTS: special treatment of last TWO blocks} + end; + + {encrypt the tweak twk, tweak.IV = enc(twk)} + AES_Encrypt(ctx.tweak, twk, ctx.tweak.IV); + + with ctx.main do begin + for i:=1 to n do begin + AES_XorBlock(PAESBlock(ctp)^, ctx.tweak.IV, buf); + AES_Decrypt(ctx.main, buf, buf); + AES_XorBlock(buf, ctx.tweak.IV, PAESBlock(ptp)^); + mul_a(ctx.tweak.IV); + inc(Ptr2Inc(ptp),AESBLKSIZE); + inc(Ptr2Inc(ctp),AESBLKSIZE); + end; + if m<>0 then begin + {Cipher text stealing, "increment" tweak because} + {final short plaintext is padded in this block} + IV := ctx.tweak.IV; + mul_a(IV); + {Decrypt last full ciphertext block <-> final short plaintext} + AES_XorBlock(PAESBlock(ctp)^, IV, buf); + AES_Decrypt(ctx.main, buf, buf); + AES_XorBlock(buf, IV, buf); + inc(Ptr2Inc(ctp),AESBLKSIZE); + {pad and decrypt short CT block to last full PT block} + IV := buf; + move(PAESBlock(ctp)^, IV, m); + AES_XorBlock(IV, ctx.tweak.IV, IV); + AES_Decrypt(ctx.main, IV, IV); + AES_XorBlock(IV, ctx.tweak.IV, PAESBlock(ptp)^); + inc(Ptr2Inc(ptp),AESBLKSIZE); + move(buf,PAESBlock(ptp)^,m); + end; + end; +end; + + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/btypes.pas b/Tocsg.Lib/VCL/EncLib/AES/btypes.pas new file mode 100644 index 00000000..67eb6c2f --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/btypes.pas @@ -0,0 +1,199 @@ +unit BTypes; + +{Common basic type definitions} + + +interface + + +{$i STD.INC} + +(************************************************************************* + + DESCRIPTION : Common basic type definitions + + REQUIREMENTS : TP5-7, D1-D7/D9-D12/D17-D22, FPC, VP, WDOSX + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : --- + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 15.04.06 W.Ehrhardt Initial version + 0.11 15.04.06 we With $ifdef HAS_XTYPES + 0.12 15.04.06 we FPC1_0 and pShortInt + 0.13 09.09.08 we UInt32 = cardinal $ifdef HAS_CARD32 + 0.14 12.11.08 we Str127, Ptr2Inc + 0.15 14.11.08 we BString, char8 + 0.16 21.11.08 we __P2I: type cast pointer to integer for masking etc + 0.17 02.12.08 we Use pchar and pAnsiChar for pchar8 if possible + 0.18 27.02.09 we pBoolean + 0.19 14.02.12 we extended = double $ifdef SIMULATE_EXT64 + 0.20 06.05.14 we extended = double $ifdef SIMULATE_EXT64 OR EXT64 + 0.21 25.04.15 we With $ifdef HAS_INTXX, HAS_PINTXX +*************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2006-2015 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$ifdef BIT16} +type + Int8 = ShortInt; { 8 bit signed integer} + Int16 = Integer; {16 bit signed integer} + Int32 = Longint; {32 bit signed integer} + UInt8 = Byte; { 8 bit unsigned integer} + UInt16 = Word; {16 bit unsigned integer} + UInt32 = Longint; {32 bit unsigned integer} + + Smallint = Integer; + Shortstring = string; + + pByte = ^Byte; + pBoolean = ^Boolean; + pShortInt = ^ShortInt; + pWord = ^Word; + pSmallInt = ^SmallInt; + pLongint = ^Longint; + +{$else} + + {$ifndef HAS_INTXX} + type + Int8 = ShortInt; { 8 bit signed integer} + Int16 = SmallInt; {16 bit signed integer} + Int32 = Longint; {32 bit signed integer} + UInt8 = Byte; { 8 bit unsigned integer} + UInt16 = Word; {16 bit unsigned integer} + {$ifdef HAS_CARD32} + UInt32 = Cardinal; {32 bit unsigned integer} + {$else} + UInt32 = Longint; {32 bit unsigned integer} + {$endif} + {$endif} + + {$ifndef HAS_XTYPES} + type + pByte = ^Byte; + pBoolean = ^Boolean; + pShortInt = ^ShortInt; + pWord = ^Word; + pSmallInt = ^SmallInt; + pLongint = ^Longint; + {$endif} + {$ifdef FPC} {$ifdef VER1_0} + type + pBoolean = ^Boolean; + pShortInt = ^ShortInt; + {$endif} {$endif} + +{$endif} {BIT16} + +type + Str255 = string[255]; {Handy type to avoid problems with 32 bit and/or unicode} + Str127 = string[127]; + +type +{$ifndef HAS_PINTXX} + pInt8 = ^Int8; + pInt16 = ^Int16; + pInt32 = ^Int32; + pUInt8 = ^UInt8; + pUInt16 = ^UInt16; + pUInt32 = ^UInt32; +{$endif} + pStr255 = ^Str255; + pStr127 = ^Str127; + +{$ifdef BIT16} + {$ifdef V7Plus} + type + BString = string[255]; {String of 8 bit characters} + pBString = ^BString; + char8 = char; {8 bit characters} + pchar8 = pchar; + {$else} + type + BString = string[255]; {String of 8 bit characters} + pBString = ^BString; + char8 = char; {8 bit characters} + pchar8 = ^char; + {$endif} +{$else} + {$ifdef UNICODE} + type + BString = AnsiString; {String of 8 bit characters} + pBString = pAnsiString; + char8 = AnsiChar; {8 bit characters} + pchar8 = pAnsiChar; + {$else} + type + BString = AnsiString; {String of 8 bit characters} + pBString = pAnsiString; + char8 = AnsiChar; {8 bit characters} + pchar8 = pAnsiChar; + {$endif} +{$endif} + + +{$ifdef V7Plus} +type + Ptr2Inc = pByte; {Type cast to increment untyped pointer} +{$else} +type + Ptr2Inc = Longint; {Type cast to increment untyped pointer} +{$endif} + + +{$ifdef FPC} + {$ifdef VER1} + type __P2I = longint; {Type cast pointer to integer for masking etc} + {$else} + type __P2I = PtrUInt; {Type cast pointer to integer for masking etc} + {$endif} +{$else} + {$ifdef BIT64} + type __P2I = NativeInt; {Type cast pointer to integer for masking etc} + {$else} + type __P2I = longint; {Type cast pointer to integer for masking etc} + {$endif} +{$endif} + + +{$ifdef EXT64} + type extended = double; {Force 64-bit 'extended'} +{$else} + {$ifdef SIMULATE_EXT64} + type extended = double; {Debug simulation EXT64} + {$endif} +{$endif} + + +implementation + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/comp_speed b/Tocsg.Lib/VCL/EncLib/AES/comp_speed new file mode 100644 index 00000000..f2dff6e0 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/comp_speed @@ -0,0 +1,25 @@ +Cycles and MB/s for AES core encryption + +Win 98, Pentium 4, 1.8 GHz + +[-F for full tables, -C for compressed tables] + + Compiler Cyc/Bl-F MB/s-F Cyc/Bl-C MB/s-C +~~~~~~~~~~~ ~~~~~~~~ ~~~~~~ ~~~~~~~~ ~~~~~~ + TP5 6302 4.6 5356 5.4 + TP55 6321 4.5 6980 4.1 + TP6 1436 20.0 1762 16.3 + BP7 1493 19.2 1927 14.9 + VPC 426 67.3 425 67.3 + FPC 1 GoV2 542 53.0 541 53.1 + FPC 2.0.2 571 50.2 546 52.5 +FPC 2.2 -O3 416 69.0 417 68.8 + Delphi2 365 78.6 398 72.1 + Delphi3 373 76.9 398 72.1 + Delphi4 386 74.3 398 72.1 + Delphi5 375 76.5 398 72.1 + Delphi6 380 75.5 398 72.1 + Delphi7 380 75.5 398 72.1 + Delphi9 381 76.3 397 72.3 + Delphi10 380 75.0 398 72.1 + diff --git a/Tocsg.Lib/VCL/EncLib/AES/copying_we.txt b/Tocsg.Lib/VCL/EncLib/AES/copying_we.txt new file mode 100644 index 00000000..fe8e4b7d --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/copying_we.txt @@ -0,0 +1,50 @@ +(C) Copyright 2002-2017 Wolfgang Ehrhardt + +Based on "The zlib/libpng License": +http://www.opensource.org/licenses/zlib-license.php + +__________________ +COPYING CONDITIONS + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. + +_______________________________________ +Bedingungen fuer Nutzung und Weitergabe + +Die Software (Quellcodes und Binaerdateien) wird ohne jegliche Zusagen +oder Garantien bezueglich Funktionalitaet oder Funktionsfaehigkeit +abgegeben. Die Autoren uebernehmen keine Verantwortung fuer Schaeden, die +durch die Benutzung der Software verursacht werden. + +Die Software darf frei verwendet und weitergegeben werden (kommerzielle +Nutzung/Weitergabe ist erlaubt), vorausgesetzt die folgenden Bedingungen +werden eingehalten: + +1. Die Herkunft der Software darf nicht falsch angegeben werden; es ist + nicht erlaubt, die Software als Werk eines anderen auszugeben. Wird die + Software in Teilen oder als Ganzes in einem Produkt benutzt, so ist + Hinweis auf die Herkunft in der Dokumentation erwuenscht, aber nicht + notwendig. + +2. Geaenderte Quellcodes muessen deutlich als solche gekennzeichnet werden + und duerfen nicht als die Originalsoftware ausgegeben werden. + +3. Die Bedingungen ueber die Nutzung/Weitergabe duerfen nicht entfernt oder + geaendert werden. + diff --git a/Tocsg.Lib/VCL/EncLib/AES/dec_ca16.inc b/Tocsg.Lib/VCL/EncLib/AES/dec_ca16.inc new file mode 100644 index 00000000..dac01daf --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/dec_ca16.inc @@ -0,0 +1,397 @@ + +(************************************************************************* + Include file for AES_DECR.PAS - AES_Decrypt for BASM16/Compressed table + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version for compressed table + 0.11 10.07.06 we Removed bx in TCd[bx+si+?] + 0.12 13.07.06 we Uses TCd box byte instead of InvSBox +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{16 bit BASM used for TP6, BP7, Delphi1} + +{---------------------------------------------------------------------------} +procedure AES_Decrypt(var ctx: TAESContext; {$ifdef CONST} const {$else} var {$endif} BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} +var + s,t: TAESBlock; + r: integer; + pK: pointer; +begin + r := ctx.Rounds-1; + pK := @ctx.RK[ctx.Rounds]; + asm +{AES_XorBlock(BI, ctx.RK[ctx.Rounds], s);} + + db $66; pusha + + les si,[BI] + db $66; mov ax,es:[si] + db $66; mov bx,es:[si+4] + db $66; mov cx,es:[si+8] + db $66; mov dx,es:[si+12] + + les di,[pK] + db $66; xor ax,es:[di] + db $66; xor bx,es:[di+4] + db $66; xor cx,es:[di+8] + db $66; xor dx,es:[di+12] + + db $66; mov word ptr [s],ax + db $66; mov word ptr [s+4],bx + db $66; mov word ptr [s+8],cx + db $66; mov word ptr [s+12],dx + + + sub di,16 {di -> ctx.RK[r]} + mov cx,[r] + + +{ *Note* in the following round loop } +{ op eax, mem[8*ebx] is calculated as } +{ lea esi, [edx+8*ebx] $66,$67,$8D,$34,$DA } +{ op eax, mem[esi] } + + db $66; sub bx,bx {clear ebx} + db $66; sub dx,dx {clear edx} + +@@1: + + +{TWA4(t)[3] := Td0[s[3*4+0]] xor Td1[s[2*4+1]] xor Td2[s[1*4+2]] xor Td3[s[0*4+3]] xor TWA4(ctx.RK[r])[3];} + mov bl,byte ptr s[3*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCd[si+3] + + mov bl,byte ptr s[2*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+2] + + mov bl,byte ptr s[1*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+1] + + mov bl,byte ptr s[0*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si] + + db $66; xor ax,es:[di+12] + db $66; mov word ptr t[12],ax + +{TWA4(t)[2] := Td0[s[2*4+0]] xor Td1[s[1*4+1]] xor Td2[s[0*4+2]] xor Td3[s[3*4+3]] xor TWA4(ctx.RK[r])[2];} + mov bl,byte ptr s[2*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCd[si+3] + + mov bl,byte ptr s[1*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+2] + + mov bl,byte ptr s[0*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+1] + + mov bl,byte ptr s[3*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si] + + db $66; xor ax,es:[di+8] + db $66; mov word ptr t[8],ax + + +{TWA4(t)[1] := Td0[s[1*4+0]] xor Td1[s[0*4+1]] xor Td2[s[3*4+2]] xor Td3[s[2*4+3]] xor TWA4(ctx.RK[r])[1];} + mov bl,byte ptr s[1*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCd[si+3] + + mov bl,byte ptr s[0*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+2] + + mov bl,byte ptr s[3*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+1] + + mov bl,byte ptr s[2*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si] + + db $66; xor ax,es:[di+4] + db $66; mov word ptr t[4],ax + + +{TWA4(t)[0] := Td0[s[0*4+0]] xor Td1[s[3*4+1]] xor Td2[s[2*4+2]] xor Td3[s[1*4+3]] xor TWA4(ctx.RK[r])[0];} + mov bl,byte ptr s[0*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCd[si+3] + + mov bl,byte ptr s[3*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+2] + + mov bl,byte ptr s[2*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+1] + + mov bl,byte ptr s[1*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si] + + db $66; xor ax,es:[di] + db $66; mov word ptr t[0],ax + +{ dec(r); if r<1 then break;} + sub cx,1 + jle @@2 + +{TWA4(s)[3] := Td0[t[3*4+0]] xor Td1[t[2*4+1]] xor Td2[t[1*4+2]] xor Td3[t[0*4+3]] xor TWA4(ctx.RK[r])[3];} + mov bl,byte ptr t[3*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCd[si+3] + + mov bl,byte ptr t[2*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+2] + + mov bl,byte ptr t[1*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+1] + + mov bl,byte ptr t[0*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si] + + db $66; xor ax,es:[di-4] + db $66; mov word ptr s[12],ax + +{TWA4(s)[2] := Td0[t[2*4+0]] xor Td1[t[1*4+1]] xor Td2[t[0*4+2]] xor Td3[t[3*4+3]] xor TWA4(ctx.RK[r])[2];} + mov bl,byte ptr t[2*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCd[si+3] + + mov bl,byte ptr t[1*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+2] + + mov bl,byte ptr t[0*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+1] + + mov bl,byte ptr t[3*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si] + + db $66; xor ax,es:[di-8] + db $66; mov word ptr s[8],ax + +{TWA4(s)[1] := Td0[t[1*4+0]] xor Td1[t[0*4+1]] xor Td2[t[3*4+2]] xor Td3[t[2*4+3]] xor TWA4(ctx.RK[r])[1];} + mov bl,byte ptr t[1*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCd[si+3] + + mov bl,byte ptr t[0*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+2] + + mov bl,byte ptr t[3*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+1] + + mov bl,byte ptr t[2*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si] + + db $66; xor ax,es:[di-12] + db $66; mov word ptr s[4],ax + +{TWA4(s)[0] := Td0[t[0*4+0]] xor Td1[t[3*4+1]] xor Td2[t[2*4+2]] xor Td3[t[1*4+3]] xor TWA4(ctx.RK[r])[0];} + mov bl,byte ptr t[0*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCd[si+3] + + mov bl,byte ptr t[3*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+2] + + mov bl,byte ptr t[2*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si+1] + + mov bl,byte ptr t[1*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCd[si] + + db $66; xor ax,es:[di-16] + db $66; mov word ptr s[0],ax + + + sub di,32 + dec cx + jmp @@1 + +@@2: sub di,16 {di -> ctx.RK[0]} + sub bx,bx + + mov bl, byte ptr t[0*4+0] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[0],al + + mov bl, byte ptr t[3*4+1] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[1],al + + mov bl, byte ptr t[2*4+2] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[2],al + + mov bl, byte ptr t[1*4+3] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[3],al + + mov bl, byte ptr t[1*4+0] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[4],al + + mov bl, byte ptr t[0*4+1] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[5],al + + mov bl, byte ptr t[3*4+2] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[6],al + + mov bl, byte ptr t[2*4+3] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[7],al + + mov bl, byte ptr t[2*4+0] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[8],al + + mov bl, byte ptr t[1*4+1] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[9],al + + mov bl, byte ptr t[0*4+2] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[10],al + + mov bl, byte ptr t[3*4+3] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[11],al + + mov bl, byte ptr t[3*4+0] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[12],al + + mov bl, byte ptr t[2*4+1] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[13],al + + mov bl, byte ptr t[1*4+2] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[14],al + + mov bl, byte ptr t[0*4+3] + sub bh,bh + shl bx,3 + mov al, byte ptr Tcd[bx+7] + mov byte ptr s[15],al + +{AES_XorBlock(s, ctx.RK[0], BO);} + db $66; mov ax,word ptr [s] + db $66; mov bx,word ptr [s+4] + db $66; mov cx,word ptr [s+8] + db $66; mov dx,word ptr [s+12] + db $66; xor ax,es:[di] + db $66; xor bx,es:[di+4] + db $66; xor cx,es:[di+8] + db $66; xor dx,es:[di+12] + les si,[BO] + db $66; mov es:[si],ax + db $66; mov es:[si+4],bx + db $66; mov es:[si+8],cx + db $66; mov es:[si+12],dx + + db $66; popa + + end; +end; + + +{---------------------------------------------------------------------------} +procedure MakeDecrKey(var ctx: TAESContext); + {-Calculate decryption key from encryption key} +var + n: integer; + p: PLong; +begin + p := Plong(@ctx.RK[1]); + n := 4*(ctx.Rounds-1); + {BASM version of 16 bit code, no need for local x/t} + {implicit endian conversion compared with [2]} + asm + les si,[p] + mov cx,[n] + @@1: mov dx,es:[si] + sub bh,bh + mov bl,dl + mov bl,byte ptr SBox[bx] + shl bx,3 + db $66; mov ax,word ptr TCd[bx+3] + sub bh,bh + mov bl,dh + mov bl,byte ptr SBox[bx] + shl bx,3 + db $66; xor ax,word ptr TCd[bx+2] + mov dx,es:[si+2] + sub bh,bh + mov bl,dl + mov bl,byte ptr SBox[bx] + shl bx,3 + db $66; xor ax,word ptr TCd[bx+1] + sub bh,bh + mov bl,dh + mov bl,byte ptr SBox[bx] + shl bx,3 + db $66; xor ax,word ptr TCd[bx] + db $66; mov es:[si],ax + add si,4 + dec cx + jnz @@1 + end; +end; diff --git a/Tocsg.Lib/VCL/EncLib/AES/dec_cdat.inc b/Tocsg.Lib/VCL/EncLib/AES/dec_cdat.inc new file mode 100644 index 00000000..98835336 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/dec_cdat.inc @@ -0,0 +1,197 @@ + +(************************************************************************* + Include file for AES_DECR.PAS - Compressed tables/Helper types + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version for compressed tables + 0.11 13.07.06 we Removed InvSBox, b3 gets box byte + 0.12 19.07.06 we TCdDummy +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +type + TH3 = packed record + L: longint; + b0,b1,b2,box: byte; + end; + + TH2 = packed record + b0: byte; + L: longint; + b1,b2,box: byte; + end; + + TH1 = packed record + b0,b1: byte; + L: longint; + b2,box: byte; + end; + + TH0 = packed record + b0,b1,b2: byte; + L: longint; + box: byte; + end; + + TDU = record + case integer of + 0: (D0: TH0); + 1: (D1: TH1); + 2: (D2: TH2); + 3: (D3: TH3); + end; + + +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9+ errors!} +{$endif} + + +const + {$ifdef AES_Decr_DummyAlign} + TCdDummy : longint = 0; {Use to align TCd to 8 byte boundary} + {$endif} + TCd: packed array[0..2047] of byte = ( + $f4,$a7,$50,$51,$f4,$a7,$50,$52,$41,$65,$53,$7e,$41,$65,$53,$09, + $17,$a4,$c3,$1a,$17,$a4,$c3,$6a,$27,$5e,$96,$3a,$27,$5e,$96,$d5, + $ab,$6b,$cb,$3b,$ab,$6b,$cb,$30,$9d,$45,$f1,$1f,$9d,$45,$f1,$36, + $fa,$58,$ab,$ac,$fa,$58,$ab,$a5,$e3,$03,$93,$4b,$e3,$03,$93,$38, + $30,$fa,$55,$20,$30,$fa,$55,$bf,$76,$6d,$f6,$ad,$76,$6d,$f6,$40, + $cc,$76,$91,$88,$cc,$76,$91,$a3,$02,$4c,$25,$f5,$02,$4c,$25,$9e, + $e5,$d7,$fc,$4f,$e5,$d7,$fc,$81,$2a,$cb,$d7,$c5,$2a,$cb,$d7,$f3, + $35,$44,$80,$26,$35,$44,$80,$d7,$62,$a3,$8f,$b5,$62,$a3,$8f,$fb, + $b1,$5a,$49,$de,$b1,$5a,$49,$7c,$ba,$1b,$67,$25,$ba,$1b,$67,$e3, + $ea,$0e,$98,$45,$ea,$0e,$98,$39,$fe,$c0,$e1,$5d,$fe,$c0,$e1,$82, + $2f,$75,$02,$c3,$2f,$75,$02,$9b,$4c,$f0,$12,$81,$4c,$f0,$12,$2f, + $46,$97,$a3,$8d,$46,$97,$a3,$ff,$d3,$f9,$c6,$6b,$d3,$f9,$c6,$87, + $8f,$5f,$e7,$03,$8f,$5f,$e7,$34,$92,$9c,$95,$15,$92,$9c,$95,$8e, + $6d,$7a,$eb,$bf,$6d,$7a,$eb,$43,$52,$59,$da,$95,$52,$59,$da,$44, + $be,$83,$2d,$d4,$be,$83,$2d,$c4,$74,$21,$d3,$58,$74,$21,$d3,$de, + $e0,$69,$29,$49,$e0,$69,$29,$e9,$c9,$c8,$44,$8e,$c9,$c8,$44,$cb, + $c2,$89,$6a,$75,$c2,$89,$6a,$54,$8e,$79,$78,$f4,$8e,$79,$78,$7b, + $58,$3e,$6b,$99,$58,$3e,$6b,$94,$b9,$71,$dd,$27,$b9,$71,$dd,$32, + $e1,$4f,$b6,$be,$e1,$4f,$b6,$a6,$88,$ad,$17,$f0,$88,$ad,$17,$c2, + $20,$ac,$66,$c9,$20,$ac,$66,$23,$ce,$3a,$b4,$7d,$ce,$3a,$b4,$3d, + $df,$4a,$18,$63,$df,$4a,$18,$ee,$1a,$31,$82,$e5,$1a,$31,$82,$4c, + $51,$33,$60,$97,$51,$33,$60,$95,$53,$7f,$45,$62,$53,$7f,$45,$0b, + $64,$77,$e0,$b1,$64,$77,$e0,$42,$6b,$ae,$84,$bb,$6b,$ae,$84,$fa, + $81,$a0,$1c,$fe,$81,$a0,$1c,$c3,$08,$2b,$94,$f9,$08,$2b,$94,$4e, + $48,$68,$58,$70,$48,$68,$58,$08,$45,$fd,$19,$8f,$45,$fd,$19,$2e, + $de,$6c,$87,$94,$de,$6c,$87,$a1,$7b,$f8,$b7,$52,$7b,$f8,$b7,$66, + $73,$d3,$23,$ab,$73,$d3,$23,$28,$4b,$02,$e2,$72,$4b,$02,$e2,$d9, + $1f,$8f,$57,$e3,$1f,$8f,$57,$24,$55,$ab,$2a,$66,$55,$ab,$2a,$b2, + $eb,$28,$07,$b2,$eb,$28,$07,$76,$b5,$c2,$03,$2f,$b5,$c2,$03,$5b, + $c5,$7b,$9a,$86,$c5,$7b,$9a,$a2,$37,$08,$a5,$d3,$37,$08,$a5,$49, + $28,$87,$f2,$30,$28,$87,$f2,$6d,$bf,$a5,$b2,$23,$bf,$a5,$b2,$8b, + $03,$6a,$ba,$02,$03,$6a,$ba,$d1,$16,$82,$5c,$ed,$16,$82,$5c,$25, + $cf,$1c,$2b,$8a,$cf,$1c,$2b,$72,$79,$b4,$92,$a7,$79,$b4,$92,$f8, + $07,$f2,$f0,$f3,$07,$f2,$f0,$f6,$69,$e2,$a1,$4e,$69,$e2,$a1,$64, + $da,$f4,$cd,$65,$da,$f4,$cd,$86,$05,$be,$d5,$06,$05,$be,$d5,$68, + $34,$62,$1f,$d1,$34,$62,$1f,$98,$a6,$fe,$8a,$c4,$a6,$fe,$8a,$16, + $2e,$53,$9d,$34,$2e,$53,$9d,$d4,$f3,$55,$a0,$a2,$f3,$55,$a0,$a4, + $8a,$e1,$32,$05,$8a,$e1,$32,$5c,$f6,$eb,$75,$a4,$f6,$eb,$75,$cc, + $83,$ec,$39,$0b,$83,$ec,$39,$5d,$60,$ef,$aa,$40,$60,$ef,$aa,$65, + $71,$9f,$06,$5e,$71,$9f,$06,$b6,$6e,$10,$51,$bd,$6e,$10,$51,$92, + $21,$8a,$f9,$3e,$21,$8a,$f9,$6c,$dd,$06,$3d,$96,$dd,$06,$3d,$70, + $3e,$05,$ae,$dd,$3e,$05,$ae,$48,$e6,$bd,$46,$4d,$e6,$bd,$46,$50, + $54,$8d,$b5,$91,$54,$8d,$b5,$fd,$c4,$5d,$05,$71,$c4,$5d,$05,$ed, + $06,$d4,$6f,$04,$06,$d4,$6f,$b9,$50,$15,$ff,$60,$50,$15,$ff,$da, + $98,$fb,$24,$19,$98,$fb,$24,$5e,$bd,$e9,$97,$d6,$bd,$e9,$97,$15, + $40,$43,$cc,$89,$40,$43,$cc,$46,$d9,$9e,$77,$67,$d9,$9e,$77,$57, + $e8,$42,$bd,$b0,$e8,$42,$bd,$a7,$89,$8b,$88,$07,$89,$8b,$88,$8d, + $19,$5b,$38,$e7,$19,$5b,$38,$9d,$c8,$ee,$db,$79,$c8,$ee,$db,$84, + $7c,$0a,$47,$a1,$7c,$0a,$47,$90,$42,$0f,$e9,$7c,$42,$0f,$e9,$d8, + $84,$1e,$c9,$f8,$84,$1e,$c9,$ab,$00,$00,$00,$00,$00,$00,$00,$00, + $80,$86,$83,$09,$80,$86,$83,$8c,$2b,$ed,$48,$32,$2b,$ed,$48,$bc, + $11,$70,$ac,$1e,$11,$70,$ac,$d3,$5a,$72,$4e,$6c,$5a,$72,$4e,$0a, + $0e,$ff,$fb,$fd,$0e,$ff,$fb,$f7,$85,$38,$56,$0f,$85,$38,$56,$e4, + $ae,$d5,$1e,$3d,$ae,$d5,$1e,$58,$2d,$39,$27,$36,$2d,$39,$27,$05, + $0f,$d9,$64,$0a,$0f,$d9,$64,$b8,$5c,$a6,$21,$68,$5c,$a6,$21,$b3, + $5b,$54,$d1,$9b,$5b,$54,$d1,$45,$36,$2e,$3a,$24,$36,$2e,$3a,$06, + $0a,$67,$b1,$0c,$0a,$67,$b1,$d0,$57,$e7,$0f,$93,$57,$e7,$0f,$2c, + $ee,$96,$d2,$b4,$ee,$96,$d2,$1e,$9b,$91,$9e,$1b,$9b,$91,$9e,$8f, + $c0,$c5,$4f,$80,$c0,$c5,$4f,$ca,$dc,$20,$a2,$61,$dc,$20,$a2,$3f, + $77,$4b,$69,$5a,$77,$4b,$69,$0f,$12,$1a,$16,$1c,$12,$1a,$16,$02, + $93,$ba,$0a,$e2,$93,$ba,$0a,$c1,$a0,$2a,$e5,$c0,$a0,$2a,$e5,$af, + $22,$e0,$43,$3c,$22,$e0,$43,$bd,$1b,$17,$1d,$12,$1b,$17,$1d,$03, + $09,$0d,$0b,$0e,$09,$0d,$0b,$01,$8b,$c7,$ad,$f2,$8b,$c7,$ad,$13, + $b6,$a8,$b9,$2d,$b6,$a8,$b9,$8a,$1e,$a9,$c8,$14,$1e,$a9,$c8,$6b, + $f1,$19,$85,$57,$f1,$19,$85,$3a,$75,$07,$4c,$af,$75,$07,$4c,$91, + $99,$dd,$bb,$ee,$99,$dd,$bb,$11,$7f,$60,$fd,$a3,$7f,$60,$fd,$41, + $01,$26,$9f,$f7,$01,$26,$9f,$4f,$72,$f5,$bc,$5c,$72,$f5,$bc,$67, + $66,$3b,$c5,$44,$66,$3b,$c5,$dc,$fb,$7e,$34,$5b,$fb,$7e,$34,$ea, + $43,$29,$76,$8b,$43,$29,$76,$97,$23,$c6,$dc,$cb,$23,$c6,$dc,$f2, + $ed,$fc,$68,$b6,$ed,$fc,$68,$cf,$e4,$f1,$63,$b8,$e4,$f1,$63,$ce, + $31,$dc,$ca,$d7,$31,$dc,$ca,$f0,$63,$85,$10,$42,$63,$85,$10,$b4, + $97,$22,$40,$13,$97,$22,$40,$e6,$c6,$11,$20,$84,$c6,$11,$20,$73, + $4a,$24,$7d,$85,$4a,$24,$7d,$96,$bb,$3d,$f8,$d2,$bb,$3d,$f8,$ac, + $f9,$32,$11,$ae,$f9,$32,$11,$74,$29,$a1,$6d,$c7,$29,$a1,$6d,$22, + $9e,$2f,$4b,$1d,$9e,$2f,$4b,$e7,$b2,$30,$f3,$dc,$b2,$30,$f3,$ad, + $86,$52,$ec,$0d,$86,$52,$ec,$35,$c1,$e3,$d0,$77,$c1,$e3,$d0,$85, + $b3,$16,$6c,$2b,$b3,$16,$6c,$e2,$70,$b9,$99,$a9,$70,$b9,$99,$f9, + $94,$48,$fa,$11,$94,$48,$fa,$37,$e9,$64,$22,$47,$e9,$64,$22,$e8, + $fc,$8c,$c4,$a8,$fc,$8c,$c4,$1c,$f0,$3f,$1a,$a0,$f0,$3f,$1a,$75, + $7d,$2c,$d8,$56,$7d,$2c,$d8,$df,$33,$90,$ef,$22,$33,$90,$ef,$6e, + $49,$4e,$c7,$87,$49,$4e,$c7,$47,$38,$d1,$c1,$d9,$38,$d1,$c1,$f1, + $ca,$a2,$fe,$8c,$ca,$a2,$fe,$1a,$d4,$0b,$36,$98,$d4,$0b,$36,$71, + $f5,$81,$cf,$a6,$f5,$81,$cf,$1d,$7a,$de,$28,$a5,$7a,$de,$28,$29, + $b7,$8e,$26,$da,$b7,$8e,$26,$c5,$ad,$bf,$a4,$3f,$ad,$bf,$a4,$89, + $3a,$9d,$e4,$2c,$3a,$9d,$e4,$6f,$78,$92,$0d,$50,$78,$92,$0d,$b7, + $5f,$cc,$9b,$6a,$5f,$cc,$9b,$62,$7e,$46,$62,$54,$7e,$46,$62,$0e, + $8d,$13,$c2,$f6,$8d,$13,$c2,$aa,$d8,$b8,$e8,$90,$d8,$b8,$e8,$18, + $39,$f7,$5e,$2e,$39,$f7,$5e,$be,$c3,$af,$f5,$82,$c3,$af,$f5,$1b, + $5d,$80,$be,$9f,$5d,$80,$be,$fc,$d0,$93,$7c,$69,$d0,$93,$7c,$56, + $d5,$2d,$a9,$6f,$d5,$2d,$a9,$3e,$25,$12,$b3,$cf,$25,$12,$b3,$4b, + $ac,$99,$3b,$c8,$ac,$99,$3b,$c6,$18,$7d,$a7,$10,$18,$7d,$a7,$d2, + $9c,$63,$6e,$e8,$9c,$63,$6e,$79,$3b,$bb,$7b,$db,$3b,$bb,$7b,$20, + $26,$78,$09,$cd,$26,$78,$09,$9a,$59,$18,$f4,$6e,$59,$18,$f4,$db, + $9a,$b7,$01,$ec,$9a,$b7,$01,$c0,$4f,$9a,$a8,$83,$4f,$9a,$a8,$fe, + $95,$6e,$65,$e6,$95,$6e,$65,$78,$ff,$e6,$7e,$aa,$ff,$e6,$7e,$cd, + $bc,$cf,$08,$21,$bc,$cf,$08,$5a,$15,$e8,$e6,$ef,$15,$e8,$e6,$f4, + $e7,$9b,$d9,$ba,$e7,$9b,$d9,$1f,$6f,$36,$ce,$4a,$6f,$36,$ce,$dd, + $9f,$09,$d4,$ea,$9f,$09,$d4,$a8,$b0,$7c,$d6,$29,$b0,$7c,$d6,$33, + $a4,$b2,$af,$31,$a4,$b2,$af,$88,$3f,$23,$31,$2a,$3f,$23,$31,$07, + $a5,$94,$30,$c6,$a5,$94,$30,$c7,$a2,$66,$c0,$35,$a2,$66,$c0,$31, + $4e,$bc,$37,$74,$4e,$bc,$37,$b1,$82,$ca,$a6,$fc,$82,$ca,$a6,$12, + $90,$d0,$b0,$e0,$90,$d0,$b0,$10,$a7,$d8,$15,$33,$a7,$d8,$15,$59, + $04,$98,$4a,$f1,$04,$98,$4a,$27,$ec,$da,$f7,$41,$ec,$da,$f7,$80, + $cd,$50,$0e,$7f,$cd,$50,$0e,$ec,$91,$f6,$2f,$17,$91,$f6,$2f,$5f, + $4d,$d6,$8d,$76,$4d,$d6,$8d,$60,$ef,$b0,$4d,$43,$ef,$b0,$4d,$51, + $aa,$4d,$54,$cc,$aa,$4d,$54,$7f,$96,$04,$df,$e4,$96,$04,$df,$a9, + $d1,$b5,$e3,$9e,$d1,$b5,$e3,$19,$6a,$88,$1b,$4c,$6a,$88,$1b,$b5, + $2c,$1f,$b8,$c1,$2c,$1f,$b8,$4a,$65,$51,$7f,$46,$65,$51,$7f,$0d, + $5e,$ea,$04,$9d,$5e,$ea,$04,$2d,$8c,$35,$5d,$01,$8c,$35,$5d,$e5, + $87,$74,$73,$fa,$87,$74,$73,$7a,$0b,$41,$2e,$fb,$0b,$41,$2e,$9f, + $67,$1d,$5a,$b3,$67,$1d,$5a,$93,$db,$d2,$52,$92,$db,$d2,$52,$c9, + $10,$56,$33,$e9,$10,$56,$33,$9c,$d6,$47,$13,$6d,$d6,$47,$13,$ef, + $d7,$61,$8c,$9a,$d7,$61,$8c,$a0,$a1,$0c,$7a,$37,$a1,$0c,$7a,$e0, + $f8,$14,$8e,$59,$f8,$14,$8e,$3b,$13,$3c,$89,$eb,$13,$3c,$89,$4d, + $a9,$27,$ee,$ce,$a9,$27,$ee,$ae,$61,$c9,$35,$b7,$61,$c9,$35,$2a, + $1c,$e5,$ed,$e1,$1c,$e5,$ed,$f5,$47,$b1,$3c,$7a,$47,$b1,$3c,$b0, + $d2,$df,$59,$9c,$d2,$df,$59,$c8,$f2,$73,$3f,$55,$f2,$73,$3f,$eb, + $14,$ce,$79,$18,$14,$ce,$79,$bb,$c7,$37,$bf,$73,$c7,$37,$bf,$3c, + $f7,$cd,$ea,$53,$f7,$cd,$ea,$83,$fd,$aa,$5b,$5f,$fd,$aa,$5b,$53, + $3d,$6f,$14,$df,$3d,$6f,$14,$99,$44,$db,$86,$78,$44,$db,$86,$61, + $af,$f3,$81,$ca,$af,$f3,$81,$17,$68,$c4,$3e,$b9,$68,$c4,$3e,$2b, + $24,$34,$2c,$38,$24,$34,$2c,$04,$a3,$40,$5f,$c2,$a3,$40,$5f,$7e, + $1d,$c3,$72,$16,$1d,$c3,$72,$ba,$e2,$25,$0c,$bc,$e2,$25,$0c,$77, + $3c,$49,$8b,$28,$3c,$49,$8b,$d6,$0d,$95,$41,$ff,$0d,$95,$41,$26, + $a8,$01,$71,$39,$a8,$01,$71,$e1,$0c,$b3,$de,$08,$0c,$b3,$de,$69, + $b4,$e4,$9c,$d8,$b4,$e4,$9c,$14,$56,$c1,$90,$64,$56,$c1,$90,$63, + $cb,$84,$61,$7b,$cb,$84,$61,$55,$32,$b6,$70,$d5,$32,$b6,$70,$21, + $6c,$5c,$74,$48,$6c,$5c,$74,$0c,$b8,$57,$42,$d0,$b8,$57,$42,$7d); +var + Td: packed array[byte] of TDU absolute TCd; + +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} + + diff --git a/Tocsg.Lib/VCL/EncLib/AES/dec_cp16.inc b/Tocsg.Lib/VCL/EncLib/AES/dec_cp16.inc new file mode 100644 index 00000000..21bcab51 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/dec_cp16.inc @@ -0,0 +1,94 @@ + +(************************************************************************* + Include file for AES_DECR.PAS - AES_Decrypt for Pascal16/Compressed tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version for compressed tables + 0.11 13.07.06 we Uses TDe box byte instead of InvSBox + 0.12 15.11.08 we Use Ptr2Inc from BTypes +**************************************************************************) + +(**** (C) Copyright 2002-2008 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{Normally used for TP5/5.5 (and during development BP7)} + +{---------------------------------------------------------------------------} +procedure AES_Decrypt(var ctx: TAESContext; {$ifdef CONST} const {$else} var {$endif} BI: TAESBlock; var BO: TAESBlock); + {-decrypt one block (in ECB mode)} +label done; +var + r: integer; + pK: PWA4; {pointer to loop rount key } + s,t: TAESBlock; +begin + {Setup key pointer} + pK := PWA4(@ctx.RK[ctx.Rounds]); + {Initialize with input block} + TWA4(s)[0] := TWA4(BI)[0] xor pK^[0]; + TWA4(s)[1] := TWA4(BI)[1] xor pK^[1]; + TWA4(s)[2] := TWA4(BI)[2] xor pK^[2]; + TWA4(s)[3] := TWA4(BI)[3] xor pK^[3]; + dec(Ptr2Inc(pK), 4*sizeof(longint)); + r := ctx.Rounds-1; + while true do begin + TWA4(t)[3] := Td[s[3*4+0]].D0.L xor Td[s[2*4+1]].D1.L xor Td[s[1*4+2]].D2.L xor Td[s[0*4+3]].D3.L xor pK^[3]; + TWA4(t)[2] := Td[s[2*4+0]].D0.L xor Td[s[1*4+1]].D1.L xor Td[s[0*4+2]].D2.L xor Td[s[3*4+3]].D3.L xor pK^[2]; + TWA4(t)[1] := Td[s[1*4+0]].D0.L xor Td[s[0*4+1]].D1.L xor Td[s[3*4+2]].D2.L xor Td[s[2*4+3]].D3.L xor pK^[1]; + TWA4(t)[0] := Td[s[0*4+0]].D0.L xor Td[s[3*4+1]].D1.L xor Td[s[2*4+2]].D2.L xor Td[s[1*4+3]].D3.L xor pK^[0]; + dec(Ptr2Inc(pK), 4*sizeof(longint)); + dec(r); + if r<1 then goto done; + TWA4(s)[3] := Td[t[3*4+0]].D0.L xor Td[t[2*4+1]].D1.L xor Td[t[1*4+2]].D2.L xor Td[t[0*4+3]].D3.L xor pK^[3]; + TWA4(s)[2] := Td[t[2*4+0]].D0.L xor Td[t[1*4+1]].D1.L xor Td[t[0*4+2]].D2.L xor Td[t[3*4+3]].D3.L xor pK^[2]; + TWA4(s)[1] := Td[t[1*4+0]].D0.L xor Td[t[0*4+1]].D1.L xor Td[t[3*4+2]].D2.L xor Td[t[2*4+3]].D3.L xor pK^[1]; + TWA4(s)[0] := Td[t[0*4+0]].D0.L xor Td[t[3*4+1]].D1.L xor Td[t[2*4+2]].D2.L xor Td[t[1*4+3]].D3.L xor pK^[0]; + dec(Ptr2Inc(pK), 4*sizeof(longint)); + dec(r); + end; + +done: + + s[00] := Td[t[0*4+0]].D0.box; + s[01] := Td[t[3*4+1]].D0.box; + s[02] := Td[t[2*4+2]].D0.box; + s[03] := Td[t[1*4+3]].D0.box; + s[04] := Td[t[1*4+0]].D0.box; + s[05] := Td[t[0*4+1]].D0.box; + s[06] := Td[t[3*4+2]].D0.box; + s[07] := Td[t[2*4+3]].D0.box; + s[08] := Td[t[2*4+0]].D0.box; + s[09] := Td[t[1*4+1]].D0.box; + s[10] := Td[t[0*4+2]].D0.box; + s[11] := Td[t[3*4+3]].D0.box; + s[12] := Td[t[3*4+0]].D0.box; + s[13] := Td[t[2*4+1]].D0.box; + s[14] := Td[t[1*4+2]].D0.box; + s[15] := Td[t[0*4+3]].D0.box; + + TWA4(BO)[0] := TWA4(s)[0] xor pK^[0]; + TWA4(BO)[1] := TWA4(s)[1] xor pK^[1]; + TWA4(BO)[2] := TWA4(s)[2] xor pK^[2]; + TWA4(BO)[3] := TWA4(s)[3] xor pK^[3]; +end; + + +{---------------------------------------------------------------------------} +procedure MakeDecrKey(var ctx: TAESContext); + {-Calculate decryption key from encryption key} +var + i: integer; + x: longint; + t: TBA4 absolute x; +begin + with ctx do begin + for i:=4 to 4*Rounds-1 do begin + {Inverse MixColumns transformation: use Sbox and} + {implicit endian conversion compared with [2] } + x := TAWK(RK)[i]; + TAWK(RK)[i] := Td[SBox[t[3]]].D3.L xor Td[SBox[t[2]]].D2.L xor Td[SBox[t[1]]].D1.L xor Td[SBox[t[0]]].D0.L; + end; + end; +end; + diff --git a/Tocsg.Lib/VCL/EncLib/AES/dec_cp32.inc b/Tocsg.Lib/VCL/EncLib/AES/dec_cp32.inc new file mode 100644 index 00000000..2d9b3be3 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/dec_cp32.inc @@ -0,0 +1,83 @@ +(************************************************************************* + Include file for AES_DECR.PAS - AES_Decrypt for BIT32/Compressed tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version for compressed tables + 0.11 09.07.06 we Removed AES_LONGBOX code + 0.12 13.07.06 we Uses TCd box byte instead of InvSBox +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{---------------------------------------------------------------------------} +procedure AES_Decrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); + {-decrypt one block (in ECB mode)} +var + r: integer; {round loop countdown counter} + pK: PWA4; {pointer to loop rount key } + s0,s1,s2,s3: longint; {TAESBlock s as separate variables} + t: TWA4; +begin + + {Setup key pointer} + pK := PWA4(@ctx.RK[ctx.Rounds]); + + {Initialize with input block} + s0 := TWA4(BI)[0] xor pK^[0]; + s1 := TWA4(BI)[1] xor pK^[1]; + s2 := TWA4(BI)[2] xor pK^[2]; + s3 := TWA4(BI)[3] xor pK^[3]; + + dec(pK); + {perform encryption rounds} + for r:=1 to ctx.Rounds-1 do begin + t[3] := Td[s3 and $ff].D0.L xor Td[s2 shr 8 and $ff].D1.L xor Td[s1 shr 16 and $ff].D2.L xor Td[s0 shr 24].D3.L xor pK^[3]; + t[2] := Td[s2 and $ff].D0.L xor Td[s1 shr 8 and $ff].D1.L xor Td[s0 shr 16 and $ff].D2.L xor Td[s3 shr 24].D3.L xor pK^[2]; + t[1] := Td[s1 and $ff].D0.L xor Td[s0 shr 8 and $ff].D1.L xor Td[s3 shr 16 and $ff].D2.L xor Td[s2 shr 24].D3.L xor pK^[1]; + s0 := Td[s0 and $ff].D0.L xor Td[s3 shr 8 and $ff].D1.L xor Td[s2 shr 16 and $ff].D2.L xor Td[s1 shr 24].D3.L xor pK^[0]; + s1 := t[1]; + s2 := t[2]; + s3 := t[3]; + dec(pK); + end; + + {Uses InvSbox byte from Td and shl, needs type cast longint() for 16 bit compilers} + TWA4(BO)[0] := (longint(Td[s0 and $ff].D0.box) xor + longint(Td[s3 shr 8 and $ff].D0.box) shl 8 xor + longint(Td[s2 shr 16 and $ff].D0.box) shl 16 xor + longint(Td[s1 shr 24 ].D0.box) shl 24 ) xor pK^[0]; + TWA4(BO)[1] := (longint(Td[s1 and $ff].D0.box) xor + longint(Td[s0 shr 8 and $ff].D0.box) shl 8 xor + longint(Td[s3 shr 16 and $ff].D0.box) shl 16 xor + longint(Td[s2 shr 24 ].D0.box) shl 24 ) xor pK^[1]; + TWA4(BO)[2] := (longint(Td[s2 and $ff ].D0.box) xor + longint(Td[s1 shr 8 and $ff].D0.box) shl 8 xor + longint(Td[s0 shr 16 and $ff].D0.box) shl 16 xor + longint(Td[s3 shr 24 ].D0.box) shl 24 ) xor pK^[2]; + TWA4(BO)[3] := (longint(Td[s3 and $ff ].D0.box) xor + longint(Td[s2 shr 8 and $ff].D0.box) shl 8 xor + longint(Td[s1 shr 16 and $ff].D0.box) shl 16 xor + longint(Td[s0 shr 24 ].D0.box) shl 24 ) xor pK^[3]; + +end; + + +{---------------------------------------------------------------------------} +procedure MakeDecrKey(var ctx: TAESContext); + {-Calculate decryption key from encryption key} +var + i: integer; + p: PLong; + x: longint; +begin + p := PLong(@ctx.RK[1]); + for i:=1 to 4*(ctx.Rounds-1) do begin + x := p^; + p^ := Td[SBox[x shr 24]].D3.L xor Td[SBox[x shr 16 and $ff]].D2.L xor + Td[SBox[x shr 8 and $ff]].D1.L xor Td[SBox[x and $ff]].D0.L; + inc(p); + end; +end; + diff --git a/Tocsg.Lib/VCL/EncLib/AES/dec_fa16.inc b/Tocsg.Lib/VCL/EncLib/AES/dec_fa16.inc new file mode 100644 index 00000000..b16b1b8d --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/dec_fa16.inc @@ -0,0 +1,358 @@ +(************************************************************************* + Include file for AES_DECR.PAS - AES_Decrypt for BASM16/Full tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version from AES_DECR.PAS +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + +{16 bit BASM used for TP6, BP7, Delphi1} + +{---------------------------------------------------------------------------} +procedure AES_Decrypt(var ctx: TAESContext; {$ifdef CONST} const {$else} var {$endif} BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} +var + s,t: TAESBlock; + r: integer; + pK: pointer; +begin + r := ctx.Rounds-1; + pK := @ctx.RK[ctx.Rounds]; + asm +{AES_XorBlock(BI, ctx.RK[ctx.Rounds], s);} + + db $66; pusha + + les si,[BI] + db $66; mov ax,es:[si] + db $66; mov bx,es:[si+4] + db $66; mov cx,es:[si+8] + db $66; mov dx,es:[si+12] + + les di,[pK] + db $66; xor ax,es:[di] + db $66; xor bx,es:[di+4] + db $66; xor cx,es:[di+8] + db $66; xor dx,es:[di+12] + + db $66; mov word ptr [s],ax + db $66; mov word ptr [s+4],bx + db $66; mov word ptr [s+8],cx + db $66; mov word ptr [s+12],dx + + + sub di,16 {di -> ctx.RK[r]} + mov cx,[r] + +{ op eax, mem[4*bx] is calculated as } +{ lea esi, [ebx + 2*ebx] } +{ op eax, mem[ebx+esi] } +{ lea esi,[ebx+2*ebx] = db $66,$67,$8D,$34,$5B; } + db $66; sub bx,bx +@@1: + + +{TWA4(t)[3] := Td0[s[3*4+0]] xor Td1[s[2*4+1]] xor Td2[s[1*4+2]] xor Td3[s[0*4+3]] xor TWA4(ctx.RK[r])[3];} + mov bl,byte ptr s[3*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Td0[bx+si] + + mov bl,byte ptr s[2*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td1[bx+si] + + mov bl,byte ptr s[1*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td2[bx+si] + + mov bl,byte ptr s[0*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td3[bx+si] + + db $66; xor ax,es:[di+12] + db $66; mov word ptr t[12],ax + +{TWA4(t)[2] := Td0[s[2*4+0]] xor Td1[s[1*4+1]] xor Td2[s[0*4+2]] xor Td3[s[3*4+3]] xor TWA4(ctx.RK[r])[2];} + mov bl,byte ptr s[2*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Td0[bx+si] + + mov bl,byte ptr s[1*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td1[bx+si] + + mov bl,byte ptr s[0*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td2[bx+si] + + mov bl,byte ptr s[3*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td3[bx+si] + + db $66; xor ax,es:[di+8] + db $66; mov word ptr t[8],ax + + +{TWA4(t)[1] := Td0[s[1*4+0]] xor Td1[s[0*4+1]] xor Td2[s[3*4+2]] xor Td3[s[2*4+3]] xor TWA4(ctx.RK[r])[1];} + mov bl,byte ptr s[1*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Td0[bx+si] + + mov bl,byte ptr s[0*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td1[bx+si] + + mov bl,byte ptr s[3*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td2[bx+si] + + mov bl,byte ptr s[2*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td3[bx+si] + + db $66; xor ax,es:[di+4] + db $66; mov word ptr t[4],ax + + +{TWA4(t)[0] := Td0[s[0*4+0]] xor Td1[s[3*4+1]] xor Td2[s[2*4+2]] xor Td3[s[1*4+3]] xor TWA4(ctx.RK[r])[0];} + mov bl,byte ptr s[0*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Td0[bx+si] + + mov bl,byte ptr s[3*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td1[bx+si] + + mov bl,byte ptr s[2*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td2[bx+si] + + mov bl,byte ptr s[1*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td3[bx+si] + + db $66; xor ax,es:[di] + db $66; mov word ptr t[0],ax + +{ dec(r); if r<1 then break;} + sub cx,1 + jle @@2 + +{TWA4(s)[3] := Td0[t[3*4+0]] xor Td1[t[2*4+1]] xor Td2[t[1*4+2]] xor Td3[t[0*4+3]] xor TWA4(ctx.RK[r])[3];} + mov bl,byte ptr t[3*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Td0[bx+si] + + mov bl,byte ptr t[2*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td1[bx+si] + + mov bl,byte ptr t[1*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td2[bx+si] + + mov bl,byte ptr t[0*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td3[bx+si] + + db $66; xor ax,es:[di-4] + db $66; mov word ptr s[12],ax + +{TWA4(s)[2] := Td0[t[2*4+0]] xor Td1[t[1*4+1]] xor Td2[t[0*4+2]] xor Td3[t[3*4+3]] xor TWA4(ctx.RK[r])[2];} + mov bl,byte ptr t[2*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Td0[bx+si] + + mov bl,byte ptr t[1*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td1[bx+si] + + mov bl,byte ptr t[0*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td2[bx+si] + + mov bl,byte ptr t[3*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td3[bx+si] + + db $66; xor ax,es:[di-8] + db $66; mov word ptr s[8],ax + +{TWA4(s)[1] := Td0[t[1*4+0]] xor Td1[t[0*4+1]] xor Td2[t[3*4+2]] xor Td3[t[2*4+3]] xor TWA4(ctx.RK[r])[1];} + mov bl,byte ptr t[1*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Td0[bx+si] + + mov bl,byte ptr t[0*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td1[bx+si] + + mov bl,byte ptr t[3*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td2[bx+si] + + mov bl,byte ptr t[2*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td3[bx+si] + + db $66; xor ax,es:[di-12] + db $66; mov word ptr s[4],ax + +{TWA4(s)[0] := Td0[t[0*4+0]] xor Td1[t[3*4+1]] xor Td2[t[2*4+2]] xor Td3[t[1*4+3]] xor TWA4(ctx.RK[r])[0];} + mov bl,byte ptr t[0*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Td0[bx+si] + + mov bl,byte ptr t[3*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td1[bx+si] + + mov bl,byte ptr t[2*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td2[bx+si] + + mov bl,byte ptr t[1*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Td3[bx+si] + + db $66; xor ax,es:[di-16] + db $66; mov word ptr s[0],ax + + + sub di,32 + dec cx + jmp @@1 + +@@2: sub di,16 {di -> ctx.RK[0]} + sub bx,bx + + mov bl, byte ptr t[0*4+0] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[0],al + + mov bl, byte ptr t[3*4+1] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[1],al + + mov bl, byte ptr t[2*4+2] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[2],al + + mov bl, byte ptr t[1*4+3] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[3],al + + mov bl, byte ptr t[1*4+0] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[4],al + + mov bl, byte ptr t[0*4+1] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[5],al + + mov bl, byte ptr t[3*4+2] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[6],al + + mov bl, byte ptr t[2*4+3] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[7],al + + mov bl, byte ptr t[2*4+0] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[8],al + + mov bl, byte ptr t[1*4+1] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[9],al + + mov bl, byte ptr t[0*4+2] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[10],al + + mov bl, byte ptr t[3*4+3] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[11],al + + mov bl, byte ptr t[3*4+0] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[12],al + + mov bl, byte ptr t[2*4+1] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[13],al + + mov bl, byte ptr t[1*4+2] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[14],al + + mov bl, byte ptr t[0*4+3] + mov al, byte ptr InvSBox[bx] + mov byte ptr s[15],al + +{AES_XorBlock(s, ctx.RK[0], BO);} + db $66; mov ax,word ptr [s] + db $66; mov bx,word ptr [s+4] + db $66; mov cx,word ptr [s+8] + db $66; mov dx,word ptr [s+12] + db $66; xor ax,es:[di] + db $66; xor bx,es:[di+4] + db $66; xor cx,es:[di+8] + db $66; xor dx,es:[di+12] + les si,[BO] + db $66; mov es:[si],ax + db $66; mov es:[si+4],bx + db $66; mov es:[si+8],cx + db $66; mov es:[si+12],dx + + db $66; popa + + end; +end; + + +{---------------------------------------------------------------------------} +procedure MakeDecrKey(var ctx: TAESContext); + {-Calculate decryption key from encryption key} +var + n: integer; + p: PLong; +begin + p := Plong(@ctx.RK[1]); + n := 4*(ctx.Rounds-1); + {BASM version of 16 bit code, no need for local x/t} + {implicit endian conversion compared with [2]} + asm + les si,[p] + mov cx,[n] + @@1: mov dx,es:[si] + sub bh,bh + mov bl,dl + mov bl,byte ptr SBox[bx] + shl bx,2 + db $66; mov ax,word ptr Td0[bx] + sub bh,bh + mov bl,dh + mov bl,byte ptr SBox[bx] + shl bx,2 + db $66; xor ax,word ptr Td1[bx] + mov dx,es:[si+2] + sub bh,bh + mov bl,dl + mov bl,byte ptr SBox[bx] + shl bx,2 + db $66; xor ax,word ptr Td2[bx] + sub bh,bh + mov bl,dh + mov bl,byte ptr SBox[bx] + shl bx,2 + db $66; xor ax,word ptr Td3[bx] + db $66; mov es:[si],ax + add si,4 + dec cx + jnz @@1 + end; +end; + diff --git a/Tocsg.Lib/VCL/EncLib/AES/dec_fdat.inc b/Tocsg.Lib/VCL/EncLib/AES/dec_fdat.inc new file mode 100644 index 00000000..09b84b26 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/dec_fdat.inc @@ -0,0 +1,224 @@ +(************************************************************************* + Include file for AES_DECR.PAS - Full tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version from AES_DECR.PAS +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9+ errors!} +{$endif} + + +const + InvSBox: array[byte] of byte = + ($52, $09, $6a, $d5, $30, $36, $a5, $38, $bf, $40, $a3, $9e, $81, $f3, $d7, $fb, + $7c, $e3, $39, $82, $9b, $2f, $ff, $87, $34, $8e, $43, $44, $c4, $de, $e9, $cb, + $54, $7b, $94, $32, $a6, $c2, $23, $3d, $ee, $4c, $95, $0b, $42, $fa, $c3, $4e, + $08, $2e, $a1, $66, $28, $d9, $24, $b2, $76, $5b, $a2, $49, $6d, $8b, $d1, $25, + $72, $f8, $f6, $64, $86, $68, $98, $16, $d4, $a4, $5c, $cc, $5d, $65, $b6, $92, + $6c, $70, $48, $50, $fd, $ed, $b9, $da, $5e, $15, $46, $57, $a7, $8d, $9d, $84, + $90, $d8, $ab, $00, $8c, $bc, $d3, $0a, $f7, $e4, $58, $05, $b8, $b3, $45, $06, + $d0, $2c, $1e, $8f, $ca, $3f, $0f, $02, $c1, $af, $bd, $03, $01, $13, $8a, $6b, + $3a, $91, $11, $41, $4f, $67, $dc, $ea, $97, $f2, $cf, $ce, $f0, $b4, $e6, $73, + $96, $ac, $74, $22, $e7, $ad, $35, $85, $e2, $f9, $37, $e8, $1c, $75, $df, $6e, + $47, $f1, $1a, $71, $1d, $29, $c5, $89, $6f, $b7, $62, $0e, $aa, $18, $be, $1b, + $fc, $56, $3e, $4b, $c6, $d2, $79, $20, $9a, $db, $c0, $fe, $78, $cd, $5a, $f4, + $1f, $dd, $a8, $33, $88, $07, $c7, $31, $b1, $12, $10, $59, $27, $80, $ec, $5f, + $60, $51, $7f, $a9, $19, $b5, $4a, $0d, $2d, $e5, $7a, $9f, $93, $c9, $9c, $ef, + $a0, $e0, $3b, $4d, $ae, $2a, $f5, $b0, $c8, $eb, $bb, $3c, $83, $53, $99, $61, + $17, $2b, $04, $7e, $ba, $77, $d6, $26, $e1, $69, $14, $63, $55, $21, $0c, $7d); + + +const + Td0: array[byte] of longint = + ($50a7f451, $5365417e, $c3a4171a, $965e273a, $cb6bab3b, $f1459d1f, $ab58faac, $9303e34b, + $55fa3020, $f66d76ad, $9176cc88, $254c02f5, $fcd7e54f, $d7cb2ac5, $80443526, $8fa362b5, + $495ab1de, $671bba25, $980eea45, $e1c0fe5d, $02752fc3, $12f04c81, $a397468d, $c6f9d36b, + $e75f8f03, $959c9215, $eb7a6dbf, $da595295, $2d83bed4, $d3217458, $2969e049, $44c8c98e, + $6a89c275, $78798ef4, $6b3e5899, $dd71b927, $b64fe1be, $17ad88f0, $66ac20c9, $b43ace7d, + $184adf63, $82311ae5, $60335197, $457f5362, $e07764b1, $84ae6bbb, $1ca081fe, $942b08f9, + $58684870, $19fd458f, $876cde94, $b7f87b52, $23d373ab, $e2024b72, $578f1fe3, $2aab5566, + $0728ebb2, $03c2b52f, $9a7bc586, $a50837d3, $f2872830, $b2a5bf23, $ba6a0302, $5c8216ed, + $2b1ccf8a, $92b479a7, $f0f207f3, $a1e2694e, $cdf4da65, $d5be0506, $1f6234d1, $8afea6c4, + $9d532e34, $a055f3a2, $32e18a05, $75ebf6a4, $39ec830b, $aaef6040, $069f715e, $51106ebd, + $f98a213e, $3d06dd96, $ae053edd, $46bde64d, $b58d5491, $055dc471, $6fd40604, $ff155060, + $24fb9819, $97e9bdd6, $cc434089, $779ed967, $bd42e8b0, $888b8907, $385b19e7, $dbeec879, + $470a7ca1, $e90f427c, $c91e84f8, $00000000, $83868009, $48ed2b32, $ac70111e, $4e725a6c, + $fbff0efd, $5638850f, $1ed5ae3d, $27392d36, $64d90f0a, $21a65c68, $d1545b9b, $3a2e3624, + $b1670a0c, $0fe75793, $d296eeb4, $9e919b1b, $4fc5c080, $a220dc61, $694b775a, $161a121c, + $0aba93e2, $e52aa0c0, $43e0223c, $1d171b12, $0b0d090e, $adc78bf2, $b9a8b62d, $c8a91e14, + $8519f157, $4c0775af, $bbdd99ee, $fd607fa3, $9f2601f7, $bcf5725c, $c53b6644, $347efb5b, + $7629438b, $dcc623cb, $68fcedb6, $63f1e4b8, $cadc31d7, $10856342, $40229713, $2011c684, + $7d244a85, $f83dbbd2, $1132f9ae, $6da129c7, $4b2f9e1d, $f330b2dc, $ec52860d, $d0e3c177, + $6c16b32b, $99b970a9, $fa489411, $2264e947, $c48cfca8, $1a3ff0a0, $d82c7d56, $ef903322, + $c74e4987, $c1d138d9, $fea2ca8c, $360bd498, $cf81f5a6, $28de7aa5, $268eb7da, $a4bfad3f, + $e49d3a2c, $0d927850, $9bcc5f6a, $62467e54, $c2138df6, $e8b8d890, $5ef7392e, $f5afc382, + $be805d9f, $7c93d069, $a92dd56f, $b31225cf, $3b99acc8, $a77d1810, $6e639ce8, $7bbb3bdb, + $097826cd, $f418596e, $01b79aec, $a89a4f83, $656e95e6, $7ee6ffaa, $08cfbc21, $e6e815ef, + $d99be7ba, $ce366f4a, $d4099fea, $d67cb029, $afb2a431, $31233f2a, $3094a5c6, $c066a235, + $37bc4e74, $a6ca82fc, $b0d090e0, $15d8a733, $4a9804f1, $f7daec41, $0e50cd7f, $2ff69117, + $8dd64d76, $4db0ef43, $544daacc, $df0496e4, $e3b5d19e, $1b886a4c, $b81f2cc1, $7f516546, + $04ea5e9d, $5d358c01, $737487fa, $2e410bfb, $5a1d67b3, $52d2db92, $335610e9, $1347d66d, + $8c61d79a, $7a0ca137, $8e14f859, $893c13eb, $ee27a9ce, $35c961b7, $ede51ce1, $3cb1477a, + $59dfd29c, $3f73f255, $79ce1418, $bf37c773, $eacdf753, $5baafd5f, $146f3ddf, $86db4478, + $81f3afca, $3ec468b9, $2c342438, $5f40a3c2, $72c31d16, $0c25e2bc, $8b493c28, $41950dff, + $7101a839, $deb30c08, $9ce4b4d8, $90c15664, $6184cb7b, $70b632d5, $745c6c48, $4257b8d0); + + Td1: array[byte] of longint = + ($a7f45150, $65417e53, $a4171ac3, $5e273a96, $6bab3bcb, $459d1ff1, $58faacab, $03e34b93, + $fa302055, $6d76adf6, $76cc8891, $4c02f525, $d7e54ffc, $cb2ac5d7, $44352680, $a362b58f, + $5ab1de49, $1bba2567, $0eea4598, $c0fe5de1, $752fc302, $f04c8112, $97468da3, $f9d36bc6, + $5f8f03e7, $9c921595, $7a6dbfeb, $595295da, $83bed42d, $217458d3, $69e04929, $c8c98e44, + $89c2756a, $798ef478, $3e58996b, $71b927dd, $4fe1beb6, $ad88f017, $ac20c966, $3ace7db4, + $4adf6318, $311ae582, $33519760, $7f536245, $7764b1e0, $ae6bbb84, $a081fe1c, $2b08f994, + $68487058, $fd458f19, $6cde9487, $f87b52b7, $d373ab23, $024b72e2, $8f1fe357, $ab55662a, + $28ebb207, $c2b52f03, $7bc5869a, $0837d3a5, $872830f2, $a5bf23b2, $6a0302ba, $8216ed5c, + $1ccf8a2b, $b479a792, $f207f3f0, $e2694ea1, $f4da65cd, $be0506d5, $6234d11f, $fea6c48a, + $532e349d, $55f3a2a0, $e18a0532, $ebf6a475, $ec830b39, $ef6040aa, $9f715e06, $106ebd51, + $8a213ef9, $06dd963d, $053eddae, $bde64d46, $8d5491b5, $5dc47105, $d406046f, $155060ff, + $fb981924, $e9bdd697, $434089cc, $9ed96777, $42e8b0bd, $8b890788, $5b19e738, $eec879db, + $0a7ca147, $0f427ce9, $1e84f8c9, $00000000, $86800983, $ed2b3248, $70111eac, $725a6c4e, + $ff0efdfb, $38850f56, $d5ae3d1e, $392d3627, $d90f0a64, $a65c6821, $545b9bd1, $2e36243a, + $670a0cb1, $e757930f, $96eeb4d2, $919b1b9e, $c5c0804f, $20dc61a2, $4b775a69, $1a121c16, + $ba93e20a, $2aa0c0e5, $e0223c43, $171b121d, $0d090e0b, $c78bf2ad, $a8b62db9, $a91e14c8, + $19f15785, $0775af4c, $dd99eebb, $607fa3fd, $2601f79f, $f5725cbc, $3b6644c5, $7efb5b34, + $29438b76, $c623cbdc, $fcedb668, $f1e4b863, $dc31d7ca, $85634210, $22971340, $11c68420, + $244a857d, $3dbbd2f8, $32f9ae11, $a129c76d, $2f9e1d4b, $30b2dcf3, $52860dec, $e3c177d0, + $16b32b6c, $b970a999, $489411fa, $64e94722, $8cfca8c4, $3ff0a01a, $2c7d56d8, $903322ef, + $4e4987c7, $d138d9c1, $a2ca8cfe, $0bd49836, $81f5a6cf, $de7aa528, $8eb7da26, $bfad3fa4, + $9d3a2ce4, $9278500d, $cc5f6a9b, $467e5462, $138df6c2, $b8d890e8, $f7392e5e, $afc382f5, + $805d9fbe, $93d0697c, $2dd56fa9, $1225cfb3, $99acc83b, $7d1810a7, $639ce86e, $bb3bdb7b, + $7826cd09, $18596ef4, $b79aec01, $9a4f83a8, $6e95e665, $e6ffaa7e, $cfbc2108, $e815efe6, + $9be7bad9, $366f4ace, $099fead4, $7cb029d6, $b2a431af, $233f2a31, $94a5c630, $66a235c0, + $bc4e7437, $ca82fca6, $d090e0b0, $d8a73315, $9804f14a, $daec41f7, $50cd7f0e, $f691172f, + $d64d768d, $b0ef434d, $4daacc54, $0496e4df, $b5d19ee3, $886a4c1b, $1f2cc1b8, $5165467f, + $ea5e9d04, $358c015d, $7487fa73, $410bfb2e, $1d67b35a, $d2db9252, $5610e933, $47d66d13, + $61d79a8c, $0ca1377a, $14f8598e, $3c13eb89, $27a9ceee, $c961b735, $e51ce1ed, $b1477a3c, + $dfd29c59, $73f2553f, $ce141879, $37c773bf, $cdf753ea, $aafd5f5b, $6f3ddf14, $db447886, + $f3afca81, $c468b93e, $3424382c, $40a3c25f, $c31d1672, $25e2bc0c, $493c288b, $950dff41, + $01a83971, $b30c08de, $e4b4d89c, $c1566490, $84cb7b61, $b632d570, $5c6c4874, $57b8d042); + + Td2: array[byte] of longint = + ($f45150a7, $417e5365, $171ac3a4, $273a965e, $ab3bcb6b, $9d1ff145, $faacab58, $e34b9303, + $302055fa, $76adf66d, $cc889176, $02f5254c, $e54ffcd7, $2ac5d7cb, $35268044, $62b58fa3, + $b1de495a, $ba25671b, $ea45980e, $fe5de1c0, $2fc30275, $4c8112f0, $468da397, $d36bc6f9, + $8f03e75f, $9215959c, $6dbfeb7a, $5295da59, $bed42d83, $7458d321, $e0492969, $c98e44c8, + $c2756a89, $8ef47879, $58996b3e, $b927dd71, $e1beb64f, $88f017ad, $20c966ac, $ce7db43a, + $df63184a, $1ae58231, $51976033, $5362457f, $64b1e077, $6bbb84ae, $81fe1ca0, $08f9942b, + $48705868, $458f19fd, $de94876c, $7b52b7f8, $73ab23d3, $4b72e202, $1fe3578f, $55662aab, + $ebb20728, $b52f03c2, $c5869a7b, $37d3a508, $2830f287, $bf23b2a5, $0302ba6a, $16ed5c82, + $cf8a2b1c, $79a792b4, $07f3f0f2, $694ea1e2, $da65cdf4, $0506d5be, $34d11f62, $a6c48afe, + $2e349d53, $f3a2a055, $8a0532e1, $f6a475eb, $830b39ec, $6040aaef, $715e069f, $6ebd5110, + $213ef98a, $dd963d06, $3eddae05, $e64d46bd, $5491b58d, $c471055d, $06046fd4, $5060ff15, + $981924fb, $bdd697e9, $4089cc43, $d967779e, $e8b0bd42, $8907888b, $19e7385b, $c879dbee, + $7ca1470a, $427ce90f, $84f8c91e, $00000000, $80098386, $2b3248ed, $111eac70, $5a6c4e72, + $0efdfbff, $850f5638, $ae3d1ed5, $2d362739, $0f0a64d9, $5c6821a6, $5b9bd154, $36243a2e, + $0a0cb167, $57930fe7, $eeb4d296, $9b1b9e91, $c0804fc5, $dc61a220, $775a694b, $121c161a, + $93e20aba, $a0c0e52a, $223c43e0, $1b121d17, $090e0b0d, $8bf2adc7, $b62db9a8, $1e14c8a9, + $f1578519, $75af4c07, $99eebbdd, $7fa3fd60, $01f79f26, $725cbcf5, $6644c53b, $fb5b347e, + $438b7629, $23cbdcc6, $edb668fc, $e4b863f1, $31d7cadc, $63421085, $97134022, $c6842011, + $4a857d24, $bbd2f83d, $f9ae1132, $29c76da1, $9e1d4b2f, $b2dcf330, $860dec52, $c177d0e3, + $b32b6c16, $70a999b9, $9411fa48, $e9472264, $fca8c48c, $f0a01a3f, $7d56d82c, $3322ef90, + $4987c74e, $38d9c1d1, $ca8cfea2, $d498360b, $f5a6cf81, $7aa528de, $b7da268e, $ad3fa4bf, + $3a2ce49d, $78500d92, $5f6a9bcc, $7e546246, $8df6c213, $d890e8b8, $392e5ef7, $c382f5af, + $5d9fbe80, $d0697c93, $d56fa92d, $25cfb312, $acc83b99, $1810a77d, $9ce86e63, $3bdb7bbb, + $26cd0978, $596ef418, $9aec01b7, $4f83a89a, $95e6656e, $ffaa7ee6, $bc2108cf, $15efe6e8, + $e7bad99b, $6f4ace36, $9fead409, $b029d67c, $a431afb2, $3f2a3123, $a5c63094, $a235c066, + $4e7437bc, $82fca6ca, $90e0b0d0, $a73315d8, $04f14a98, $ec41f7da, $cd7f0e50, $91172ff6, + $4d768dd6, $ef434db0, $aacc544d, $96e4df04, $d19ee3b5, $6a4c1b88, $2cc1b81f, $65467f51, + $5e9d04ea, $8c015d35, $87fa7374, $0bfb2e41, $67b35a1d, $db9252d2, $10e93356, $d66d1347, + $d79a8c61, $a1377a0c, $f8598e14, $13eb893c, $a9ceee27, $61b735c9, $1ce1ede5, $477a3cb1, + $d29c59df, $f2553f73, $141879ce, $c773bf37, $f753eacd, $fd5f5baa, $3ddf146f, $447886db, + $afca81f3, $68b93ec4, $24382c34, $a3c25f40, $1d1672c3, $e2bc0c25, $3c288b49, $0dff4195, + $a8397101, $0c08deb3, $b4d89ce4, $566490c1, $cb7b6184, $32d570b6, $6c48745c, $b8d04257); + + Td3: array[byte] of longint = + ($5150a7f4, $7e536541, $1ac3a417, $3a965e27, $3bcb6bab, $1ff1459d, $acab58fa, $4b9303e3, + $2055fa30, $adf66d76, $889176cc, $f5254c02, $4ffcd7e5, $c5d7cb2a, $26804435, $b58fa362, + $de495ab1, $25671bba, $45980eea, $5de1c0fe, $c302752f, $8112f04c, $8da39746, $6bc6f9d3, + $03e75f8f, $15959c92, $bfeb7a6d, $95da5952, $d42d83be, $58d32174, $492969e0, $8e44c8c9, + $756a89c2, $f478798e, $996b3e58, $27dd71b9, $beb64fe1, $f017ad88, $c966ac20, $7db43ace, + $63184adf, $e582311a, $97603351, $62457f53, $b1e07764, $bb84ae6b, $fe1ca081, $f9942b08, + $70586848, $8f19fd45, $94876cde, $52b7f87b, $ab23d373, $72e2024b, $e3578f1f, $662aab55, + $b20728eb, $2f03c2b5, $869a7bc5, $d3a50837, $30f28728, $23b2a5bf, $02ba6a03, $ed5c8216, + $8a2b1ccf, $a792b479, $f3f0f207, $4ea1e269, $65cdf4da, $06d5be05, $d11f6234, $c48afea6, + $349d532e, $a2a055f3, $0532e18a, $a475ebf6, $0b39ec83, $40aaef60, $5e069f71, $bd51106e, + $3ef98a21, $963d06dd, $ddae053e, $4d46bde6, $91b58d54, $71055dc4, $046fd406, $60ff1550, + $1924fb98, $d697e9bd, $89cc4340, $67779ed9, $b0bd42e8, $07888b89, $e7385b19, $79dbeec8, + $a1470a7c, $7ce90f42, $f8c91e84, $00000000, $09838680, $3248ed2b, $1eac7011, $6c4e725a, + $fdfbff0e, $0f563885, $3d1ed5ae, $3627392d, $0a64d90f, $6821a65c, $9bd1545b, $243a2e36, + $0cb1670a, $930fe757, $b4d296ee, $1b9e919b, $804fc5c0, $61a220dc, $5a694b77, $1c161a12, + $e20aba93, $c0e52aa0, $3c43e022, $121d171b, $0e0b0d09, $f2adc78b, $2db9a8b6, $14c8a91e, + $578519f1, $af4c0775, $eebbdd99, $a3fd607f, $f79f2601, $5cbcf572, $44c53b66, $5b347efb, + $8b762943, $cbdcc623, $b668fced, $b863f1e4, $d7cadc31, $42108563, $13402297, $842011c6, + $857d244a, $d2f83dbb, $ae1132f9, $c76da129, $1d4b2f9e, $dcf330b2, $0dec5286, $77d0e3c1, + $2b6c16b3, $a999b970, $11fa4894, $472264e9, $a8c48cfc, $a01a3ff0, $56d82c7d, $22ef9033, + $87c74e49, $d9c1d138, $8cfea2ca, $98360bd4, $a6cf81f5, $a528de7a, $da268eb7, $3fa4bfad, + $2ce49d3a, $500d9278, $6a9bcc5f, $5462467e, $f6c2138d, $90e8b8d8, $2e5ef739, $82f5afc3, + $9fbe805d, $697c93d0, $6fa92dd5, $cfb31225, $c83b99ac, $10a77d18, $e86e639c, $db7bbb3b, + $cd097826, $6ef41859, $ec01b79a, $83a89a4f, $e6656e95, $aa7ee6ff, $2108cfbc, $efe6e815, + $bad99be7, $4ace366f, $ead4099f, $29d67cb0, $31afb2a4, $2a31233f, $c63094a5, $35c066a2, + $7437bc4e, $fca6ca82, $e0b0d090, $3315d8a7, $f14a9804, $41f7daec, $7f0e50cd, $172ff691, + $768dd64d, $434db0ef, $cc544daa, $e4df0496, $9ee3b5d1, $4c1b886a, $c1b81f2c, $467f5165, + $9d04ea5e, $015d358c, $fa737487, $fb2e410b, $b35a1d67, $9252d2db, $e9335610, $6d1347d6, + $9a8c61d7, $377a0ca1, $598e14f8, $eb893c13, $ceee27a9, $b735c961, $e1ede51c, $7a3cb147, + $9c59dfd2, $553f73f2, $1879ce14, $73bf37c7, $53eacdf7, $5f5baafd, $df146f3d, $7886db44, + $ca81f3af, $b93ec468, $382c3424, $c25f40a3, $1672c31d, $bc0c25e2, $288b493c, $ff41950d, + $397101a8, $08deb30c, $d89ce4b4, $6490c156, $7b6184cb, $d570b632, $48745c6c, $d04257b8); + +{$ifdef AES_LONGBOX} + Td4: array[byte] of longint = + ($52525252, $09090909, $6a6a6a6a, $d5d5d5d5, $30303030, $36363636, $a5a5a5a5, $38383838, + $bfbfbfbf, $40404040, $a3a3a3a3, $9e9e9e9e, $81818181, $f3f3f3f3, $d7d7d7d7, $fbfbfbfb, + $7c7c7c7c, $e3e3e3e3, $39393939, $82828282, $9b9b9b9b, $2f2f2f2f, $ffffffff, $87878787, + $34343434, $8e8e8e8e, $43434343, $44444444, $c4c4c4c4, $dededede, $e9e9e9e9, $cbcbcbcb, + $54545454, $7b7b7b7b, $94949494, $32323232, $a6a6a6a6, $c2c2c2c2, $23232323, $3d3d3d3d, + $eeeeeeee, $4c4c4c4c, $95959595, $0b0b0b0b, $42424242, $fafafafa, $c3c3c3c3, $4e4e4e4e, + $08080808, $2e2e2e2e, $a1a1a1a1, $66666666, $28282828, $d9d9d9d9, $24242424, $b2b2b2b2, + $76767676, $5b5b5b5b, $a2a2a2a2, $49494949, $6d6d6d6d, $8b8b8b8b, $d1d1d1d1, $25252525, + $72727272, $f8f8f8f8, $f6f6f6f6, $64646464, $86868686, $68686868, $98989898, $16161616, + $d4d4d4d4, $a4a4a4a4, $5c5c5c5c, $cccccccc, $5d5d5d5d, $65656565, $b6b6b6b6, $92929292, + $6c6c6c6c, $70707070, $48484848, $50505050, $fdfdfdfd, $edededed, $b9b9b9b9, $dadadada, + $5e5e5e5e, $15151515, $46464646, $57575757, $a7a7a7a7, $8d8d8d8d, $9d9d9d9d, $84848484, + $90909090, $d8d8d8d8, $abababab, $00000000, $8c8c8c8c, $bcbcbcbc, $d3d3d3d3, $0a0a0a0a, + $f7f7f7f7, $e4e4e4e4, $58585858, $05050505, $b8b8b8b8, $b3b3b3b3, $45454545, $06060606, + $d0d0d0d0, $2c2c2c2c, $1e1e1e1e, $8f8f8f8f, $cacacaca, $3f3f3f3f, $0f0f0f0f, $02020202, + $c1c1c1c1, $afafafaf, $bdbdbdbd, $03030303, $01010101, $13131313, $8a8a8a8a, $6b6b6b6b, + $3a3a3a3a, $91919191, $11111111, $41414141, $4f4f4f4f, $67676767, $dcdcdcdc, $eaeaeaea, + $97979797, $f2f2f2f2, $cfcfcfcf, $cececece, $f0f0f0f0, $b4b4b4b4, $e6e6e6e6, $73737373, + $96969696, $acacacac, $74747474, $22222222, $e7e7e7e7, $adadadad, $35353535, $85858585, + $e2e2e2e2, $f9f9f9f9, $37373737, $e8e8e8e8, $1c1c1c1c, $75757575, $dfdfdfdf, $6e6e6e6e, + $47474747, $f1f1f1f1, $1a1a1a1a, $71717171, $1d1d1d1d, $29292929, $c5c5c5c5, $89898989, + $6f6f6f6f, $b7b7b7b7, $62626262, $0e0e0e0e, $aaaaaaaa, $18181818, $bebebebe, $1b1b1b1b, + $fcfcfcfc, $56565656, $3e3e3e3e, $4b4b4b4b, $c6c6c6c6, $d2d2d2d2, $79797979, $20202020, + $9a9a9a9a, $dbdbdbdb, $c0c0c0c0, $fefefefe, $78787878, $cdcdcdcd, $5a5a5a5a, $f4f4f4f4, + $1f1f1f1f, $dddddddd, $a8a8a8a8, $33333333, $88888888, $07070707, $c7c7c7c7, $31313131, + $b1b1b1b1, $12121212, $10101010, $59595959, $27272727, $80808080, $ecececec, $5f5f5f5f, + $60606060, $51515151, $7f7f7f7f, $a9a9a9a9, $19191919, $b5b5b5b5, $4a4a4a4a, $0d0d0d0d, + $2d2d2d2d, $e5e5e5e5, $7a7a7a7a, $9f9f9f9f, $93939393, $c9c9c9c9, $9c9c9c9c, $efefefef, + $a0a0a0a0, $e0e0e0e0, $3b3b3b3b, $4d4d4d4d, $aeaeaeae, $2a2a2a2a, $f5f5f5f5, $b0b0b0b0, + $c8c8c8c8, $ebebebeb, $bbbbbbbb, $3c3c3c3c, $83838383, $53535353, $99999999, $61616161, + $17171717, $2b2b2b2b, $04040404, $7e7e7e7e, $babababa, $77777777, $d6d6d6d6, $26262626, + $e1e1e1e1, $69696969, $14141414, $63636363, $55555555, $21212121, $0c0c0c0c, $7d7d7d7d); +{$endif} + +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} + + +{$ifdef AES_LONGBOX} +const + X000000ff = longint($000000ff); {Avoid D4+ warnings} + X0000ff00 = longint($0000ff00); + X00ff0000 = longint($00ff0000); + Xff000000 = longint($ff000000); +{$endif} + diff --git a/Tocsg.Lib/VCL/EncLib/AES/dec_fp16.inc b/Tocsg.Lib/VCL/EncLib/AES/dec_fp16.inc new file mode 100644 index 00000000..182d6e05 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/dec_fp16.inc @@ -0,0 +1,92 @@ +(************************************************************************* + Include file for AES_DECR.PAS - AES_Decrypt for Pascal16/Full tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version from AES_DECR.PAS + 0.11 15.11.08 we Use Ptr2Inc from BTypes +**************************************************************************) + +(**** (C) Copyright 2002-2008 Wolfgang Ehrhardt -- see copying_we.txt ****) + +{Normally used for TP5/5.5 (and during development BP7)} + +{---------------------------------------------------------------------------} +procedure AES_Decrypt(var ctx: TAESContext; {$ifdef CONST} const {$else} var {$endif} BI: TAESBlock; var BO: TAESBlock); + {-decrypt one block (in ECB mode)} +label done; +var + r: integer; + pK: PWA4; {pointer to loop rount key } + s,t: TAESBlock; +begin + {Setup key pointer} + pK := PWA4(@ctx.RK[ctx.Rounds]); + {Initialize with input block} + TWA4(s)[0] := TWA4(BI)[0] xor pK^[0]; + TWA4(s)[1] := TWA4(BI)[1] xor pK^[1]; + TWA4(s)[2] := TWA4(BI)[2] xor pK^[2]; + TWA4(s)[3] := TWA4(BI)[3] xor pK^[3]; + dec(Ptr2Inc(pK), 4*sizeof(longint)); + r := ctx.Rounds-1; + while true do begin + TWA4(t)[3] := Td0[s[3*4+0]] xor Td1[s[2*4+1]] xor Td2[s[1*4+2]] xor Td3[s[0*4+3]] xor pK^[3]; + TWA4(t)[2] := Td0[s[2*4+0]] xor Td1[s[1*4+1]] xor Td2[s[0*4+2]] xor Td3[s[3*4+3]] xor pK^[2]; + TWA4(t)[1] := Td0[s[1*4+0]] xor Td1[s[0*4+1]] xor Td2[s[3*4+2]] xor Td3[s[2*4+3]] xor pK^[1]; + TWA4(t)[0] := Td0[s[0*4+0]] xor Td1[s[3*4+1]] xor Td2[s[2*4+2]] xor Td3[s[1*4+3]] xor pK^[0]; + dec(Ptr2Inc(pK), 4*sizeof(longint)); + dec(r); + if r<1 then goto done; + TWA4(s)[3] := Td0[t[3*4+0]] xor Td1[t[2*4+1]] xor Td2[t[1*4+2]] xor Td3[t[0*4+3]] xor pK^[3]; + TWA4(s)[2] := Td0[t[2*4+0]] xor Td1[t[1*4+1]] xor Td2[t[0*4+2]] xor Td3[t[3*4+3]] xor pK^[2]; + TWA4(s)[1] := Td0[t[1*4+0]] xor Td1[t[0*4+1]] xor Td2[t[3*4+2]] xor Td3[t[2*4+3]] xor pK^[1]; + TWA4(s)[0] := Td0[t[0*4+0]] xor Td1[t[3*4+1]] xor Td2[t[2*4+2]] xor Td3[t[1*4+3]] xor pK^[0]; + dec(Ptr2Inc(pK), 4*sizeof(longint)); + dec(r); + end; + +done: + + s[00] := InvSBox[t[0*4+0]]; + s[01] := InvSBox[t[3*4+1]]; + s[02] := InvSBox[t[2*4+2]]; + s[03] := InvSBox[t[1*4+3]]; + s[04] := InvSBox[t[1*4+0]]; + s[05] := InvSBox[t[0*4+1]]; + s[06] := InvSBox[t[3*4+2]]; + s[07] := InvSBox[t[2*4+3]]; + s[08] := InvSBox[t[2*4+0]]; + s[09] := InvSBox[t[1*4+1]]; + s[10] := InvSBox[t[0*4+2]]; + s[11] := InvSBox[t[3*4+3]]; + s[12] := InvSBox[t[3*4+0]]; + s[13] := InvSBox[t[2*4+1]]; + s[14] := InvSBox[t[1*4+2]]; + s[15] := InvSBox[t[0*4+3]]; + + TWA4(BO)[0] := TWA4(s)[0] xor pK^[0]; + TWA4(BO)[1] := TWA4(s)[1] xor pK^[1]; + TWA4(BO)[2] := TWA4(s)[2] xor pK^[2]; + TWA4(BO)[3] := TWA4(s)[3] xor pK^[3]; +end; + + +{---------------------------------------------------------------------------} +procedure MakeDecrKey(var ctx: TAESContext); + {-Calculate decryption key from encryption key} +var + i: integer; + x: longint; + t: TBA4 absolute x; +begin + with ctx do begin + for i:=4 to 4*Rounds-1 do begin + {Inverse MixColumns transformation: use Sbox and} + {implicit endian conversion compared with [2] } + x := TAWK(RK)[i]; + TAWK(RK)[i] := Td3[SBox[t[3]]] xor Td2[SBox[t[2]]] xor Td1[SBox[t[1]]] xor Td0[SBox[t[0]]]; + end; + end; +end; + + diff --git a/Tocsg.Lib/VCL/EncLib/AES/dec_fp32.inc b/Tocsg.Lib/VCL/EncLib/AES/dec_fp32.inc new file mode 100644 index 00000000..99caf138 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/dec_fp32.inc @@ -0,0 +1,106 @@ +(************************************************************************* + Include file for AES_DECR.PAS - AES_Decrypt for BIT32/Full tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version from AES_DECR.PAS +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + +{ 32 Bit code: Alternative versions can be found in options.zip + dec_full.inc - fully unrolled version for highest speed + dec_ptr.inc - pointer version (may be faster on some systems) +} + + +{---------------------------------------------------------------------------} +procedure AES_Decrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); + {-decrypt one block (in ECB mode)} +var + r: integer; {round loop countdown counter} + pK: PWA4; {pointer to loop rount key } + s0,s1,s2,s3: longint; {TAESBlock s as separate variables} + t: TWA4; +begin + + {Setup key pointer} + pK := PWA4(@ctx.RK[ctx.Rounds]); + + {Initialize with input block} + s0 := TWA4(BI)[0] xor pK^[0]; + s1 := TWA4(BI)[1] xor pK^[1]; + s2 := TWA4(BI)[2] xor pK^[2]; + s3 := TWA4(BI)[3] xor pK^[3]; + + dec(pK); + {perform encryption rounds} + for r:=1 to ctx.Rounds-1 do begin + t[3] := Td0[s3 and $ff] xor Td1[s2 shr 8 and $ff] xor Td2[s1 shr 16 and $ff] xor Td3[s0 shr 24] xor pK^[3]; + t[2] := Td0[s2 and $ff] xor Td1[s1 shr 8 and $ff] xor Td2[s0 shr 16 and $ff] xor Td3[s3 shr 24] xor pK^[2]; + t[1] := Td0[s1 and $ff] xor Td1[s0 shr 8 and $ff] xor Td2[s3 shr 16 and $ff] xor Td3[s2 shr 24] xor pK^[1]; + s0 := Td0[s0 and $ff] xor Td1[s3 shr 8 and $ff] xor Td2[s2 shr 16 and $ff] xor Td3[s1 shr 24] xor pK^[0]; + s1 := t[1]; + s2 := t[2]; + s3 := t[3]; + dec(pK); + end; + +{$ifdef AES_LONGBOX} + {Use expanded longint InvSBox table Td4 from [2]} + TWA4(BO)[0] := (Td4[s0 and $ff] and X000000ff) xor + (Td4[s3 shr 8 and $ff] and X0000ff00) xor + (Td4[s2 shr 16 and $ff] and X00ff0000) xor + (Td4[s1 shr 24 ] and Xff000000) xor pK^[0]; + TWA4(BO)[1] := (Td4[s1 and $ff] and X000000ff) xor + (Td4[s0 shr 8 and $ff] and X0000ff00) xor + (Td4[s3 shr 16 and $ff] and X00ff0000) xor + (Td4[s2 shr 24 ] and Xff000000) xor pK^[1]; + TWA4(BO)[2] := (Td4[s2 and $ff ] and X000000ff) xor + (Td4[s1 shr 8 and $ff] and X0000ff00) xor + (Td4[s0 shr 16 and $ff] and X00ff0000) xor + (Td4[s3 shr 24 ] and Xff000000) xor pK^[2]; + TWA4(BO)[3] := (Td4[s3 and $ff ] and X000000ff) xor + (Td4[s2 shr 8 and $ff] and X0000ff00) xor + (Td4[s1 shr 16 and $ff] and X00ff0000) xor + (Td4[s0 shr 24 ] and Xff000000) xor pK^[3]; +{$else} + {Uses InvSbox and shl, needs type cast longint() for } + {16 bit compilers: here InvSbox is byte, Td4 is longint} + TWA4(BO)[0] := (longint(InvSBox[s0 and $ff]) xor + longint(InvSBox[s3 shr 8 and $ff]) shl 8 xor + longint(InvSBox[s2 shr 16 and $ff]) shl 16 xor + longint(InvSBox[s1 shr 24 ]) shl 24 ) xor pK^[0]; + TWA4(BO)[1] := (longint(InvSBox[s1 and $ff]) xor + longint(InvSBox[s0 shr 8 and $ff]) shl 8 xor + longint(InvSBox[s3 shr 16 and $ff]) shl 16 xor + longint(InvSBox[s2 shr 24 ]) shl 24 ) xor pK^[1]; + TWA4(BO)[2] := (longint(InvSBox[s2 and $ff ]) xor + longint(InvSBox[s1 shr 8 and $ff]) shl 8 xor + longint(InvSBox[s0 shr 16 and $ff]) shl 16 xor + longint(InvSBox[s3 shr 24 ]) shl 24 ) xor pK^[2]; + TWA4(BO)[3] := (longint(InvSBox[s3 and $ff ]) xor + longint(InvSBox[s2 shr 8 and $ff]) shl 8 xor + longint(InvSBox[s1 shr 16 and $ff]) shl 16 xor + longint(InvSBox[s0 shr 24 ]) shl 24 ) xor pK^[3]; +{$endif} + +end; + + +{---------------------------------------------------------------------------} +procedure MakeDecrKey(var ctx: TAESContext); + {-Calculate decryption key from encryption key} +var + i: integer; + p: PLong; + x: longint; +begin + p := PLong(@ctx.RK[1]); + for i:=1 to 4*(ctx.Rounds-1) do begin + x := p^; + p^ := Td3[SBox[x shr 24]] xor Td2[SBox[x shr 16 and $ff]] xor Td1[SBox[x shr 8 and $ff]] xor Td0[SBox[x and $ff]]; + inc(p); + end; +end; + diff --git a/Tocsg.Lib/VCL/EncLib/AES/enc_ca16.inc b/Tocsg.Lib/VCL/EncLib/AES/enc_ca16.inc new file mode 100644 index 00000000..bfa6982c --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/enc_ca16.inc @@ -0,0 +1,350 @@ + +(************************************************************************* + Include file for AES_ENCR.PAS - AES_Encrypt for BASM16/Compressed table + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version for compressed table + 0.11 10.07.06 we Removed bx in TCe[bx+si+?] + 0.13 13.07.06 we Uses TCe box byte instead of SBox +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{16 bit BASM used for TP6, BP7, Delphi1} + +{---------------------------------------------------------------------------} +procedure AES_Encrypt(var ctx: TAESContext; {$ifdef CONST} const {$else} var {$endif} BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} +var + s,t: TAESBlock; + rnd: integer; + pK: pointer; +begin + rnd := ctx.rounds; + pK := @ctx.RK; + asm + + db $66; pusha + +{AES_XorBlock(BI, ctx.RK[0], s);} + les si,[BI] + db $66; mov ax,es:[si] + db $66; mov bx,es:[si+4] + db $66; mov cx,es:[si+8] + db $66; mov dx,es:[si+12] + + les di,[pK] + db $66; xor ax,es:[di] + db $66; xor bx,es:[di+4] + db $66; xor cx,es:[di+8] + db $66; xor dx,es:[di+12] + + db $66; mov word ptr [s],ax + db $66; mov word ptr [s+4],bx + db $66; mov word ptr [s+8],cx + db $66; mov word ptr [s+12],dx + + add di,16 {di->ctx.RK[1]} + mov cx,[rnd] + dec cx + +{ *Note* in the following round loop } +{ op eax, mem[8*ebx] is calculated as } +{ lea esi, [edx+8*ebx] $66,$67,$8D,$34,$DA } +{ op eax, mem[esi] } + db $66; sub bx,bx {clear ebx} + db $66; sub dx,dx {clear edx} + +@@1: + +{TWA4(t)[0] := Te0[s[0*4+0]] xor Te1[s[1*4+1]] xor Te2[s[2*4+2]] xor Te3[s[3*4+3]] xor TWA4(ctx.RK[r])[0];} + mov bl,byte ptr s[0*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCe[si+3] + + mov bl,byte ptr s[1*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+2] + + mov bl,byte ptr s[2*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+1] + + mov bl,byte ptr s[3*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si] + + db $66; xor ax,es:[di] + db $66; mov word ptr t[0],ax + +{TWA4(t)[1] := Te0[s[1*4+0]] xor Te1[s[2*4+1]] xor Te2[s[3*4+2]] xor Te3[s[0*4+3]] xor TWA4(ctx.RK[r])[1];} + mov bl,byte ptr s[1*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCe[si+3] + + mov bl,byte ptr s[2*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+2] + + mov bl,byte ptr s[3*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+1] + + mov bl,byte ptr s[0*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si] + + db $66; xor ax,es:[di+4] + db $66; mov word ptr t[4],ax + +{TWA4(t)[2] := Te0[s[2*4+0]] xor Te1[s[3*4+1]] xor Te2[s[0*4+2]] xor Te3[s[1*4+3]] xor TWA4(ctx.RK[r])[2];} + mov bl,byte ptr s[2*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCe[si+3] + + mov bl,byte ptr s[3*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+2] + + mov bl,byte ptr s[0*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+1] + + mov bl,byte ptr s[1*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si] + + db $66; xor ax,es:[di+8] + db $66; mov word ptr t[8],ax + +{TWA4(t)[3] := Te0[s[3*4+0]] xor Te1[s[0*4+1]] xor Te2[s[1*4+2]] xor Te3[s[2*4+3]] xor TWA4(ctx.RK[r])[3];} + mov bl,byte ptr s[3*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCe[si+3] + + mov bl,byte ptr s[0*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+2] + + mov bl,byte ptr s[1*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+1] + + mov bl,byte ptr s[2*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si] + + db $66; xor ax,es:[di+12] + db $66; mov word ptr t[12],ax + +{if r>=ctx.rounds then break;} + dec cx + jbe @@2 + +{TWA4(s)[0] := Te0[t[0*4+0]] xor Te1[t[1*4+1]] xor Te2[t[2*4+2]] xor Te3[t[3*4+3]] xor TWA4(ctx.RK[r])[0];} + mov bl,byte ptr t[0*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCe[si+3] + + mov bl,byte ptr t[1*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+2] + + mov bl,byte ptr t[2*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+1] + + mov bl,byte ptr t[3*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si] + + db $66; xor ax,es:[di+16] + db $66; mov word ptr s[0],ax + +{TWA4(s)[1] := Te0[t[1*4+0]] xor Te1[t[2*4+1]] xor Te2[t[3*4+2]] xor Te3[t[0*4+3]] xor TWA4(ctx.RK[r])[1];} + mov bl,byte ptr t[1*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCe[si+3] + + mov bl,byte ptr t[2*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+2] + + mov bl,byte ptr t[3*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+1] + + mov bl,byte ptr t[0*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si] + + db $66; xor ax,es:[di+20] + db $66; mov word ptr s[4],ax + +{TWA4(s)[2] := Te0[t[2*4+0]] xor Te1[t[3*4+1]] xor Te2[t[0*4+2]] xor Te3[t[1*4+3]] xor TWA4(ctx.RK[r])[2];} + mov bl,byte ptr t[2*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCe[si+3] + + mov bl,byte ptr t[3*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+2] + + mov bl,byte ptr t[0*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+1] + + mov bl,byte ptr t[1*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si] + + db $66; xor ax,es:[di+24] + db $66; mov word ptr s[8],ax + +{TWA4(s)[3] := Te0[t[3*4+0]] xor Te1[t[0*4+1]] xor Te2[t[1*4+2]] xor Te3[t[2*4+3]] xor TWA4(ctx.RK[r])[3];} + mov bl,byte ptr t[3*4+0] + db $66,$67,$8D,$34,$DA; + db $66; mov ax,word ptr TCe[si+3] + + mov bl,byte ptr t[0*4+1] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+2] + + mov bl,byte ptr t[1*4+2] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si+1] + + mov bl,byte ptr t[2*4+3] + db $66,$67,$8D,$34,$DA; + db $66; xor ax,word ptr TCe[si] + + db $66; xor ax,es:[di+28] + add di,32 + db $66; mov word ptr s[12],ax + + dec cx + jmp @@1 + +@@2: add di,16 {di -> ctx.RK[ctx.rounds]} + + {Last round uses SBox} + + mov bl, byte ptr t[0*4+0] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[0],al + + mov bl, byte ptr t[1*4+1] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[1],al + + mov bl, byte ptr t[2*4+2] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[2],al + + mov bl, byte ptr t[3*4+3] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[3],al + + mov bl, byte ptr t[1*4+0] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[4],al + + mov bl, byte ptr t[2*4+1] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[5],al + + mov bl, byte ptr t[3*4+2] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[6],al + + mov bl, byte ptr t[0*4+3] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[7],al + + mov bl, byte ptr t[2*4+0] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[8],al + + mov bl, byte ptr t[3*4+1] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[9],al + + mov bl, byte ptr t[0*4+2] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[10],al + + mov bl, byte ptr t[1*4+3] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[11],al + + mov bl, byte ptr t[3*4+0] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[12],al + + mov bl, byte ptr t[0*4+1] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[13],al + + mov bl, byte ptr t[1*4+2] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[14],al + + mov bl, byte ptr t[2*4+3] + sub bh,bh + shl bx,3 + mov al, byte ptr TCe[bx+7] + mov byte ptr s[15],al + +{AES_XorBlock(s, ctx.RK[rnd], BO)} + + db $66; mov ax,word ptr [s] + db $66; mov bx,word ptr [s+4] + db $66; mov cx,word ptr [s+8] + db $66; mov dx,word ptr [s+12] + db $66; xor ax,es:[di] + db $66; xor bx,es:[di+4] + db $66; xor cx,es:[di+8] + db $66; xor dx,es:[di+12] + les si,[BO] + db $66; mov es:[si],ax + db $66; mov es:[si+4],bx + db $66; mov es:[si+8],cx + db $66; mov es:[si+12],dx + + db $66; popa + + end; +end; + diff --git a/Tocsg.Lib/VCL/EncLib/AES/enc_cdat.inc b/Tocsg.Lib/VCL/EncLib/AES/enc_cdat.inc new file mode 100644 index 00000000..ecfb904e --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/enc_cdat.inc @@ -0,0 +1,196 @@ + +(************************************************************************* + Include file for AES_ENCR.PAS - Compressed tables/Helper types + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version for compressed tables + 0.11 13.07.06 we Removed AES_LONGBOX consts, b3 gets box byte + 0.12 19.07.06 we TCeDummy +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +type + TH3 = packed record + L: longint; + b0,b1,b2,box: byte; + end; + + TH2 = packed record + b0: byte; + L: longint; + b1,b2,box: byte; + end; + + TH1 = packed record + b0,b1: byte; + L: longint; + b2,box: byte; + end; + + TH0 = packed record + b0,b1,b2: byte; + L: longint; + box: byte; + end; + + TEU = record + case integer of + 0: (E0: TH0); + 1: (E1: TH1); + 2: (E2: TH2); + 3: (E3: TH3); + end; + +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9+ errors!} +{$endif} + +const + {$ifdef AES_Encr_DummyAlign} + TCeDummy : longint = 0; {Use to align TCe to 8 byte boundary} + {$endif} + TCe: packed array[0..2047] of byte = ( + $63,$63,$a5,$c6,$63,$63,$a5,$63,$7c,$7c,$84,$f8,$7c,$7c,$84,$7c, + $77,$77,$99,$ee,$77,$77,$99,$77,$7b,$7b,$8d,$f6,$7b,$7b,$8d,$7b, + $f2,$f2,$0d,$ff,$f2,$f2,$0d,$f2,$6b,$6b,$bd,$d6,$6b,$6b,$bd,$6b, + $6f,$6f,$b1,$de,$6f,$6f,$b1,$6f,$c5,$c5,$54,$91,$c5,$c5,$54,$c5, + $30,$30,$50,$60,$30,$30,$50,$30,$01,$01,$03,$02,$01,$01,$03,$01, + $67,$67,$a9,$ce,$67,$67,$a9,$67,$2b,$2b,$7d,$56,$2b,$2b,$7d,$2b, + $fe,$fe,$19,$e7,$fe,$fe,$19,$fe,$d7,$d7,$62,$b5,$d7,$d7,$62,$d7, + $ab,$ab,$e6,$4d,$ab,$ab,$e6,$ab,$76,$76,$9a,$ec,$76,$76,$9a,$76, + $ca,$ca,$45,$8f,$ca,$ca,$45,$ca,$82,$82,$9d,$1f,$82,$82,$9d,$82, + $c9,$c9,$40,$89,$c9,$c9,$40,$c9,$7d,$7d,$87,$fa,$7d,$7d,$87,$7d, + $fa,$fa,$15,$ef,$fa,$fa,$15,$fa,$59,$59,$eb,$b2,$59,$59,$eb,$59, + $47,$47,$c9,$8e,$47,$47,$c9,$47,$f0,$f0,$0b,$fb,$f0,$f0,$0b,$f0, + $ad,$ad,$ec,$41,$ad,$ad,$ec,$ad,$d4,$d4,$67,$b3,$d4,$d4,$67,$d4, + $a2,$a2,$fd,$5f,$a2,$a2,$fd,$a2,$af,$af,$ea,$45,$af,$af,$ea,$af, + $9c,$9c,$bf,$23,$9c,$9c,$bf,$9c,$a4,$a4,$f7,$53,$a4,$a4,$f7,$a4, + $72,$72,$96,$e4,$72,$72,$96,$72,$c0,$c0,$5b,$9b,$c0,$c0,$5b,$c0, + $b7,$b7,$c2,$75,$b7,$b7,$c2,$b7,$fd,$fd,$1c,$e1,$fd,$fd,$1c,$fd, + $93,$93,$ae,$3d,$93,$93,$ae,$93,$26,$26,$6a,$4c,$26,$26,$6a,$26, + $36,$36,$5a,$6c,$36,$36,$5a,$36,$3f,$3f,$41,$7e,$3f,$3f,$41,$3f, + $f7,$f7,$02,$f5,$f7,$f7,$02,$f7,$cc,$cc,$4f,$83,$cc,$cc,$4f,$cc, + $34,$34,$5c,$68,$34,$34,$5c,$34,$a5,$a5,$f4,$51,$a5,$a5,$f4,$a5, + $e5,$e5,$34,$d1,$e5,$e5,$34,$e5,$f1,$f1,$08,$f9,$f1,$f1,$08,$f1, + $71,$71,$93,$e2,$71,$71,$93,$71,$d8,$d8,$73,$ab,$d8,$d8,$73,$d8, + $31,$31,$53,$62,$31,$31,$53,$31,$15,$15,$3f,$2a,$15,$15,$3f,$15, + $04,$04,$0c,$08,$04,$04,$0c,$04,$c7,$c7,$52,$95,$c7,$c7,$52,$c7, + $23,$23,$65,$46,$23,$23,$65,$23,$c3,$c3,$5e,$9d,$c3,$c3,$5e,$c3, + $18,$18,$28,$30,$18,$18,$28,$18,$96,$96,$a1,$37,$96,$96,$a1,$96, + $05,$05,$0f,$0a,$05,$05,$0f,$05,$9a,$9a,$b5,$2f,$9a,$9a,$b5,$9a, + $07,$07,$09,$0e,$07,$07,$09,$07,$12,$12,$36,$24,$12,$12,$36,$12, + $80,$80,$9b,$1b,$80,$80,$9b,$80,$e2,$e2,$3d,$df,$e2,$e2,$3d,$e2, + $eb,$eb,$26,$cd,$eb,$eb,$26,$eb,$27,$27,$69,$4e,$27,$27,$69,$27, + $b2,$b2,$cd,$7f,$b2,$b2,$cd,$b2,$75,$75,$9f,$ea,$75,$75,$9f,$75, + $09,$09,$1b,$12,$09,$09,$1b,$09,$83,$83,$9e,$1d,$83,$83,$9e,$83, + $2c,$2c,$74,$58,$2c,$2c,$74,$2c,$1a,$1a,$2e,$34,$1a,$1a,$2e,$1a, + $1b,$1b,$2d,$36,$1b,$1b,$2d,$1b,$6e,$6e,$b2,$dc,$6e,$6e,$b2,$6e, + $5a,$5a,$ee,$b4,$5a,$5a,$ee,$5a,$a0,$a0,$fb,$5b,$a0,$a0,$fb,$a0, + $52,$52,$f6,$a4,$52,$52,$f6,$52,$3b,$3b,$4d,$76,$3b,$3b,$4d,$3b, + $d6,$d6,$61,$b7,$d6,$d6,$61,$d6,$b3,$b3,$ce,$7d,$b3,$b3,$ce,$b3, + $29,$29,$7b,$52,$29,$29,$7b,$29,$e3,$e3,$3e,$dd,$e3,$e3,$3e,$e3, + $2f,$2f,$71,$5e,$2f,$2f,$71,$2f,$84,$84,$97,$13,$84,$84,$97,$84, + $53,$53,$f5,$a6,$53,$53,$f5,$53,$d1,$d1,$68,$b9,$d1,$d1,$68,$d1, + $00,$00,$00,$00,$00,$00,$00,$00,$ed,$ed,$2c,$c1,$ed,$ed,$2c,$ed, + $20,$20,$60,$40,$20,$20,$60,$20,$fc,$fc,$1f,$e3,$fc,$fc,$1f,$fc, + $b1,$b1,$c8,$79,$b1,$b1,$c8,$b1,$5b,$5b,$ed,$b6,$5b,$5b,$ed,$5b, + $6a,$6a,$be,$d4,$6a,$6a,$be,$6a,$cb,$cb,$46,$8d,$cb,$cb,$46,$cb, + $be,$be,$d9,$67,$be,$be,$d9,$be,$39,$39,$4b,$72,$39,$39,$4b,$39, + $4a,$4a,$de,$94,$4a,$4a,$de,$4a,$4c,$4c,$d4,$98,$4c,$4c,$d4,$4c, + $58,$58,$e8,$b0,$58,$58,$e8,$58,$cf,$cf,$4a,$85,$cf,$cf,$4a,$cf, + $d0,$d0,$6b,$bb,$d0,$d0,$6b,$d0,$ef,$ef,$2a,$c5,$ef,$ef,$2a,$ef, + $aa,$aa,$e5,$4f,$aa,$aa,$e5,$aa,$fb,$fb,$16,$ed,$fb,$fb,$16,$fb, + $43,$43,$c5,$86,$43,$43,$c5,$43,$4d,$4d,$d7,$9a,$4d,$4d,$d7,$4d, + $33,$33,$55,$66,$33,$33,$55,$33,$85,$85,$94,$11,$85,$85,$94,$85, + $45,$45,$cf,$8a,$45,$45,$cf,$45,$f9,$f9,$10,$e9,$f9,$f9,$10,$f9, + $02,$02,$06,$04,$02,$02,$06,$02,$7f,$7f,$81,$fe,$7f,$7f,$81,$7f, + $50,$50,$f0,$a0,$50,$50,$f0,$50,$3c,$3c,$44,$78,$3c,$3c,$44,$3c, + $9f,$9f,$ba,$25,$9f,$9f,$ba,$9f,$a8,$a8,$e3,$4b,$a8,$a8,$e3,$a8, + $51,$51,$f3,$a2,$51,$51,$f3,$51,$a3,$a3,$fe,$5d,$a3,$a3,$fe,$a3, + $40,$40,$c0,$80,$40,$40,$c0,$40,$8f,$8f,$8a,$05,$8f,$8f,$8a,$8f, + $92,$92,$ad,$3f,$92,$92,$ad,$92,$9d,$9d,$bc,$21,$9d,$9d,$bc,$9d, + $38,$38,$48,$70,$38,$38,$48,$38,$f5,$f5,$04,$f1,$f5,$f5,$04,$f5, + $bc,$bc,$df,$63,$bc,$bc,$df,$bc,$b6,$b6,$c1,$77,$b6,$b6,$c1,$b6, + $da,$da,$75,$af,$da,$da,$75,$da,$21,$21,$63,$42,$21,$21,$63,$21, + $10,$10,$30,$20,$10,$10,$30,$10,$ff,$ff,$1a,$e5,$ff,$ff,$1a,$ff, + $f3,$f3,$0e,$fd,$f3,$f3,$0e,$f3,$d2,$d2,$6d,$bf,$d2,$d2,$6d,$d2, + $cd,$cd,$4c,$81,$cd,$cd,$4c,$cd,$0c,$0c,$14,$18,$0c,$0c,$14,$0c, + $13,$13,$35,$26,$13,$13,$35,$13,$ec,$ec,$2f,$c3,$ec,$ec,$2f,$ec, + $5f,$5f,$e1,$be,$5f,$5f,$e1,$5f,$97,$97,$a2,$35,$97,$97,$a2,$97, + $44,$44,$cc,$88,$44,$44,$cc,$44,$17,$17,$39,$2e,$17,$17,$39,$17, + $c4,$c4,$57,$93,$c4,$c4,$57,$c4,$a7,$a7,$f2,$55,$a7,$a7,$f2,$a7, + $7e,$7e,$82,$fc,$7e,$7e,$82,$7e,$3d,$3d,$47,$7a,$3d,$3d,$47,$3d, + $64,$64,$ac,$c8,$64,$64,$ac,$64,$5d,$5d,$e7,$ba,$5d,$5d,$e7,$5d, + $19,$19,$2b,$32,$19,$19,$2b,$19,$73,$73,$95,$e6,$73,$73,$95,$73, + $60,$60,$a0,$c0,$60,$60,$a0,$60,$81,$81,$98,$19,$81,$81,$98,$81, + $4f,$4f,$d1,$9e,$4f,$4f,$d1,$4f,$dc,$dc,$7f,$a3,$dc,$dc,$7f,$dc, + $22,$22,$66,$44,$22,$22,$66,$22,$2a,$2a,$7e,$54,$2a,$2a,$7e,$2a, + $90,$90,$ab,$3b,$90,$90,$ab,$90,$88,$88,$83,$0b,$88,$88,$83,$88, + $46,$46,$ca,$8c,$46,$46,$ca,$46,$ee,$ee,$29,$c7,$ee,$ee,$29,$ee, + $b8,$b8,$d3,$6b,$b8,$b8,$d3,$b8,$14,$14,$3c,$28,$14,$14,$3c,$14, + $de,$de,$79,$a7,$de,$de,$79,$de,$5e,$5e,$e2,$bc,$5e,$5e,$e2,$5e, + $0b,$0b,$1d,$16,$0b,$0b,$1d,$0b,$db,$db,$76,$ad,$db,$db,$76,$db, + $e0,$e0,$3b,$db,$e0,$e0,$3b,$e0,$32,$32,$56,$64,$32,$32,$56,$32, + $3a,$3a,$4e,$74,$3a,$3a,$4e,$3a,$0a,$0a,$1e,$14,$0a,$0a,$1e,$0a, + $49,$49,$db,$92,$49,$49,$db,$49,$06,$06,$0a,$0c,$06,$06,$0a,$06, + $24,$24,$6c,$48,$24,$24,$6c,$24,$5c,$5c,$e4,$b8,$5c,$5c,$e4,$5c, + $c2,$c2,$5d,$9f,$c2,$c2,$5d,$c2,$d3,$d3,$6e,$bd,$d3,$d3,$6e,$d3, + $ac,$ac,$ef,$43,$ac,$ac,$ef,$ac,$62,$62,$a6,$c4,$62,$62,$a6,$62, + $91,$91,$a8,$39,$91,$91,$a8,$91,$95,$95,$a4,$31,$95,$95,$a4,$95, + $e4,$e4,$37,$d3,$e4,$e4,$37,$e4,$79,$79,$8b,$f2,$79,$79,$8b,$79, + $e7,$e7,$32,$d5,$e7,$e7,$32,$e7,$c8,$c8,$43,$8b,$c8,$c8,$43,$c8, + $37,$37,$59,$6e,$37,$37,$59,$37,$6d,$6d,$b7,$da,$6d,$6d,$b7,$6d, + $8d,$8d,$8c,$01,$8d,$8d,$8c,$8d,$d5,$d5,$64,$b1,$d5,$d5,$64,$d5, + $4e,$4e,$d2,$9c,$4e,$4e,$d2,$4e,$a9,$a9,$e0,$49,$a9,$a9,$e0,$a9, + $6c,$6c,$b4,$d8,$6c,$6c,$b4,$6c,$56,$56,$fa,$ac,$56,$56,$fa,$56, + $f4,$f4,$07,$f3,$f4,$f4,$07,$f4,$ea,$ea,$25,$cf,$ea,$ea,$25,$ea, + $65,$65,$af,$ca,$65,$65,$af,$65,$7a,$7a,$8e,$f4,$7a,$7a,$8e,$7a, + $ae,$ae,$e9,$47,$ae,$ae,$e9,$ae,$08,$08,$18,$10,$08,$08,$18,$08, + $ba,$ba,$d5,$6f,$ba,$ba,$d5,$ba,$78,$78,$88,$f0,$78,$78,$88,$78, + $25,$25,$6f,$4a,$25,$25,$6f,$25,$2e,$2e,$72,$5c,$2e,$2e,$72,$2e, + $1c,$1c,$24,$38,$1c,$1c,$24,$1c,$a6,$a6,$f1,$57,$a6,$a6,$f1,$a6, + $b4,$b4,$c7,$73,$b4,$b4,$c7,$b4,$c6,$c6,$51,$97,$c6,$c6,$51,$c6, + $e8,$e8,$23,$cb,$e8,$e8,$23,$e8,$dd,$dd,$7c,$a1,$dd,$dd,$7c,$dd, + $74,$74,$9c,$e8,$74,$74,$9c,$74,$1f,$1f,$21,$3e,$1f,$1f,$21,$1f, + $4b,$4b,$dd,$96,$4b,$4b,$dd,$4b,$bd,$bd,$dc,$61,$bd,$bd,$dc,$bd, + $8b,$8b,$86,$0d,$8b,$8b,$86,$8b,$8a,$8a,$85,$0f,$8a,$8a,$85,$8a, + $70,$70,$90,$e0,$70,$70,$90,$70,$3e,$3e,$42,$7c,$3e,$3e,$42,$3e, + $b5,$b5,$c4,$71,$b5,$b5,$c4,$b5,$66,$66,$aa,$cc,$66,$66,$aa,$66, + $48,$48,$d8,$90,$48,$48,$d8,$48,$03,$03,$05,$06,$03,$03,$05,$03, + $f6,$f6,$01,$f7,$f6,$f6,$01,$f6,$0e,$0e,$12,$1c,$0e,$0e,$12,$0e, + $61,$61,$a3,$c2,$61,$61,$a3,$61,$35,$35,$5f,$6a,$35,$35,$5f,$35, + $57,$57,$f9,$ae,$57,$57,$f9,$57,$b9,$b9,$d0,$69,$b9,$b9,$d0,$b9, + $86,$86,$91,$17,$86,$86,$91,$86,$c1,$c1,$58,$99,$c1,$c1,$58,$c1, + $1d,$1d,$27,$3a,$1d,$1d,$27,$1d,$9e,$9e,$b9,$27,$9e,$9e,$b9,$9e, + $e1,$e1,$38,$d9,$e1,$e1,$38,$e1,$f8,$f8,$13,$eb,$f8,$f8,$13,$f8, + $98,$98,$b3,$2b,$98,$98,$b3,$98,$11,$11,$33,$22,$11,$11,$33,$11, + $69,$69,$bb,$d2,$69,$69,$bb,$69,$d9,$d9,$70,$a9,$d9,$d9,$70,$d9, + $8e,$8e,$89,$07,$8e,$8e,$89,$8e,$94,$94,$a7,$33,$94,$94,$a7,$94, + $9b,$9b,$b6,$2d,$9b,$9b,$b6,$9b,$1e,$1e,$22,$3c,$1e,$1e,$22,$1e, + $87,$87,$92,$15,$87,$87,$92,$87,$e9,$e9,$20,$c9,$e9,$e9,$20,$e9, + $ce,$ce,$49,$87,$ce,$ce,$49,$ce,$55,$55,$ff,$aa,$55,$55,$ff,$55, + $28,$28,$78,$50,$28,$28,$78,$28,$df,$df,$7a,$a5,$df,$df,$7a,$df, + $8c,$8c,$8f,$03,$8c,$8c,$8f,$8c,$a1,$a1,$f8,$59,$a1,$a1,$f8,$a1, + $89,$89,$80,$09,$89,$89,$80,$89,$0d,$0d,$17,$1a,$0d,$0d,$17,$0d, + $bf,$bf,$da,$65,$bf,$bf,$da,$bf,$e6,$e6,$31,$d7,$e6,$e6,$31,$e6, + $42,$42,$c6,$84,$42,$42,$c6,$42,$68,$68,$b8,$d0,$68,$68,$b8,$68, + $41,$41,$c3,$82,$41,$41,$c3,$41,$99,$99,$b0,$29,$99,$99,$b0,$99, + $2d,$2d,$77,$5a,$2d,$2d,$77,$2d,$0f,$0f,$11,$1e,$0f,$0f,$11,$0f, + $b0,$b0,$cb,$7b,$b0,$b0,$cb,$b0,$54,$54,$fc,$a8,$54,$54,$fc,$54, + $bb,$bb,$d6,$6d,$bb,$bb,$d6,$bb,$16,$16,$3a,$2c,$16,$16,$3a,$16); + +var + Te: array[byte] of TEU absolute TCe; + +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} + + diff --git a/Tocsg.Lib/VCL/EncLib/AES/enc_cp16.inc b/Tocsg.Lib/VCL/EncLib/AES/enc_cp16.inc new file mode 100644 index 00000000..ea8633a3 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/enc_cp16.inc @@ -0,0 +1,73 @@ +(************************************************************************* + Include file for AES_ENCR.PAS - AES_Encrypt for Pascal16/Compressed tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version for compressed tables + 0.11 13.07.06 we Uses TCe box byte instead of SBox + 0.12 15.11.08 we Use Ptr2Inc from BTypes +**************************************************************************) + +(**** (C) Copyright 2002-2008 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{Normally used for TP5/5.5 (and during development BP7)} + +{---------------------------------------------------------------------------} +procedure AES_Encrypt(var ctx: TAESContext; {$ifdef CONST} const {$else} var {$endif} BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} +label done; +var + pK: PWA4; {pointer to loop round key} + r: integer; {round loop counter} + t,s: TAESBlock; +begin + {Setup key pointer} + pK := PWA4(@ctx.RK); + {Initialize with input block} + TWA4(s)[0] := TWA4(BI)[0] xor pK^[0]; + TWA4(s)[1] := TWA4(BI)[1] xor pK^[1]; + TWA4(s)[2] := TWA4(BI)[2] xor pK^[2]; + TWA4(s)[3] := TWA4(BI)[3] xor pK^[3]; + inc(Ptr2Inc(pK), 4*sizeof(longint)); + r := 1; + while true do begin + TWA4(t)[0] := Te[s[0*4+0]].E0.L xor Te[s[1*4+1]].E1.L xor Te[s[2*4+2]].E2.L xor Te[s[3*4+3]].E3.L xor pK^[0]; + TWA4(t)[1] := Te[s[1*4+0]].E0.L xor Te[s[2*4+1]].E1.L xor Te[s[3*4+2]].E2.L xor Te[s[0*4+3]].E3.L xor pK^[1]; + TWA4(t)[2] := Te[s[2*4+0]].E0.L xor Te[s[3*4+1]].E1.L xor Te[s[0*4+2]].E2.L xor Te[s[1*4+3]].E3.L xor pK^[2]; + TWA4(t)[3] := Te[s[3*4+0]].E0.L xor Te[s[0*4+1]].E1.L xor Te[s[1*4+2]].E2.L xor Te[s[2*4+3]].E3.L xor pK^[3]; + inc(Ptr2Inc(pK), 4*sizeof(longint)); + inc(r); + if r>=ctx.rounds then goto done; + TWA4(s)[0] := Te[t[0*4+0]].E0.L xor Te[t[1*4+1]].E1.L xor Te[t[2*4+2]].E2.L xor Te[t[3*4+3]].E3.L xor pK^[0]; + TWA4(s)[1] := Te[t[1*4+0]].E0.L xor Te[t[2*4+1]].E1.L xor Te[t[3*4+2]].E2.L xor Te[t[0*4+3]].E3.L xor pK^[1]; + TWA4(s)[2] := Te[t[2*4+0]].E0.L xor Te[t[3*4+1]].E1.L xor Te[t[0*4+2]].E2.L xor Te[t[1*4+3]].E3.L xor pK^[2]; + TWA4(s)[3] := Te[t[3*4+0]].E0.L xor Te[t[0*4+1]].E1.L xor Te[t[1*4+2]].E2.L xor Te[t[2*4+3]].E3.L xor pK^[3]; + inc(Ptr2Inc(pK), 4*sizeof(longint)); + inc(r); + end; + +done: + + s[00] := Te[t[0*4+0]].E0.box; + s[01] := Te[t[1*4+1]].E0.box; + s[02] := Te[t[2*4+2]].E0.box; + s[03] := Te[t[3*4+3]].E0.box; + s[04] := Te[t[1*4+0]].E0.box; + s[05] := Te[t[2*4+1]].E0.box; + s[06] := Te[t[3*4+2]].E0.box; + s[07] := Te[t[0*4+3]].E0.box; + s[08] := Te[t[2*4+0]].E0.box; + s[09] := Te[t[3*4+1]].E0.box; + s[10] := Te[t[0*4+2]].E0.box; + s[11] := Te[t[1*4+3]].E0.box; + s[12] := Te[t[3*4+0]].E0.box; + s[13] := Te[t[0*4+1]].E0.box; + s[14] := Te[t[1*4+2]].E0.box; + s[15] := Te[t[2*4+3]].E0.box; + + TWA4(BO)[0] := TWA4(s)[0] xor pK^[0]; + TWA4(BO)[1] := TWA4(s)[1] xor pK^[1]; + TWA4(BO)[2] := TWA4(s)[2] xor pK^[2]; + TWA4(BO)[3] := TWA4(s)[3] xor pK^[3]; +end; diff --git a/Tocsg.Lib/VCL/EncLib/AES/enc_cp32.inc b/Tocsg.Lib/VCL/EncLib/AES/enc_cp32.inc new file mode 100644 index 00000000..768bedb0 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/enc_cp32.inc @@ -0,0 +1,62 @@ + +(************************************************************************* + Include file for AES_ENCR.PAS - AES_Encrypt for BIT32/Compressed tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version for compressed tables + 0.11 09.07.06 we Removed AES_LONGBOX code + 0.12 13.07.06 we Uses TCe box byte instead of SBox +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{---------------------------------------------------------------------------} +procedure AES_Encrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} +var + r: integer; {round loop countdown counter} + pK: PWA4; {pointer to loop round key } + s3,s0,s1,s2: longint; {TAESBlock s as separate variables} + t: TWA4; +begin + {Setup key pointer} + pK := PWA4(@ctx.RK); + {Initialize with input block} + s0 := TWA4(BI)[0] xor pK^[0]; + s1 := TWA4(BI)[1] xor pK^[1]; + s2 := TWA4(BI)[2] xor pK^[2]; + s3 := TWA4(BI)[3] xor pK^[3]; + inc(pK); + {perform encryption rounds} + for r:=1 to ctx.Rounds-1 do begin + t[0] := Te[s0 and $ff].E0.L xor Te[s1 shr 8 and $ff].E1.L xor Te[s2 shr 16 and $ff].E2.L xor Te[s3 shr 24].E3.L xor pK^[0]; + t[1] := Te[s1 and $ff].E0.L xor Te[s2 shr 8 and $ff].E1.L xor Te[s3 shr 16 and $ff].E2.L xor Te[s0 shr 24].E3.L xor pK^[1]; + t[2] := Te[s2 and $ff].E0.L xor Te[s3 shr 8 and $ff].E1.L xor Te[s0 shr 16 and $ff].E2.L xor Te[s1 shr 24].E3.L xor pK^[2]; + s3 := Te[s3 and $ff].E0.L xor Te[s0 shr 8 and $ff].E1.L xor Te[s1 shr 16 and $ff].E2.L xor Te[s2 shr 24].E3.L xor pK^[3]; + s0 := t[0]; + s1 := t[1]; + s2 := t[2]; + inc(pK); + end; + {Uses Sbox byte from Te and shl, needs type cast longint() for 16 bit compilers} + TWA4(BO)[0] := (longint(Te[s0 and $ff].E0.box) xor + longint(Te[s1 shr 8 and $ff].E0.box) shl 8 xor + longint(Te[s2 shr 16 and $ff].E0.box) shl 16 xor + longint(Te[s3 shr 24 ].E0.box) shl 24 ) xor pK^[0]; + TWA4(BO)[1] := (longint(Te[s1 and $ff].E0.box) xor + longint(Te[s2 shr 8 and $ff].E0.box) shl 8 xor + longint(Te[s3 shr 16 and $ff].E0.box) shl 16 xor + longint(Te[s0 shr 24 ].E0.box) shl 24 ) xor pK^[1]; + TWA4(BO)[2] := (longint(Te[s2 and $ff].E0.box) xor + longint(Te[s3 shr 8 and $ff].E0.box) shl 8 xor + longint(Te[s0 shr 16 and $ff].E0.box) shl 16 xor + longint(Te[s1 shr 24 ].E0.box) shl 24 ) xor pK^[2]; + TWA4(BO)[3] := (longint(Te[s3 and $ff].E0.box) xor + longint(Te[s0 shr 8 and $ff].E0.box) shl 8 xor + longint(Te[s1 shr 16 and $ff].E0.box) shl 16 xor + longint(Te[s2 shr 24 ].E0.box) shl 24 ) xor pK^[3]; + +end; + diff --git a/Tocsg.Lib/VCL/EncLib/AES/enc_fa16.inc b/Tocsg.Lib/VCL/EncLib/AES/enc_fa16.inc new file mode 100644 index 00000000..56201767 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/enc_fa16.inc @@ -0,0 +1,318 @@ +(************************************************************************* + Include file for AES_ENCR.PAS - AES_Encrypt for BASM16/Full tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version from AES_ENCR.PAS +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{16 bit BASM used for TP6, BP7, Delphi1} + +{---------------------------------------------------------------------------} +procedure AES_Encrypt(var ctx: TAESContext; {$ifdef CONST} const {$else} var {$endif} BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} +var + s,t: TAESBlock; + rnd: integer; + pK: pointer; +begin + rnd := ctx.rounds; + pK := @ctx.RK; + asm + + db $66; pusha + +{AES_XorBlock(BI, ctx.RK[0], s);} + les si,[BI] + db $66; mov ax,es:[si] + db $66; mov bx,es:[si+4] + db $66; mov cx,es:[si+8] + db $66; mov dx,es:[si+12] + + les di,[pK] + db $66; xor ax,es:[di] + db $66; xor bx,es:[di+4] + db $66; xor cx,es:[di+8] + db $66; xor dx,es:[di+12] + + db $66; mov word ptr [s],ax + db $66; mov word ptr [s+4],bx + db $66; mov word ptr [s+8],cx + db $66; mov word ptr [s+12],dx + + add di,16 {di->ctx.RK[1]} + mov dx,[rnd] + mov cx,1 + +{ *Note* in the following round loop } +{ op eax, mem[4*bx] is calculated as } +{ lea esi, [ebx + 2*ebx] } +{ op eax, mem[ebx+esi] } +{ lea esi,[ebx+2*ebx] = db $66,$67,$8D,$34,$5B; } + + db $66; sub bx,bx {clear ebx} + +@@1: + +{TWA4(t)[0] := Te0[s[0*4+0]] xor Te1[s[1*4+1]] xor Te2[s[2*4+2]] xor Te3[s[3*4+3]] xor TWA4(ctx.RK[r])[0];} + mov bl,byte ptr s[0*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Te0[bx+si] + + mov bl,byte ptr s[1*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te1[bx+si] + + mov bl,byte ptr s[2*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te2[bx+si] + + mov bl,byte ptr s[3*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te3[bx+si] + + db $66; xor ax,es:[di] + db $66; mov word ptr t[0],ax + +{TWA4(t)[1] := Te0[s[1*4+0]] xor Te1[s[2*4+1]] xor Te2[s[3*4+2]] xor Te3[s[0*4+3]] xor TWA4(ctx.RK[r])[1];} + mov bl,byte ptr s[1*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Te0[bx+si] + + mov bl,byte ptr s[2*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te1[bx+si] + + mov bl,byte ptr s[3*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te2[bx+si] + + mov bl,byte ptr s[0*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te3[bx+si] + + db $66; xor ax,es:[di+4] + db $66; mov word ptr t[4],ax + +{TWA4(t)[2] := Te0[s[2*4+0]] xor Te1[s[3*4+1]] xor Te2[s[0*4+2]] xor Te3[s[1*4+3]] xor TWA4(ctx.RK[r])[2];} + mov bl,byte ptr s[2*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Te0[bx+si] + + mov bl,byte ptr s[3*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te1[bx+si] + + mov bl,byte ptr s[0*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te2[bx+si] + + mov bl,byte ptr s[1*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te3[bx+si] + + db $66; xor ax,es:[di+8] + db $66; mov word ptr t[8],ax + +{TWA4(t)[3] := Te0[s[3*4+0]] xor Te1[s[0*4+1]] xor Te2[s[1*4+2]] xor Te3[s[2*4+3]] xor TWA4(ctx.RK[r])[3];} + mov bl,byte ptr s[3*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Te0[bx+si] + + mov bl,byte ptr s[0*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te1[bx+si] + + mov bl,byte ptr s[1*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te2[bx+si] + + mov bl,byte ptr s[2*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te3[bx+si] + + db $66; xor ax,es:[di+12] + db $66; mov word ptr t[12],ax + +{if r>=ctx.rounds then break;} + inc cx + cmp cx,dx + jae @@2 + +{TWA4(s)[0] := Te0[t[0*4+0]] xor Te1[t[1*4+1]] xor Te2[t[2*4+2]] xor Te3[t[3*4+3]] xor TWA4(ctx.RK[r])[0];} + mov bl,byte ptr t[0*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Te0[bx+si] + + mov bl,byte ptr t[1*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te1[bx+si] + + mov bl,byte ptr t[2*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te2[bx+si] + + mov bl,byte ptr t[3*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te3[bx+si] + + db $66; xor ax,es:[di+16] + db $66; mov word ptr s[0],ax + +{TWA4(s)[1] := Te0[t[1*4+0]] xor Te1[t[2*4+1]] xor Te2[t[3*4+2]] xor Te3[t[0*4+3]] xor TWA4(ctx.RK[r])[1];} + mov bl,byte ptr t[1*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Te0[bx+si] + + mov bl,byte ptr t[2*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te1[bx+si] + + mov bl,byte ptr t[3*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te2[bx+si] + + mov bl,byte ptr t[0*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te3[bx+si] + + db $66; xor ax,es:[di+20] + db $66; mov word ptr s[4],ax + +{TWA4(s)[2] := Te0[t[2*4+0]] xor Te1[t[3*4+1]] xor Te2[t[0*4+2]] xor Te3[t[1*4+3]] xor TWA4(ctx.RK[r])[2];} + mov bl,byte ptr t[2*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Te0[bx+si] + + mov bl,byte ptr t[3*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te1[bx+si] + + mov bl,byte ptr t[0*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te2[bx+si] + + mov bl,byte ptr t[1*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te3[bx+si] + + db $66; xor ax,es:[di+24] + db $66; mov word ptr s[8],ax + +{TWA4(s)[3] := Te0[t[3*4+0]] xor Te1[t[0*4+1]] xor Te2[t[1*4+2]] xor Te3[t[2*4+3]] xor TWA4(ctx.RK[r])[3];} + mov bl,byte ptr t[3*4+0] + db $66,$67,$8D,$34,$5B; + db $66; mov ax,word ptr Te0[bx+si] + + mov bl,byte ptr t[0*4+1] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te1[bx+si] + + mov bl,byte ptr t[1*4+2] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te2[bx+si] + + mov bl,byte ptr t[2*4+3] + db $66,$67,$8D,$34,$5B; + db $66; xor ax,word ptr Te3[bx+si] + + db $66; xor ax,es:[di+28] + add di,32 + db $66; mov word ptr s[12],ax + + inc cx + jmp @@1 + +@@2: add di,16 {di -> ctx.RK[ctx.rounds]} + + {Last round uses SBox} + + sub bx,bx + + mov bl, byte ptr t[0*4+0] + mov al, byte ptr SBox[bx] + mov byte ptr s[0],al + + mov bl, byte ptr t[1*4+1] + mov al, byte ptr SBox[bx] + mov byte ptr s[1],al + + mov bl, byte ptr t[2*4+2] + mov al, byte ptr SBox[bx] + mov byte ptr s[2],al + + mov bl, byte ptr t[3*4+3] + mov al, byte ptr SBox[bx] + mov byte ptr s[3],al + + mov bl, byte ptr t[1*4+0] + mov al, byte ptr SBox[bx] + mov byte ptr s[4],al + + mov bl, byte ptr t[2*4+1] + mov al, byte ptr SBox[bx] + mov byte ptr s[5],al + + mov bl, byte ptr t[3*4+2] + mov al, byte ptr SBox[bx] + mov byte ptr s[6],al + + mov bl, byte ptr t[0*4+3] + mov al, byte ptr SBox[bx] + mov byte ptr s[7],al + + mov bl, byte ptr t[2*4+0] + mov al, byte ptr SBox[bx] + mov byte ptr s[8],al + + mov bl, byte ptr t[3*4+1] + mov al, byte ptr SBox[bx] + mov byte ptr s[9],al + + mov bl, byte ptr t[0*4+2] + mov al, byte ptr SBox[bx] + mov byte ptr s[10],al + + mov bl, byte ptr t[1*4+3] + mov al, byte ptr SBox[bx] + mov byte ptr s[11],al + + mov bl, byte ptr t[3*4+0] + mov al, byte ptr SBox[bx] + mov byte ptr s[12],al + + mov bl, byte ptr t[0*4+1] + mov al, byte ptr SBox[bx] + mov byte ptr s[13],al + + mov bl, byte ptr t[1*4+2] + mov al, byte ptr SBox[bx] + mov byte ptr s[14],al + + mov bl, byte ptr t[2*4+3] + mov al, byte ptr SBox[bx] + mov byte ptr s[15],al + +{AES_XorBlock(s, ctx.RK[rnd], BO)} + + db $66; mov ax,word ptr [s] + db $66; mov bx,word ptr [s+4] + db $66; mov cx,word ptr [s+8] + db $66; mov dx,word ptr [s+12] + db $66; xor ax,es:[di] + db $66; xor bx,es:[di+4] + db $66; xor cx,es:[di+8] + db $66; xor dx,es:[di+12] + les si,[BO] + db $66; mov es:[si],ax + db $66; mov es:[si+4],bx + db $66; mov es:[si+8],cx + db $66; mov es:[si+12],dx + + db $66; popa + + end; +end; diff --git a/Tocsg.Lib/VCL/EncLib/AES/enc_fdat.inc b/Tocsg.Lib/VCL/EncLib/AES/enc_fdat.inc new file mode 100644 index 00000000..6f2a9695 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/enc_fdat.inc @@ -0,0 +1,207 @@ +(************************************************************************* + Include file for AES_ENCR.PAS - Full tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version from AES_ENCR.PAS +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9+ errors!} +{$endif} + + +const + Te0: array[byte] of longint = + ($a56363c6, $847c7cf8, $997777ee, $8d7b7bf6, $0df2f2ff, $bd6b6bd6, $b16f6fde, $54c5c591, + $50303060, $03010102, $a96767ce, $7d2b2b56, $19fefee7, $62d7d7b5, $e6abab4d, $9a7676ec, + $45caca8f, $9d82821f, $40c9c989, $877d7dfa, $15fafaef, $eb5959b2, $c947478e, $0bf0f0fb, + $ecadad41, $67d4d4b3, $fda2a25f, $eaafaf45, $bf9c9c23, $f7a4a453, $967272e4, $5bc0c09b, + $c2b7b775, $1cfdfde1, $ae93933d, $6a26264c, $5a36366c, $413f3f7e, $02f7f7f5, $4fcccc83, + $5c343468, $f4a5a551, $34e5e5d1, $08f1f1f9, $937171e2, $73d8d8ab, $53313162, $3f15152a, + $0c040408, $52c7c795, $65232346, $5ec3c39d, $28181830, $a1969637, $0f05050a, $b59a9a2f, + $0907070e, $36121224, $9b80801b, $3de2e2df, $26ebebcd, $6927274e, $cdb2b27f, $9f7575ea, + $1b090912, $9e83831d, $742c2c58, $2e1a1a34, $2d1b1b36, $b26e6edc, $ee5a5ab4, $fba0a05b, + $f65252a4, $4d3b3b76, $61d6d6b7, $ceb3b37d, $7b292952, $3ee3e3dd, $712f2f5e, $97848413, + $f55353a6, $68d1d1b9, $00000000, $2cededc1, $60202040, $1ffcfce3, $c8b1b179, $ed5b5bb6, + $be6a6ad4, $46cbcb8d, $d9bebe67, $4b393972, $de4a4a94, $d44c4c98, $e85858b0, $4acfcf85, + $6bd0d0bb, $2aefefc5, $e5aaaa4f, $16fbfbed, $c5434386, $d74d4d9a, $55333366, $94858511, + $cf45458a, $10f9f9e9, $06020204, $817f7ffe, $f05050a0, $443c3c78, $ba9f9f25, $e3a8a84b, + $f35151a2, $fea3a35d, $c0404080, $8a8f8f05, $ad92923f, $bc9d9d21, $48383870, $04f5f5f1, + $dfbcbc63, $c1b6b677, $75dadaaf, $63212142, $30101020, $1affffe5, $0ef3f3fd, $6dd2d2bf, + $4ccdcd81, $140c0c18, $35131326, $2fececc3, $e15f5fbe, $a2979735, $cc444488, $3917172e, + $57c4c493, $f2a7a755, $827e7efc, $473d3d7a, $ac6464c8, $e75d5dba, $2b191932, $957373e6, + $a06060c0, $98818119, $d14f4f9e, $7fdcdca3, $66222244, $7e2a2a54, $ab90903b, $8388880b, + $ca46468c, $29eeeec7, $d3b8b86b, $3c141428, $79dedea7, $e25e5ebc, $1d0b0b16, $76dbdbad, + $3be0e0db, $56323264, $4e3a3a74, $1e0a0a14, $db494992, $0a06060c, $6c242448, $e45c5cb8, + $5dc2c29f, $6ed3d3bd, $efacac43, $a66262c4, $a8919139, $a4959531, $37e4e4d3, $8b7979f2, + $32e7e7d5, $43c8c88b, $5937376e, $b76d6dda, $8c8d8d01, $64d5d5b1, $d24e4e9c, $e0a9a949, + $b46c6cd8, $fa5656ac, $07f4f4f3, $25eaeacf, $af6565ca, $8e7a7af4, $e9aeae47, $18080810, + $d5baba6f, $887878f0, $6f25254a, $722e2e5c, $241c1c38, $f1a6a657, $c7b4b473, $51c6c697, + $23e8e8cb, $7cdddda1, $9c7474e8, $211f1f3e, $dd4b4b96, $dcbdbd61, $868b8b0d, $858a8a0f, + $907070e0, $423e3e7c, $c4b5b571, $aa6666cc, $d8484890, $05030306, $01f6f6f7, $120e0e1c, + $a36161c2, $5f35356a, $f95757ae, $d0b9b969, $91868617, $58c1c199, $271d1d3a, $b99e9e27, + $38e1e1d9, $13f8f8eb, $b398982b, $33111122, $bb6969d2, $70d9d9a9, $898e8e07, $a7949433, + $b69b9b2d, $221e1e3c, $92878715, $20e9e9c9, $49cece87, $ff5555aa, $78282850, $7adfdfa5, + $8f8c8c03, $f8a1a159, $80898909, $170d0d1a, $dabfbf65, $31e6e6d7, $c6424284, $b86868d0, + $c3414182, $b0999929, $772d2d5a, $110f0f1e, $cbb0b07b, $fc5454a8, $d6bbbb6d, $3a16162c); + + Te1: array[byte] of longint = + ($6363c6a5, $7c7cf884, $7777ee99, $7b7bf68d, $f2f2ff0d, $6b6bd6bd, $6f6fdeb1, $c5c59154, + $30306050, $01010203, $6767cea9, $2b2b567d, $fefee719, $d7d7b562, $abab4de6, $7676ec9a, + $caca8f45, $82821f9d, $c9c98940, $7d7dfa87, $fafaef15, $5959b2eb, $47478ec9, $f0f0fb0b, + $adad41ec, $d4d4b367, $a2a25ffd, $afaf45ea, $9c9c23bf, $a4a453f7, $7272e496, $c0c09b5b, + $b7b775c2, $fdfde11c, $93933dae, $26264c6a, $36366c5a, $3f3f7e41, $f7f7f502, $cccc834f, + $3434685c, $a5a551f4, $e5e5d134, $f1f1f908, $7171e293, $d8d8ab73, $31316253, $15152a3f, + $0404080c, $c7c79552, $23234665, $c3c39d5e, $18183028, $969637a1, $05050a0f, $9a9a2fb5, + $07070e09, $12122436, $80801b9b, $e2e2df3d, $ebebcd26, $27274e69, $b2b27fcd, $7575ea9f, + $0909121b, $83831d9e, $2c2c5874, $1a1a342e, $1b1b362d, $6e6edcb2, $5a5ab4ee, $a0a05bfb, + $5252a4f6, $3b3b764d, $d6d6b761, $b3b37dce, $2929527b, $e3e3dd3e, $2f2f5e71, $84841397, + $5353a6f5, $d1d1b968, $00000000, $ededc12c, $20204060, $fcfce31f, $b1b179c8, $5b5bb6ed, + $6a6ad4be, $cbcb8d46, $bebe67d9, $3939724b, $4a4a94de, $4c4c98d4, $5858b0e8, $cfcf854a, + $d0d0bb6b, $efefc52a, $aaaa4fe5, $fbfbed16, $434386c5, $4d4d9ad7, $33336655, $85851194, + $45458acf, $f9f9e910, $02020406, $7f7ffe81, $5050a0f0, $3c3c7844, $9f9f25ba, $a8a84be3, + $5151a2f3, $a3a35dfe, $404080c0, $8f8f058a, $92923fad, $9d9d21bc, $38387048, $f5f5f104, + $bcbc63df, $b6b677c1, $dadaaf75, $21214263, $10102030, $ffffe51a, $f3f3fd0e, $d2d2bf6d, + $cdcd814c, $0c0c1814, $13132635, $ececc32f, $5f5fbee1, $979735a2, $444488cc, $17172e39, + $c4c49357, $a7a755f2, $7e7efc82, $3d3d7a47, $6464c8ac, $5d5dbae7, $1919322b, $7373e695, + $6060c0a0, $81811998, $4f4f9ed1, $dcdca37f, $22224466, $2a2a547e, $90903bab, $88880b83, + $46468cca, $eeeec729, $b8b86bd3, $1414283c, $dedea779, $5e5ebce2, $0b0b161d, $dbdbad76, + $e0e0db3b, $32326456, $3a3a744e, $0a0a141e, $494992db, $06060c0a, $2424486c, $5c5cb8e4, + $c2c29f5d, $d3d3bd6e, $acac43ef, $6262c4a6, $919139a8, $959531a4, $e4e4d337, $7979f28b, + $e7e7d532, $c8c88b43, $37376e59, $6d6ddab7, $8d8d018c, $d5d5b164, $4e4e9cd2, $a9a949e0, + $6c6cd8b4, $5656acfa, $f4f4f307, $eaeacf25, $6565caaf, $7a7af48e, $aeae47e9, $08081018, + $baba6fd5, $7878f088, $25254a6f, $2e2e5c72, $1c1c3824, $a6a657f1, $b4b473c7, $c6c69751, + $e8e8cb23, $dddda17c, $7474e89c, $1f1f3e21, $4b4b96dd, $bdbd61dc, $8b8b0d86, $8a8a0f85, + $7070e090, $3e3e7c42, $b5b571c4, $6666ccaa, $484890d8, $03030605, $f6f6f701, $0e0e1c12, + $6161c2a3, $35356a5f, $5757aef9, $b9b969d0, $86861791, $c1c19958, $1d1d3a27, $9e9e27b9, + $e1e1d938, $f8f8eb13, $98982bb3, $11112233, $6969d2bb, $d9d9a970, $8e8e0789, $949433a7, + $9b9b2db6, $1e1e3c22, $87871592, $e9e9c920, $cece8749, $5555aaff, $28285078, $dfdfa57a, + $8c8c038f, $a1a159f8, $89890980, $0d0d1a17, $bfbf65da, $e6e6d731, $424284c6, $6868d0b8, + $414182c3, $999929b0, $2d2d5a77, $0f0f1e11, $b0b07bcb, $5454a8fc, $bbbb6dd6, $16162c3a); + + Te2: array[byte] of longint = + ($63c6a563, $7cf8847c, $77ee9977, $7bf68d7b, $f2ff0df2, $6bd6bd6b, $6fdeb16f, $c59154c5, + $30605030, $01020301, $67cea967, $2b567d2b, $fee719fe, $d7b562d7, $ab4de6ab, $76ec9a76, + $ca8f45ca, $821f9d82, $c98940c9, $7dfa877d, $faef15fa, $59b2eb59, $478ec947, $f0fb0bf0, + $ad41ecad, $d4b367d4, $a25ffda2, $af45eaaf, $9c23bf9c, $a453f7a4, $72e49672, $c09b5bc0, + $b775c2b7, $fde11cfd, $933dae93, $264c6a26, $366c5a36, $3f7e413f, $f7f502f7, $cc834fcc, + $34685c34, $a551f4a5, $e5d134e5, $f1f908f1, $71e29371, $d8ab73d8, $31625331, $152a3f15, + $04080c04, $c79552c7, $23466523, $c39d5ec3, $18302818, $9637a196, $050a0f05, $9a2fb59a, + $070e0907, $12243612, $801b9b80, $e2df3de2, $ebcd26eb, $274e6927, $b27fcdb2, $75ea9f75, + $09121b09, $831d9e83, $2c58742c, $1a342e1a, $1b362d1b, $6edcb26e, $5ab4ee5a, $a05bfba0, + $52a4f652, $3b764d3b, $d6b761d6, $b37dceb3, $29527b29, $e3dd3ee3, $2f5e712f, $84139784, + $53a6f553, $d1b968d1, $00000000, $edc12ced, $20406020, $fce31ffc, $b179c8b1, $5bb6ed5b, + $6ad4be6a, $cb8d46cb, $be67d9be, $39724b39, $4a94de4a, $4c98d44c, $58b0e858, $cf854acf, + $d0bb6bd0, $efc52aef, $aa4fe5aa, $fbed16fb, $4386c543, $4d9ad74d, $33665533, $85119485, + $458acf45, $f9e910f9, $02040602, $7ffe817f, $50a0f050, $3c78443c, $9f25ba9f, $a84be3a8, + $51a2f351, $a35dfea3, $4080c040, $8f058a8f, $923fad92, $9d21bc9d, $38704838, $f5f104f5, + $bc63dfbc, $b677c1b6, $daaf75da, $21426321, $10203010, $ffe51aff, $f3fd0ef3, $d2bf6dd2, + $cd814ccd, $0c18140c, $13263513, $ecc32fec, $5fbee15f, $9735a297, $4488cc44, $172e3917, + $c49357c4, $a755f2a7, $7efc827e, $3d7a473d, $64c8ac64, $5dbae75d, $19322b19, $73e69573, + $60c0a060, $81199881, $4f9ed14f, $dca37fdc, $22446622, $2a547e2a, $903bab90, $880b8388, + $468cca46, $eec729ee, $b86bd3b8, $14283c14, $dea779de, $5ebce25e, $0b161d0b, $dbad76db, + $e0db3be0, $32645632, $3a744e3a, $0a141e0a, $4992db49, $060c0a06, $24486c24, $5cb8e45c, + $c29f5dc2, $d3bd6ed3, $ac43efac, $62c4a662, $9139a891, $9531a495, $e4d337e4, $79f28b79, + $e7d532e7, $c88b43c8, $376e5937, $6ddab76d, $8d018c8d, $d5b164d5, $4e9cd24e, $a949e0a9, + $6cd8b46c, $56acfa56, $f4f307f4, $eacf25ea, $65caaf65, $7af48e7a, $ae47e9ae, $08101808, + $ba6fd5ba, $78f08878, $254a6f25, $2e5c722e, $1c38241c, $a657f1a6, $b473c7b4, $c69751c6, + $e8cb23e8, $dda17cdd, $74e89c74, $1f3e211f, $4b96dd4b, $bd61dcbd, $8b0d868b, $8a0f858a, + $70e09070, $3e7c423e, $b571c4b5, $66ccaa66, $4890d848, $03060503, $f6f701f6, $0e1c120e, + $61c2a361, $356a5f35, $57aef957, $b969d0b9, $86179186, $c19958c1, $1d3a271d, $9e27b99e, + $e1d938e1, $f8eb13f8, $982bb398, $11223311, $69d2bb69, $d9a970d9, $8e07898e, $9433a794, + $9b2db69b, $1e3c221e, $87159287, $e9c920e9, $ce8749ce, $55aaff55, $28507828, $dfa57adf, + $8c038f8c, $a159f8a1, $89098089, $0d1a170d, $bf65dabf, $e6d731e6, $4284c642, $68d0b868, + $4182c341, $9929b099, $2d5a772d, $0f1e110f, $b07bcbb0, $54a8fc54, $bb6dd6bb, $162c3a16); + + Te3: array[byte] of longint = + ($c6a56363, $f8847c7c, $ee997777, $f68d7b7b, $ff0df2f2, $d6bd6b6b, $deb16f6f, $9154c5c5, + $60503030, $02030101, $cea96767, $567d2b2b, $e719fefe, $b562d7d7, $4de6abab, $ec9a7676, + $8f45caca, $1f9d8282, $8940c9c9, $fa877d7d, $ef15fafa, $b2eb5959, $8ec94747, $fb0bf0f0, + $41ecadad, $b367d4d4, $5ffda2a2, $45eaafaf, $23bf9c9c, $53f7a4a4, $e4967272, $9b5bc0c0, + $75c2b7b7, $e11cfdfd, $3dae9393, $4c6a2626, $6c5a3636, $7e413f3f, $f502f7f7, $834fcccc, + $685c3434, $51f4a5a5, $d134e5e5, $f908f1f1, $e2937171, $ab73d8d8, $62533131, $2a3f1515, + $080c0404, $9552c7c7, $46652323, $9d5ec3c3, $30281818, $37a19696, $0a0f0505, $2fb59a9a, + $0e090707, $24361212, $1b9b8080, $df3de2e2, $cd26ebeb, $4e692727, $7fcdb2b2, $ea9f7575, + $121b0909, $1d9e8383, $58742c2c, $342e1a1a, $362d1b1b, $dcb26e6e, $b4ee5a5a, $5bfba0a0, + $a4f65252, $764d3b3b, $b761d6d6, $7dceb3b3, $527b2929, $dd3ee3e3, $5e712f2f, $13978484, + $a6f55353, $b968d1d1, $00000000, $c12ceded, $40602020, $e31ffcfc, $79c8b1b1, $b6ed5b5b, + $d4be6a6a, $8d46cbcb, $67d9bebe, $724b3939, $94de4a4a, $98d44c4c, $b0e85858, $854acfcf, + $bb6bd0d0, $c52aefef, $4fe5aaaa, $ed16fbfb, $86c54343, $9ad74d4d, $66553333, $11948585, + $8acf4545, $e910f9f9, $04060202, $fe817f7f, $a0f05050, $78443c3c, $25ba9f9f, $4be3a8a8, + $a2f35151, $5dfea3a3, $80c04040, $058a8f8f, $3fad9292, $21bc9d9d, $70483838, $f104f5f5, + $63dfbcbc, $77c1b6b6, $af75dada, $42632121, $20301010, $e51affff, $fd0ef3f3, $bf6dd2d2, + $814ccdcd, $18140c0c, $26351313, $c32fecec, $bee15f5f, $35a29797, $88cc4444, $2e391717, + $9357c4c4, $55f2a7a7, $fc827e7e, $7a473d3d, $c8ac6464, $bae75d5d, $322b1919, $e6957373, + $c0a06060, $19988181, $9ed14f4f, $a37fdcdc, $44662222, $547e2a2a, $3bab9090, $0b838888, + $8cca4646, $c729eeee, $6bd3b8b8, $283c1414, $a779dede, $bce25e5e, $161d0b0b, $ad76dbdb, + $db3be0e0, $64563232, $744e3a3a, $141e0a0a, $92db4949, $0c0a0606, $486c2424, $b8e45c5c, + $9f5dc2c2, $bd6ed3d3, $43efacac, $c4a66262, $39a89191, $31a49595, $d337e4e4, $f28b7979, + $d532e7e7, $8b43c8c8, $6e593737, $dab76d6d, $018c8d8d, $b164d5d5, $9cd24e4e, $49e0a9a9, + $d8b46c6c, $acfa5656, $f307f4f4, $cf25eaea, $caaf6565, $f48e7a7a, $47e9aeae, $10180808, + $6fd5baba, $f0887878, $4a6f2525, $5c722e2e, $38241c1c, $57f1a6a6, $73c7b4b4, $9751c6c6, + $cb23e8e8, $a17cdddd, $e89c7474, $3e211f1f, $96dd4b4b, $61dcbdbd, $0d868b8b, $0f858a8a, + $e0907070, $7c423e3e, $71c4b5b5, $ccaa6666, $90d84848, $06050303, $f701f6f6, $1c120e0e, + $c2a36161, $6a5f3535, $aef95757, $69d0b9b9, $17918686, $9958c1c1, $3a271d1d, $27b99e9e, + $d938e1e1, $eb13f8f8, $2bb39898, $22331111, $d2bb6969, $a970d9d9, $07898e8e, $33a79494, + $2db69b9b, $3c221e1e, $15928787, $c920e9e9, $8749cece, $aaff5555, $50782828, $a57adfdf, + $038f8c8c, $59f8a1a1, $09808989, $1a170d0d, $65dabfbf, $d731e6e6, $84c64242, $d0b86868, + $82c34141, $29b09999, $5a772d2d, $1e110f0f, $7bcbb0b0, $a8fc5454, $6dd6bbbb, $2c3a1616); + + +{$ifdef AES_LONGBOX} + Te4: array[byte] of longint = + ($63636363, $7c7c7c7c, $77777777, $7b7b7b7b, $f2f2f2f2, $6b6b6b6b, $6f6f6f6f, $c5c5c5c5, + $30303030, $01010101, $67676767, $2b2b2b2b, $fefefefe, $d7d7d7d7, $abababab, $76767676, + $cacacaca, $82828282, $c9c9c9c9, $7d7d7d7d, $fafafafa, $59595959, $47474747, $f0f0f0f0, + $adadadad, $d4d4d4d4, $a2a2a2a2, $afafafaf, $9c9c9c9c, $a4a4a4a4, $72727272, $c0c0c0c0, + $b7b7b7b7, $fdfdfdfd, $93939393, $26262626, $36363636, $3f3f3f3f, $f7f7f7f7, $cccccccc, + $34343434, $a5a5a5a5, $e5e5e5e5, $f1f1f1f1, $71717171, $d8d8d8d8, $31313131, $15151515, + $04040404, $c7c7c7c7, $23232323, $c3c3c3c3, $18181818, $96969696, $05050505, $9a9a9a9a, + $07070707, $12121212, $80808080, $e2e2e2e2, $ebebebeb, $27272727, $b2b2b2b2, $75757575, + $09090909, $83838383, $2c2c2c2c, $1a1a1a1a, $1b1b1b1b, $6e6e6e6e, $5a5a5a5a, $a0a0a0a0, + $52525252, $3b3b3b3b, $d6d6d6d6, $b3b3b3b3, $29292929, $e3e3e3e3, $2f2f2f2f, $84848484, + $53535353, $d1d1d1d1, $00000000, $edededed, $20202020, $fcfcfcfc, $b1b1b1b1, $5b5b5b5b, + $6a6a6a6a, $cbcbcbcb, $bebebebe, $39393939, $4a4a4a4a, $4c4c4c4c, $58585858, $cfcfcfcf, + $d0d0d0d0, $efefefef, $aaaaaaaa, $fbfbfbfb, $43434343, $4d4d4d4d, $33333333, $85858585, + $45454545, $f9f9f9f9, $02020202, $7f7f7f7f, $50505050, $3c3c3c3c, $9f9f9f9f, $a8a8a8a8, + $51515151, $a3a3a3a3, $40404040, $8f8f8f8f, $92929292, $9d9d9d9d, $38383838, $f5f5f5f5, + $bcbcbcbc, $b6b6b6b6, $dadadada, $21212121, $10101010, $ffffffff, $f3f3f3f3, $d2d2d2d2, + $cdcdcdcd, $0c0c0c0c, $13131313, $ecececec, $5f5f5f5f, $97979797, $44444444, $17171717, + $c4c4c4c4, $a7a7a7a7, $7e7e7e7e, $3d3d3d3d, $64646464, $5d5d5d5d, $19191919, $73737373, + $60606060, $81818181, $4f4f4f4f, $dcdcdcdc, $22222222, $2a2a2a2a, $90909090, $88888888, + $46464646, $eeeeeeee, $b8b8b8b8, $14141414, $dededede, $5e5e5e5e, $0b0b0b0b, $dbdbdbdb, + $e0e0e0e0, $32323232, $3a3a3a3a, $0a0a0a0a, $49494949, $06060606, $24242424, $5c5c5c5c, + $c2c2c2c2, $d3d3d3d3, $acacacac, $62626262, $91919191, $95959595, $e4e4e4e4, $79797979, + $e7e7e7e7, $c8c8c8c8, $37373737, $6d6d6d6d, $8d8d8d8d, $d5d5d5d5, $4e4e4e4e, $a9a9a9a9, + $6c6c6c6c, $56565656, $f4f4f4f4, $eaeaeaea, $65656565, $7a7a7a7a, $aeaeaeae, $08080808, + $babababa, $78787878, $25252525, $2e2e2e2e, $1c1c1c1c, $a6a6a6a6, $b4b4b4b4, $c6c6c6c6, + $e8e8e8e8, $dddddddd, $74747474, $1f1f1f1f, $4b4b4b4b, $bdbdbdbd, $8b8b8b8b, $8a8a8a8a, + $70707070, $3e3e3e3e, $b5b5b5b5, $66666666, $48484848, $03030303, $f6f6f6f6, $0e0e0e0e, + $61616161, $35353535, $57575757, $b9b9b9b9, $86868686, $c1c1c1c1, $1d1d1d1d, $9e9e9e9e, + $e1e1e1e1, $f8f8f8f8, $98989898, $11111111, $69696969, $d9d9d9d9, $8e8e8e8e, $94949494, + $9b9b9b9b, $1e1e1e1e, $87878787, $e9e9e9e9, $cececece, $55555555, $28282828, $dfdfdfdf, + $8c8c8c8c, $a1a1a1a1, $89898989, $0d0d0d0d, $bfbfbfbf, $e6e6e6e6, $42424242, $68686868, + $41414141, $99999999, $2d2d2d2d, $0f0f0f0f, $b0b0b0b0, $54545454, $bbbbbbbb, $16161616); +{$endif} + +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} + + +{$ifdef AES_LONGBOX} +const + X000000ff = longint($000000ff); {Avoid D4+ warnings} + X0000ff00 = longint($0000ff00); + X00ff0000 = longint($00ff0000); + Xff000000 = longint($ff000000); +{$endif} + diff --git a/Tocsg.Lib/VCL/EncLib/AES/enc_fp16.inc b/Tocsg.Lib/VCL/EncLib/AES/enc_fp16.inc new file mode 100644 index 00000000..503c71a8 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/enc_fp16.inc @@ -0,0 +1,72 @@ +(************************************************************************* + Include file for AES_ENCR.PAS - AES_Encrypt for Pascal16/Full tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version from AES_ENCR.PAS + 0.11 16.11.08 we Use Ptr2Inc from BTypes +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{Normally used for TP5/5.5 (and during development BP7)} + +{---------------------------------------------------------------------------} +procedure AES_Encrypt(var ctx: TAESContext; {$ifdef CONST} const {$else} var {$endif} BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} +label done; +var + pK: PWA4; {pointer to loop rount key} + r: integer; + t,s: TAESBlock; +begin + {Setup key pointer} + pK := PWA4(@ctx.RK); + {Initialize with input block} + TWA4(s)[0] := TWA4(BI)[0] xor pK^[0]; + TWA4(s)[1] := TWA4(BI)[1] xor pK^[1]; + TWA4(s)[2] := TWA4(BI)[2] xor pK^[2]; + TWA4(s)[3] := TWA4(BI)[3] xor pK^[3]; + inc(Ptr2Inc(pK), 4*sizeof(longint)); + r := 1; + while true do begin + TWA4(t)[0] := Te0[s[0*4+0]] xor Te1[s[1*4+1]] xor Te2[s[2*4+2]] xor Te3[s[3*4+3]] xor pK^[0]; + TWA4(t)[1] := Te0[s[1*4+0]] xor Te1[s[2*4+1]] xor Te2[s[3*4+2]] xor Te3[s[0*4+3]] xor pK^[1]; + TWA4(t)[2] := Te0[s[2*4+0]] xor Te1[s[3*4+1]] xor Te2[s[0*4+2]] xor Te3[s[1*4+3]] xor pK^[2]; + TWA4(t)[3] := Te0[s[3*4+0]] xor Te1[s[0*4+1]] xor Te2[s[1*4+2]] xor Te3[s[2*4+3]] xor pK^[3]; + inc(Ptr2Inc(pK), 4*sizeof(longint)); + inc(r); + if r>=ctx.rounds then goto done; + TWA4(s)[0] := Te0[t[0*4+0]] xor Te1[t[1*4+1]] xor Te2[t[2*4+2]] xor Te3[t[3*4+3]] xor pK^[0]; + TWA4(s)[1] := Te0[t[1*4+0]] xor Te1[t[2*4+1]] xor Te2[t[3*4+2]] xor Te3[t[0*4+3]] xor pK^[1]; + TWA4(s)[2] := Te0[t[2*4+0]] xor Te1[t[3*4+1]] xor Te2[t[0*4+2]] xor Te3[t[1*4+3]] xor pK^[2]; + TWA4(s)[3] := Te0[t[3*4+0]] xor Te1[t[0*4+1]] xor Te2[t[1*4+2]] xor Te3[t[2*4+3]] xor pK^[3]; + inc(Ptr2Inc(pK), 4*sizeof(longint)); + inc(r); + end; + +done: + + s[00] := SBox[t[0*4+0]]; + s[01] := SBox[t[1*4+1]]; + s[02] := SBox[t[2*4+2]]; + s[03] := SBox[t[3*4+3]]; + s[04] := SBox[t[1*4+0]]; + s[05] := SBox[t[2*4+1]]; + s[06] := SBox[t[3*4+2]]; + s[07] := SBox[t[0*4+3]]; + s[08] := SBox[t[2*4+0]]; + s[09] := SBox[t[3*4+1]]; + s[10] := SBox[t[0*4+2]]; + s[11] := SBox[t[1*4+3]]; + s[12] := SBox[t[3*4+0]]; + s[13] := SBox[t[0*4+1]]; + s[14] := SBox[t[1*4+2]]; + s[15] := SBox[t[2*4+3]]; + + TWA4(BO)[0] := TWA4(s)[0] xor pK^[0]; + TWA4(BO)[1] := TWA4(s)[1] xor pK^[1]; + TWA4(BO)[2] := TWA4(s)[2] xor pK^[2]; + TWA4(BO)[3] := TWA4(s)[3] xor pK^[3]; +end; diff --git a/Tocsg.Lib/VCL/EncLib/AES/enc_fp32.inc b/Tocsg.Lib/VCL/EncLib/AES/enc_fp32.inc new file mode 100644 index 00000000..a193d30e --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/enc_fp32.inc @@ -0,0 +1,88 @@ +(************************************************************************* + Include file for AES_ENCR.PAS - AES_Encrypt for BIT32/Full tables + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 09.07.06 W.Ehrhardt Initial version from AES_ENCR.PAS +**************************************************************************) + +(**** (C) Copyright 2002-2006 Wolfgang Ehrhardt -- see copying_we.txt ****) + + +{ 32 Bit code: Alternative versions can be found in options.zip + enc_full.inc - fully unrolled version for highest speed + enc_ptr.inc - pointer version (may be faster on some systems) +} + + +{---------------------------------------------------------------------------} +procedure AES_Encrypt(var ctx: TAESContext; const BI: TAESBlock; var BO: TAESBlock); + {-encrypt one block, not checked: key must be encryption key} +var + r: integer; {round loop countdown counter} + pK: PWA4; {pointer to loop rount key } + s3,s0,s1,s2: longint; {TAESBlock s as separate variables} + t: TWA4; +begin + {Setup key pointer} + pK := PWA4(@ctx.RK); + {Initialize with input block} + s0 := TWA4(BI)[0] xor pK^[0]; + s1 := TWA4(BI)[1] xor pK^[1]; + s2 := TWA4(BI)[2] xor pK^[2]; + s3 := TWA4(BI)[3] xor pK^[3]; + inc(pK); + {perform encryption rounds} + for r:=1 to ctx.Rounds-1 do begin + t[0] := Te0[s0 and $ff] xor Te1[s1 shr 8 and $ff] xor Te2[s2 shr 16 and $ff] xor Te3[s3 shr 24] xor pK^[0]; + t[1] := Te0[s1 and $ff] xor Te1[s2 shr 8 and $ff] xor Te2[s3 shr 16 and $ff] xor Te3[s0 shr 24] xor pK^[1]; + t[2] := Te0[s2 and $ff] xor Te1[s3 shr 8 and $ff] xor Te2[s0 shr 16 and $ff] xor Te3[s1 shr 24] xor pK^[2]; + s3 := Te0[s3 and $ff] xor Te1[s0 shr 8 and $ff] xor Te2[s1 shr 16 and $ff] xor Te3[s2 shr 24] xor pK^[3]; + s0 := t[0]; + s1 := t[1]; + s2 := t[2]; + inc(pK); + end; + +{$ifdef AES_LONGBOX} + {Use expanded longint SBox table Te4 from [2]} + TWA4(BO)[0] := (Te4[s0 and $ff] and X000000ff) xor + (Te4[s1 shr 8 and $ff] and X0000ff00) xor + (Te4[s2 shr 16 and $ff] and X00ff0000) xor + (Te4[s3 shr 24 and $ff] and Xff000000) xor pK^[0]; + TWA4(BO)[1] := (Te4[s1 and $ff] and X000000ff) xor + (Te4[s2 shr 8 and $ff] and X0000ff00) xor + (Te4[s3 shr 16 and $ff] and X00ff0000) xor + (Te4[s0 shr 24 and $ff] and Xff000000) xor pK^[1]; + TWA4(BO)[2] := (Te4[s2 and $ff] and X000000ff) xor + (Te4[s3 shr 8 and $ff] and X0000ff00) xor + (Te4[s0 shr 16 and $ff] and X00ff0000) xor + (Te4[s1 shr 24 and $ff] and Xff000000) xor pK^[2]; + TWA4(BO)[3] := (Te4[s3 and $ff] and X000000ff) xor + (Te4[s0 shr 8 and $ff] and X0000ff00) xor + (Te4[s1 shr 16 and $ff] and X00ff0000) xor + (Te4[s2 shr 24 and $ff] and Xff000000) xor pK^[3]; +{$else} + {Uses Sbox and shl, needs type cast longint() for} + {16 bit compilers: here Sbox is byte, Te4 is longint} + TWA4(BO)[0] := (longint(SBox[s0 and $ff]) xor + longint(SBox[s1 shr 8 and $ff]) shl 8 xor + longint(SBox[s2 shr 16 and $ff]) shl 16 xor + longint(SBox[s3 shr 24]) shl 24 ) xor pK^[0]; + TWA4(BO)[1] := (longint(SBox[s1 and $ff]) xor + longint(SBox[s2 shr 8 and $ff]) shl 8 xor + longint(SBox[s3 shr 16 and $ff]) shl 16 xor + longint(SBox[s0 shr 24]) shl 24 ) xor pK^[1]; + TWA4(BO)[2] := (longint(SBox[s2 and $ff]) xor + longint(SBox[s3 shr 8 and $ff]) shl 8 xor + longint(SBox[s0 shr 16 and $ff]) shl 16 xor + longint(SBox[s1 shr 24]) shl 24 ) xor pK^[2]; + TWA4(BO)[3] := (longint(SBox[s3 and $ff]) xor + longint(SBox[s0 shr 8 and $ff]) shl 8 xor + longint(SBox[s1 shr 16 and $ff]) shl 16 xor + longint(SBox[s2 shr 24]) shl 24 ) xor pK^[3]; + +{$endif} + +end; + diff --git a/Tocsg.Lib/VCL/EncLib/AES/legal.txt b/Tocsg.Lib/VCL/EncLib/AES/legal.txt new file mode 100644 index 00000000..91468ea3 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/legal.txt @@ -0,0 +1,34 @@ +--------------------------------------------------------------------------- +Legal Notice + +Some of my software/programs contain cryptographic algorithms. There are +countries that restrict the use, import, export of cryptographic software. +Before keeping, using, or distributing the software, make sure that you +comply to these restrictions. If (for any reason) you are unable to do so, +you are not allowed to download, use, distribute the software. + +If you are residing in a country that allows software patents you must +verify that no part of the software is covered by a patent in your country. +If (for any reason) you are unable to do so, you are not allowed to use or +distribute the software. + + +--------------------------------------------------------------------------- +Rechtlicher Hinweis + +Einige meiner Software/Programme enthalten kryptographische Algorithmen. Es +gibt Laender, die den Gebrauch, Import, Export von kryptographischer Software +einschraenken bzw. verbieten. Vor Besitz, Gebrauch, Verbreitung dieser +Software/Programme in diese(n) Laendern muss sichergestellt sein, dass +diesen Beschraenkungen entsprochen wird. Sollte das (aus welchen Gruenden +auch immer) nicht moeglich sein, darf die Software nicht heruntergeladen, +benutzt oder verbreitet werden. + +Einige Laender erlauben Softwarepatente. Benutzer aus solchen Laendern +muessen sicherstellen, dass die Software (oder Teile davon) keine Patente +beruehrt oder verletzt. Sollte das (aus welchen Gruenden auch immer) nicht +moeglich sein, darf die Software nicht benutzt oder verbreitet werden. + + +--------------------------------------------------------------------------- +http://wolfgang-ehrhardt.de diff --git a/Tocsg.Lib/VCL/EncLib/AES/manifest.aes b/Tocsg.Lib/VCL/EncLib/AES/manifest.aes new file mode 100644 index 00000000..d0c6702e --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/manifest.aes @@ -0,0 +1,71 @@ +!bdll.bat Compile batch file for AES_DLL +#ca.bat Generic compile batch file for all console compilers +#ca_dll.bat T_AES_WS with AES_DLL compile batch file for win32 compilers +#times.aes Times for encrypting 512MB, different compilers and packages +$d25.zip dproj files for Delphi 25 (Tokyo Starter) +$log_aes.zip Archive with log files of final tests done before release +aes_base.pas AES basic routines +aes_cbc.pas AES CBC functions +aes_ccm.pas AES CCM functions +aes_cfb.pas AES CFB128 functions +aes_cfb8.pas AES CFB8 functions +aes_cmac.pas AES CMAC routines +aes_conf.inc AES configuration include file +aes_cprf.pas AES CMAC Pseudo-Random Function-128 +aes_ctr.pas AES CTR mode functions +aes_decr.pas AES decrypt functions (not needed for CFB/CTR/OFB mode) +aes_dll.dpr Project file for AES_DLL +aes_dll.res RES file for AES_DLL +aes_eax.pas AES EAX mode functions +aes_ecb.pas AES ECB functions +aes_encr.pas AES encrypt functions +aes_gcm.pas AES GCM mode functions +aes_intf.pas Interface unit for AES_DLL +aes_intv.pas Interface unit for AES_DLL (VirtualPascal version) +aes_ofb.pas AES OFB functions +aes_omac.pas AES OMAC1 routines +aes_seek.inc Include file for CTR_Seek functions +aes_type.pas AES type definitions +aes_xts.pas AES XTS mode functions +btypes.pas Common basic type definitions +comp_speed Cycles/Block and MB/s for supported (console) compilers +copying_we.txt License +dec_*.inc Include files for aes_decr.pas +enc_*.inc Include files for aes_encr.pas +legal.txt Legal notice (cryptography, software patents) +manifest.aes This file +mem_util.pas Utilities for hex dump and memory compare +options.zip Archive with optional inc files +ppp.pas AES PPP routines (GRC's Perfect Paper Passwords) +readme.aes Info about the AES archive +samples.zip Additional simple sample programs +std.inc Standard definitions and options +t_aescbc.pas Test prog for AES CBC +t_aesccm.pas Test prog for AES CCM +t_aescf8.pas Test prog for AES CFB8 +t_aescfb.pas Test prog for AES CFB +t_aescrp.pas Test prog for AES encrypt/decrypt +t_aesctr.pas Test prog for AES CTR +t_aesecb.pas Test prog for AES ECB +t_aesgcm.pas Test prog for AES GCM +t_aesofb.pas Test prog for AES OFB +t_aestab.pas Calculate static full AES tables +t_aes_as.pas Test prog for associativity of CFB,OFB,CTR modes +t_aes_cs.pas Test prog for CTR_Seek functions +t_aes_ws.pas Main test prog for AES modes +t_aes_xl.pas Test prog for AES modes, ILen > $FFFF for 32 bit +t_cbccts.pas Test prog for AES CBC cipher text stealing +t_cmac.pas Test prog for AES CMAC routines +t_cprf.pas Test prog for aes_cprf +t_eax2.pas Test prog for AES EAX +t_ecbcts.pas Test prog for AES ECB cipher text stealing +t_fbmodi.pas Test prog for AES CTR/CFB/OFB with full blocks first +t_gsp128.pas Cycle test program for 128 bit keys, alignment info +t_gspeed.pas Test prog to compare AES encr/decr speed with Gladmann +t_mcst.pas Monte Carlo Self Tests, compares only final results +t_mctful.pas Full Monte Carlo Self Tests from AES submission +t_mkctab.pas Calculate compressed AES tables +t_omac.pas Test prog for AES OMAC +t_ppp.pas Test prog for PPP unit +t_xts.pas Test prog for AES XTS +_comparm Compile and run test programs on Raspberry Pi / 3 diff --git a/Tocsg.Lib/VCL/EncLib/AES/mem_util.pas b/Tocsg.Lib/VCL/EncLib/AES/mem_util.pas new file mode 100644 index 00000000..18719e30 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/mem_util.pas @@ -0,0 +1,383 @@ +unit Mem_Util; + + +{Utility procedures for Hex/Base64 and memory compare} + + +interface + + +{$i STD.INC} + +(************************************************************************* + + DESCRIPTION : Utility procedures for Hex/Base64 and memory compare + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP, WDOSX + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : RFC 3548 - The Base16, Base32, and Base64 Data Encodings + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 01.01.02 W.Ehrhardt Initial version + 0.20 30.08.03 we with pointer valid for all compilers + 0.30 17.09.03 we with HexLong + 0.40 27.09.03 we FPC/go32v2 + 0.50 05.10.03 we STD.INC + 0.60 10.10.03 we english comments + 0.70 26.12.03 we Base64Str + 0.80 12.04.04 we HexUpper, Delphi 7 + 0.81 12.06.04 we handle nil pointers + 0.90 05.12.04 we Hex2Mem + 0.91 31.10.05 we Simple Base64Enc/DecStr, D9/WDOSX, Base64Str with result + 0.92 11.12.05 we Bugfix: Hex2Mem and $R+ + 0.93 07.02.06 we RandMem + 0.94 14.10.07 we HexWord + 0.95 25.09.08 we uses BTypes + 0.96 14.11.08 we BString, char8, Ptr2Inc + 0.97 05.07.09 we D12 fix for Hex2Mem + 0.98 27.07.10 we CompMemXL, RandMemXL + 0.99 25.09.10 we CompMemXL returns true if size <= 0 +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +uses + BTypes; + +var + HexUpper: boolean; {Hex strings in uppercase} + +function HexByte(b: byte): BString; + {-byte as hex string} + +function HexWord(w: word): BString; + {-word as hex string} + +function HexLong(L: longint): BString; + {-longint as hex string, LSB first} + +function HexStr(psrc: pointer; L: integer): BString; + {-hex string of memory block of length L pointed by psrc} + +procedure Hex2Mem({$ifdef CONST}const{$endif} s: BString; pdest: pointer; MaxL: word; var L: word); + {-Convert hex string to mem pointed by pdest, MaxL bytes, actual byte count in L} + +function Base64Str(psrc: pointer; L: integer): BString; + {-Base64 string of memory block of length L pointed by psrc} + +function Base64EncStr({$ifdef CONST}const{$endif} s: BString): BString; + {-Simple Base64 encoder, uses Base64Str} + +function Base64DecStr({$ifdef CONST}const{$endif} es: BString): BString; + {-Simple Base64 decoder, stops conversion on first invalid char} + +function CompMem(psrc, pdest: pointer; size: word): boolean; + {-compare memory block} + +procedure RandMem(pdest: pointer; size: word); + {-fill memory block with size random bytes} + +function CompMemXL(psrc, pdest: pointer; size: longint): boolean; + {-compare memory block} + +procedure RandMemXL(pdest: pointer; size: longint); + {-fill memory block with size random bytes} + + +implementation + + +const + CT64: array[0..63] of char8 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + + +{---------------------------------------------------------------------------} +function HexByte(b: byte): BString; + {-byte as hex string} +const + nib: array[0..15] of char8 = '0123456789abcdef'; +begin + if HexUpper then HexByte := upcase(nib[b div 16]) + upcase(nib[b and 15]) + else HexByte := nib[b div 16] + nib[b and 15]; +end; + + +{---------------------------------------------------------------------------} +function HexWord(w: word): BString; + {-word as hex string} +begin + HexWord := HexByte(w shr 8)+HexByte(w and $FF); +end; + + +{---------------------------------------------------------------------------} +function HexLong(L: longint): BString; + {-longint as hex string, LSB first} +var + i: integer; + s: string[8]; +begin + s := ''; + for i:=0 to 3 do begin + s := HexByte(L and $FF) + s; + L := L shr 8; + end; + HexLong := s; +end; + + +{---------------------------------------------------------------------------} +function HexStr(psrc: pointer; L: integer): BString; + {-hex string of memory block of length L pointed by psrc} +var + i: integer; + s: BString; +begin + s := ''; + if psrc<>nil then begin + for i:=0 to L-1 do begin + s := s + HexByte(pByte(psrc)^); + inc(Ptr2Inc(psrc)); + end; + end; + HexStr := s; +end; + + +{---------------------------------------------------------------------------} +procedure Hex2Mem({$ifdef CONST}const{$endif} s: BString; pdest: pointer; MaxL: word; var L: word); + {-Convert hex string to mem pointed by pdest, MaxL bytes, actual byte count in L} +const + nib: array[0..15] of char8 = '0123456789ABCDEF'; + wsp: array[0..3] of char8 = #32#9#13#10; +label + _break; {for versions without break} +var + i,p: integer; + b: byte; + c: char8; + bdone: boolean; {flag byte complete} +begin + L := 0; + if MaxL=0 then exit; + bdone := true; + b := 0; + for i:=1 to length(s) do begin + c := upcase(s[i]); + p := pos(c,nib)-1; + if p>=0 then begin + {Insert new nibble into b. If range checking is on, we} + {must prevent the following shift from overflowing b. } + {$ifopt R+} + b := ((b and $F) shl 4) or (p and $0F); + {$else} + b := (b shl 4) or (p and $0F); + {$endif} + bdone := not bdone; + if bdone then begin + {byte complete, store or break} + if L0) and (psrc<>nil) then begin + q := L div 3; + r := L mod 3; + while q>0 do begin + b0 := pByte(psrc)^; inc(Ptr2Inc(psrc)); + b1 := pByte(psrc)^; inc(Ptr2Inc(psrc)); + b2 := pByte(psrc)^; inc(Ptr2Inc(psrc)); + result := result + CT64[(b0 shr 2) and $3f] + + CT64[((b0 shl 4) and $30) or ((b1 shr 4) and $0f)] + + CT64[((b1 shl 2) and $3c) or ((b2 shr 6) and $03)] + + CT64[b2 and $3f]; + dec(q); + end; + if r=2 then begin + b0 := pByte(psrc)^; inc(Ptr2Inc(psrc)); + b1 := pByte(psrc)^; + result := result + CT64[(b0 shr 2) and $3f] + + CT64[((b0 shl 4) and $30) or ((b1 shr 4) and $0f)] + + CT64[(b1 shl 2) and $3c] + + '='; + end + else if r=1 then begin + b0 := pByte(psrc)^; + result := result + CT64[(b0 shr 2) and $3f] + + CT64[(b0 shl 4) and $30] + + '=='; + end; + end; + {$ifndef RESULT} + Base64Str := result; + {$endif} +end; + + +{---------------------------------------------------------------------------} +function Base64EncStr({$ifdef CONST}const{$endif} s: BString): BString; + {-Simple Base64 encoder, uses Base64Str} +begin + Base64EncStr := Base64Str(@s[1], length(s)); +end; + + +{---------------------------------------------------------------------------} +function Base64DecStr({$ifdef CONST}const{$endif} es: BString): BString; + {-Simple Base64 decoder, stops conversion on first invalid char} +var + i,bits,buf: word; + {$ifndef RESULT} + result: BString; + {$endif} + ic: array[char8] of byte; + b: byte; +label + _break; {for TP5/5.5} +begin + {Note: this is a stripped down version of Base2N.Decode2NPrim} + result := ''; + {Fill input array with Base64 digit values, $FF if not valid} + fillchar(IC, sizeof(IC), $FF); + for i:=0 to 63 do ic[CT64[i]] := i; + buf := 0; + bits := 0; + for i:=1 to length(es) do begin + b := IC[es[i]]; + if b>127 then goto _break; + {Include next input into buffer. If range checking is on, } + {we must prevent the following shift from overflowing buf.} + {$ifopt R+} + buf := ((buf and $03FF) shl 6) or b; + {$else} + buf := (buf shl 6) or b; + {$endif} + inc(bits,6); + if bits>7 then begin + {output a byte if at least 8 bits in input buf} + dec(bits,8); + result := result + char8((buf shr bits) and $FF); + end; + end; + +_break: + + {$ifndef RESULT} + Base64DecStr := result; + {$endif} +end; + + +{---------------------------------------------------------------------------} +function CompMemXL(psrc, pdest: pointer; size: longint): boolean; + {-compare memory block} +var + i: longint; +begin + if size>0 then begin + CompMemXL := false; + if (psrc=nil) or (pdest=nil) then exit; + for i:=1 to size do begin + if pByte(psrc)^<>pByte(pdest)^ then exit; + inc(Ptr2Inc(psrc)); + inc(Ptr2Inc(pdest)); + end; + end; + CompMemXL := true; +end; + + +{---------------------------------------------------------------------------} +procedure RandMemXL(pdest: pointer; size: longint); + {-fill memory block with size random bytes} +var + i: longint; +begin + if pdest<>nil then begin + for i:=1 to size do begin + pByte(pdest)^ := random(256); + inc(Ptr2Inc(pdest)); + end; + end; +end; + + +{---------------------------------------------------------------------------} +function CompMem(psrc, pdest: pointer; size: word): boolean; + {-compare memory block} +begin + CompMem := CompMemXL(psrc, pdest, size); +end; + + +{---------------------------------------------------------------------------} +procedure RandMem(pdest: pointer; size: word); + {-fill memory block with size random bytes} +begin + RandMemXL(pdest, size); +end; + + +begin + HexUpper := false; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/options.zip b/Tocsg.Lib/VCL/EncLib/AES/options.zip new file mode 100644 index 0000000000000000000000000000000000000000..7b1b299b04a407dff33aa99c194fc36d9fe599b6 GIT binary patch literal 4941 zcmZ{obyQT_`^JavMv(6Ak_M#(9YDH4LOLa+y9R`zyQD)HBm|@phHjhzr9o1LZusJj zb?e0ssI^K%S62H zM{>rPEFFjWdbP$fCM<*Kx^`d|tb_unt{v+0v<=HdI9k+(O{OcB8~Y=^r@0Xv^Y1lC zJeQv5fW^&X`9sK8^zI%@ORZ5|@Xk;~pHT6U&X2@m>U?_K*y4#ubzz?8*LA*Yqstlr zISzi%>Gp)?)49mg2H@c6SDsQYu5Nwc*72_)%c#-j6q8uQr(=O1?IJg9O%CTWxVW8S zcWsOc1{e&jXsdT&3f-+w5*eG%NuR`58VUzJiP9rj`cTt4zgwoyV;yCVnQbG-B%g#(-})xA{vr%G4tmrgELwc#TS=vbau zay`aHiKx65Dy)8rxYVnOFHDfZ-@Rh{GPRf&;asbI48#=#zK6&Oo+!76Z5qB4B2 z3QD?4G0DTwdKlLUBF!d@Zkwbr-o}jJOI|SajLy*p9}F#5V;0;bj^TEVQE0k1_ZVOx zhR?7N!=1`ha>NyjtSN}X?!+u)ga@ztzUAk>D(`U8)?w}7_{7zKo|b03B2w44jtvR1 zX41>Ro9aRhj3{&h?wg04RO^S7PS1x#>{37I8dMot8&TmLb9&X2NKz2D$ufIAVfOO1 z-76-Ntg)=EXnf-CvuCBUcb5o*7ec0$_8i%M3nZAm1ev|=CtzTAksyS^Q7lifMbxyT zQ%a&wf1*3>bB*krUcr>gVlep4*c?(*tCjuxxpcT9FR>|9Jm)Y}Z!SE1I)2qsUQ{kk zNdl|vt@*pkFn=k(rDP0SLtCN5GRxi&6rKiKs9{%#JWoRlRKE@-$f~HRrTh6I23rIk z5L=p_;R2Lc^3JRjRQ^*RYqSK(!+V+-I*`GK;X-#WWg=_OKE zHT?iuQ;{Uq5D6G5j2sYYP|SI1lb^93X3e5HvEDbFhLig^n1(=7K2Kku;FZ3tY~^^#OIQ=nv`|+Rd*9KPk&-4H zs#wLMV87&j9Z#3p!p3Cm*-{XJsdM9aIhWj7sLb(60tq=a8|r!4%{gF{uV=dirMscS}X#CAwIp z-jtcUwd(JyluH;O$1=v#zhW5EJS6EeBOv@z9t-kCSAGC$i7)!_BaAjl04U6`nUj#! zA3$s1=_?pc0pHMa3Ux34g>vm0<_oBDD4aC`CoxrqhtoP$-jV*o5<&P{`Mje|(Y`-*3Rw#io-+*%UZ>=|?L>4rvkww1PY)m>(0tY4sr^R3y}Nv4U1OGQEtym0=KjI2y#o~g?iRFb<-=--SZ@!d%4(=DKxjrZ z<4oK+*PtOJ)6tr&Nr*(v<|C$cDWmc3#_-y4*xH>6L}o!}z|V+rL(eb$MbY4DOt2%N zGalX&E$6(vI5KGFM{!voI#^b}g<}%-@~mA-O~51U;$(f7kCsGUr1m3GkR@PDEh)iH zx@@`nb7v7|om3(;p4Q56)SOv-?T7}kW&YL0br`RYuE@|pH&eO5SD@S(s;W#4eHISG zv_BgPp)SVL_9mL!7U&DHe?yVEdYpRSAl%Ae;031k0&};jyl;7EFe{rd z5A&$}^}w6d+pK1~w=%PQ)RDats6LZJlwwW!G$ezvj(|mun97I%dAzpc0}^%GZuNZMXo0*+YN<;#jdNTPxx{b~ z)x9JZ(9lXo=(1{TtHR`@fMrARe1a9C0%||M$CtFwtkh?&dZi7zz4C8{O(v9w!>WHG z7EJ?6i-{aOY&=z+mTz8rUrOm6o(q*n=5@BX+4*~2lXaafnto0~CYy~16blmaDc+bc zdtC57ac!SMCwpyH{9*iK-s`vBq&()DoGK?$U91unO~TnoB!5l8f1nkxj4J>Dnn<5 zY%~4Fj}3P-A*W%I#AxgK!1Su#1Uh1+nRiQ!5E4>@T0sQcuHG3uLfj6Nt!&-A_E(hY zHB9wt}H28*EA`2vnnd@KRA7>FOi`;zBhUYW6p8YXhRq_0muD6Wu) zIh?3!O$-y;>`U&c3VBBX7n(0pH-C}gIBdEOIBtc+(K1-JTYbrodkbaFi=%glRfovu`;dVUXTRh<(=wmx&)5()eR@Lco z=gFQ_7Zb@46bebXe!oE#S%c<~l$oYO#~VzlZR-!Wj@83TR6Og^w8gm7;VG7_iIEvk zij$Q{xMNF z?BUkJadz(G-=FuWu55Q6XL#ZoH|MmZF=fHnD2w6)Dpx4pt%hNb50Oym?2oyBGmw&0 z_xE3+@Lfg09iJkhGw>woHi;h1Xv zl5pQD`nOI}r)_v)p9bvU7LAQZel)NlS3?6W1p;10D}=#Gkyll+10v)46D!>@inW^6 zX{&Y_hZQS+){&L~MAb_zAOei8&yu&LZ)|7w%08}ct8B*I9!MV*A{~^D!AjUifFa%< z1HIcPq&~S)r$sb55wmbvkFpXgeFj*a9Ks@ko{h9fHr!A(@=+)O7b=A=rmq~s6-mW! z0klqT!Xm=FjI?JU8HYX7s^YpV^T+TM-9Op(8%5kYwz+~IP-O8h6#1QP|DcG&!c*Kp zx;@#gLIStvpa8x8XgEypOhaOB%Gr^yeg)?4kaaQgqfrg(_8@tzy$QHBMKkh&%IVSqAug?IODiiJZ-s~11bl!hWRr+;${|BB<#`v%E#Z? z_Zl_b2L;5XDkfh`6w_s652|-3lSWS4qV~kj{WP^x$*aOM`xK~WR4(i3C%@0=OtD0b zN42xR4yqiV#$R-Bd6Yx@vh=CP8i8gZ-?D|(lv(NHpx!d{jN zfe7T8Zg4sB-t@u zTymY7BzRfSqGp){)Sn_}m9Qw{d*Riy-p`M}{>Id!`a>U+fFBluTSc#($qhDVi^H}m11Mk5YqA?cyQV!A#0^s`( zCw3x`!mPa-vU5GP*4eE1*(AJK1s4&x8PB4&Q{DB|>@VIfJ!8YVAkta}5KeVXh*Z@j zno)tw0OQ7I=QoFuV@Zo+3PEqCyuI|o1wDv9Hr^o+U(Y+JAcivjbtQR4Z~R_ z<-ZQgTL-Z#n~w^u7)g#6#!U_IsY*F{-vM>V^qaV@cFU%hzVP*-#t-m5%(y} z5JOyr4w~SK*GDKr5XNGqe1nmhuK|=}2N4blhP!`38)6Kv$1S9e(f~F+HHg%BFVD`# zkn(kyqt?sS8F6PV>Z)&+KRT2203tHsln{P%7s_xcp*fe3XMLR$Jc;vbLB%bG!n4$k z6y0d{sOe>b{B01iw^c=gw2KC0GAw*)ct%V|k-U0aU3tIaqp#U|kNG>rTlod0Fm|hh zf-sfPJ8pM{8kLyiIx*MydM^eR*7$lZhWYQ@9^YH}-B>@q7mEub?l=3A(rF~%shQgB ze;%ZIhpeH7giH$f?=7W=g~P)^|Ht+JZZQ4r{IB)KpO)WF8uUM%e@*$njsHbH{}@NG p0DymU(7&DkU#|S)EPqIvf2E9u8rs7@005{D=jOv*llb@B{{W=$7DoU8 literal 0 HcmV?d00001 diff --git a/Tocsg.Lib/VCL/EncLib/AES/ppp.pas b/Tocsg.Lib/VCL/EncLib/AES/ppp.pas new file mode 100644 index 00000000..51fdf290 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/ppp.pas @@ -0,0 +1,338 @@ +unit PPP; + +(************************************************************************* + + DESCRIPTION : AES PPP routines (GRC's Perfect Paper Passwords) + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : http://www.grc.com/ppp/algorithm.htm + + REMARKS : This unit provides functions for using the PPP system + described on the http://www.grc.com/ppp.htm page. + + Although there are hints to a PPP V3 Specification, there + seems to be no formal definition. IMO the best available + description is from the algorithm page: + + "The 256-bit PPP "Sequence Key" directly provides the key + for the AES-standard keyed Rijndael block cipher. A 128-bit + sequence counter is initialized to zero for the first + passcode, then increments once for every subsequent + passcode to provide encrypted data that are translated into + individual passcodes for printing on PPP passcards." + + Some programs linked by the GRC pages do not comply to this, + and produce e.g. five standard passcodes from one 128-bit + counter: Instead of '32YT 65!@' from the GRC example they + give '32YT YNBq LhY# sGsm cT47 65!@ V2o6 VFjK WPFn ?aWE'. + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 08.08.10 W.Ehrhardt Initial basic version + 0.11 08.08.10 we Improved DivBlock + 0.12 08.08.10 we PPP_First32, PPP_Next + 0.13 08.08.10 we Map constants + 0.14 08.08.10 we Error checking + 0.15 09.08.10 we PPP_FirstCard, PPP_Init4Standard, PPP_Init4Extended + 0.16 09.08.10 we Fix for mlen=0, PPP_SetCodesPerCard + 0.17 09.08.10 we Sort character map + 0.18 27.09.10 we Add $N- for TP5 +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2010 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + + +{$i STD.INC} + +{$ifdef VER50} + {$N-} {Once again: brain-damaged TP5 floating-point arithmetic!} +{$endif} + +interface + + +uses + BTypes, AES_Type, AES_Base, AES_Encr; + +type + TPPPKey = packed array[0..31] of byte; {PPP uses 256 bit keys} + TPPPMap = packed array[0..255] of char8; + +type + TPPPctx = record + actx: TAESContext; + map : TPPPMap; {character map} + mlen: byte; {map length} + clen: byte; {code length} + cpc : word; {codes per card} + end; + +const + PPP_Err_non_increasing = -30; {Characters in map are not strictly increasing} + PPP_Err_invalid_maplen = -31; {Invalid number of characters in map} + PPP_Err_invalid_codelen = -32; {Passcode length too large or zero} + +const + map64: string[64] = '!#%+23456789:=?@ABCDEFGHJKLMNPRSTUVWXYZabcdefghijkmnopqrstuvwxyz'; + map88: string[88] = '!"#$%&''()*+,-./23456789:;<=>?@ABCDEFGHJKLMNOPRSTUVWXYZ[\]^_abcdefghijkmnopqrstuvwxyz{|}~'; + + +procedure PPP_Init(var pctx: TPPPctx; SeqKey: TPPPKey; smap: str255; codelen: word; var Err: integer); + {-Initialize context pctx with Seqkey, character map smap, and passcode length.} + { If smap is empty, all 256 characters #0..#255 are used.} + +procedure PPP_Init4Standard(var pctx: TPPPctx; SeqKey: TPPPKey; var Err: integer); + {-Initialize context pctx with Seqkey, standard map64, passcode length = 4} + +procedure PPP_Init4Extended(var pctx: TPPPctx; SeqKey: TPPPKey; var Err: integer); + {-Initialize context pctx with Seqkey, extended map88, passcode length = 4} + +procedure PPP_SetCodesPerCard(var pctx: TPPPctx; newcpc: word); + {-Set new "codes per card" value, 70 if 0 } + +function PPP_First32(var pctx: TPPPctx; startcode: longint): str255; + {-Get first PPP passcode starting with passcode startcode} + +function PPP_First128(var pctx: TPPPctx; start128: TAESBlock): str255; + {-Get first PPP passcode for LSB 128 bit number start128} + +function PPP_FirstCard(var pctx: TPPPctx; cardnum: word): str255; + {-Get first PPP passcode of card cardnum (use card 1 if cardnum=0)} + +function PPP_Next(var pctx: TPPPctx): str255; + {-Return the next passcode from context pctx} + + +implementation + + +{---------------------------------------------------------------------------} +procedure DivBlock(var a: TAESBlock; b: byte; var r: byte); + {-Divide an AES LSB block by b (256 if b=0): r = a mod b; a = a div b} +var + i: integer; + q,w: word; +begin + q := b; + if q=0 then q := 256; + {initialize "carry"} + w := 0; + for i:=15 downto 0 do begin + {loop invariant: 0 <= w < q} + w := (w shl 8) or a[i]; + r := w div q; + w := w mod q; + a[i] := r; + end; + {set r to remainder, w is still < q!} + r := byte(w); +end; + + +{---------------------------------------------------------------------------} +procedure IncBlock(var a: TAESBlock); + {-Increment an AES LSB block} +var + j: integer; +begin + for j:=0 to 15 do begin + if a[j]=$FF then a[j] := 0 + else begin + inc(a[j]); + exit; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure SortMap(var pctx: TPPPctx); + {-Sort character map with CombSort routine} +var + i,j,gap,r: integer; + swapped: boolean; + c: char8; +begin + {See my CombSort routine from util archive} + with pctx do begin + if mlen=0 then r := 255 else r := mlen - 1; + gap := r; + if gap<1 then exit; + repeat + gap := longint(gap)*10 div 13; + if (gap=9) or (gap=10) then gap := 11 + else if gap<1 then gap:=1; + swapped := false; + for i:=0 to r-gap do begin + j := i + gap; + if ord(map[j]) < ord(map[i]) then begin + c := map[j]; + map[j] := map[i]; + map[i] := c; + swapped := true; + end + end + until (gap=1) and not swapped; + end; +end; + + +{---------------------------------------------------------------------------} +procedure PPP_Init(var pctx: TPPPctx; SeqKey: TPPPKey; smap: str255; codelen: word; var Err: integer); + {-Initialize context pctx with Seqkey, character map smap, and passcode length.} + { If smap is empty, all 256 characters #0..#255 are used.} +var + i: integer; + sorted: boolean; +begin + with pctx do begin + Err := AES_Init_Encr(SeqKey, 256, actx); + if Err<>0 then exit; + fillchar(map, sizeof(map),0); + if smap='' then begin + {use all chars #0..#255} + mlen := 0; + for i:=0 to 255 do map[i] := char8(i); + end + else begin + mlen := length(smap); + if mlen=1 then begin + Err := PPP_Err_invalid_maplen; + exit; + end; + move(smap[1],map[0],mlen); + sorted := true; + i:= 1; + while (i= ord(map[i]) then begin + Err := PPP_Err_non_increasing; + exit; + end; + end; + end; + end; + {here 2 <= mlen <= 256 or mlen=0} + if mlen=0 then i := 16 + else i := trunc(128.0*ln(2.0)/ln(mlen)); + if (codelen > i) or (codelen=0) then begin + Err := PPP_Err_invalid_codelen; + exit; + end; + clen := codelen; + cpc := 70; {default codes pre card} + end; +end; + + +{---------------------------------------------------------------------------} +procedure PPP_Init4Standard(var pctx: TPPPctx; SeqKey: TPPPKey; var Err: integer); + {-Initialize context pctx with Seqkey, standard map64, passcode length = 4} +begin + PPP_Init(pctx, SeqKey, map64, 4, Err); +end; + + +{---------------------------------------------------------------------------} +procedure PPP_Init4Extended(var pctx: TPPPctx; SeqKey: TPPPKey; var Err: integer); + {-Initialize context pctx with Seqkey, extended map88, passcode length = 4} +begin + PPP_Init(pctx, SeqKey, map88, 4, Err); +end; + + +{---------------------------------------------------------------------------} +procedure PPP_SetCodesPerCard(var pctx: TPPPctx; newcpc: word); + {-Set new "codes per card" value, 70 if 0 } +begin + if newcpc=0 then newcpc := 70; + pctx.cpc := newcpc; +end; + + +{---------------------------------------------------------------------------} +function PPP_Next(var pctx: TPPPctx): str255; + {-Return the next passcode from context pctx} +var + i: integer; + idx: byte; + s: str255; +begin + s := ''; + with pctx do begin + AES_Encrypt(actx, actx.iv, actx.buf); + for i:=1 to clen do begin + DivBlock(actx.buf, mlen, idx); + s := s + map[idx]; + end; + IncBlock(actx.IV); + end; + PPP_Next := s; +end; + + +{---------------------------------------------------------------------------} +function PPP_First32(var pctx: TPPPctx; startcode: longint): str255; + {-Get first PPP passcode starting with passcode startcode} +begin + with pctx do begin + fillchar(actx.iv, sizeof(actx.iv), 0); + TWA4(actx.iv)[0] := startcode; + end; + PPP_First32 := PPP_Next(pctx); +end; + + +{---------------------------------------------------------------------------} +function PPP_FirstCard(var pctx: TPPPctx; cardnum: word): str255; + {-Get first PPP passcode of card cardnum (use card 1 if cardnum=0)} +begin + if cardnum=0 then cardnum := 1; + PPP_FirstCard := PPP_First32(pctx, longint(cardnum-1)*pctx.cpc); +end; + + +{---------------------------------------------------------------------------} +function PPP_First128(var pctx: TPPPctx; start128: TAESBlock): str255; + {-Get first PPP passcode for LSB 128 bit number start128} +begin + pctx.actx.iv := start128; + PPP_First128 := PPP_Next(pctx); +end; + + +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/readme.aes b/Tocsg.Lib/VCL/EncLib/AES/readme.aes new file mode 100644 index 00000000..29fa86f9 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/readme.aes @@ -0,0 +1,108 @@ +This archive contains AES (Advanced Encryption Standard) related Pascal / +Delphi sources: basic AES routines and recommended block cipher modes of +operation (with test programs that verify compilation and results). + +The block level routines supply separate units for encryption and decryption. +The source code for basic encryption/decryption is split into several include +files. At the lowest level there are type definitions and common routines. Key +sizes of 128, 192, and 256 bits are supported. + +The following recommended block cipher modes of operation are implemented: +CBC, CFB128, CFB8, CTR, ECB, OFB, OMAC, CMAC, CCM, EAX, GCM, and XTS. All +chaining modes allow plain and cipher text lengths that need not be multiples +of the block length (for ECB and CBC cipher text stealing is used for the +short block; only one short block is allowed and there must be at least one +full block). CTR mode can use 4 built-in incrementing functions or a user +supplied one, and provides seek functions for random access reads. + +All routines have been included in the AES_DLL.DLL, there are two interface +units for this DLL (one for Virtual Pascal, the second for the other Win32 +compilers). + +Since the July 2006 release there are conditional defines to support +compressed tables: one 2K encryption table (calculated with t_mkctab) replaces +the four 1K tables (same for decryption, here the inverse SBox is no longer +needed). Besides using less static memory, compressed tables are considered as +a countermeasure against cache timing attacks. + +W.Ehrhardt, Nov. 2017 +http://wolfgang-ehrhardt.de + +------------------------------------------------------------------------------- + +Last changes: + +Nov. 2017 +- FPC/ARM and Delphi Tokyo adjustments + +Sep. 2015 +- Constant time verification/compare for the all-in-one packet + functions (aes_eax, aes_gcm, aes_ccm) + +Jan. 2013 +- Adjustments (test programs) for D17 (XE3), {$J+} if needed + +Dec. 2012 +- Small 64-bit adjustments (separate BIT64 include statements in + aes_decr and aes_encr; improved aes_gcm) + +July 2012 +- 64-bit adjustment for GCM + +Oct. 2010 +- Galois/Counter Mode (GCM) +- Fix PPP unit for TP5 + +Aug. 2010 +- Message length ILen has now type longint +- New PPP unit (Perfect Paper Passwords) + +June 2010 +- AES_CTR_Seek functions + +July 2009 +- Delphi 2009 (D12) adjustments + +May 2009 +- Counter with CBC-MAC (CCM) mode + +Nov. 2008 +- Uses the BTypes unit for better portability + +Aug. 2008 +- All-in-one EAX functions for encrypt / authenticate and decrypt / verify: + decryption is performed only if the verification was successful. +- Range check safe IncProcs for FPC -dDebug + +Jan. 2008 +New unit aes_cfb8 implementing the 8 bit CFB mode + +Oct. 2007 +- New unit aes_xts implementing the XTS mode from the IEEE P1619 Draft Standard + for Cryptographic Protection of Data on Block-Oriented Storage Devices. + +June 2007 +- AES-CMAC-PRF-128 from RFC 4615 +- New EAX context name + +Nov. 2006 +- Contributed AES256 file crypt/authenticate unit + +July 2006 +- CMAC mode, compressed tables as a countermeasure against cache timing attacks + +Jul. 2004 +- EAX mode, AES DLL, new demo programs + +Jun. 2004 +- OMAC mode on AES page + +Mar. 2004 +- Significant speedup of AES key generation + +Jan. 2004 +- New faster AES routines + +Dec. 2003 +- First version of AES archive released + diff --git a/Tocsg.Lib/VCL/EncLib/AES/samples.zip b/Tocsg.Lib/VCL/EncLib/AES/samples.zip new file mode 100644 index 0000000000000000000000000000000000000000..50280b68203c1612a9c947a824007795f11bae89 GIT binary patch literal 3968 zcmZ`+XHXN|whakNAarSwCcR4)gwPRbA~i@6F#^&dQlx_*MFByiNbiV%NJn}V5+DfD zr3#_?&Kr9FV*dql1 zAOHZs1L1;nwiUmQM0gCq5pL7c)Msqh2n$3I2H0!M>C`67$LN};icHf(2=Q?$b;Qtc zFE3|2P#yIv^z;y?S^DPrWl-Ivl!W_BBRJe_6Bd^%nSVcD%dI< zSY=Zona7WAUn@(B>I1`6cdKA)zarv__=@OA%V6J@re z#(p#_VqucKHRh=Ml{iyKf@uOYQo)?Dh>wvG?}HYYEt%9tq3o<|1N7e6*fHWoxD03$ z>!dp6yC1k2xJGkM`)5#Dz^<5_s%{M2XUz)0qzR*$T!z*)TpN1Tled|1{4##&Jf`s^ zY2P=Gug?_|=cV3dB`)aHIimi=zJG6HSu`rgO^)i&19qmpC#k? zf!D^VH~YOFZM{1Kt$W3Fst@wDXP#u*TQZLqLgD^ti0#MX_iB=(N`*(R;#^vy;EqG> z_KSiYxWpvSE$<(~mLsBW#+V%t_I)1p7@lS^$9h`)S`z-9pBB{arxK0(?LjTse77js z{9yi-uCg0d{QN3;-eiUBf|{?sRGP|plAPl?^B8ZV7BqEb=;j;NbF(+F0d8{#p`0)- z5!({49ncfD1_GQ{6tinm#Vg-{3aWY<3ZlD;htt+X77m+Ow{%%6OpwM|vb87QJHK;s z{+*0Tg^BAR+i%u27!Q@}c61}XQuD>H1#H)%m`;?gBdt^ct@0gMLA~fWKfrR9-#q1$ z4jqWn#qc83oQDtUADboxhwgXZPDZwcM&^?C!pj??OKutP_?=sp`|4r{fKFDN;s`GD z-d&)E3^DaI_!7ZZwM08P=u>*U`LwRk*2DpAH#6enOkSh9{3Y46pAT;wt8q_lA8Q4z zcp$>GJ?E~HTX_V5nfIar&;W)lT=}HI;Ur1*4qI|q)6S`Kd`AEkOT;~{waP{ibCLVU z0+-pN5{-vgu=F6JB`*s$@j*j?z@1swnMLyvJHM#F3*%&i@m5ds;C)y zd`98P@S*$rcCS1UQzlJtp?rb&He|1WMX_4UCvDb8o>voBNMO|eKe83iLzV?z$W{aV zw`?VT%eEG7@LRS)qC*5E6-d}N3elv=XbKsc+E#0{1q(dd5WZGPp5O{6OBC-}d z&uZJNeLqJu-5I?!i^F=OcGrsbsp?1cp_a-YDVhl>?d~m6597pqC9`yS8RxCq7WI$^ z$7A21Gs*nIp~IA`6?58mEkq?w06GPE|v#{lh|Qb7aLJT<9KanWl-%XhIH7`CL+ zI05STr2~_D#`2o!rRfX3D~*hkoCL!XZ*I_1>FC=^6yctH#)`HbtGIl1pM0bX5fQ)b zk7C;9_v(>EM9 z@Ga~@h{@jeAwpJ0v%hnl$fQ-#ZWLw@b0+8saRfY4*D||~SCFny`J`cNBkB2G*(=%-bp~XKp#ngJQ3V6tq;)y5fNEha)1*<{o=CihD{3X?N><j;S*u6IN5KZ_Q-`JeQ^)a?nSaz9q4!K*EHOzrUBeOxtW> z__lRFUE|@h()<1P!OoFd|MfZ%J+#zM7Br%u%dmU!amRZRZPAG%{s8C#JuK2-iKNKY zgulrbxnUbv^_E1mS!$DRs+C~(wMIheMaMjECdEyD&g-b^PnzYd=0apOT|xDg>Jy|R zIG>(ZVryrBP_>3PQ`(w>sf+w8!x+1flxQ*UcRga9@3R#YM){5_D~1GN$}MMQ;eF~3 z;^f%7IfGuilDYw*O2d5Q%&0-z;6d``lf;}-A<5TNO#&;}!ye zYK0@P;HH%+>hEL384>H<5b-{irQNsf!9>KT@F1*mflZ?sgbs6kE&`NFjx36S`Cpzk zDx3?+{4yj1`UDj&0ByqJ%8S&h{rUSokDU3YQ)+)BJt{WB2=r-qtyvC3Z0U$@JehCq zhvU`i!_-%Q;utQkxiXn|2_FwRB^{ttXqP-4b=FBCs4gfn53iKaEuu~m<38p0{EAz& zp0VuKr1X2d-jUV6Rl25~e8XyGWiti{0KhN*ty0N9Dm6B6n-ZfADjy{vM~1+LIYfQq z9VvANY$Xn9HF?`a95#zO6={?4*x1}CLMyCj-LS+#)bcwmN^w3gyRB))OH^FuH4}t= zbwbP{U>`edR%oQmIvu$1h5OhJ3=6ZLWWM!v4e96ZXK0#W9^X}qjwX-1lGWr?eCrVq zRu~ET0jzg=nTI?9a!5ByLD?oDwZ^2c@ZJ`Wdb5E2H((J#bTDSs*rVg|VhrkBK)7ij z<|)4a6+$It*NV4U>=Q#zjyb%mL|r#N;s^9gb%(LT{TS@v1A zn>i$51Xxp#N1aJ*{5sC3Pa&4}j}!~fp;t!;Z6r{jBWzY}xT+>>+*D(K?3U77zCN^& zP^sgH?&XHQ;mOnj8TJ0^X_$^K6AU>A_LWuAXZoe~=b3%WGC#2$6)r5@1;AMY`|bot z;y8iwC7b~35o$8j2;5FsG>^VaD)EzQKdnKh57{bcZrP|5Ck3?2Q35*fPaBp^K5x-w zBfnh^^8#jle71il$)yi+dR+9Tb*hF$oi{O}gk&lvCf_G@HK~~*u1n4O&e64TPwGvf zvinGEI7NtCm~hynH!aGq5v%CBmy7H_7YsX2&AmG-eT|p{bM=Jz%s}m=gKpzk%{TZB zhcl8-I8>|N?ixIu!W`~u#lnV*xKt`z?#;g6daG@Z`*gpe?X#U7fsC6?_E%zyx+q`==br}rxE$kOK=5QF9`G73kj+%Fj4k)#9 zZ*z>|{)79f@7#$;hd)9HirstZ?PLh#3~c9cP&$$%l4RREl4Ot4b+s?Vs6SLS1FRH& zLsBSNU(VA4lk~$QiU2TLMua$#%;|G(%6E-^Q}$JrEKC9q7iiw4`Bk8CofI$YD1F;x zK)1)?I6)`QC7!o)iSorJ`3>_0@iKmT%Kp)3^l~?JQa&m)(o{YiOoGovdS)ae1UtoU zma=r%=mHhKRM{pcnfuvFnbH+MFMbW#3+av>D`E*(8|vZOCZ)<6i;=jRS>7=)(D#Ie z=q3+`j3f`p!^oshH;6=5qe0&!Zp$ncRrt@Zb0@hgA_JXB4bPM}mxKL>b>WFhq9iy-md-*G? zFxxT^jpZdbhS6~Pjf-be~E5%Ws_neYS?Gyy(oiC&83ys6^4 z^yu?}L#nMkQA86h=hvNQLZoHA${!35x6h>)oO#|As@IqF{4!sjU?CUmSI6!E(p#!8n9Mq%u}>I z0xDa)nM;f}OZ%YEuxYGPDr>MR!SCUi<_l-Qi05qN-tE3iHJF_u?u~vN1+EakVP*3{ z%kYS&@o`$7bAp@8Ai=P;R_QlFJ34KszR z!C*Ok>i~KEJ6EFG*xvhvKDv{U)=DXjOGskK>D1+Wb)f37u`QD!?GwP-EEOyq zs}t0;g7 zaP4=wIDc)W{|WrhB>emPKfq5H`S>5;pIrPKNcX>t|7|$`1_J&tT9W(=_-9oA&G_F8 h@;B@sMq09e0sq*gzRsnK!4CisU)-gO8bSH{^*0 then begin + writeln('*** Error CFB'); + exit; + end; + pp := @plain; + pc := @ct; + for i:=1 to sizeof(plain) do begin + if AES_CFB_Encrypt(pp, pc, 1, context)<>0 then begin + writeln('*** Error CFB'); + exit; + end; + inc(Ptr2Inc(pp)); + inc(Ptr2Inc(pc)); + end; + writeln('CFB test: ', test(@ct,@ct_cfb)); +end; + + +{---------------------------------------------------------------------------} +procedure TestCFB8; +const + ct_cf8 : array[0..17] of byte = ($3b,$79,$42,$4c,$9c,$0d,$d4,$36, + $ba,$ce,$9e,$0e,$d4,$58,$6a,$4f, + $32,$b9); +var + i: integer; + pp,pc: pointer; +begin + {Note CFB8 is about 16 times slower than CFB. Therefore only} + {the case N=1 is tested using NIST SP 800-38A Test F.3.7} + if AES_CFB8_Init(key128, 128, IV, context)<>0 then begin + writeln('*** Error CFB8'); + exit; + end; + pp := @plain; + pc := @ct; + for i:=1 to sizeof(plain) do begin + if AES_CFB8_Encrypt(pp, pc, 1, context)<>0 then begin + writeln('*** Error CFB8'); + exit; + end; + inc(Ptr2Inc(pp)); + inc(Ptr2Inc(pc)); + end; + write('CFB8 test: '); + if compmem(@ct,@ct_cf8,sizeof(ct_cf8)) then writeln('OK') else writeln('Error'); +end; + + + +{---------------------------------------------------------------------------} +procedure TestCTR; +var + i: integer; + pp,pc: pointer; +begin + if AES_CTR_Init(key128, 128, CTR, context)<>0 then begin + writeln('*** Error CTR'); + exit; + end; + pp := @plain; + pc := @ct; + for i:=1 to sizeof(plain) do begin + if AES_CTR_Encrypt(pp, pc, 1, context)<>0 then begin + writeln('*** Error CTR'); + exit; + end; + inc(Ptr2Inc(pp)); + inc(Ptr2Inc(pc)); + end; + writeln('CTR test: ', test(@ct,@ct_ctr)); +end; + + +{---------------------------------------------------------------------------} +procedure TestOFB; +var + i: integer; + pp,pc: pointer; +begin + if AES_OFB_Init(key128, 128, IV, context)<>0 then begin + writeln('*** Error OFB'); + exit; + end; + pp := @plain; + pc := @ct; + for i:=1 to sizeof(plain) do begin + if AES_OFB_Encrypt(pp, pc, 1, context)<>0 then begin + writeln('*** Error OFB'); + exit; + end; + inc(Ptr2Inc(pp)); + inc(Ptr2Inc(pc)); + end; + writeln('OFB test: ', test(@ct,@ct_ofb)); +end; + + +begin + writeln('Test program "Associativity of CFB,OFB,CTR" (C) 2008 W.Ehrhardt'); + AES_SetFastInit(true); + TestCFB; + TestCFB8; + TestCTR; + TestOFB; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aes_cs.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aes_cs.pas new file mode 100644 index 00000000..8028dc98 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aes_cs.pas @@ -0,0 +1,377 @@ +{-Test prog for AES CTR Seek, (c) we July 2010} + +program T_AES_CS; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +{$ifdef BIT16} +{$N+,F+} +{$endif} + + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + HRTimer, + {$ifdef USEDLL} + {$ifdef VirtualPascal} + AES_Intv; + {$else} + AES_Intf; + {$endif} + {$else} + aes_type, aes_ctr; + {$endif} + +{USE_INT64: if Int64 and errout available} + +{$ifdef FPC} + {$ifdef FPC2Plus} + {$define USE_INT64} + {$endif} +{$endif} +{$ifdef CONDITIONALEXPRESSIONS} {D6+} + {$define USE_INT64} +{$endif} + + +{---------------------------------------------------------------------------} +procedure My_IncMSBFull(var CTR: TAESBlock); +{$ifdef USEDLL} stdcall; {$endif} + {-Increment CTR[15]..CTR[0]} +var + j: integer; +begin + {This is the same as the standard pre-defined function, but it cannot be } + {recognized by its @address and therefore the seek loop will be performed} + for j:=15 downto 0 do begin + if CTR[j]=$FF then CTR[j] := 0 + else begin + inc(CTR[j]); + exit; + end; + end; +end; + + +var + HR: THRTimer; + +var + ctx1, ctx2: TAESContext; + Err : integer; + +{$ifdef USE_INT64} +const + BSIZE=$8000; +{$else} +const + BSIZE=8192; +{$endif} + +var + pbuf, cbuf1, cbuf2: array[0..BSIZE-1] of byte; + +{---------------------------------------------------------------------------} +procedure CheckError; +begin + if Err<>0 then begin + writeln('Error ',Err); + halt; + end; +end; + + +{---------------------------------------------------------------------------} +procedure randomtest(userdef: boolean); +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + key192 : array[0..23] of byte = ($8e,$73,$b0,$f7,$da,$0e,$64,$52, + $c8,$10,$f3,$2b,$80,$90,$79,$e5, + $62,$f8,$ea,$d2,$52,$2c,$6b,$7b); + + key256 : array[0..31] of byte = ($60,$3d,$eb,$10,$15,$ca,$71,$be, + $2b,$73,$ae,$f0,$85,$7d,$77,$81, + $1f,$35,$2c,$07,$3b,$61,$08,$d7, + $2d,$98,$10,$a3,$09,$14,$df,$f4); + + CTR : TAESBlock = ($f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7, + $f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff); + + plain : array[0..63] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d,$8a,$57,$1e,$03,$ac,$9c, + $9e,$b7,$6f,$ac,$45,$af,$8e,$51, + $30,$c8,$1c,$46,$a3,$5c,$e4,$11, + $e5,$fb,$c1,$19,$1a,$0a,$52,$ef, + $f6,$9f,$24,$45,$df,$4f,$9b,$17, + $ad,$2b,$41,$7b,$e6,$6c,$37,$10); + + ct1 : array[0..63] of byte = ($87,$4d,$61,$91,$b6,$20,$e3,$26, + $1b,$ef,$68,$64,$99,$0d,$b6,$ce, + $98,$06,$f6,$6b,$79,$70,$fd,$ff, + $86,$17,$18,$7b,$b9,$ff,$fd,$ff, + $5a,$e4,$df,$3e,$db,$d5,$d3,$5e, + $5b,$4f,$09,$02,$0d,$b0,$3e,$ab, + $1e,$03,$1d,$da,$2f,$be,$03,$d1, + $79,$21,$70,$a0,$f3,$00,$9c,$ee); + + ct2 : array[0..63] of byte = ($1a,$bc,$93,$24,$17,$52,$1c,$a2, + $4f,$2b,$04,$59,$fe,$7e,$6e,$0b, + $09,$03,$39,$ec,$0a,$a6,$fa,$ef, + $d5,$cc,$c2,$c6,$f4,$ce,$8e,$94, + $1e,$36,$b2,$6b,$d1,$eb,$c6,$70, + $d1,$bd,$1d,$66,$56,$20,$ab,$f7, + $4f,$78,$a7,$f6,$d2,$98,$09,$58, + $5a,$97,$da,$ec,$58,$c6,$b0,$50); + + ct3 : array[0..63] of byte = ($60,$1e,$c3,$13,$77,$57,$89,$a5, + $b7,$a7,$f5,$04,$bb,$f3,$d2,$28, + $f4,$43,$e3,$ca,$4d,$62,$b5,$9a, + $ca,$84,$e9,$90,$ca,$ca,$f5,$c5, + $2b,$09,$30,$da,$a2,$3d,$e9,$4c, + $e8,$70,$17,$ba,$2d,$84,$98,$8d, + $df,$c9,$c5,$8d,$b6,$7a,$ad,$a6, + $13,$c2,$dd,$08,$45,$79,$41,$a6); + +var + ct: array[0..255] of byte; + SO: integer; +begin + + writeln('NIST vector test: 128 bit key'); + Err := AES_CTR_Init(key128, 128, CTR, ctx2); + CheckError; + if userdef then begin + Err := AES_SetIncProc({$ifdef FPC_ProcVar}@{$endif}My_IncMSBFull, ctx2); + CheckError; + end; + for SO:=0 to 63 do begin + write('.'); + Err := AES_CTR_Seek(CTR, SO, 0, ctx2); + CheckError; + Err := AES_CTR_Encrypt(@plain[SO], @ct[SO], 1, ctx2); + if ct[SO]<>ct1[SO] then begin + writeln('Diff: SO=',SO:2,' ct1[SO]=',ct1[SO]:3,' ct[SO]=',ct[SO]:3); + end; + end; + writeln(' done'); + + writeln('NIST vector test: 192 bit key'); + Err := AES_CTR_Init(key192, 192, CTR, ctx2); + CheckError; + for SO:=0 to 63 do begin + write('.'); + {$ifdef USE_INT64} + Err := AES_CTR_Seek64(CTR, SO, ctx2); + {$else} + Err := AES_CTR_Seek(CTR, SO, 0, ctx2); + {$endif} + CheckError; + Err := AES_CTR_Encrypt(@plain[SO], @ct[SO], 1, ctx2); + if ct[SO]<>ct2[SO] then begin + writeln('Diff: SO=',SO:2,' ct2[SO]=',ct2[SO]:3,' ct[SO]=',ct[SO]:3); + end; + end; + writeln(' done'); + + writeln('NIST vector test: 256 bit key'); + Err := AES_CTR_Init(key256, 256, CTR, ctx2); + CheckError; + for SO:=63 downto 0 do begin + write('.'); + Err := AES_CTR_Seek(CTR, SO, 0, ctx2); + CheckError; + Err := AES_CTR_Encrypt(@plain[SO], @ct[SO], 1, ctx2); + if ct[SO]<>ct3[SO] then begin + writeln('Diff: SO=',SO:2,' ct3[SO]=',ct2[SO]:3,' ct[SO]=',ct[SO]:3); + end; + end; + writeln(' done'); +end; + + +{---------------------------------------------------------------------------} +procedure bigtest(n: integer); +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + CTR : TAESBlock = ($ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff, + $ff,$ff,$ff,$ff,$fd,$fc,$fb,$fa); + +{$ifdef USE_INT64} +var + ofs: int64; +const + oma = int64($3FFFFFFF)*$100; {avoid braindamaged D2 error} +{$else} +var + ofs: longint; +const + oma = $6FFFFFFF; +{$endif} +var + i: integer; +begin + for i:=0 to BSIZE-1 do pbuf[i] := random(256); + Err := AES_CTR_Init(key128, 128, CTR, ctx1); + CheckError; + case n of + 1: begin + writeln('IncProc = AES_IncMSBFull, max. offset = ',oma); + {$ifdef USE_INT64} + writeln(erroutput, 'IncProc = AES_IncMSBFull, max. offset = ',oma); + {$endif} + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncMSBFull, ctx1); + {$else} + err := AES_SetIncProc(AES_IncMSBFull, ctx1); + {$endif} + end; + 2: begin + writeln('IncProc = AES_IncLSBFull, max. offset = ',oma); + {$ifdef USE_INT64} + writeln(erroutput, 'IncProc = AES_IncLSBFull, max. offset = ',oma); + {$endif} + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncLSBFull, ctx1); + {$else} + err := AES_SetIncProc(AES_IncLSBFull, ctx1); + {$endif} + end; + + 3: begin + writeln('IncProc = AES_IncMSBPart, max. offset = ',oma); + {$ifdef USE_INT64} + writeln(erroutput, 'IncProc = AES_IncMSBPart, max. offset = ',oma); + {$endif} + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncMSBPart, ctx1); + {$else} + err := AES_SetIncProc(AES_IncMSBPart, ctx1); + {$endif} + end; + + 4: begin + writeln('IncProc = AES_IncLSBPart, max. offset = ',oma); + {$ifdef USE_INT64} + writeln(erroutput, 'IncProc = AES_IncLSBPart, max. offset = ',oma); + {$endif} + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncLSBPart, ctx1); + {$else} + err := AES_SetIncProc(AES_IncLSBPart, ctx1); + {$endif} + end; + end; + + CheckError; + ofs := 0; + ReStartTimer(HR); + repeat + for i:=1 to 99 do begin + Err := AES_CTR_Encrypt(@pbuf, @cbuf1, BSIZE, ctx1); + ofs := ofs + BSIZE; + end; + {$ifdef USE_INT64} + write(erroutput, 100.0*ofs/oma:1:3,'%'#13); + {$else} + write(100.0*ofs/oma:1:3,'%'#13); + {$endif} + Err := AES_CTR_Encrypt(@pbuf, @cbuf1, BSIZE, ctx1); + CheckError; + i := random(BSIZE); + Err := AES_CTR_Init(key128, 128, CTR, ctx2); + CheckError; + case n of + 1: begin + (* + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncMSBFull, ctx2); + {$else} + err := AES_SetIncProc(AES_IncMSBFull, ctx2); + {$endif} + *) + end; + 2: begin + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncLSBFull, ctx2); + {$else} + err := AES_SetIncProc(AES_IncLSBFull, ctx2); + {$endif} + end; + + 3: begin + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncMSBPart, ctx2); + {$else} + err := AES_SetIncProc(AES_IncMSBPart, ctx2); + {$endif} + end; + + 4: begin + {$ifdef FPC_ProcVar} + err := AES_SetIncProc(@AES_IncLSBPart, ctx2); + {$else} + err := AES_SetIncProc(AES_IncLSBPart, ctx2); + {$endif} + end; + else begin + writeln('Invalid n'); + halt; + end; + end; + CheckError; + {$ifdef USE_INT64} + Err := AES_CTR_Seek64(CTR, ofs+i, ctx2); + {$else} + Err := AES_CTR_Seek(CTR, ofs+i, 0, ctx2); + {$endif} + CheckError; + Err := AES_CTR_Encrypt(@pbuf[i], @cbuf2[i], 1, ctx2); + CheckError; + if cbuf1[i]<>cbuf2[i] then begin + writeln('Diff: Offset=',ofs+i,' cbuf1[]=',cbuf1[i]:3,' cbuf2[]=',cbuf2[i]:3); + halt; + end; + ofs := ofs + BSIZE; + until ofs>oma; + writeln('Done - no differences.'); + writeln('Time [s]: ', ReadSeconds(HR):1:3); +end; + +var + {$ifdef D12Plus} + s: string; + {$else} + s: string[10]; + {$endif} + +begin + writeln('Test program "AES CTR Seek" (C) 2010-2017 W.Ehrhardt'); + {$ifdef USEDLL} + writeln('DLL Version: ',AES_DLL_Version); + {$endif} + writeln; + writeln('Test using standard AES_IncMSBFull'); + randomtest(false); + writeln; + writeln('Test using user-defines My_IncMSBFull'); + randomtest(true); + writeln; + StartTimer(HR); + s := paramstr(1); + if s='big' then begin + bigtest(1); + bigtest(2); + bigtest(3); + bigtest(4); + end; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aes_ws.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aes_ws.pas new file mode 100644 index 00000000..437670c2 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aes_ws.pas @@ -0,0 +1,549 @@ +{-Speed test prog for AES modes, we 2003-2012} + +{23.05.2004 we TestOMAC} +{09.07.2006 we TestCMAC} +{22.06.2007 we Selftest AES CMAC PRF-128} +{25.12.2007 we Test CFB8} +{20.07.2008 we EAX All-in-one API} + +program T_AES_WS; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +{$ifdef J_OPT} + {$J+} +{$endif} + +{$ifndef FPC} + {$N+} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + {$ifdef USEDLL} + {$ifdef VirtualPascal} + AES_Intv, + {$else} + AES_Intf, + {$endif} + {$else} + aes_type,aes_base,aes_ctr,aes_cfb,aes_cfb8,aes_ofb,aes_cbc, + aes_ecb,aes_omac,aes_cmac,aes_eax,aes_cprf, + {$endif} + BTypes,mem_util; + +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + IV : TAESBlock = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f); + + CTR : TAESBlock = ($f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7, + $f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff); + + plain : array[0..63] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d,$8a,$57,$1e,$03,$ac,$9c, + $9e,$b7,$6f,$ac,$45,$af,$8e,$51, + $30,$c8,$1c,$46,$a3,$5c,$e4,$11, + $e5,$fb,$c1,$19,$1a,$0a,$52,$ef, + $f6,$9f,$24,$45,$df,$4f,$9b,$17, + $ad,$2b,$41,$7b,$e6,$6c,$37,$10); + + ct_cbc : array[0..63] of byte = ($76,$49,$ab,$ac,$81,$19,$b2,$46, + $ce,$e9,$8e,$9b,$12,$e9,$19,$7d, + $50,$86,$cb,$9b,$50,$72,$19,$ee, + $95,$db,$11,$3a,$91,$76,$78,$b2, + $73,$be,$d6,$b8,$e3,$c1,$74,$3b, + $71,$16,$e6,$9e,$22,$22,$95,$16, + $3f,$f1,$ca,$a1,$68,$1f,$ac,$09, + $12,$0e,$ca,$30,$75,$86,$e1,$a7); + + ct_cfb : array[0..63] of byte = ($3b,$3f,$d9,$2e,$b7,$2d,$ad,$20, + $33,$34,$49,$f8,$e8,$3c,$fb,$4a, + $c8,$a6,$45,$37,$a0,$b3,$a9,$3f, + $cd,$e3,$cd,$ad,$9f,$1c,$e5,$8b, + $26,$75,$1f,$67,$a3,$cb,$b1,$40, + $b1,$80,$8c,$f1,$87,$a4,$f4,$df, + $c0,$4b,$05,$35,$7c,$5d,$1c,$0e, + $ea,$c4,$c6,$6f,$9f,$f7,$f2,$e6); + + ct_ctr : array[0..63] of byte = ($87,$4d,$61,$91,$b6,$20,$e3,$26, + $1b,$ef,$68,$64,$99,$0d,$b6,$ce, + $98,$06,$f6,$6b,$79,$70,$fd,$ff, + $86,$17,$18,$7b,$b9,$ff,$fd,$ff, + $5a,$e4,$df,$3e,$db,$d5,$d3,$5e, + $5b,$4f,$09,$02,$0d,$b0,$3e,$ab, + $1e,$03,$1d,$da,$2f,$be,$03,$d1, + $79,$21,$70,$a0,$f3,$00,$9c,$ee); + + ct_ofb : array[0..63] of byte = ($3b,$3f,$d9,$2e,$b7,$2d,$ad,$20, + $33,$34,$49,$f8,$e8,$3c,$fb,$4a, + $77,$89,$50,$8d,$16,$91,$8f,$03, + $f5,$3c,$52,$da,$c5,$4e,$d8,$25, + $97,$40,$05,$1e,$9c,$5f,$ec,$f6, + $43,$44,$f7,$a8,$22,$60,$ed,$cc, + $30,$4c,$65,$28,$f6,$59,$c7,$78, + $66,$a5,$10,$d9,$c1,$d6,$ae,$5e); + + ct_ecb : array[0..63] of byte = ($3a,$d7,$7b,$b4,$0d,$7a,$36,$60, + $a8,$9e,$ca,$f3,$24,$66,$ef,$97, + $f5,$d3,$d5,$85,$03,$b9,$69,$9d, + $e7,$85,$89,$5a,$96,$fd,$ba,$af, + $43,$b1,$cd,$7f,$59,$8e,$ce,$23, + $88,$1b,$00,$e3,$ed,$03,$06,$88, + $7b,$0c,$78,$5e,$27,$e8,$ad,$3f, + $82,$23,$20,$71,$04,$72,$5d,$d4); + + + tag03 : TAESBlock = ($51,$f0,$be,$bf,$7e,$3b,$9d,$92,$fc,$49,$74,$17,$79,$36,$3c,$fe); + +var + ct: array[0..63] of byte; + +var + Context: TAESContext; + +const + N : longint = 8*1000000; {512MB} + + +{---------------------------------------------------------------------------} +function test(px,py: pointer): str255; +begin + if compmem(px,py,64) then test := 'OK' else test := 'Error'; +end; + + +{---------------------------------------------------------------------------} +procedure TestCFB; +var + i: longint; +begin + if AES_CFB_Init(key128, 128, IV, context)<>0 then begin + writeln('*** Error CFB'); + exit; + end; + for i:=1 to N do begin + if AES_CFB_Encrypt(@plain, @ct, sizeof(plain), context)<>0 then begin + writeln('*** Error CFB'); + exit; + end; + end; + if N=1 then begin + writeln('CFB test: ', test(@ct,@ct_cfb)); + end; +end; + + +{---------------------------------------------------------------------------} +procedure TestCFB8; +const + ct_cf8 : array[0..17] of byte = ($3b,$79,$42,$4c,$9c,$0d,$d4,$36, + $ba,$ce,$9e,$0e,$d4,$58,$6a,$4f, + $32,$b9); +begin + {Note CFB8 is about 16 times slower than CFB. Therefore only} + {the case N=1 is tested using NIST SP 800-38A Test F.3.7} + if AES_CFB8_Init(key128, 128, IV, context)<>0 then begin + writeln('*** Error CFB8'); + exit; + end; + if AES_CFB8_Encrypt(@plain, @ct, sizeof(plain), context)<>0 then begin + writeln('*** Error CFB8'); + exit; + end; + write('CFB8 test: '); + if compmem(@ct,@ct_cf8,sizeof(ct_cf8)) then writeln('OK') else writeln('Error'); +end; + + +{---------------------------------------------------------------------------} +procedure TestCBC; +var + i: longint; +begin + if AES_CBC_Init_Encr(key128, 128, IV, context)<>0 then begin + writeln('*** Error CBC'); + exit; + end; + for i:=1 to N do begin + if AES_CBC_Encrypt(@plain, @ct, sizeof(plain), context)<>0 then begin + writeln('*** Error CBC'); + exit; + end; + end; + if N=1 then begin + writeln('CBC test: ', test(@ct,@ct_cbc)); + end; +end; + + +{---------------------------------------------------------------------------} +procedure TestECB; +var + i: longint; +begin + if AES_ECB_Init_Encr(key128, 128, context)<>0 then begin + writeln('*** Error ECB'); + exit; + end; + for i:=1 to N do begin + if AES_ECB_Encrypt(@plain, @ct, sizeof(plain), context)<>0 then begin + writeln('*** Error ECB'); + exit; + end; + end; + if N=1 then begin + writeln('ECB test: ', test(@ct,@ct_ECB)); + end; +end; + + +{---------------------------------------------------------------------------} +procedure TestCTR; +var + i: longint; +begin + if AES_CTR_Init(key128, 128, CTR, context)<>0 then begin + writeln('*** Error CTR'); + exit; + end; + for i:=1 to N do begin + if AES_CTR_Encrypt(@plain, @ct, sizeof(plain), context)<>0 then begin + writeln('*** Error CTR'); + exit; + end; + end; + if N=1 then begin + writeln('CTR test: ', test(@ct,@ct_ctr)); + end; +end; + + +{---------------------------------------------------------------------------} +procedure TestOFB; +var + i: longint; +begin + if AES_OFB_Init(key128, 128, IV, context)<>0 then begin + writeln('*** Error OFB'); + exit; + end; + for i:=1 to N do begin + if AES_OFB_Encrypt(@plain, @ct, sizeof(plain), context)<>0 then begin + writeln('*** Error OFB'); + exit; + end; + end; + if N=1 then begin + writeln('OFB test: ', test(@ct,@ct_ofb)); + end; +end; + + +{---------------------------------------------------------------------------} +procedure TestOMAC; +var + i: longint; + tag: TAESBlock; +begin + if AES_OMAC_Init(key128, 128, context)<>0 then begin + writeln('*** Error OMAC Init'); + exit; + end; + for i:=1 to N do begin + if AES_OMAC_Update(@plain, 64, context)<>0 then begin + writeln('*** Error OMAC update'); + exit; + end; + end; + AES_OMAC_Final(tag, context); + if N=1 then begin + write('OMAC test: '); + if compmem(@tag, @tag03, sizeof(tag)) then writeln('OK') else writeln('Error'); + end; +end; + + +{---------------------------------------------------------------------------} +procedure TestCMAC; +var + i: longint; + tag: TAESBlock; +begin + if AES_CMAC_Init(key128, 128, context)<>0 then begin + writeln('*** Error OMAC Init'); + exit; + end; + for i:=1 to N do begin + if AES_CMAC_Update(@plain, 64, context)<>0 then begin + writeln('*** Error CMAC update'); + exit; + end; + end; + AES_CMAC_Final(tag, context); + if N=1 then begin + write('CMAC test: '); + if compmem(@tag, @tag03, sizeof(tag)) then writeln('OK') else writeln('Error'); + end; +end; + + +{---------------------------------------------------------------------------} +procedure TestEAX; +const + {Test vector from Tom St Denis} + hex32: array[1..32] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17, + $18, $19, $1a, $1b, $1c, $1d, $1e, $1f); + + tag00: array[1..16] of byte = ($9a, $d0, $7e, $7d, $bf, $f3, $01, $f5, + $05, $de, $59, $6b, $96, $15, $df, $ff); + + tag01: array[1..16] of byte = ($1c, $e1, $0d, $3e, $ff, $d4, $ca, $db, + $e2, $e4, $4b, $58, $d6, $0a, $b9, $ec); + + tag02: array[1..16] of byte = ($3a, $69, $8f, $7a, $27, $0e, $51, $b0, + $f6, $5b, $3d, $3e, $47, $19, $3c, $ff); + + ct03 : array[1..32] of byte = ($29, $d8, $78, $d1, $a3, $be, $85, $7b, + $6f, $b8, $c8, $ea, $59, $50, $a7, $78, + $33, $1f, $bf, $2c, $cf, $33, $98, $6f, + $35, $e8, $cf, $12, $1d, $cb, $30, $bc); + tag03: array[1..16] of byte = ($4f, $be, $03, $38, $be, $1c, $8c, $7e, + $1d, $7a, $e7, $e4, $5b, $92, $c5, $87); + + ct04: array[1..29] of byte = ($dd, $25, $c7, $54, $c5, $b1, $7c, $59, + $28, $b6, $9b, $73, $15, $5f, $7b, $b8, + $88, $8f, $af, $37, $09, $1a, $d9, $2c, + $8a, $24, $db, $86, $8b); + + tag04: array[1..16] of byte = ($0d, $1a, $14, $e5, $22, $24, $ff, $d2, + $3a, $05, $fa, $02, $cd, $ef, $52, $da); + + {Test vectors from App. E,} + {reproduced by Brian Gladman, ctx is split into ctxx and tagxx} + + key05: array[1..16] of byte = ($23, $39, $52, $de, $e4, $d5, $ed, $5f, + $9b, $9c, $6d, $6f, $f8, $0f, $f4, $78); + non05: array[1..16] of byte = ($62, $ec, $67, $f9, $c3, $a4, $a4, $07, + $fc, $b2, $a8, $c4, $90, $31, $a8, $b3); + hdr05: array[1..08] of byte = ($6b, $fb, $91, $4f, $d0, $7e, $ae, $6b); + tag05: array[1..16] of byte = ($e0, $37, $83, $0e, $83, $89, $f2, $7b, + $02, $5a, $2d, $65, $27, $e7, $9d, $01); + + pt06 : array[1..02] of byte = ($f7, $fb); + key06: array[1..16] of byte = ($91, $94, $5d, $3f, $4d, $cb, $ee, $0b, + $f4, $5e, $f5, $22, $55, $f0, $95, $a4); + non06: array[1..16] of byte = ($be, $ca, $f0, $43, $b0, $a2, $3d, $84, + $31, $94, $ba, $97, $2c, $66, $de, $bd); + hdr06: array[1..08] of byte = ($fa, $3b, $fd, $48, $06, $eb, $53, $fa); + ct06 : array[1..02] of byte = ($19, $dd); + tag06: array[1..16] of byte = ($5c, $4c, $93, $31, $04, $9d, $0b, $da, + $b0, $27, $74, $08, $f6, $79, $67, $e5); + + pt07 : array[1..05] of byte = ($1a, $47, $cb, $49, $33); + key07: array[1..16] of byte = ($01, $f7, $4a, $d6, $40, $77, $f2, $e7, + $04, $c0, $f6, $0a, $da, $3d, $d5, $23); + non07: array[1..16] of byte = ($70, $c3, $db, $4f, $0d, $26, $36, $84, + $00, $a1, $0e, $d0, $5d, $2b, $ff, $5e); + hdr07: array[1..08] of byte = ($23, $4a, $34, $63, $c1, $26, $4a, $c6); + ct07 : array[1..05] of byte = ($d8, $51, $d5, $ba, $e0); + tag07: array[1..16] of byte = ($3a, $59, $f2, $38, $a2, $3e, $39, $19, + $9d, $c9, $26, $66, $26, $c4, $0f, $80); + + pt08 : array[1..05] of byte = ($48, $1c, $9e, $39, $b1); + key08: array[1..16] of byte = ($d0, $7c, $f6, $cb, $b7, $f3, $13, $bd, + $de, $66, $b7, $27, $af, $d3, $c5, $e8); + non08: array[1..16] of byte = ($84, $08, $df, $ff, $3c, $1a, $2b, $12, + $92, $dc, $19, $9e, $46, $b7, $d6, $17); + hdr08: array[1..08] of byte = ($33, $cc, $e2, $ea, $bf, $f5, $a7, $9d); + ct08 : array[1..05] of byte = ($63, $2a, $9d, $13, $1a); + tag08: array[1..16] of byte = ($d4, $c1, $68, $a4, $22, $5d, $8e, $1f, + $f7, $55, $93, $99, $74, $a7, $be, $de); + + pt09 : array[1..06] of byte = ($40, $d0, $c0, $7d, $a5, $e4); + key09: array[1..16] of byte = ($35, $b6, $d0, $58, $00, $05, $bb, $c1, + $2b, $05, $87, $12, $45, $57, $d2, $c2); + non09: array[1..16] of byte = ($fd, $b6, $b0, $66, $76, $ee, $dc, $5c, + $61, $d7, $42, $76, $e1, $f8, $e8, $16); + hdr09: array[1..08] of byte = ($ae, $b9, $6e, $ae, $be, $29, $70, $e9); + ct09 : array[1..06] of byte = ($07, $1d, $fe, $16, $c6, $75); + tag09: array[1..16] of byte = ($cb, $06, $77, $e5, $36, $f7, $3a, $fe, + $6a, $14, $b7, $4e, $e4, $98, $44, $dd); + + pt10 : array[1..12] of byte = ($4d, $e3, $b3, $5c, $3f, $c0, $39, $24, + $5b, $d1, $fb, $7d); + key10: array[1..16] of byte = ($bd, $8e, $6e, $11, $47, $5e, $60, $b2, + $68, $78, $4c, $38, $c6, $2f, $eb, $22); + non10: array[1..16] of byte = ($6e, $ac, $5c, $93, $07, $2d, $8e, $85, + $13, $f7, $50, $93, $5e, $46, $da, $1b); + hdr10: array[1..08] of byte = ($d4, $48, $2d, $1c, $a7, $8d, $ce, $0f); + ct10 : array[1..12] of byte = ($83, $5b, $b4, $f1, $5d, $74, $3e, $35, + $0e, $72, $84, $14); + tag10: array[1..16] of byte = ($ab, $b8, $64, $4f, $d6, $cc, $b8, $69, + $47, $c5, $e1, $05, $90, $21, $0a, $4f); + + pt11 : array[1..17] of byte = ($8b, $0a, $79, $30, $6c, $9c, $e7, $ed, + $99, $da, $e4, $f8, $7f, $8d, $d6, $16, $36); + key11: array[1..16] of byte = ($7c, $77, $d6, $e8, $13, $be, $d5, $ac, + $98, $ba, $a4, $17, $47, $7a, $2e, $7d); + non11: array[1..16] of byte = ($1a, $8c, $98, $dc, $d7, $3d, $38, $39, + $3b, $2b, $f1, $56, $9d, $ee, $fc, $19); + hdr11: array[1..08] of byte = ($65, $d2, $01, $79, $90, $d6, $25, $28); + ct11 : array[1..17] of byte = ($02, $08, $3e, $39, $79, $da, $01, $48, + $12, $f5, $9f, $11, $d5, $26, $30, $da, $30); + tag11: array[1..16] of byte = ($13, $73, $27, $d1, $06, $49, $b0, $aa, + $6e, $1c, $18, $1d, $b6, $17, $d7, $f2); + + pt12 : array[1..18] of byte = ($1b, $da, $12, $2b, $ce, $8a, $8d, $ba, + $f1, $87, $7d, $96, $2b, $85, $92, $dd, $2d, $56); + key12: array[1..16] of byte = ($5f, $ff, $20, $ca, $fa, $b1, $19, $ca, + $2f, $c7, $35, $49, $e2, $0f, $5b, $0d); + non12: array[1..16] of byte = ($dd, $e5, $9b, $97, $d7, $22, $15, $6d, + $4d, $9a, $ff, $2b, $c7, $55, $98, $26); + hdr12: array[1..08] of byte = ($54, $b9, $f0, $4e, $6a, $09, $18, $9a); + ct12 : array[1..18] of byte = ($2e, $c4, $7b, $2c, $49, $54, $a4, $89, + $af, $c7, $ba, $48, $97, $ed, $cd, $ae, $8c, $c3); + tag12: array[1..16] of byte = ($3b, $60, $45, $05, $99, $bd, $02, $c9, + $63, $82, $90, $2a, $ef, $7f, $83, $2a); + + pt13 : array[1..18] of byte = ($6c, $f3, $67, $20, $87, $2b, $85, $13, + $f6, $ea, $b1, $a8, $a4, $44, $38, $d5, $ef, $11); + key13: array[1..16] of byte = ($a4, $a4, $78, $2b, $cf, $fd, $3e, $c5, + $e7, $ef, $6d, $8c, $34, $a5, $61, $23); + non13: array[1..16] of byte = ($b7, $81, $fc, $f2, $f7, $5f, $a5, $a8, + $de, $97, $a9, $ca, $48, $e5, $22, $ec); + hdr13: array[1..08] of byte = ($89, $9a, $17, $58, $97, $56, $1d, $7e); + ct13 : array[1..18] of byte = ($0d, $e1, $8f, $d0, $fd, $d9, $1e, $7a, + $f1, $9f, $1d, $8e, $e8, $73, $39, $38, $b1, $e8); + tag13: array[1..16] of byte = ($e7, $f6, $d2, $23, $16, $18, $10, $2f, + $db, $7f, $e5, $5f, $f1, $99, $17, $00); + + pt14 : array[1..21] of byte = ($ca, $40, $d7, $44, $6e, $54, $5f, $fa, + $ed, $3b, $d1, $2a, $74, $0a, $65, $9f, + $fb, $bb, $3c, $ea, $b7); + key14: array[1..16] of byte = ($83, $95, $fc, $f1, $e9, $5b, $eb, $d6, + $97, $bd, $01, $0b, $c7, $66, $aa, $c3); + non14: array[1..16] of byte = ($22, $e7, $ad, $d9, $3c, $fc, $63, $93, + $c5, $7e, $c0, $b3, $c1, $7d, $6b, $44); + hdr14: array[1..08] of byte = ($12, $67, $35, $fc, $c3, $20, $d2, $5a); + ct14 : array[1..21] of byte = ($cb, $89, $20, $f8, $7a, $6c, $75, $cf, + $f3, $96, $27, $b5, $6e, $3e, $d1, $97, + $c5, $52, $d2, $95, $a7); + tag14: array[1..16] of byte = ($cf, $c4, $6a, $fc, $25, $3b, $46, $52, + $b1, $af, $37, $95, $b1, $24, $ab, $6e); + + function test(var key, hdr, nonce, pt, tct, ttag; nlen, hlen, plen: word): boolean; + var + ctx: TAES_EAXContext; + tag: TAESBlock; + buf: array[0..63] of byte; + begin + test := false; + {Incremental API} + {encrypt} + if AES_EAX_Init(Key, 128, nonce, nlen, ctx)<>0 then exit; + if AES_EAX_Provide_Header(@hdr,hLen,ctx)<>0 then exit; + if AES_EAX_Encrypt(@pt, @buf, plen, ctx)<>0 then exit; + AES_EAX_Final(tag, ctx); + if not compmem(@buf,@tct,plen) then exit; + if not compmem(@tag,@ttag,sizeof(tag)) then exit; + {decrypt} + if AES_EAX_Init(Key, 128, nonce, nlen, ctx)<>0 then exit; + if AES_EAX_Provide_Header(@hdr,hLen,ctx)<>0 then exit; + if AES_EAX_Decrypt(@tct, @buf, plen, ctx)<>0 then exit; + AES_EAX_Final(tag, ctx); + if not compmem(@buf,@pt,plen) then exit; + if not compmem(@tag,@ttag,sizeof(tag)) then exit; + {All-in-one API} + {encrypt} + if AES_EAX_Enc_Auth(tag,Key,128,nonce,nlen,@hdr,hLen, @pt,plen, @buf)<>0 then exit; + if not compmem(@buf,@tct,plen) then exit; + if not compmem(@tag,@ttag,sizeof(tag)) then exit; + {decrypt} + {adjust test procedure if taglen <> 16!!!} + if AES_EAX_Dec_Veri(@ttag,16,key,128,nonce,nlen,@hdr,hLen,@tct,plen,@buf)<>0 then exit; + {tag is OK, otherwise AES_Err_EAX_Verify_Tag would have been returned} + if not compmem(@buf,@pt,plen) then exit; + test := true; + end; + +var + OK: boolean; +begin + OK := true; + write('EAX test: '); + if OK then OK := Test(hex32, hex32, hex32, hex32, hex32, tag00, 0, 0, 0); + if OK then OK := Test(hex32, hex32, hex32, hex32, hex32, tag01, 16, 0, 0); + if OK then OK := Test(hex32, hex32, hex32, hex32, hex32, tag02, 0, 16, 0); + if OK then OK := Test(hex32, hex32, hex32, hex32, ct03, tag03, 16, 16, 32); + if OK then OK := Test(hex32, hex32, hex32, hex32, ct04, tag04, 15, 14, 29); + if OK then OK := Test(key05, hdr05, non05, hex32, hex32, tag05, 16, 08, 0); + if OK then OK := Test(key06, hdr06, non06, pt06, ct06, tag06, 16, 08, 2); + if OK then OK := Test(key07, hdr07, non07, pt07, ct07, tag07, 16, 08, 5); + if OK then OK := Test(key08, hdr08, non08, pt08, ct08, tag08, 16, 08, 5); + if OK then OK := Test(key09, hdr09, non09, pt09, ct09, tag09, 16, 08, 6); + if OK then OK := Test(key10, hdr10, non10, pt10, ct10, tag10, 16, 08, 12); + if OK then OK := Test(key11, hdr11, non11, pt11, ct11, tag11, 16, 08, 17); + if OK then OK := Test(key12, hdr12, non12, pt12, ct12, tag12, 16, 08, 18); + if OK then OK := Test(key13, hdr13, non13, pt13, ct13, tag13, 16, 08, 18); + if OK then OK := Test(key14, hdr14, non14, pt14, ct14, tag14, 16, 08, 21); + if OK then writeln('OK') else writeln('Error'); +end; + +var + {$ifdef D12Plus} + s: string; + {$else} + s: string[10]; + {$endif} + i: integer; +begin + AES_SetFastInit(true); + {$ifdef USEDLL} + writeln('Test program for AES_DLL V',AES_DLL_Version,' (C) 2004-2012 W.Ehrhardt'); + {$else} + {$ifdef AES_ComprTab} + writeln('Test program for AES functions [compressed tables] (C) 2004-2012 W.Ehrhardt'); + {$else} + writeln('Test program for AES functions [full tables] (C) 2004-2012 W.Ehrhardt'); + {$endif} + {$endif} + s := paramstr(1); + for i:=1 to length(s) do s[i] := upcase(s[i]); + if s='TEST' then begin + N := 1; + writeln('Selftest AES CMAC PRF-128: ', AES_CPRF128_selftest); + TestCBC; + TestCFB; + TestCFB8; + TestCTR; + TestECB; + TestOFB; + TestOMAC; + TestCMAC; + TestEAX; + writeln; + end + else if s='CBC' then TestCBC + else if s='CFB' then TestCFB + else if s='CTR' then TestCTR + else if s='ECB' then TestECB + else if s='OFB' then TestOFB + else if s='OMAC' then TestOMAC + else if s='CMAC' then TestCMAC + else begin + writeln('Usage: T_AES_WS [ TEST | CBC | CFB | CTR | ECB | OFB | OMAC | CMAC ]'); + halt; + end; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aes_xl.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aes_xl.pas new file mode 100644 index 00000000..7b71a398 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aes_xl.pas @@ -0,0 +1,306 @@ +{-Test prog for AES modes, ILen > $FFFF for 32 bit, we July 2010} + +program T_AES_XL; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +{$ifndef FPC} + {$N+} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + {$ifdef USEDLL} + {$ifdef VirtualPascal} + AES_Intv, + {$else} + AES_Intf, + {$endif} + {$else} + AES_Type, AES_CTR, AES_CFB, AES_CFB8, AES_OFB, AES_CBC, AES_ECB, AES_OMAC, AES_EAX, + {$endif} + BTypes, mem_util; + +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + IV : array[0..15] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f); + + CTR : array[0..15] of byte = ($f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7, + $f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff); + +{$ifndef BIT16} +const BSIZE=400000; +{$else} +const BSIZE=10000; +{$endif} + +const + BS1 = AESBLKSIZE*(BSIZE div (2*AESBLKSIZE)); + +type + TBuf = array[0..BSIZE-1] of byte; + +var + pt, ct, dt: Tbuf; + +var + Context: TAESContext; + + +{---------------------------------------------------------------------------} +function test(px,py: pointer): Str255; +begin + if compmemxl(px,py,sizeof(TBuf)) then test := 'OK' else test := 'Error'; +end; + + +{---------------------------------------------------------------------------} +procedure TestCFB; +begin + fillchar(dt,sizeof(dt),0); + if AES_CFB_Init(key128, 8*sizeof(key128), TAESBlock(IV), context)<>0 then begin + writeln('*** Error CFB_Init'); + exit; + end; + if AES_CFB_Encrypt(@pt, @ct, BS1, context)<>0 then begin + writeln('*** Error CFB_Encrypt 1'); + exit; + end; + if AES_CFB_Encrypt(@pt[BS1], @ct[BS1], sizeof(TBuf)-BS1, context)<>0 then begin + writeln('*** Error CFB_Encrypt 2'); + exit; + end; + if AES_CFB_Init(key128, 8*sizeof(key128), TAESBlock(IV), context)<>0 then begin + writeln('*** Error CFB_Init'); + exit; + end; + if AES_CFB_Decrypt(@ct, @dt, sizeof(TBuf), context)<>0 then begin + writeln('*** Error CFB_Decrypt'); + exit; + end; + writeln('CFB test: ', test(@pt,@dt)); +end; + + +{---------------------------------------------------------------------------} +procedure TestCFB8; +begin + fillchar(dt,sizeof(dt),0); + if AES_CFB8_Init(key128, 8*sizeof(key128), TAESBlock(IV), context)<>0 then begin + writeln('*** Error CFB8_Init'); + exit; + end; + if AES_CFB8_Encrypt(@pt, @ct, BS1, context)<>0 then begin + writeln('*** Error CFB8_Encrypt 1'); + exit; + end; + if AES_CFB8_Encrypt(@pt[BS1], @ct[BS1], sizeof(TBuf)-BS1, context)<>0 then begin + writeln('*** Error CFB8_Encrypt 2'); + exit; + end; + if AES_CFB8_Init(key128, 8*sizeof(key128), TAESBlock(IV), context)<>0 then begin + writeln('*** Error CFB8_Init'); + exit; + end; + if AES_CFB8_Decrypt(@ct, @dt, sizeof(TBuf), context)<>0 then begin + writeln('*** Error CFB8_Decrypt'); + exit; + end; + writeln('CFB8 test: ', test(@pt,@dt)); +end; + + +{---------------------------------------------------------------------------} +procedure TestCBC; +begin + fillchar(dt,sizeof(dt),0); + if AES_CBC_Init_Encr(key128, 8*sizeof(key128), TAESBlock(IV), context)<>0 then begin + writeln('*** Error CBC_Init_Encr'); + exit; + end; + if AES_CBC_Encrypt(@pt, @ct, BS1, context)<>0 then begin + writeln('*** Error CBC_Encrypt 1'); + exit; + end; + if AES_CBC_Encrypt(@pt[BS1], @ct[BS1], sizeof(TBuf)-BS1, context)<>0 then begin + writeln('*** Error CBC_Encrypt 2'); + exit; + end; + if AES_CBC_Init_Decr(key128, 8*sizeof(key128), TAESBlock(IV), context)<>0 then begin + writeln('*** Error CBC_Init_Decr'); + exit; + end; + if AES_CBC_Decrypt(@ct, @dt, sizeof(TBuf), context)<>0 then begin + writeln('*** Error CBC_Decrypt'); + exit; + end; + writeln('CBC test: ', test(@pt,@dt)); +end; + + +{---------------------------------------------------------------------------} +procedure TestECB; +begin + fillchar(dt,sizeof(dt),0); + if AES_ECB_Init_Encr(key128, 8*sizeof(key128), context)<>0 then begin + writeln('*** Error ECB_Init_Encr'); + exit; + end; + if AES_ECB_Encrypt(@pt, @ct, BS1, context)<>0 then begin + writeln('*** Error ECB_Encrypt 1'); + exit; + end; + if AES_ECB_Encrypt(@pt[BS1], @ct[BS1], sizeof(TBuf)-BS1, context)<>0 then begin + writeln('*** Error ECB_Encrypt 2'); + exit; + end; + if AES_ECB_Init_Decr(key128, 8*sizeof(key128), context)<>0 then begin + writeln('*** Error ECB_Init_Decr'); + exit; + end; + if AES_ECB_Decrypt(@ct, @dt, sizeof(TBuf), context)<>0 then begin + writeln('*** Error ECB_Decrypt'); + exit; + end; + writeln('ECB test: ', test(@pt,@dt)); +end; + + +{---------------------------------------------------------------------------} +procedure TestCTR; +begin + fillchar(dt,sizeof(dt),0); + if AES_CTR_Init(key128, 8*sizeof(key128), TAESBlock(CTR), context)<>0 then begin + writeln('*** Error CTR_Init'); + exit; + end; + if AES_CTR_Encrypt(@pt, @ct, BS1, context)<>0 then begin + writeln('*** Error CTR_Encrypt 1'); + exit; + end; + if AES_CTR_Encrypt(@pt[BS1], @ct[BS1], sizeof(TBuf)-BS1, context)<>0 then begin + writeln('*** Error CTR_Encrypt 2'); + exit; + end; + if AES_CTR_Init(key128, 8*sizeof(key128), TAESBlock(CTR), context)<>0 then begin + writeln('*** Error CTR_Init'); + exit; + end; + if AES_CTR_Decrypt(@ct, @dt, sizeof(TBuf), context)<>0 then begin + writeln('*** Error CTR_Decrypt'); + exit; + end; + writeln('CTR test: ', test(@pt,@dt)); +end; + + +{---------------------------------------------------------------------------} +procedure TestOFB; +begin + fillchar(dt,sizeof(dt),0); + if AES_OFB_Init(key128, 8*sizeof(key128), TAESBlock(IV), context)<>0 then begin + writeln('*** Error OFB_Init'); + exit; + end; + if AES_OFB_Encrypt(@pt, @ct, BS1, context)<>0 then begin + writeln('*** Error OFB_Encrypt 1'); + exit; + end; + if AES_OFB_Encrypt(@pt[BS1], @ct[BS1], sizeof(TBuf)-BS1, context)<>0 then begin + writeln('*** Error OFB_Encrypt 2'); + exit; + end; + if AES_OFB_Init(key128, 8*sizeof(key128), TAESBlock(IV), context)<>0 then begin + writeln('*** Error OFB_Init'); + exit; + end; + if AES_OFB_Decrypt(@ct, @dt, sizeof(TBuf), context)<>0 then begin + writeln('*** Error OFB_Decrypt'); + exit; + end; + writeln('OFB test: ', test(@pt,@dt)); +end; + + +{---------------------------------------------------------------------------} +procedure TestEAX; +const + hex32: array[1..32] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17, + $18,$19,$1a,$1b,$1c,$1d,$1e,$1f); +var + ctx: TAES_EAXContext; + te,td: TAESBlock; +begin + fillchar(dt,sizeof(dt),0); + if AES_EAX_Init(key128, 128, hex32, sizeof(hex32), ctx) <>0 then begin + writeln('*** Error EAX_Init'); + exit; + end; + if AES_EAX_Provide_Header(@hex32, sizeof(hex32),ctx) <>0 then begin + writeln('*** Error EAX_Provide_Header'); + exit; + end; + if AES_EAX_Encrypt(@pt, @ct, BS1, ctx) <>0 then begin + writeln('*** Error EAX_Encrypt 1'); + exit; + end; + if AES_EAX_Encrypt(@pt[BS1], @ct[BS1], sizeof(TBuf)-BS1, ctx) <>0 then begin + writeln('*** Error EAX_Encrypt 2'); + exit; + end; + AES_EAX_Final(te, ctx); + + if AES_EAX_Init(key128, 128, hex32, sizeof(hex32), ctx) <>0 then begin + writeln('*** Error EAX_Init'); + exit; + end; + if AES_EAX_Provide_Header(@hex32, sizeof(hex32),ctx) <>0 then begin + writeln('*** Error EAX_Provide_Header'); + exit; + end; + if AES_EAX_Decrypt(@ct, @dt, sizeof(TBuf), ctx) <>0 then begin + writeln('*** Error EAX_Encrypt'); + exit; + end; + AES_EAX_Final(td, ctx); + + if not compmemxl(@pt, @dt, sizeof(TBuf)) then begin + writeln('*** Dec EAX diff buf'); + exit; + end; + if not compmem(@te, @td, sizeof(td)) then begin + writeln('*** Dec EAX diff tag'); + exit; + end; + write('EAX test: OK'); +end; + + +begin + {$ifdef USEDLL} + writeln('Test program for AES_DLL V',AES_DLL_Version,' (C) 2010 W.Ehrhardt'); + {$else} + writeln('Test program for AES modes (C) 2010 W.Ehrhardt'); + {$endif} + writeln('Test of encrypt/decrypt routines using single calls with ',BS1,'/',BSize, ' bytes.'); + RandMemXL(@pt, sizeof(TBuf)); + TestCBC; + TestCFB; + TestCFB8; + TestCTR; + TestECB; + TestOFB; + TestEAX; + writeln; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aescbc.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aescbc.pas new file mode 100644 index 00000000..6c20d54d --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aescbc.pas @@ -0,0 +1,218 @@ +{-Test prog for AES CBC, we Sep.2003} + +program T_AESCBC; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_type, aes_cbc, mem_util, BTypes; + +var + Context: TAESContext; + Err: integer; + + +{---------------------------------------------------------------------------} +procedure CheckError; +begin + if Err<>0 then writeln('Error ',Err); +end; + + +{---------------------------------------------------------------------------} +procedure SimpleTests; + {-Simple encrypt/decrypt test for AES-CBC mode} +const + Key128 : array[0..15] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f); + Key192 : array[0..23] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17); + Key256 : array[0..31] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17, + $18, $19, $1a, $1b, $1c, $1d, $1e, $1f); + +const + sample = 'This is a short test sample for AES CBC mode'#0; + + +var + i : integer; + ct, pt, plain: array[1..length(sample)] of char8; + IV : TAESBlock; + + procedure CheckRes; + begin + writeln('Test Dec(Enc)=Id: ',CompMem(@pt, @plain, sizeof(plain))); + end; + +begin + for i:=0 to 15 do IV[i] := random(256); + plain := sample; + + writeln; + writeln('============================================'); + writeln('Simple encrypt/decrypt test for AES-CBC mode'); + writeln('Plain text: ', plain); + writeln; + + writeln('++++ 128 bit key ++++'); + pt := plain; + Err := AES_CBC_Init_Encr(key128, 128, IV, context); + Err := AES_CBC_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + Err := AES_CBC_Init_Decr(key128, 128, IV, context); + Err := AES_CBC_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/Dec @pt<>@ct: ', pt); + CheckRes; + pt := ct; + Err := AES_CBC_Init_Decr(key128, 128, IV, context); + Err := AES_CBC_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/dec inplace : ', pt); + CheckRes; + + writeln; + writeln('++++ 192 bit key ++++'); + pt := plain; + Err := AES_CBC_Init_Encr(key192, 192, IV, context); + Err := AES_CBC_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + Err := AES_CBC_Init_Decr(key192, 192, IV, context); + Err := AES_CBC_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/dec @pt<>@ct: ', pt); + CheckRes; + pt := ct; + Err := AES_CBC_Init_Decr(key192, 192, IV, context); + Err := AES_CBC_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/dec inplace : ', pt); + CheckRes; + + writeln; + writeln('++++ 256 bit key ++++'); + pt := plain; + Err := AES_CBC_Init_Encr(key256, 256, IV, context); + Err := AES_CBC_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + Err := AES_CBC_Init_Decr(key256, 256, IV, context); + Err := AES_CBC_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/dec @pt<>@ct: ', pt); + CheckRes; + pt := ct; + Err := AES_CBC_Init_Decr(key256, 256, IV, context); + Err := AES_CBC_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/dec inplace : ', pt); + CheckRes; +end; + + +{---------------------------------------------------------------------------} +procedure NistTests; + {-NIST SP 800-38A CBC/AES Tests} +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + key192 : array[0..23] of byte = ($8e,$73,$b0,$f7,$da,$0e,$64,$52, + $c8,$10,$f3,$2b,$80,$90,$79,$e5, + $62,$f8,$ea,$d2,$52,$2c,$6b,$7b); + + key256 : array[0..31] of byte = ($60,$3d,$eb,$10,$15,$ca,$71,$be, + $2b,$73,$ae,$f0,$85,$7d,$77,$81, + $1f,$35,$2c,$07,$3b,$61,$08,$d7, + $2d,$98,$10,$a3,$09,$14,$df,$f4); + + IV : TAESBlock = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f); + + plain : array[0..63] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d,$8a,$57,$1e,$03,$ac,$9c, + $9e,$b7,$6f,$ac,$45,$af,$8e,$51, + $30,$c8,$1c,$46,$a3,$5c,$e4,$11, + $e5,$fb,$c1,$19,$1a,$0a,$52,$ef, + $f6,$9f,$24,$45,$df,$4f,$9b,$17, + $ad,$2b,$41,$7b,$e6,$6c,$37,$10); + + ct1 : array[0..63] of byte = ($76,$49,$ab,$ac,$81,$19,$b2,$46, + $ce,$e9,$8e,$9b,$12,$e9,$19,$7d, + $50,$86,$cb,$9b,$50,$72,$19,$ee, + $95,$db,$11,$3a,$91,$76,$78,$b2, + $73,$be,$d6,$b8,$e3,$c1,$74,$3b, + $71,$16,$e6,$9e,$22,$22,$95,$16, + $3f,$f1,$ca,$a1,$68,$1f,$ac,$09, + $12,$0e,$ca,$30,$75,$86,$e1,$a7); + + ct2 : array[0..63] of byte = ($4f,$02,$1d,$b2,$43,$bc,$63,$3d, + $71,$78,$18,$3a,$9f,$a0,$71,$e8, + $b4,$d9,$ad,$a9,$ad,$7d,$ed,$f4, + $e5,$e7,$38,$76,$3f,$69,$14,$5a, + $57,$1b,$24,$20,$12,$fb,$7a,$e0, + $7f,$a9,$ba,$ac,$3d,$f1,$02,$e0, + $08,$b0,$e2,$79,$88,$59,$88,$81, + $d9,$20,$a9,$e6,$4f,$56,$15,$cd); + + ct3 : array[0..63] of byte = ($f5,$8c,$4c,$04,$d6,$e5,$f1,$ba, + $77,$9e,$ab,$fb,$5f,$7b,$fb,$d6, + $9c,$fc,$4e,$96,$7e,$db,$80,$8d, + $67,$9f,$77,$7b,$c6,$70,$2c,$7d, + $39,$f2,$33,$69,$a9,$d9,$ba,$cf, + $a5,$30,$e2,$63,$04,$23,$14,$61, + $b2,$eb,$05,$e2,$c3,$9b,$e9,$fc, + $da,$6c,$19,$07,$8c,$6a,$9d,$1b); + +var + ct: array[0..255] of byte; +begin + writeln; + writeln('============================='); + writeln('NIST SP 800-38A CBC/AES tests'); + Err := AES_CBC_Init_Encr(key128, 128, IV, context); + Err := AES_CBC_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.2.1 CBC-AES128.Encrypt - OK: ',CompMem(@ct1, @ct, sizeof(ct1))); + + Err := AES_CBC_Init_Decr(key128, 128, IV, context); + Err := AES_CBC_Decrypt(@ct{1}, @ct, sizeof(ct1), context); + CheckError; + writeln('Test F.2.2 CBC-AES128.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_CBC_Init_Encr(key192, 192, IV, context); + Err := AES_CBC_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.2.3 CBC-AES192.Encrypt - OK: ',CompMem(@ct2, @ct, sizeof(ct2))); + + Err := AES_CBC_Init_Decr(key192, 192, IV, context); + Err := AES_CBC_Decrypt(@ct{2}, @ct, sizeof(ct3), context); + CheckError; + writeln('Test F.2.4 CBC-AES192.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_CBC_Init_Encr(key256, 256, IV, context); + Err := AES_CBC_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.2.5 CBC-AES256.Encrypt - OK: ',CompMem(@ct3, @ct, sizeof(ct3))); + + Err := AES_CBC_Init_Decr(key256, 256, IV, context); + Err := AES_CBC_Decrypt(@ct{3}, @ct, sizeof(ct3), context); + CheckError; + writeln('Test F.2.6 CBC-AES256.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + +end; + +begin + SimpleTests; + NistTests; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aesccm.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aesccm.pas new file mode 100644 index 00000000..0c102e32 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aesccm.pas @@ -0,0 +1,308 @@ +{-Test program for CCM, (c) we 05.2009} + +program T_AESCCM; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + {$ifdef USEDLL} + {$ifdef VirtualPascal} + AES_Intv, + {$else} + AES_Intf, + {$endif} + {$else} + AES_Type, AES_Encr, AES_CCM, + {$endif} + mem_util; + + + +{---------------------------------------------------------------------------} +procedure Simple_Tests; + {-Two tests from RFC one from NIST} +const + key1: array[0..15] of byte = ($C0,$C1,$C2,$C3,$C4,$C5,$C6,$C7,$C8,$C9,$CA,$CB,$CC,$CD,$CE,$CF); + iv1 : array[0..12] of byte = ($00,$00,$00,$03,$02,$01,$00,$A0,$A1,$A2,$A3,$A4,$A5); + hdr1: array[0..07] of byte = ($00,$01,$02,$03,$04,$05,$06,$07); + pt1 : array[0..22] of byte = ($08,$09,$0A,$0B,$0C,$0D,$0E,$0F, + $10,$11,$12,$13,$14,$15,$16,$17, + $18,$19,$1A,$1B,$1C,$1D,$1E); + ct1 : array[0..22] of byte = ($58,$8C,$97,$9A,$61,$C6,$63,$D2, + $F0,$66,$D0,$C2,$C0,$F9,$89,$80, + $6D,$5F,$6B,$61,$DA,$C3,$84); + tag1: array[0..07] of byte = ($17,$e8,$d1,$2c,$fd,$f9,$26,$e0); + +const + key2: array[0..15] of byte = ($C0,$C1,$C2,$C3,$C4,$C5,$C6,$C7,$C8,$C9,$CA,$CB,$CC,$CD,$CE,$CF); + iv2 : array[0..12] of byte = ($00,$00,$00,$06,$05,$04,$03,$A0,$A1,$A2,$A3,$A4,$A5); + hdr2: array[0..11] of byte = ($00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0A,$0B); + pt2 : array[0..18] of byte = ($0C,$0D,$0E,$0F,$10,$11,$12,$13, + $14,$15,$16,$17,$18,$19,$1A,$1B, + $1C,$1D,$1E); + ct2 : array[0..18] of byte = ($A2,$8C,$68,$65,$93,$9A,$9A,$79, + $FA,$AA,$5C,$4C,$2A,$9D,$4A,$91, + $CD,$AC,$8C); + tag2: array[0..07] of byte = ($96,$C8,$61,$B9,$C9,$E6,$1E,$F1); + +const + key3: array[0..15] of byte = ($40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4a,$4b,$4c,$4d,$4e,$4f); + iv3 : array[0..06] of byte = ($10,$11,$12,$13,$14,$15,$16); + hdr3: array[0..07] of byte = ($00,$01,$02,$03,$04,$05,$06,$07); + pt3 : array[0..03] of byte = ($20,$21,$22,$23); + ct3 : array[0..03] of byte = ($71,$62,$01,$5b); + tag3: array[0..03] of byte = ($4d,$ac,$25,$5d); + + +var + ccm_ctx: TAESContext; + +var + tag: TAESBlock; + buf: array[0..63] of byte; + err: integer; +begin + + {-----------------------------------------------------------------} + writeln('Test 1: Ex functions'); + err := AES_Init_Encr(Key1, 8*sizeof(key1), ccm_ctx); + if err=0 then err := AES_CCM_Enc_AuthEx(ccm_ctx, tag, sizeof(tag1), + iv1, sizeof(iv1), @hdr1, sizeof(hdr1), + @pt1, sizeof(pt1), @buf); + if err<>0 then writeln('Err1: ', err) + else begin + writeln(' CT1: ', compmem(@buf, @ct1, sizeof(ct1))); + writeln('Tag1: ', compmem(@tag, @tag1, sizeof(tag1))); + end; + err := AES_CCM_Dec_VeriEx(ccm_ctx, @tag1, sizeof(tag1), + iv1, sizeof(iv1), @hdr1, sizeof(hdr1), + @ct1, sizeof(ct1), @buf); + if err<>0 then writeln('Err1: ', err) + else begin + writeln(' PT1: ', compmem(@buf, @pt1, sizeof(pt1))); + end; + + writeln('Test 1: simple functions'); + err := AES_CCM_Enc_Auth(tag, sizeof(tag1), key1, sizeof(key1), + iv1, sizeof(iv1), @hdr1, sizeof(hdr1), + @pt1, sizeof(pt1), @buf); + if err<>0 then writeln('Err1: ', err) + else begin + writeln(' CT1: ', compmem(@buf, @ct1, sizeof(ct1))); + writeln('Tag1: ', compmem(@tag, @tag1, sizeof(tag1))); + end; + err := AES_CCM_Dec_Veri(@tag1, sizeof(tag1), key1, sizeof(key1), + iv1, sizeof(iv1), @hdr1, sizeof(hdr1), + @ct1, sizeof(ct1), @buf); + if err<>0 then writeln('Err1: ', err) + else begin + writeln(' PT1: ', compmem(@buf, @pt1, sizeof(pt1))); + end; + + {-----------------------------------------------------------------} + writeln('Test 2: Ex functions'); + err := AES_Init_Encr(Key2, 8*sizeof(key2), ccm_ctx); + if err=0 then err := AES_CCM_Enc_AuthEx(ccm_ctx, tag, sizeof(tag2), + iv2, sizeof(iv2), @hdr2, sizeof(hdr2), + @pt2, sizeof(pt2), @buf); + if err<>0 then writeln('Err2: ', err) + else begin + writeln(' CT2: ', compmem(@buf, @ct2, sizeof(ct2))); + writeln('Tag2: ', compmem(@tag, @tag2, sizeof(tag2))); + end; + err := AES_CCM_Dec_VeriEx(ccm_ctx, @tag2, sizeof(tag2), + iv2, sizeof(iv2), @hdr2, sizeof(hdr2), + @ct2, sizeof(ct2), @buf); + if err<>0 then writeln('Err2: ', err) + else begin + writeln(' PT2: ', compmem(@buf, @pt2, sizeof(pt2))); + end; + + writeln('Test 2: simple functions'); + err := AES_CCM_Enc_Auth(tag, sizeof(tag2), key2, sizeof(key2), + iv2, sizeof(iv2), @hdr2, sizeof(hdr2), + @pt2, sizeof(pt2), @buf); + if err<>0 then writeln('Err2: ', err) + else begin + writeln(' CT2: ', compmem(@buf, @ct2, sizeof(ct2))); + writeln('Tag2: ', compmem(@tag, @tag2, sizeof(tag2))); + end; + err := AES_CCM_Dec_Veri(@tag2, sizeof(tag2), key2, sizeof(key2), + iv2, sizeof(iv2), @hdr2, sizeof(hdr2), + @ct2, sizeof(ct2), @buf); + if err<>0 then writeln('Err2: ', err) + else begin + writeln(' PT2: ', compmem(@buf, @pt2, sizeof(pt2))); + end; + + {-----------------------------------------------------------------} + writeln('Test 3: Ex functions'); + err := AES_Init_Encr(Key3, 8*sizeof(key3), ccm_ctx); + if err=0 then err := AES_CCM_Enc_AuthEx(ccm_ctx, tag, sizeof(tag3), + iv3, sizeof(iv3), @hdr3, sizeof(hdr3), + @pt3, sizeof(pt3), @buf); + if err<>0 then writeln('Err3: ', err) + else begin + writeln(' CT3: ', compmem(@buf, @ct3, sizeof(ct3))); + writeln('Tag3: ', compmem(@tag, @tag3, sizeof(tag3))); + end; + err := AES_CCM_Dec_VeriEx(ccm_ctx, @tag3, sizeof(tag3), + iv3, sizeof(iv3), @hdr3, sizeof(hdr3), + @ct3, sizeof(ct3), @buf); + if err<>0 then writeln('Err3: ', err) + else begin + writeln(' PT3: ', compmem(@buf, @pt3, sizeof(pt3))); + end; + + writeln('Test 3: simple functions'); + err := AES_CCM_Enc_Auth(tag, sizeof(tag3), key3, sizeof(key3), + iv3, sizeof(iv3), @hdr3, sizeof(hdr3), + @pt3, sizeof(pt3), @buf); + if err<>0 then writeln('Err3: ', err) + else begin + writeln(' CT3: ', compmem(@buf, @ct3, sizeof(ct3))); + writeln('Tag3: ', compmem(@tag, @tag3, sizeof(tag3))); + end; + err := AES_CCM_Dec_Veri(@tag3, sizeof(tag3), key3, sizeof(key3), + iv3, sizeof(iv3), @hdr3, sizeof(hdr3), + @ct3, sizeof(ct3), @buf); + if err<>0 then writeln('Err3: ', err) + else begin + writeln(' PT3: ', compmem(@buf, @pt3, sizeof(pt3))); + end; +end; + + +{---------------------------------------------------------------------------} +procedure LTC_Test(print: boolean); + {-reproduce LTC CCM-AES test vectors} +var + key, nonce, tag: TAESBlock; + buf: array[0..63] of byte; + i,k,err: integer; +const + final: TAESBlock = ($0f,$5a,$69,$f5,$2a,$a8,$d8,$50,$8d,$09,$e6,$42,$51,$1e,$54,$e5); +begin + writeln('LibTomCrypt CCM-AES test'); + HexUpper := true; + for i:=0 to 15 do key[i] := i and $FF; + nonce := key; + for k:=0 to 32 do begin + for i:=0 to k-1 do buf[i] := i and $FF; + err := AES_CCM_Enc_Auth(tag, sizeof(tag), key, sizeof(key), nonce, 13, @buf, k, @buf, k, @buf); + if err<>0 then begin + writeln('AES_CCM_Enc_Auth error code ',err, ' at k=',k); + exit; + end; + if print then writeln(k:2,': ',HexStr(@buf,k),', ',HexStr(@tag,sizeof(tag))); + key := tag; + end; + writeln('Final tag OK: ', compmem(@tag, @final, sizeof(final))); +end; + + +{---------------------------------------------------------------------------} +procedure RFC_Packets; + {-Check (non-random) CCM packets from RFC 3610} +type + ta25 = array[0..24] of byte; + ta10 = array[0..09] of byte; +const + ctest: array[1..12] of ta25 = ( + ($58,$8C,$97,$9A,$61,$C6,$63,$D2,$F0,$66,$D0,$C2,$C0,$F9,$89,$80,$6D,$5F,$6B,$61,$DA,$C3,$84,$00,$00), + ($72,$C9,$1A,$36,$E1,$35,$F8,$CF,$29,$1C,$A8,$94,$08,$5C,$87,$E3,$CC,$15,$C4,$39,$C9,$E4,$3A,$3B,$00), + ($51,$B1,$E5,$F4,$4A,$19,$7D,$1D,$A4,$6B,$0F,$8E,$2D,$28,$2A,$E8,$71,$E8,$38,$BB,$64,$DA,$85,$96,$57), + ($A2,$8C,$68,$65,$93,$9A,$9A,$79,$FA,$AA,$5C,$4C,$2A,$9D,$4A,$91,$CD,$AC,$8C,$00,$00,$00,$00,$00,$00), + ($DC,$F1,$FB,$7B,$5D,$9E,$23,$FB,$9D,$4E,$13,$12,$53,$65,$8A,$D8,$6E,$BD,$CA,$3E,$00,$00,$00,$00,$00), + ($6F,$C1,$B0,$11,$F0,$06,$56,$8B,$51,$71,$A4,$2D,$95,$3D,$46,$9B,$25,$70,$A4,$BD,$87,$00,$00,$00,$00), + ($01,$35,$D1,$B2,$C9,$5F,$41,$D5,$D1,$D4,$FE,$C1,$85,$D1,$66,$B8,$09,$4E,$99,$9D,$FE,$D9,$6C,$00,$00), + ($7B,$75,$39,$9A,$C0,$83,$1D,$D2,$F0,$BB,$D7,$58,$79,$A2,$FD,$8F,$6C,$AE,$6B,$6C,$D9,$B7,$DB,$24,$00), + ($82,$53,$1A,$60,$CC,$24,$94,$5A,$4B,$82,$79,$18,$1A,$B5,$C8,$4D,$F2,$1C,$E7,$F9,$B7,$3F,$42,$E1,$97), + ($07,$34,$25,$94,$15,$77,$85,$15,$2B,$07,$40,$98,$33,$0A,$BB,$14,$1B,$94,$7B,$00,$00,$00,$00,$00,$00), + ($67,$6B,$B2,$03,$80,$B0,$E3,$01,$E8,$AB,$79,$59,$0A,$39,$6D,$A7,$8B,$83,$49,$34,$00,$00,$00,$00,$00), + ($C0,$FF,$A0,$D6,$F0,$5B,$DB,$67,$F2,$4D,$43,$A4,$33,$8D,$2A,$A4,$BE,$D7,$B2,$0E,$43,$00,$00,$00,$00)); + ttest: array[1..12] of ta10 = ( + ($17,$E8,$D1,$2C,$FD,$F9,$26,$E0,$00,$00), + ($A0,$91,$D5,$6E,$10,$40,$09,$16,$00,$00), + ($4A,$DA,$A7,$6F,$BD,$9F,$B0,$C5,$00,$00), + ($96,$C8,$61,$B9,$C9,$E6,$1E,$F1,$00,$00), + ($51,$E8,$3F,$07,$7D,$9C,$2D,$93,$00,$00), + ($40,$5A,$04,$43,$AC,$91,$CB,$94,$00,$00), + ($04,$8C,$56,$60,$2C,$97,$AC,$BB,$74,$90), + ($C1,$7B,$44,$33,$F4,$34,$96,$3F,$34,$B4), + ($EA,$9C,$07,$E5,$6B,$5E,$B1,$7E,$5F,$4E), + ($56,$6A,$A9,$40,$6B,$4D,$99,$99,$88,$DD), + ($F5,$3A,$A2,$E9,$10,$7A,$8B,$6C,$02,$2C), + ($CD,$1A,$A3,$16,$62,$E7,$AD,$65,$D6,$DB)); +var + pn: integer; + key, nonce, tag, hdr: TAESBlock; + buf: array[0..63] of byte; + i,ih,it,k,err: integer; + plen,tlen,hlen: word; + x: longint; + b: byte; +begin + writeln('Test packet vectors 1 .. 12 from RFC 3610'); + nonce[00] := 0; + nonce[01] := 0; + nonce[02] := 0; + nonce[07] := $A0; + nonce[08] := $A1; + nonce[09] := $A2; + nonce[10] := $A3; + nonce[11] := $A4; + nonce[12] := $A5; + pn := 0; + for i:=0 to 15 do key[i] := $C0+i; + for it:=0 to 1 do begin + tlen := 8 + 2*it; + for ih:=0 to 1 do begin + hlen := 8 + 4*ih; + for k := 31 to 33 do begin + pLen := k-hlen; + x := pn*$01010101+$03020100; + inc(pn); + nonce[03] := (x shr 24) and $ff; + nonce[04] := (x shr 16) and $ff; + nonce[05] := (x shr 08) and $ff; + nonce[06] := x and $ff; + b := 0; + for i:=0 to pred(hlen) do begin + hdr[i] := b; + inc(b); + end; + for i:=0 to pred(pLen) do begin + buf[i] := b; + inc(b); + end; + err := AES_CCM_Enc_Auth(tag,tlen,key,16,nonce,13,@hdr,hlen,@buf,plen,@buf); + write('Packet ',pn:2); + if err<>0 then writeln(': AES_CCM_Enc_Auth error code ',err) + else begin + writeln(': CT ',compmem(@buf,@ctest[pn],plen), ', Tag ',compmem(@tag,@ttest[pn],tlen)); + err := AES_CCM_Dec_Veri(@tag,tlen,key,16,nonce,13,@hdr,hlen,@ctest[pn],plen,@buf); + if err<>0 then writeln(' - AES_CCM_Dec_Veri error code ',err); + end; + end; + end; + end; +end; + +begin + writeln('Test program AES-CCM mode (c) 2009 W.Ehrhardt'); + {$ifdef USEDLL} + writeln('DLL Version: ',AES_DLL_Version); + {$endif} + Simple_Tests; + RFC_Packets; + writeln; + LTC_Test(false); +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aescf8.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aescf8.pas new file mode 100644 index 00000000..00538b44 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aescf8.pas @@ -0,0 +1,198 @@ +{-Test prog for AES CFB8, we Dec.2007} + +program T_AESCF8; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_type, aes_cfb8, mem_util, BTypes; + + +var + Context: TAESContext; + Err : integer; + +{---------------------------------------------------------------------------} +procedure CheckError; +begin + if Err<>0 then writeln('Error ',Err); +end; + +{---------------------------------------------------------------------------} +procedure SimpleTests; + {-Simple encrypt/decrypt test for AES-CFB8 mode} +const + Key128 : array[0..15] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f); + Key192 : array[0..23] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17); + Key256 : array[0..31] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17, + $18, $19, $1a, $1b, $1c, $1d, $1e, $1f); + +const + sample = 'This is a short test sample text for AES CFB8 mode'#0; + +var + i : integer; + IV : TAESBlock; + ct, pt, plain: array[1..length(sample)] of char8; + + procedure CheckRes; + begin + writeln('Decr(Encr)=Id : ',CompMem(@pt, @plain, sizeof(plain))); + end; + +begin + for i:=0 to 15 do IV[i] := random(256); + plain := sample; + + writeln; + writeln('============================================'); + writeln('Simple encrypt/decrypt test for AES-CFB8 mode'); + writeln('Org. plain text: ', plain); + writeln; + + writeln('++++ 128 bit key ++++'); + pt := plain; + Err := AES_CFB8_Init(key128, 128, IV, context); + Err := AES_CFB8_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CFB8_Init(key128, 128, IV, context); + Err := AES_CFB8_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + + Err := AES_CFB8_Init(key128, 128, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CFB8_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; + + writeln; + writeln('++++ 192 bit key ++++'); + pt := plain; + Err := AES_CFB8_Init(key192, 192, IV, context); + Err := AES_CFB8_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CFB8_Init(key192, 192, IV, context); + Err := AES_CFB8_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_CFB8_Init(key192, 192, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CFB8_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; + + writeln; + writeln('++++ 256 bit key ++++'); + pt := plain; + Err := AES_CFB8_Init(key256, 256, IV, context); + Err := AES_CFB8_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CFB8_Init(key256, 256, IV, context); + Err := AES_CFB8_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_CFB8_Init(key256, 256, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CFB8_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; +end; + + + +{---------------------------------------------------------------------------} +procedure NistTests; + {-NIST SP 800-38A CFB8/AES Tests} +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + key192 : array[0..23] of byte = ($8e,$73,$b0,$f7,$da,$0e,$64,$52, + $c8,$10,$f3,$2b,$80,$90,$79,$e5, + $62,$f8,$ea,$d2,$52,$2c,$6b,$7b); + + key256 : array[0..31] of byte = ($60,$3d,$eb,$10,$15,$ca,$71,$be, + $2b,$73,$ae,$f0,$85,$7d,$77,$81, + $1f,$35,$2c,$07,$3b,$61,$08,$d7, + $2d,$98,$10,$a3,$09,$14,$df,$f4); + + IV : TAESBlock = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f); + + plain : array[0..17] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d); + + ct1 : array[0..17] of byte = ($3b,$79,$42,$4c,$9c,$0d,$d4,$36, + $ba,$ce,$9e,$0e,$d4,$58,$6a,$4f, + $32,$b9); + + ct2 : array[0..17] of byte = ($cd,$a2,$52,$1e,$f0,$a9,$05,$ca, + $44,$cd,$05,$7c,$bf,$0d,$47,$a0, + $67,$8a); + + ct3 : array[0..17] of byte = ($dc,$1f,$1a,$85,$20,$a6,$4d,$b5, + $5f,$cc,$8a,$c5,$54,$84,$4e,$88, + $97,$00); + +var + ct: array[0..255] of byte; +begin + writeln; + writeln('============================='); + writeln('NIST SP 800-38A CFB8/AES tests'); + Err := AES_CFB8_Init(key128, 128, IV, context); + Err := AES_CFB8_Encrypt(@plain, @ct, sizeof(plain), context); + writeln('Test F.3.7 CFB8-AES128.Encrypt - OK: ',CompMem(@ct1, @ct, sizeof(ct1))); + + Err := AES_CFB8_Init(key128, 128, IV, context); + Err := AES_CFB8_Decrypt(@ct1, @ct, sizeof(ct1), context); + writeln('Test F.3.8 CFB8-AES128.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_CFB8_Init(key192, 192, IV, context); + Err := AES_CFB8_Encrypt(@plain, @ct, sizeof(plain), context); + writeln('Test F.3.9 CFB8-AES192.Encrypt - OK: ',CompMem(@ct2, @ct, sizeof(ct2))); + + Err := AES_CFB8_Init(key192, 192, IV, context); + Err := AES_CFB8_Decrypt(@ct2, @ct, sizeof(ct3), context); + writeln('Test F.3.10 CFB8-AES192.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_CFB8_Init(key256, 256, IV, context); + Err := AES_CFB8_Encrypt(@plain, @ct, sizeof(plain), context); + writeln('Test F.3.11 CFB8-AES256.Encrypt - OK: ',CompMem(@ct3, @ct, sizeof(ct3))); + + Err := AES_CFB8_Init(key256, 256, IV, context); + Err := AES_CFB8_Decrypt(@ct3, @ct, sizeof(ct3), context); + writeln('Test F.3.12 CFB8-AES256.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + +end; + +begin + SimpleTests; + NistTests; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aescfb.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aescfb.pas new file mode 100644 index 00000000..cc367ad3 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aescfb.pas @@ -0,0 +1,217 @@ +{-Test prog for AES CFB, we Sep.2003} + +program T_AESCFB; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_type, aes_cfb, mem_util, BTypes; + + +var + Context: TAESContext; + Err : integer; + +{---------------------------------------------------------------------------} +procedure CheckError; +begin + if Err<>0 then writeln('Error ',Err); +end; + +{---------------------------------------------------------------------------} +procedure SimpleTests; + {-Simple encrypt/decrypt test for AES-CFB mode} +const + Key128 : array[0..15] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f); + Key192 : array[0..23] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17); + Key256 : array[0..31] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17, + $18, $19, $1a, $1b, $1c, $1d, $1e, $1f); + +const + sample = 'This is a short test sample text for AES CFB mode'#0; + +var + i : integer; + IV : TAESBlock; + ct, pt, plain: array[1..length(sample)] of char8; + + procedure CheckRes; + begin + writeln('Decr(Encr)=Id : ',CompMem(@pt, @plain, sizeof(plain))); + end; + +begin + for i:=0 to 15 do IV[i] := random(256); + plain := sample; + + writeln; + writeln('============================================'); + writeln('Simple encrypt/decrypt test for AES-CFB mode'); + writeln('Org. plain text: ', plain); + writeln; + + writeln('++++ 128 bit key ++++'); + pt := plain; + Err := AES_CFB_Init(key128, 128, IV, context); + Err := AES_CFB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CFB_Init(key128, 128, IV, context); + Err := AES_CFB_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + + Err := AES_CFB_Init(key128, 128, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CFB_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; + + writeln; + writeln('++++ 192 bit key ++++'); + pt := plain; + Err := AES_CFB_Init(key192, 192, IV, context); + Err := AES_CFB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CFB_Init(key192, 192, IV, context); + Err := AES_CFB_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_CFB_Init(key192, 192, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CFB_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; + + writeln; + writeln('++++ 256 bit key ++++'); + pt := plain; + Err := AES_CFB_Init(key256, 256, IV, context); + Err := AES_CFB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CFB_Init(key256, 256, IV, context); + Err := AES_CFB_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_CFB_Init(key256, 256, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CFB_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; +end; + + +{---------------------------------------------------------------------------} +procedure NistTests; + {-NIST SP 800-38A CFB/AES Tests} +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + key192 : array[0..23] of byte = ($8e,$73,$b0,$f7,$da,$0e,$64,$52, + $c8,$10,$f3,$2b,$80,$90,$79,$e5, + $62,$f8,$ea,$d2,$52,$2c,$6b,$7b); + + key256 : array[0..31] of byte = ($60,$3d,$eb,$10,$15,$ca,$71,$be, + $2b,$73,$ae,$f0,$85,$7d,$77,$81, + $1f,$35,$2c,$07,$3b,$61,$08,$d7, + $2d,$98,$10,$a3,$09,$14,$df,$f4); + + IV : TAESBlock = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f); + + plain : array[0..63] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d,$8a,$57,$1e,$03,$ac,$9c, + $9e,$b7,$6f,$ac,$45,$af,$8e,$51, + $30,$c8,$1c,$46,$a3,$5c,$e4,$11, + $e5,$fb,$c1,$19,$1a,$0a,$52,$ef, + $f6,$9f,$24,$45,$df,$4f,$9b,$17, + $ad,$2b,$41,$7b,$e6,$6c,$37,$10); + + ct1 : array[0..63] of byte = ($3b,$3f,$d9,$2e,$b7,$2d,$ad,$20, + $33,$34,$49,$f8,$e8,$3c,$fb,$4a, + $c8,$a6,$45,$37,$a0,$b3,$a9,$3f, + $cd,$e3,$cd,$ad,$9f,$1c,$e5,$8b, + $26,$75,$1f,$67,$a3,$cb,$b1,$40, + $b1,$80,$8c,$f1,$87,$a4,$f4,$df, + $c0,$4b,$05,$35,$7c,$5d,$1c,$0e, + $ea,$c4,$c6,$6f,$9f,$f7,$f2,$e6); + + ct2 : array[0..63] of byte = ($cd,$c8,$0d,$6f,$dd,$f1,$8c,$ab, + $34,$c2,$59,$09,$c9,$9a,$41,$74, + $67,$ce,$7f,$7f,$81,$17,$36,$21, + $96,$1a,$2b,$70,$17,$1d,$3d,$7a, + $2e,$1e,$8a,$1d,$d5,$9b,$88,$b1, + $c8,$e6,$0f,$ed,$1e,$fa,$c4,$c9, + $c0,$5f,$9f,$9c,$a9,$83,$4f,$a0, + $42,$ae,$8f,$ba,$58,$4b,$09,$ff); + + ct3 : array[0..63] of byte = ($dc,$7e,$84,$bf,$da,$79,$16,$4b, + $7e,$cd,$84,$86,$98,$5d,$38,$60, + $39,$ff,$ed,$14,$3b,$28,$b1,$c8, + $32,$11,$3c,$63,$31,$e5,$40,$7b, + $df,$10,$13,$24,$15,$e5,$4b,$92, + $a1,$3e,$d0,$a8,$26,$7a,$e2,$f9, + $75,$a3,$85,$74,$1a,$b9,$ce,$f8, + $20,$31,$62,$3d,$55,$b1,$e4,$71); + +var + ct: array[0..255] of byte; +begin + writeln; + writeln('============================='); + writeln('NIST SP 800-38A CFB/AES tests'); + Err := AES_CFB_Init(key128, 128, IV, context); + Err := AES_CFB_Encrypt(@plain, @ct, sizeof(plain), context); + writeln('Test F.3.13 CFB128-AES128.Encrypt - OK: ',CompMem(@ct1, @ct, sizeof(ct1))); + + Err := AES_CFB_Init(key128, 128, IV, context); + Err := AES_CFB_Decrypt(@ct1, @ct, sizeof(ct1), context); + writeln('Test F.3.14 CFB128-AES128.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_CFB_Init(key192, 192, IV, context); + Err := AES_CFB_Encrypt(@plain, @ct, sizeof(plain), context); + writeln('Test F.3.15 CFB128-AES192.Encrypt - OK: ',CompMem(@ct2, @ct, sizeof(ct2))); + + Err := AES_CFB_Init(key192, 192, IV, context); + Err := AES_CFB_Decrypt(@ct2, @ct, sizeof(ct3), context); + writeln('Test F.3.16 CFB128-AES192.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_CFB_Init(key256, 256, IV, context); + Err := AES_CFB_Encrypt(@plain, @ct, sizeof(plain), context); + writeln('Test F.3.17 CFB128-AES256.Encrypt - OK: ',CompMem(@ct3, @ct, sizeof(ct3))); + + Err := AES_CFB_Init(key256, 256, IV, context); + Err := AES_CFB_Decrypt(@ct3, @ct, sizeof(ct3), context); + writeln('Test F.3.18 CFB128-AES256.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + +end; + +begin + SimpleTests; + NistTests; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aescrp.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aescrp.pas new file mode 100644 index 00000000..9ace2c82 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aescrp.pas @@ -0,0 +1,100 @@ +{-Test prog for AES encrypt/decrypt, we 2003} + +program T_AESCRP; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_type, aes_encr, aes_decr, mem_util; + +var + Context: TAESContext; + + +const + Plain: TAESBlock = ($0, $1, $2, $3, $4, $5, $6, $7, $8, $9, $a, $b, $c, $d, $e, $f); + Key128 : array[0..15] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f); + Key192 : array[0..23] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17); + Key256 : array[0..31] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17, + $18, $19, $1a, $1b, $1c, $1d, $1e, $1f); + + CT128 : TAESBlock = ($0A, $94, $0B, $B5, $41, $6E, $F0, $45, $F1, $C3, $94, $58, $C6, $53, $EA, $5A); + CT192 : TAESBlock = ($00, $60, $BF, $FE, $46, $83, $4B, $B8, $DA, $5C, $F9, $A6, $1F, $F2, $20, $AE); + CT256 : TAESBlock = ($5A, $6E, $04, $57, $08, $FB, $71, $96, $F0, $2E, $55, $3D, $02, $C3, $A6, $92); + +var + Err : integer; + OK : boolean; + +{---------------------------------------------------------------------------} +procedure CheckError; +begin + if Err<>0 then writeln('Error ',Err); +end; + +{---------------------------------------------------------------------------} +procedure DoTests; +var + Block: TAESBlock; {16 Bit: dorce Block in stack for debugging} +begin + writeln('------------------------------------'); + + Err := AES_Init_Encr(Key128, 8*sizeof(Key128), Context); + CheckError; + writeln('Plaintext : ', HexStr(@Plain, sizeof(Plain))); + + writeln; + writeln('Key : ', HexStr(@key128, sizeof(key128))); + AES_Encrypt(Context, Plain, Block); + OK := CompMem(@CT128, @Block, sizeof(Block)); + writeln('Encrypted : ', HexStr(@Block, sizeof(Block)), OK:8); + + Err := AES_Init_Decr(Key128, 8*sizeof(Key128), Context); + CheckError; + AES_Decrypt(Context, Block, Block); + OK := CompMem(@Plain, @Block, sizeof(Block)); + writeln('Decrypted : ', HexStr(@Block, sizeof(Block)), OK:8); + + writeln; + Err := AES_Init_Encr(Key192, 8*sizeof(Key192), Context); + CheckError; + writeln('Key : ', HexStr(@key192, sizeof(key192))); + AES_Encrypt(Context, Plain, Block); + OK := CompMem(@CT192, @Block, sizeof(Block)); + writeln('Encrypted : ', HexStr(@Block, sizeof(Block)), OK:8); + Err := AES_Init_Decr(Key192, 8*sizeof(Key192), Context); + CheckError; + AES_Decrypt(Context, Block, Block); + OK := CompMem(@Plain, @Block, sizeof(Block)); + writeln('Decrypted : ', HexStr(@Block, sizeof(Block)), OK:8); + + writeln; + Err := AES_Init_Encr(Key256, 8*sizeof(Key256), Context); + CheckError; + writeln('Key : ', HexStr(@key256, sizeof(key256))); + AES_Encrypt(Context, Plain, Block); + OK := CompMem(@CT256, @Block, sizeof(Block)); + writeln('Encrypted : ', HexStr(@Block, sizeof(Block)), OK:8); + Err := AES_Init_Decr(Key256, 8*sizeof(Key256), Context); + CheckError; + AES_Decrypt(Context, Block, Block); + OK := CompMem(@Plain, @Block, sizeof(Block)); + writeln('Decrypted : ', HexStr(@Block, sizeof(Block)), OK:8); +end; + + +begin + DoTests; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aesctr.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aesctr.pas new file mode 100644 index 00000000..c4a4a734 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aesctr.pas @@ -0,0 +1,224 @@ +{-Test prog for AES CTR, we Sep.2003} + +program T_AESCTR; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_type, aes_ctr, mem_util, BTypes; + +var + Context: TAESContext; + Err : integer; + +{---------------------------------------------------------------------------} +procedure CheckError; +begin + if Err<>0 then writeln('Error ',Err); +end; + +{---------------------------------------------------------------------------} +procedure SimpleTests; + {-Simple encrypt/decrypt test for AES-CTR mode} +const + Key128 : array[0..15] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f); + Key192 : array[0..23] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17); + Key256 : array[0..31] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17, + $18, $19, $1a, $1b, $1c, $1d, $1e, $1f); + +const + sample = 'This is a short test sample text for AES CTR mode'#0; + +var + IV : TAESBlock; + i : integer; + ct, pt, plain: array[1..length(sample)] of char8; + + procedure CheckRes; + begin + writeln('Decr(Encr)=Id : ',CompMem(@pt, @plain, sizeof(plain))); + end; + +begin + for i:=0 to 15 do IV[i] := random(256); + plain := sample; + + writeln; + writeln('============================================'); + writeln('Simple encrypt/decrypt test for AES-CTR mode'); + writeln('Org. plain text: ', plain); + writeln; + writeln('++++ 128 bit key ++++'); + pt := plain; + Err := AES_CTR_Init(key128, 128, IV, context); + Err := AES_CTR_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CTR_Init(key128, 128, IV, context); + Err := AES_CTR_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_CTR_Init(key128, 128, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CTR_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; + + writeln; + writeln('++++ 192 bit key ++++'); + pt := plain; + Err := AES_CTR_Init(key192, 192, IV, context); + Err := AES_CTR_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CTR_Init(key192, 192, IV, context); + Err := AES_CTR_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_CTR_Init(key192, 192, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CTR_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; + + writeln; + writeln('++++ 256 bit key ++++'); + pt := plain; + Err := AES_CTR_Init(key256, 256, IV, context); + Err := AES_CTR_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_CTR_Init(key256, 256, IV, context); + Err := AES_CTR_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_CTR_Init(key256, 256, IV, context); + for i:=1 to sizeof(plain) do begin + if Err=0 then Err := AES_CTR_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + CheckRes; +end; + + +{---------------------------------------------------------------------------} +procedure NistTests; + {-NIST SP 800-38A CTR/AES Tests} +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + key192 : array[0..23] of byte = ($8e,$73,$b0,$f7,$da,$0e,$64,$52, + $c8,$10,$f3,$2b,$80,$90,$79,$e5, + $62,$f8,$ea,$d2,$52,$2c,$6b,$7b); + + key256 : array[0..31] of byte = ($60,$3d,$eb,$10,$15,$ca,$71,$be, + $2b,$73,$ae,$f0,$85,$7d,$77,$81, + $1f,$35,$2c,$07,$3b,$61,$08,$d7, + $2d,$98,$10,$a3,$09,$14,$df,$f4); + + CTR : TAESBlock = ($f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7, + $f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff); + + plain : array[0..63] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d,$8a,$57,$1e,$03,$ac,$9c, + $9e,$b7,$6f,$ac,$45,$af,$8e,$51, + $30,$c8,$1c,$46,$a3,$5c,$e4,$11, + $e5,$fb,$c1,$19,$1a,$0a,$52,$ef, + $f6,$9f,$24,$45,$df,$4f,$9b,$17, + $ad,$2b,$41,$7b,$e6,$6c,$37,$10); + + ct1 : array[0..63] of byte = ($87,$4d,$61,$91,$b6,$20,$e3,$26, + $1b,$ef,$68,$64,$99,$0d,$b6,$ce, + $98,$06,$f6,$6b,$79,$70,$fd,$ff, + $86,$17,$18,$7b,$b9,$ff,$fd,$ff, + $5a,$e4,$df,$3e,$db,$d5,$d3,$5e, + $5b,$4f,$09,$02,$0d,$b0,$3e,$ab, + $1e,$03,$1d,$da,$2f,$be,$03,$d1, + $79,$21,$70,$a0,$f3,$00,$9c,$ee); + + + + ct2 : array[0..63] of byte = ($1a,$bc,$93,$24,$17,$52,$1c,$a2, + $4f,$2b,$04,$59,$fe,$7e,$6e,$0b, + $09,$03,$39,$ec,$0a,$a6,$fa,$ef, + $d5,$cc,$c2,$c6,$f4,$ce,$8e,$94, + $1e,$36,$b2,$6b,$d1,$eb,$c6,$70, + $d1,$bd,$1d,$66,$56,$20,$ab,$f7, + $4f,$78,$a7,$f6,$d2,$98,$09,$58, + $5a,$97,$da,$ec,$58,$c6,$b0,$50); + + + + ct3 : array[0..63] of byte = ($60,$1e,$c3,$13,$77,$57,$89,$a5, + $b7,$a7,$f5,$04,$bb,$f3,$d2,$28, + $f4,$43,$e3,$ca,$4d,$62,$b5,$9a, + $ca,$84,$e9,$90,$ca,$ca,$f5,$c5, + $2b,$09,$30,$da,$a2,$3d,$e9,$4c, + $e8,$70,$17,$ba,$2d,$84,$98,$8d, + $df,$c9,$c5,$8d,$b6,$7a,$ad,$a6, + $13,$c2,$dd,$08,$45,$79,$41,$a6); + +var + ct: array[0..255] of byte; +begin + writeln; + writeln('============================='); + writeln('NIST SP 800-38A CTR/AES tests'); + + Err := AES_CTR_Init(key128, 128, CTR, context); + Err := AES_CTR_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.5.1 CTR-AES128.Encrypt - OK: ',CompMem(@ct1, @ct, sizeof(ct1))); + + Err := AES_CTR_Init(key128, 128, CTR, context); + Err := AES_CTR_Decrypt(@ct1, @ct, sizeof(ct1), context); + CheckError; + writeln('Test F.5.2 CTR-AES128.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_CTR_Init(key192, 192, CTR, context); + Err := AES_CTR_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.5.3 CTR-AES192.Encrypt - OK: ',CompMem(@ct2, @ct, sizeof(ct2))); + + Err := AES_CTR_Init(key192, 192, CTR, context); + Err := AES_CTR_Decrypt(@ct2, @ct, sizeof(ct3), context); + CheckError; + writeln('Test F.5.4 CTR-AES192.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_CTR_Init(key256, 256, CTR, context); + Err := AES_CTR_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.5.5 CTR-AES256.Encrypt - OK: ',CompMem(@ct3, @ct, sizeof(ct3))); + + Err := AES_CTR_Init(key256, 256, CTR, context); + Err := AES_CTR_Decrypt(@ct3, @ct, sizeof(ct3), context); + CheckError; + writeln('Test F.5.6 CTR-AES256.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); +end; + +begin + SimpleTests; + NistTests; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aesecb.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aesecb.pas new file mode 100644 index 00000000..6f99d0ff --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aesecb.pas @@ -0,0 +1,212 @@ +{-Test prog for AES ECB, we Sep.2003} + +program T_AESECB; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_type, aes_ecb, mem_util, BTypes; + +var + Context: TAESContext; + Err: integer; + + +{---------------------------------------------------------------------------} +procedure CheckError; +begin + if Err<>0 then writeln('Error ',Err); +end; + + +{---------------------------------------------------------------------------} +procedure SimpleTests; + {-Simple encrypt/decrypt test for AES-ECB mode} +const + Key128 : array[0..15] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f); + Key192 : array[0..23] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17); + Key256 : array[0..31] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17, + $18, $19, $1a, $1b, $1c, $1d, $1e, $1f); + +const + sample = 'This is a short test sample for AES ECB mode'#0; + +var + ct, pt, plain: array[1..length(sample)] of char8; + + procedure CheckRes; + begin + writeln('Test Dec(Enc)=Id: ',CompMem(@pt, @plain, sizeof(plain))); + end; + + +begin + plain := sample; + writeln; + writeln('============================================'); + writeln('Simple encrypt/decrypt test for AES-ECB mode'); + writeln('Plain text: ', plain); + writeln; + + writeln('++++ 128 bit key ++++'); + pt := plain; + Err := AES_ECB_Init_Encr(key128, 128, context); + Err := AES_ECB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + Err := AES_ECB_Init_Decr(key128, 128, context); + Err := AES_ECB_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/Dec @pt<>@ct: ', pt); + CheckRes; + pt := ct; + Err := AES_ECB_Init_Decr(key128, 128, context); + Err := AES_ECB_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/dec inplace : ', pt); + CheckRes; + + writeln; + writeln('++++ 192 bit key ++++'); + pt := plain; + Err := AES_ECB_Init_Encr(key192, 192, context); + Err := AES_ECB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + Err := AES_ECB_Init_Decr(key192, 192, context); + Err := AES_ECB_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/Dec @pt<>@ct: ', pt); + CheckRes; + pt := ct; + Err := AES_ECB_Init_Decr(key192, 192, context); + Err := AES_ECB_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/dec inplace : ', pt); + CheckRes; + + writeln; + writeln('++++ 256 bit key ++++'); + pt := plain; + Err := AES_ECB_Init_Encr(key256, 256, context); + Err := AES_ECB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + Err := AES_ECB_Init_Decr(key256, 256, context); + Err := AES_ECB_Decrypt(@ct, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/Dec @pt<>@ct: ', pt); + CheckRes; + pt := ct; + Err := AES_ECB_Init_Decr(key256, 256, context); + Err := AES_ECB_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Enc/dec inplace : ', pt); + CheckRes; +end; + + +{---------------------------------------------------------------------------} +procedure NistTests; + {-NIST SP 800-38A ECB/AES Tests} +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + key192 : array[0..23] of byte = ($8e,$73,$b0,$f7,$da,$0e,$64,$52, + $c8,$10,$f3,$2b,$80,$90,$79,$e5, + $62,$f8,$ea,$d2,$52,$2c,$6b,$7b); + + key256 : array[0..31] of byte = ($60,$3d,$eb,$10,$15,$ca,$71,$be, + $2b,$73,$ae,$f0,$85,$7d,$77,$81, + $1f,$35,$2c,$07,$3b,$61,$08,$d7, + $2d,$98,$10,$a3,$09,$14,$df,$f4); + + plain : array[0..63] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d,$8a,$57,$1e,$03,$ac,$9c, + $9e,$b7,$6f,$ac,$45,$af,$8e,$51, + $30,$c8,$1c,$46,$a3,$5c,$e4,$11, + $e5,$fb,$c1,$19,$1a,$0a,$52,$ef, + $f6,$9f,$24,$45,$df,$4f,$9b,$17, + $ad,$2b,$41,$7b,$e6,$6c,$37,$10); + + ct1 : array[0..63] of byte = ($3a,$d7,$7b,$b4,$0d,$7a,$36,$60, + $a8,$9e,$ca,$f3,$24,$66,$ef,$97, + $f5,$d3,$d5,$85,$03,$b9,$69,$9d, + $e7,$85,$89,$5a,$96,$fd,$ba,$af, + $43,$b1,$cd,$7f,$59,$8e,$ce,$23, + $88,$1b,$00,$e3,$ed,$03,$06,$88, + $7b,$0c,$78,$5e,$27,$e8,$ad,$3f, + $82,$23,$20,$71,$04,$72,$5d,$d4); + + ct2 : array[0..63] of byte = ($bd,$33,$4f,$1d,$6e,$45,$f2,$5f, + $f7,$12,$a2,$14,$57,$1f,$a5,$cc, + $97,$41,$04,$84,$6d,$0a,$d3,$ad, + $77,$34,$ec,$b3,$ec,$ee,$4e,$ef, + $ef,$7a,$fd,$22,$70,$e2,$e6,$0a, + $dc,$e0,$ba,$2f,$ac,$e6,$44,$4e, + $9a,$4b,$41,$ba,$73,$8d,$6c,$72, + $fb,$16,$69,$16,$03,$c1,$8e,$0e); + + ct3 : array[0..63] of byte = ($f3,$ee,$d1,$bd,$b5,$d2,$a0,$3c, + $06,$4b,$5a,$7e,$3d,$b1,$81,$f8, + $59,$1c,$cb,$10,$d4,$10,$ed,$26, + $dc,$5b,$a7,$4a,$31,$36,$28,$70, + $b6,$ed,$21,$b9,$9c,$a6,$f4,$f9, + $f1,$53,$e7,$b1,$be,$af,$ed,$1d, + $23,$30,$4b,$7a,$39,$f9,$f3,$ff, + $06,$7d,$8d,$8f,$9e,$24,$ec,$c7); + + +var + ct: array[0..255] of byte; +begin + writeln; + writeln('============================='); + writeln('NIST SP 800-38A ECB/AES tests'); + Err := AES_ECB_Init_Encr(key128, 128, context); + Err := AES_ECB_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.1.1 ECB-AES128.Encrypt - OK: ',CompMem(@ct1, @ct, sizeof(ct1))); + + Err := AES_ECB_Init_Decr(key128, 128, context); + Err := AES_ECB_Decrypt(@ct{1}, @ct, sizeof(ct1), context); + CheckError; + writeln('Test F.1.2 ECB-AES128.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_ECB_Init_Encr(key192, 192, context); + Err := AES_ECB_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.1.3 ECB-AES192.Encrypt - OK: ',CompMem(@ct2, @ct, sizeof(ct2))); + + Err := AES_ECB_Init_Decr(key192, 192, context); + Err := AES_ECB_Decrypt(@ct{2}, @ct, sizeof(ct3), context); + CheckError; + writeln('Test F.1.4 ECB-AES192.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_ECB_Init_Encr(key256, 256, context); + Err := AES_ECB_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.1.5 ECB-AES256.Encrypt - OK: ',CompMem(@ct3, @ct, sizeof(ct3))); + + Err := AES_ECB_Init_Decr(key256, 256, context); + Err := AES_ECB_Decrypt(@ct{3}, @ct, sizeof(ct3), context); + CheckError; + writeln('Test F.1.6 ECB-AES256.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + +end; + +begin + SimpleTests; + NistTests; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aesgcm.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aesgcm.pas new file mode 100644 index 00000000..3cec0b3b --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aesgcm.pas @@ -0,0 +1,957 @@ +{-Test prog for AES_GCM, we 09.2010} + +program T_AESGCM; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +{$ifdef BIT16} +{$N+} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + BTypes, + {$ifdef USEDLL} + {$ifdef VirtualPascal} + AES_Intv, + {$else} + AES_Intf, + {$endif} + {$else} + AES_Type, AES_Base, AES_GCM, + {$endif} + Mem_Util; + +var + tag : TAESBlock; + ctx : TAES_GCMContext; + err : integer; + pt : array[0..511] of byte; + ct : array[0..511] of byte; + fail: longint; + +const + print: boolean = false; + + +{---------------------------------------------------------------------------} +procedure single_test( ptag: pointer; tLen: word; {Tag: address / length (0..16)} + {$ifdef CONST}const{$else}var{$endif} Key; KBits: word; {key and bitlength of key} + pIV: pointer; IV_len: word; {IV: address / length} + pAAD: pointer; aLen: word; {AAD: address / length} + ctp: pointer; cLen: longint; {ciphertext: address / length} + ptp: pointer; tn: integer); {plaintext: address} +var + lf: integer; + sn: string[10]; +begin + str(tn:3,sn); + sn := 'TV '+sn+': '; + lf := 0; + + {-------------------------------------------------------------------------} + fillchar(pt,sizeof(pt),0); + fillchar(ct,sizeof(ct),0); + err := AES_GCM_Dec_Veri(ptag,tLen,Key,KBits,pIV,IV_Len,pAAD,aLen,ctp,cLen,@pt,ctx); + if err<>0 then begin + inc(lf); + writeln(sn,'AES_GCM_Dec_Veri error: ',err); + end + else begin + if not compmem(@pt, ptp, cLen) then begin + writeln(sn,'AES_GCM_Dec_Veri - plaintext does not match'); + inc(lf); + end; + end; + + {-------------------------------------------------------------------------} + fillchar(pt,sizeof(pt),0); + fillchar(ct,sizeof(ct),0); + err := AES_GCM_Enc_Auth(tag,Key,KBits,pIV,IV_Len,pAAD,aLen,ptp,cLen,@ct,ctx); + if err<>0 then begin + inc(lf); + writeln(sn,'AES_GCM_Enc_Auth error: ',err); + end + else begin + if not compmem(@tag, ptag, tLen) then begin + writeln(sn,'AES_GCM_Enc_Auth - Tag does not match'); + inc(lf); + end; + if not compmem(@ct, ctp, cLen) then begin + writeln(sn,'AES_GCM_Enc_Auth - Ciphertext does not match'); + inc(lf); + end; + end; + + {-------------------------------------------------------------------------} + fillchar(pt,sizeof(pt),0); + fillchar(ct,sizeof(ct),0); + err := AES_GCM_Init(Key, KBits, ctx); + + if err<>0 then writeln(sn,'Enc - AES_GCM_Init error: ',err); + if err=0 then begin + err := AES_GCM_Reset_IV(pIV, IV_Len, ctx); + if err<>0 then writeln(sn,'Enc - AES_GCM_Reset_IV error: ',err); + end; + + if err=0 then begin + err := AES_GCM_Add_AAD(pAAD, aLen, ctx); + if err<>0 then writeln(sn,'Enc - AES_GCM_Add_AAD error: ',err); + end; + + if err=0 then begin + err := AES_GCM_Encrypt(ptp, @ct, cLen, ctx); + if err<>0 then writeln(sn,'Enc - AES_GCM_Encrypt error: ',err); + end; + if err=0 then begin + err := AES_GCM_Final(tag, ctx); + if err<>0 then writeln(sn,'Enc - AES_GCM_Final error: ',err); + end; + if err=0 then begin + if not compmem(@tag, ptag, tLen) then begin + writeln(sn,'Enc - Tag does not match'); + inc(lf); + end; + if not compmem(@ct, ctp, cLen) then begin + writeln(sn,'Enc - Ciphertext does not match'); + inc(lf); + end; + end + else inc(lf); + + {-------------------------------------------------------------------------} + fillchar(pt,sizeof(pt),0); + fillchar(ct,sizeof(ct),0); + err := AES_GCM_Init(Key, KBits, ctx); + if err<>0 then writeln(sn,'Dec - AES_GCM_Init error: ',err); + + if err=0 then begin + err := AES_GCM_Reset_IV(pIV, IV_Len, ctx); + if err<>0 then writeln(sn,'Dec - AES_GCM_Reset_IV error: ',err); + end; + + if err=0 then begin + err := AES_GCM_Add_AAD(pAAD, aLen, ctx); + if err<>0 then writeln(sn,'Dec - AES_GCM_Add_AAD error: ',err); + end; + + if err=0 then begin + err := AES_GCM_Decrypt(ctp, @pt, cLen, ctx); + if err<>0 then writeln(sn,'Dec - AES_GCM_Encrypt error: ',err); + end; + if err=0 then begin + err := AES_GCM_Final(tag, ctx); + if err<>0 then writeln(sn,'Dec - AES_GCM_Final error: ',err); + end; + if err=0 then begin + if not compmem(@tag, ptag, tLen) then begin + writeln(sn,'Dec - Tag does not match'); + inc(lf); + end; + if not compmem(@pt, ptp, cLen) then begin + writeln(sn,'Dec - Plaintext does not match'); + inc(lf); + end; + end + else inc(lf); + + if lf<>0 then inc(fail); +end; + + + +{---------------------------------------------------------------------------} +procedure testspec; +const + K01: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + I01: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + T01: array[0..15] of byte = ($58,$e2,$fc,$ce,$fa,$7e,$30,$61, + $36,$7f,$1d,$57,$a4,$e7,$45,$5a); + + + K02: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + P02: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + I02: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + C02: array[0..15] of byte = ($03,$88,$da,$ce,$60,$b6,$a3,$92, + $f3,$28,$c2,$b9,$71,$b2,$fe,$78); + T02: array[0..15] of byte = ($ab,$6e,$47,$d4,$2c,$ec,$13,$bd, + $f5,$3a,$67,$b2,$12,$57,$bd,$df); + + + K03: array[0..15] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08); + P03: array[0..63] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39,$1a,$af,$d2,$55); + I03: array[0..11] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad, + $de,$ca,$f8,$88); + C03: array[0..63] of byte = ($42,$83,$1e,$c2,$21,$77,$74,$24, + $4b,$72,$21,$b7,$84,$d0,$d4,$9c, + $e3,$aa,$21,$2f,$2c,$02,$a4,$e0, + $35,$c1,$7e,$23,$29,$ac,$a1,$2e, + $21,$d5,$14,$b2,$54,$66,$93,$1c, + $7d,$8f,$6a,$5a,$ac,$84,$aa,$05, + $1b,$a3,$0b,$39,$6a,$0a,$ac,$97, + $3d,$58,$e0,$91,$47,$3f,$59,$85); + T03: array[0..15] of byte = ($4d,$5c,$2a,$f3,$27,$cd,$64,$a6, + $2c,$f3,$5a,$bd,$2b,$a6,$fa,$b4); + + + K04: array[0..15] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08); + P04: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A04: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I04: array[0..11] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad, + $de,$ca,$f8,$88); + C04: array[0..59] of byte = ($42,$83,$1e,$c2,$21,$77,$74,$24, + $4b,$72,$21,$b7,$84,$d0,$d4,$9c, + $e3,$aa,$21,$2f,$2c,$02,$a4,$e0, + $35,$c1,$7e,$23,$29,$ac,$a1,$2e, + $21,$d5,$14,$b2,$54,$66,$93,$1c, + $7d,$8f,$6a,$5a,$ac,$84,$aa,$05, + $1b,$a3,$0b,$39,$6a,$0a,$ac,$97, + $3d,$58,$e0,$91); + T04: array[0..15] of byte = ($5b,$c9,$4f,$bc,$32,$21,$a5,$db, + $94,$fa,$e9,$5a,$e7,$12,$1a,$47); + + + K05: array[0..15] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08); + P05: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A05: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I05: array[0..07] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad); + C05: array[0..59] of byte = ($61,$35,$3b,$4c,$28,$06,$93,$4a, + $77,$7f,$f5,$1f,$a2,$2a,$47,$55, + $69,$9b,$2a,$71,$4f,$cd,$c6,$f8, + $37,$66,$e5,$f9,$7b,$6c,$74,$23, + $73,$80,$69,$00,$e4,$9f,$24,$b2, + $2b,$09,$75,$44,$d4,$89,$6b,$42, + $49,$89,$b5,$e1,$eb,$ac,$0f,$07, + $c2,$3f,$45,$98); + T05: array[0..15] of byte = ($36,$12,$d2,$e7,$9e,$3b,$07,$85, + $56,$1b,$e1,$4a,$ac,$a2,$fc,$cb); + + + K06: array[0..15] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08); + P06: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A06: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I06: array[0..59] of byte = ($93,$13,$22,$5d,$f8,$84,$06,$e5, + $55,$90,$9c,$5a,$ff,$52,$69,$aa, + $6a,$7a,$95,$38,$53,$4f,$7d,$a1, + $e4,$c3,$03,$d2,$a3,$18,$a7,$28, + $c3,$c0,$c9,$51,$56,$80,$95,$39, + $fc,$f0,$e2,$42,$9a,$6b,$52,$54, + $16,$ae,$db,$f5,$a0,$de,$6a,$57, + $a6,$37,$b3,$9b); + C06: array[0..59] of byte = ($8c,$e2,$49,$98,$62,$56,$15,$b6, + $03,$a0,$33,$ac,$a1,$3f,$b8,$94, + $be,$91,$12,$a5,$c3,$a2,$11,$a8, + $ba,$26,$2a,$3c,$ca,$7e,$2c,$a7, + $01,$e4,$a9,$a4,$fb,$a4,$3c,$90, + $cc,$dc,$b2,$81,$d4,$8c,$7c,$6f, + $d6,$28,$75,$d2,$ac,$a4,$17,$03, + $4c,$34,$ae,$e5); + T06: array[0..15] of byte = ($61,$9c,$c5,$ae,$ff,$fe,$0b,$fa, + $46,$2a,$f4,$3c,$16,$99,$d0,$50); + + + K07: array[0..23] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + I07: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + T07: array[0..15] of byte = ($cd,$33,$b2,$8a,$c7,$73,$f7,$4b, + $a0,$0e,$d1,$f3,$12,$57,$24,$35); + + + K08: array[0..23] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + P08: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + I08: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + C08: array[0..15] of byte = ($98,$e7,$24,$7c,$07,$f0,$fe,$41, + $1c,$26,$7e,$43,$84,$b0,$f6,$00); + T08: array[0..15] of byte = ($2f,$f5,$8d,$80,$03,$39,$27,$ab, + $8e,$f4,$d4,$58,$75,$14,$f0,$fb); + + K09: array[0..23] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08, + $fe,$ff,$e9,$92,$86,$65,$73,$1c); + P09: array[0..63] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39,$1a,$af,$d2,$55); + I09: array[0..11] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad, + $de,$ca,$f8,$88); + C09: array[0..63] of byte = ($39,$80,$ca,$0b,$3c,$00,$e8,$41, + $eb,$06,$fa,$c4,$87,$2a,$27,$57, + $85,$9e,$1c,$ea,$a6,$ef,$d9,$84, + $62,$85,$93,$b4,$0c,$a1,$e1,$9c, + $7d,$77,$3d,$00,$c1,$44,$c5,$25, + $ac,$61,$9d,$18,$c8,$4a,$3f,$47, + $18,$e2,$44,$8b,$2f,$e3,$24,$d9, + $cc,$da,$27,$10,$ac,$ad,$e2,$56); + T09: array[0..15] of byte = ($99,$24,$a7,$c8,$58,$73,$36,$bf, + $b1,$18,$02,$4d,$b8,$67,$4a,$14); + + + K10: array[0..23] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08, + $fe,$ff,$e9,$92,$86,$65,$73,$1c); + P10: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A10: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I10: array[0..11] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad, + $de,$ca,$f8,$88); + C10: array[0..59] of byte = ($39,$80,$ca,$0b,$3c,$00,$e8,$41, + $eb,$06,$fa,$c4,$87,$2a,$27,$57, + $85,$9e,$1c,$ea,$a6,$ef,$d9,$84, + $62,$85,$93,$b4,$0c,$a1,$e1,$9c, + $7d,$77,$3d,$00,$c1,$44,$c5,$25, + $ac,$61,$9d,$18,$c8,$4a,$3f,$47, + $18,$e2,$44,$8b,$2f,$e3,$24,$d9, + $cc,$da,$27,$10); + T10: array[0..15] of byte = ($25,$19,$49,$8e,$80,$f1,$47,$8f, + $37,$ba,$55,$bd,$6d,$27,$61,$8c); + + + K11: array[0..23] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08, + $fe,$ff,$e9,$92,$86,$65,$73,$1c); + P11: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A11: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I11: array[0.. 7] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad); + C11: array[0..59] of byte = ($0f,$10,$f5,$99,$ae,$14,$a1,$54, + $ed,$24,$b3,$6e,$25,$32,$4d,$b8, + $c5,$66,$63,$2e,$f2,$bb,$b3,$4f, + $83,$47,$28,$0f,$c4,$50,$70,$57, + $fd,$dc,$29,$df,$9a,$47,$1f,$75, + $c6,$65,$41,$d4,$d4,$da,$d1,$c9, + $e9,$3a,$19,$a5,$8e,$8b,$47,$3f, + $a0,$f0,$62,$f7); + T11: array[0..15] of byte = ($65,$dc,$c5,$7f,$cf,$62,$3a,$24, + $09,$4f,$cc,$a4,$0d,$35,$33,$f8); + + + K12: array[0..23] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08, + $fe,$ff,$e9,$92,$86,$65,$73,$1c); + P12: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A12: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I12: array[0..59] of byte = ($93,$13,$22,$5d,$f8,$84,$06,$e5, + $55,$90,$9c,$5a,$ff,$52,$69,$aa, + $6a,$7a,$95,$38,$53,$4f,$7d,$a1, + $e4,$c3,$03,$d2,$a3,$18,$a7,$28, + $c3,$c0,$c9,$51,$56,$80,$95,$39, + $fc,$f0,$e2,$42,$9a,$6b,$52,$54, + $16,$ae,$db,$f5,$a0,$de,$6a,$57, + $a6,$37,$b3,$9b); + C12: array[0..59] of byte = ($d2,$7e,$88,$68,$1c,$e3,$24,$3c, + $48,$30,$16,$5a,$8f,$dc,$f9,$ff, + $1d,$e9,$a1,$d8,$e6,$b4,$47,$ef, + $6e,$f7,$b7,$98,$28,$66,$6e,$45, + $81,$e7,$90,$12,$af,$34,$dd,$d9, + $e2,$f0,$37,$58,$9b,$29,$2d,$b3, + $e6,$7c,$03,$67,$45,$fa,$22,$e7, + $e9,$b7,$37,$3b); + T12: array[0..15] of byte = ($dc,$f5,$66,$ff,$29,$1c,$25,$bb, + $b8,$56,$8f,$c3,$d3,$76,$a6,$d9); + + + K13: array[0..31] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + I13: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + T13: array[0..15] of byte = ($53,$0f,$8a,$fb,$c7,$45,$36,$b9, + $a9,$63,$b4,$f1,$c4,$cb,$73,$8b); + + + K14: array[0..31] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + P14: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + I14: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + C14: array[0..15] of byte = ($ce,$a7,$40,$3d,$4d,$60,$6b,$6e, + $07,$4e,$c5,$d3,$ba,$f3,$9d,$18); + T14: array[0..15] of byte = ($d0,$d1,$c8,$a7,$99,$99,$6b,$f0, + $26,$5b,$98,$b5,$d4,$8a,$b9,$19); + + + K15: array[0..31] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08, + $fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08); + + + P15: array[0..63] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39,$1a,$af,$d2,$55); + I15: array[0..11] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad, + $de,$ca,$f8,$88); + C15: array[0..63] of byte = ($52,$2d,$c1,$f0,$99,$56,$7d,$07, + $f4,$7f,$37,$a3,$2a,$84,$42,$7d, + $64,$3a,$8c,$dc,$bf,$e5,$c0,$c9, + $75,$98,$a2,$bd,$25,$55,$d1,$aa, + $8c,$b0,$8e,$48,$59,$0d,$bb,$3d, + $a7,$b0,$8b,$10,$56,$82,$88,$38, + $c5,$f6,$1e,$63,$93,$ba,$7a,$0a, + $bc,$c9,$f6,$62,$89,$80,$15,$ad); + T15: array[0..15] of byte = ($b0,$94,$da,$c5,$d9,$34,$71,$bd, + $ec,$1a,$50,$22,$70,$e3,$cc,$6c); + + + K16: array[0..31] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08, + $fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08); + P16: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A16: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I16: array[0..11] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad, + $de,$ca,$f8,$88); + C16: array[0..59] of byte = ($52,$2d,$c1,$f0,$99,$56,$7d,$07, + $f4,$7f,$37,$a3,$2a,$84,$42,$7d, + $64,$3a,$8c,$dc,$bf,$e5,$c0,$c9, + $75,$98,$a2,$bd,$25,$55,$d1,$aa, + $8c,$b0,$8e,$48,$59,$0d,$bb,$3d, + $a7,$b0,$8b,$10,$56,$82,$88,$38, + $c5,$f6,$1e,$63,$93,$ba,$7a,$0a, + $bc,$c9,$f6,$62); + T16: array[0..15] of byte = ($76,$fc,$6e,$ce,$0f,$4e,$17,$68, + $cd,$df,$88,$53,$bb,$2d,$55,$1b); + + + K17: array[0..31] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08, + $fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08); + P17: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A17: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I17: array[0.. 7] of byte = ($ca,$fe,$ba,$be,$fa,$ce,$db,$ad); + C17: array[0..59] of byte = ($c3,$76,$2d,$f1,$ca,$78,$7d,$32, + $ae,$47,$c1,$3b,$f1,$98,$44,$cb, + $af,$1a,$e1,$4d,$0b,$97,$6a,$fa, + $c5,$2f,$f7,$d7,$9b,$ba,$9d,$e0, + $fe,$b5,$82,$d3,$39,$34,$a4,$f0, + $95,$4c,$c2,$36,$3b,$c7,$3f,$78, + $62,$ac,$43,$0e,$64,$ab,$e4,$99, + $f4,$7c,$9b,$1f); + T17: array[0..15] of byte = ($3a,$33,$7d,$bf,$46,$a7,$92,$c4, + $5e,$45,$49,$13,$fe,$2e,$a8,$f2); + + + K18: array[0..31] of byte = ($fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08, + $fe,$ff,$e9,$92,$86,$65,$73,$1c, + $6d,$6a,$8f,$94,$67,$30,$83,$08); + P18: array[0..59] of byte = ($d9,$31,$32,$25,$f8,$84,$06,$e5, + $a5,$59,$09,$c5,$af,$f5,$26,$9a, + $86,$a7,$a9,$53,$15,$34,$f7,$da, + $2e,$4c,$30,$3d,$8a,$31,$8a,$72, + $1c,$3c,$0c,$95,$95,$68,$09,$53, + $2f,$cf,$0e,$24,$49,$a6,$b5,$25, + $b1,$6a,$ed,$f5,$aa,$0d,$e6,$57, + $ba,$63,$7b,$39); + A18: array[0..19] of byte = ($fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $fe,$ed,$fa,$ce,$de,$ad,$be,$ef, + $ab,$ad,$da,$d2); + I18: array[0..59] of byte = ($93,$13,$22,$5d,$f8,$84,$06,$e5, + $55,$90,$9c,$5a,$ff,$52,$69,$aa, + $6a,$7a,$95,$38,$53,$4f,$7d,$a1, + $e4,$c3,$03,$d2,$a3,$18,$a7,$28, + $c3,$c0,$c9,$51,$56,$80,$95,$39, + $fc,$f0,$e2,$42,$9a,$6b,$52,$54, + $16,$ae,$db,$f5,$a0,$de,$6a,$57, + $a6,$37,$b3,$9b); + C18: array[0..59] of byte = ($5a,$8d,$ef,$2f,$0c,$9e,$53,$f1, + $f7,$5d,$78,$53,$65,$9e,$2a,$20, + $ee,$b2,$b2,$2a,$af,$de,$64,$19, + $a0,$58,$ab,$4f,$6f,$74,$6b,$f4, + $0f,$c0,$c3,$b7,$80,$f2,$44,$45, + $2d,$a3,$eb,$f1,$c5,$d8,$2c,$de, + $a2,$41,$89,$97,$20,$0e,$f8,$2e, + $44,$ae,$7e,$3f); + T18: array[0..15] of byte = ($a4,$4a,$82,$66,$ee,$1c,$8e,$b0, + $c8,$b5,$d4,$cf,$5a,$e9,$f1,$9a); + +begin + fail := 0; + writeln('Test cases AES_GCM from GCM Spec'); + single_test(@T01,16,K01,8*sizeof(K01),@I01,sizeof(I01),nil,0,nil,0,nil,01); + single_test(@T02,16,K02,8*sizeof(K02),@I02,sizeof(I02),nil,0,@C02,sizeof(C02),@P02,02); + single_test(@T03,16,K03,8*sizeof(K03),@I03,sizeof(I03),nil,0,@C03,sizeof(C03),@P03,03); + single_test(@T04,16,K04,8*sizeof(K04),@I04,sizeof(I04),@A04,sizeof(A04),@C04,sizeof(C04),@P04,04); + single_test(@T05,16,K05,8*sizeof(K05),@I05,sizeof(I05),@A05,sizeof(A05),@C05,sizeof(C05),@P05,05); + single_test(@T06,16,K06,8*sizeof(K06),@I06,sizeof(I06),@A06,sizeof(A06),@C06,sizeof(C06),@P06,06); + single_test(@T07,16,K07,8*sizeof(K07),@I07,sizeof(I07),nil,0,nil,0,nil,07); + single_test(@T08,16,K08,8*sizeof(K08),@I08,sizeof(I08),nil,0,@C08,sizeof(C08),@P08,08); + single_test(@T09,16,K09,8*sizeof(K09),@I09,sizeof(I09),nil,0,@C09,sizeof(C09),@P09,09); + single_test(@T10,16,K10,8*sizeof(K10),@I10,sizeof(I10),@A10,sizeof(A10),@C10,sizeof(C10),@P10,10); + single_test(@T11,16,K11,8*sizeof(K11),@I11,sizeof(I11),@A11,sizeof(A11),@C11,sizeof(C11),@P11,11); + single_test(@T12,16,K12,8*sizeof(K12),@I12,sizeof(I12),@A12,sizeof(A12),@C12,sizeof(C12),@P12,12); + single_test(@T13,16,K13,8*sizeof(K13),@I13,sizeof(I13),nil,0,nil,0,nil,13); + single_test(@T14,16,K14,8*sizeof(K14),@I14,sizeof(I14),nil,0,@C14,sizeof(C14),@P14,14); + single_test(@T15,16,K15,8*sizeof(K15),@I15,sizeof(I15),nil,0,@C15,sizeof(C15),@P15,15); + single_test(@T16,16,K16,8*sizeof(K16),@I16,sizeof(I16),@A16,sizeof(A16),@C16,sizeof(C16),@P16,16); + single_test(@T17,16,K17,8*sizeof(K17),@I17,sizeof(I17),@A17,sizeof(A17),@C17,sizeof(C17),@P17,17); + single_test(@T18,16,K18,8*sizeof(K18),@I18,sizeof(I18),@A18,sizeof(A18),@C18,sizeof(C18),@P18,18); + if fail=0 then writeln('All tests passed.') + else writeln('*** Number of failed tests: ', fail); +end; + +{---------------------------------------------------------------------------} +procedure tsd_test; + {-Reproduce AES part of Tom St Denis' GCM_TV.TXT, LTC V1.18} +const + hex32: array[1..32] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17, + $18,$19,$1a,$1b,$1c,$1d,$1e,$1f); + buf32: array[0..31] of byte = ($92,$4e,$17,$8a,$17,$fa,$1c,$a0, + $e7,$48,$6f,$04,$04,$12,$3b,$91, + $db,$f7,$97,$bb,$9d,$bd,$e9,$b1, + $d4,$8d,$5c,$7f,$53,$16,$59,$12); + + + tag32: array[0..15] of byte = ($10,$f9,$72,$b6,$f9,$e0,$a3,$c1, + $cf,$9c,$cf,$56,$54,$3d,$ca,$79); + +var + err,n: integer; + ctx: TAES_GCMContext; + key, tag: TAESBlock; + buf: array[0..63] of byte; +begin + {Note: Contrary to what Tom writes in GCM_TV.TXT the length of nonce=IV is} + {NOT fixed=13, but varies the same way as the header and plaintext length!} + writeln('Test AES part of Tom St Denis'' GCM_TV.TXT (LTC V1.18)'); + {Uppercase from HexStr} + HexUpper := true; + {Initial key from hex32} + move(hex32, key, sizeof(key)); + for n:=1 to 32 do begin + err := AES_GCM_Init(key, 128, ctx); + if err=0 then err := AES_GCM_Reset_IV(@hex32, n, ctx); + if err=0 then err := AES_GCM_Add_AAD(@hex32,n,ctx); + if err=0 then err := AES_GCM_Encrypt(@hex32, @buf, n, ctx); + if err=0 then err := AES_GCM_Final(tag, ctx); + if err=0 then begin + if print then writeln(n:3,': ', HexStr(@buf,n), ', ', HexStr(@tag,16)); + {key for step n>1 is the tag of the previous step repeated} + key := tag; + end + else begin + writeln('Error ',err); + exit; + end; + end; + {compare final values} + writeln('buf32 compares: ', compmem(@buf32, @buf, sizeof(buf32)):5); + writeln('tag32 compares: ', compmem(@tag32, @tag, sizeof(tag32)):5); +end; + + +{---------------------------------------------------------------------------} +procedure test_glad2; +const + K01: array[0..31] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + + I01: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + + P01: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + + C01: array[0..15] of byte = ($ce,$a7,$40,$3d,$4d,$60,$6b,$6e, + $07,$4e,$c5,$d3,$ba,$f3,$9d,$18); + + T01: array[0..15] of byte = ($d0,$d1,$c8,$a7,$99,$99,$6b,$f0, + $26,$5b,$98,$b5,$d4,$8a,$b9,$19); + + + K02: array[0..31] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + + I02: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + + H02: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + + T02: array[0..15] of byte = ($2d,$45,$55,$2d,$85,$75,$92,$2b, + $3c,$a3,$cc,$53,$84,$42,$fa,$26); + + + K03: array[0..31] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + + I03: array[0..11] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00); + + H03: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + + P03: array[0..15] of byte = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + + C03: array[0..15] of byte = ($ce,$a7,$40,$3d,$4d,$60,$6b,$6e, + $07,$4e,$c5,$d3,$ba,$f3,$9d,$18); + + T03: array[0..15] of byte = ($ae,$9b,$17,$71,$db,$a9,$cf,$62, + $b3,$9b,$e0,$17,$94,$03,$30,$b4); + + + K04: array[0..31] of byte = ($fb,$76,$15,$b2,$3d,$80,$89,$1d, + $d4,$70,$98,$0b,$c7,$95,$84,$c8, + $b2,$fb,$64,$ce,$60,$97,$8f,$4d, + $17,$fc,$e4,$5a,$49,$e8,$30,$b7); + + I04: array[0..11] of byte = ($db,$d1,$a3,$63,$60,$24,$b7,$b4, + $02,$da,$7d,$6f); + + P04: array[0..15] of byte = ($a8,$45,$34,$8e,$c8,$c5,$b5,$f1, + $26,$f5,$0e,$76,$fe,$fd,$1b,$1e); + + C04: array[0..15] of byte = ($5d,$f5,$d1,$fa,$bc,$bb,$dd,$05, + $15,$38,$25,$24,$44,$17,$87,$04); + + T04: array[0..15] of byte = ($4c,$43,$cc,$e5,$a5,$74,$d8,$a8, + $8b,$43,$d4,$35,$3b,$d6,$0f,$9f); + + + K05: array[0..31] of byte = ($40,$41,$42,$43,$44,$45,$46,$47, + $48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57, + $58,$59,$5a,$5b,$5c,$5d,$5e,$5f); + + I05: array[0..11] of byte = ($10,$11,$12,$13,$14,$15,$16,$17, + $18,$19,$1a,$1b); + + H05: array[0..19] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13); + + P05: array[0..23] of byte = ($20,$21,$22,$23,$24,$25,$26,$27, + $28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37); + + C05: array[0..23] of byte = ($59,$1b,$1f,$f2,$72,$b4,$32,$04, + $86,$8f,$fc,$7b,$c7,$d5,$21,$99, + $35,$26,$b6,$fa,$32,$24,$7c,$3c); + + T05: array[0..15] of byte = ($7d,$e1,$2a,$56,$70,$e5,$70,$d8, + $ca,$e6,$24,$a1,$6d,$f0,$9c,$08); + + + K07: array[0..31] of byte = ($40,$41,$42,$43,$44,$45,$46,$47, + $48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57, + $58,$59,$5a,$5b,$5c,$5d,$5e,$5f); + + I07: array[0..11] of byte = ($10,$11,$12,$13,$14,$15,$16,$17, + $18,$19,$1a,$1b); + + H07: array[0..31] of byte = ($20,$21,$22,$23,$24,$25,$26,$27, + $28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37, + $38,$39,$3a,$3b,$3c,$3d,$3e,$3f); + + P07: array[0..255] of byte =($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17, + $18,$19,$1a,$1b,$1c,$1d,$1e,$1f, + $20,$21,$22,$23,$24,$25,$26,$27, + $28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37, + $38,$39,$3a,$3b,$3c,$3d,$3e,$3f, + $40,$41,$42,$43,$44,$45,$46,$47, + $48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57, + $58,$59,$5a,$5b,$5c,$5d,$5e,$5f, + $60,$61,$62,$63,$64,$65,$66,$67, + $68,$69,$6a,$6b,$6c,$6d,$6e,$6f, + $70,$71,$72,$73,$74,$75,$76,$77, + $78,$79,$7a,$7b,$7c,$7d,$7e,$7f, + $80,$81,$82,$83,$84,$85,$86,$87, + $88,$89,$8a,$8b,$8c,$8d,$8e,$8f, + $90,$91,$92,$93,$94,$95,$96,$97, + $98,$99,$9a,$9b,$9c,$9d,$9e,$9f, + $a0,$a1,$a2,$a3,$a4,$a5,$a6,$a7, + $a8,$a9,$aa,$ab,$ac,$ad,$ae,$af, + $b0,$b1,$b2,$b3,$b4,$b5,$b6,$b7, + $b8,$b9,$ba,$bb,$bc,$bd,$be,$bf, + $c0,$c1,$c2,$c3,$c4,$c5,$c6,$c7, + $c8,$c9,$ca,$cb,$cc,$cd,$ce,$cf, + $d0,$d1,$d2,$d3,$d4,$d5,$d6,$d7, + $d8,$d9,$da,$db,$dc,$dd,$de,$df, + $e0,$e1,$e2,$e3,$e4,$e5,$e6,$e7, + $e8,$e9,$ea,$eb,$ec,$ed,$ee,$ef, + $f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7, + $f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff); + + C07: array[0..255] of byte =($79,$3b,$3f,$d2,$52,$94,$12,$24, + $a6,$af,$dc,$5b,$e7,$f5,$01,$b9, + $15,$06,$96,$da,$12,$04,$5c,$1c, + $60,$77,$d3,$ca,$c7,$74,$ac,$cf, + $c3,$d5,$30,$d8,$48,$d6,$65,$d8, + $1a,$49,$cb,$b5,$00,$b8,$8b,$bb, + $62,$4a,$e6,$1d,$16,$67,$22,$9c, + $30,$2d,$c6,$ff,$0b,$b4,$d7,$0b, + $db,$bc,$85,$66,$d6,$f5,$b1,$58, + $da,$99,$a2,$ff,$2e,$01,$dd,$a6, + $29,$b8,$9c,$34,$ad,$1e,$5f,$eb, + $a7,$0e,$7a,$ae,$43,$28,$28,$9c, + $36,$29,$b0,$58,$83,$50,$58,$1c, + $a8,$b9,$7c,$cf,$12,$58,$fa,$3b, + $be,$2c,$50,$26,$04,$7b,$a7,$26, + $48,$96,$9c,$ff,$8b,$a1,$0a,$e3, + $0e,$05,$93,$5d,$f0,$c6,$93,$74, + $18,$92,$b7,$6f,$af,$67,$13,$3a, + $bd,$2c,$f2,$03,$11,$21,$bd,$8b, + $b3,$81,$27,$a4,$d2,$ee,$de,$ea, + $13,$27,$64,$94,$f4,$02,$cd,$7c, + $10,$7f,$b3,$ec,$3b,$24,$78,$48, + $34,$33,$8e,$55,$43,$62,$87,$09, + $2a,$c4,$a2,$6f,$5e,$a7,$ea,$4a, + $d6,$8d,$73,$15,$16,$39,$b0,$5b, + $24,$e6,$8b,$98,$16,$d1,$39,$83, + $76,$d8,$e4,$13,$85,$94,$75,$8d, + $b9,$ad,$3b,$40,$92,$59,$b2,$6d, + $cf,$c0,$6e,$72,$2b,$e9,$87,$b3, + $76,$7f,$70,$a7,$b8,$56,$b7,$74, + $b1,$ba,$26,$85,$b3,$68,$09,$14, + $29,$fc,$cb,$8d,$cd,$de,$09,$e4); + + T07: array[0..15] of byte = ($87,$ec,$83,$7a,$bf,$53,$28,$55, + $b2,$ce,$a1,$69,$d6,$94,$3f,$cd); + + + K08: array[0..31] of byte = ($fb,$76,$15,$b2,$3d,$80,$89,$1d, + $d4,$70,$98,$0b,$c7,$95,$84,$c8, + $b2,$fb,$64,$ce,$60,$97,$87,$8d, + $17,$fc,$e4,$5a,$49,$e8,$30,$b7); + + I08: array[0..11] of byte = ($db,$d1,$a3,$63,$60,$24,$b7,$b4, + $02,$da,$7d,$6f); + + H08: array[0.. 0] of byte = ($36); + + P08: array[0.. 0] of byte = ($a9); + + C08: array[0.. 0] of byte = ($0a); + + T08: array[0..15] of byte = ($be,$98,$7d,$00,$9a,$4b,$34,$9a, + $a8,$0c,$b9,$c4,$eb,$c1,$e9,$f4); + + + K09: array[0..31] of byte = ($f8,$d4,$76,$cf,$d6,$46,$ea,$6c, + $23,$84,$cb,$1c,$27,$d6,$19,$5d, + $fe,$f1,$a9,$f3,$7b,$9c,$8d,$21, + $a7,$9c,$21,$f8,$cb,$90,$d2,$89); + + I09: array[0..11] of byte = ($db,$d1,$a3,$63,$60,$24,$b7,$b4, + $02,$da,$7d,$6f); + + H09: array[0..19] of byte = ($7b,$d8,$59,$a2,$47,$96,$1a,$21, + $82,$3b,$38,$0e,$9f,$e8,$b6,$50, + $82,$ba,$61,$d3); + + P09: array[0..19] of byte = ($90,$ae,$61,$cf,$7b,$ae,$bd,$4c, + $ad,$e4,$94,$c5,$4a,$29,$ae,$70, + $26,$9a,$ec,$71); + + C09: array[0..19] of byte = ($ce,$20,$27,$b4,$7a,$84,$32,$52, + $01,$34,$65,$83,$4d,$75,$fd,$0f, + $07,$29,$75,$2e); + + T09: array[0..15] of byte = ($ac,$d8,$83,$38,$37,$ab,$0e,$de, + $84,$f4,$74,$8d,$a8,$89,$9c,$15); + + + K10: array[0..31] of byte = ($db,$bc,$85,$66,$d6,$f5,$b1,$58, + $da,$99,$a2,$ff,$2e,$01,$dd,$a6, + $29,$b8,$9c,$34,$ad,$1e,$5f,$eb, + $a7,$0e,$7a,$ae,$43,$28,$28,$9c); + + I10: array[0..15] of byte = ($cf,$c0,$6e,$72,$2b,$e9,$87,$b3, + $76,$7f,$70,$a7,$b8,$56,$b7,$74); + + P10: array[0..15] of byte = ($ce,$20,$27,$b4,$7a,$84,$32,$52, + $01,$34,$65,$83,$4d,$75,$fd,$0f); + + C10: array[0..15] of byte = ($dc,$03,$e5,$24,$83,$0d,$30,$f8, + $8e,$19,$7f,$3a,$ca,$ce,$66,$ef); + + T10: array[0..15] of byte = ($99,$84,$ef,$f6,$90,$57,$55,$d1, + $83,$6f,$2d,$b0,$40,$89,$63,$4c); + + + K11: array[0..31] of byte = ($0e,$05,$93,$5d,$f0,$c6,$93,$74, + $18,$92,$b7,$6f,$af,$67,$13,$3a, + $bd,$2c,$f2,$03,$11,$21,$bd,$8b, + $b3,$81,$27,$a4,$d2,$ee,$de,$ea); + + I11: array[0..16] of byte = ($74,$b1,$ba,$26,$85,$b3,$68,$09, + $14,$29,$fc,$cb,$8d,$cd,$de,$09, + $e4); + + H11: array[0..19] of byte = ($7b,$d8,$59,$a2,$47,$96,$1a,$21, + $82,$3b,$38,$0e,$9f,$e8,$b6,$50, + $82,$ba,$61,$d3); + + P11: array[0..19] of byte = ($90,$ae,$61,$cf,$7b,$ae,$bd,$4c, + $ad,$e4,$94,$c5,$4a,$29,$ae,$70, + $26,$9a,$ec,$71); + + C11: array[0..19] of byte = ($6b,$e6,$5e,$56,$06,$6c,$40,$56, + $73,$8c,$03,$fe,$23,$20,$97,$4b, + $a3,$f6,$5e,$09); + + T11: array[0..15] of byte = ($61,$08,$dc,$41,$7b,$f3,$2f,$7f, + $b7,$55,$4a,$e5,$2f,$08,$8f,$87); + + +begin + fail := 0; + writeln('Test cases AES_GCM from Brian Gladman/IEEE P1619.1'); + single_test(@T01,16,K01,8*sizeof(K01),@I01,sizeof(I01),nil ,0 ,@C01,sizeof(C01),@P01,01); + single_test(@T02,16,K02,8*sizeof(K02),@I02,sizeof(I02),@H02,sizeof(H02),nil ,0 ,nil ,02); + single_test(@T03,16,K03,8*sizeof(K03),@I03,sizeof(I03),@H03,sizeof(H03),@C03,sizeof(C03),@P03,03); + single_test(@T04,16,K04,8*sizeof(K04),@I04,sizeof(I04),nil ,0 ,@C04,sizeof(C04),@P04,04); + single_test(@T05,16,K05,8*sizeof(K05),@I05,sizeof(I05),@H05,sizeof(H05),@C05,sizeof(C05),@P05,05); + single_test(@T07,16,K07,8*sizeof(K07),@I07,sizeof(I07),@H07,sizeof(H07),@C07,sizeof(C07),@P07,07); + single_test(@T08,16,K08,8*sizeof(K08),@I08,sizeof(I08),@H08,sizeof(H08),@C08,sizeof(C08),@P08,08); + single_test(@T09,16,K09,8*sizeof(K09),@I09,sizeof(I09),@H09,sizeof(H09),@C09,sizeof(C09),@P09,09); + single_test(@T10,16,K10,8*sizeof(K10),@I10,sizeof(I10),nil ,0 ,@C10,sizeof(C10),@P10,10); + single_test(@T11,16,K11,8*sizeof(K11),@I11,sizeof(I11),@H11,sizeof(H11),@C11,sizeof(C11),@P11,11); + if fail=0 then writeln('All tests passed.') + else writeln('*** Number of failed tests: ', fail); +end; + +begin + write('Test program for AES-GCM functions'); + {$ifdef USEDLL} + write(' [AES_DLL V',AES_DLL_Version,']'); + {$endif} + writeln(' (C) 2010 W.Ehrhardt'); + writeln; + testspec; + writeln; + test_glad2; + writeln; + tsd_test; +end. + + + + diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aesofb.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aesofb.pas new file mode 100644 index 00000000..a32d5663 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aesofb.pas @@ -0,0 +1,220 @@ +{-Test prog for AES OFB, we Sep.2003} + +program T_AESOFB; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_type, aes_OFB, mem_util, BTypes; + +var + Context: TAESContext; + Err : integer; + +{---------------------------------------------------------------------------} +procedure CheckError; +begin + if Err<>0 then writeln('Error ',Err); +end; + + +{---------------------------------------------------------------------------} +procedure SimpleTests; + {-Simple encrypt/decrypt test for AES-OFB mode} +const + Key128 : array[0..15] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f); + Key192 : array[0..23] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17); + Key256 : array[0..31] of byte = ($00, $01, $02, $03, $04, $05, $06, $07, + $08, $09, $0a, $0b, $0c, $0d, $0e, $0f, + $10, $11, $12, $13, $14, $15, $16, $17, + $18, $19, $1a, $1b, $1c, $1d, $1e, $1f); + +const + sample = 'This is a short test sample text for AES OFB mode'#0; + +var + i : integer; + ct, pt, plain: array[1..length(sample)] of char8; + IV : TAESBlock; + + procedure CheckRes; + begin + writeln('Decr(Encr)=Id : ',CompMem(@pt, @plain, sizeof(plain))); + end; + + +begin + for i:=0 to 15 do IV[i] := random(256); + plain := sample; + + writeln; + writeln('============================================'); + writeln('Simple encrypt/decrypt test for AES-OFB mode'); + writeln('Org. plain text: ', plain); + writeln; + + writeln('++++ 128 bit key ++++'); + pt := plain; + Err := AES_OFB_Init(key128, 128, IV, context); + Err := AES_OFB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_OFB_Init(key128, 128, IV, context); + Err := AES_OFB_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_OFB_Init(key128, 128, IV, context); + for i:=1 to sizeof(plain) do begin + Err := AES_OFB_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + + writeln; + writeln('++++ 192 bit key ++++'); + pt := plain; + Err := AES_OFB_Init(key192, 192, IV, context); + Err := AES_OFB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_OFB_Init(key192, 192, IV, context); + Err := AES_OFB_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_OFB_Init(key192, 192, IV, context); + for i:=1 to sizeof(plain) do begin + Err := AES_OFB_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); + + writeln; + writeln('++++ 256 bit key ++++'); + pt := plain; + Err := AES_OFB_Init(key256, 256, IV, context); + Err := AES_OFB_Encrypt(@pt, @ct, sizeof(plain), context); + CheckError; + pt := ct; + Err := AES_OFB_Init(key256, 256, IV, context); + Err := AES_OFB_Decrypt(@pt, @pt, sizeof(plain), context); + CheckError; + writeln('Block Encr/decr: ', pt); + CheckRes; + Err := AES_OFB_Init(key256, 256, IV, context); + for i:=1 to sizeof(plain) do begin + Err := AES_OFB_Decrypt(@ct[i], @pt[i], 1, context); + end; + CheckError; + writeln(' Char Encr/decr: ', pt); +end; + + +{---------------------------------------------------------------------------} +procedure NistTests; + {-NIST SP 800-38A OFB/AES Tests} +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + key192 : array[0..23] of byte = ($8e,$73,$b0,$f7,$da,$0e,$64,$52, + $c8,$10,$f3,$2b,$80,$90,$79,$e5, + $62,$f8,$ea,$d2,$52,$2c,$6b,$7b); + + key256 : array[0..31] of byte = ($60,$3d,$eb,$10,$15,$ca,$71,$be, + $2b,$73,$ae,$f0,$85,$7d,$77,$81, + $1f,$35,$2c,$07,$3b,$61,$08,$d7, + $2d,$98,$10,$a3,$09,$14,$df,$f4); + + IV : TAESBlock = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f); + + plain : array[0..63] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d,$8a,$57,$1e,$03,$ac,$9c, + $9e,$b7,$6f,$ac,$45,$af,$8e,$51, + $30,$c8,$1c,$46,$a3,$5c,$e4,$11, + $e5,$fb,$c1,$19,$1a,$0a,$52,$ef, + $f6,$9f,$24,$45,$df,$4f,$9b,$17, + $ad,$2b,$41,$7b,$e6,$6c,$37,$10); + + ct1 : array[0..63] of byte = ($3b,$3f,$d9,$2e,$b7,$2d,$ad,$20, + $33,$34,$49,$f8,$e8,$3c,$fb,$4a, + $77,$89,$50,$8d,$16,$91,$8f,$03, + $f5,$3c,$52,$da,$c5,$4e,$d8,$25, + $97,$40,$05,$1e,$9c,$5f,$ec,$f6, + $43,$44,$f7,$a8,$22,$60,$ed,$cc, + $30,$4c,$65,$28,$f6,$59,$c7,$78, + $66,$a5,$10,$d9,$c1,$d6,$ae,$5e); + + ct2 : array[0..63] of byte = ($cd,$c8,$0d,$6f,$dd,$f1,$8c,$ab, + $34,$c2,$59,$09,$c9,$9a,$41,$74, + $fc,$c2,$8b,$8d,$4c,$63,$83,$7c, + $09,$e8,$17,$00,$c1,$10,$04,$01, + $8d,$9a,$9a,$ea,$c0,$f6,$59,$6f, + $55,$9c,$6d,$4d,$af,$59,$a5,$f2, + $6d,$9f,$20,$08,$57,$ca,$6c,$3e, + $9c,$ac,$52,$4b,$d9,$ac,$c9,$2a); + + ct3 : array[0..63] of byte = ($dc,$7e,$84,$bf,$da,$79,$16,$4b, + $7e,$cd,$84,$86,$98,$5d,$38,$60, + $4f,$eb,$dc,$67,$40,$d2,$0b,$3a, + $c8,$8f,$6a,$d8,$2a,$4f,$b0,$8d, + $71,$ab,$47,$a0,$86,$e8,$6e,$ed, + $f3,$9d,$1c,$5b,$ba,$97,$c4,$08, + $01,$26,$14,$1d,$67,$f3,$7b,$e8, + $53,$8f,$5a,$8b,$e7,$40,$e4,$84); + +var + ct: array[0..255] of byte; +begin + writeln; + writeln('============================='); + writeln('NIST SP 800-38A OFB/AES tests'); + Err := AES_OFB_Init(key128, 128, IV, context); + Err := AES_OFB_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.4.1 OFB-AES128.Encrypt - OK: ',CompMem(@ct1, @ct, sizeof(ct1))); + + Err := AES_OFB_Init(key128, 128, IV, context); + Err := AES_OFB_Decrypt(@ct1, @ct, sizeof(ct1), context); + CheckError; + writeln('Test F.4.2 OFB-AES128.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_OFB_Init(key192, 192, IV, context); + Err := AES_OFB_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.4.3 OFB-AES192.Encrypt - OK: ',CompMem(@ct2, @ct, sizeof(ct2))); + + Err := AES_OFB_Init(key192, 192, IV, context); + Err := AES_OFB_Decrypt(@ct2, @ct, sizeof(ct3), context); + CheckError; + writeln('Test F.4.4 OFB-AES192.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + + Err := AES_OFB_Init(key256, 256, IV, context); + Err := AES_OFB_Encrypt(@plain, @ct, sizeof(plain), context); + CheckError; + writeln('Test F.4.5 OFB-AES256.Encrypt - OK: ',CompMem(@ct3, @ct, sizeof(ct3))); + + Err := AES_OFB_Init(key256, 256, IV, context); + Err := AES_OFB_Decrypt(@ct3, @ct, sizeof(ct3), context); + CheckError; + writeln('Test F.4.6 OFB-AES256.Decrypt - OK: ',CompMem(@plain, @ct, sizeof(plain))); + +end; + +begin + SimpleTests; + NistTests; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_aestab.pas b/Tocsg.Lib/VCL/EncLib/AES/t_aestab.pas new file mode 100644 index 00000000..93b58815 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_aestab.pas @@ -0,0 +1,226 @@ +program t_aestab; + +(************************************************************************* + + DESCRIPTION : Calculate static AES tables + + REQUIREMENTS : TP5-7, D1-D7/D9-D10, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [1] http://csrc.nist.gov/fips/fips-197.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 1.00 17.09.03 we Init version + 1.01 18.09.03 we duplicate GF routines and rotword + 1.10 05.10.03 we STD.INC, TP5-6 + 1.20 09.01.04 we Sbox is calculated, uses only mem_util + 1.21 11.04.04 we D7, {$apptype console} if needed + 1.22 27.17.04 we Te0..Te4, Td0..Td4 +**************************************************************************) + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + mem_util; + +type + bytearray = array[byte] of byte; + longarray = array[byte] of longint; + + +{encr} +var + SBox: bytearray; + Te0,Te1,Te2,Te3,Te4: longarray; + +{decr} +var + InvSBox: bytearray; + GLog, GPow: bytearray; + Td0,Td1,Td2,Td3,Td4: longarray; + + +{---------------------------------------------------------------------------} +procedure CalcBaseTables; + {-Calculate dynamic tables: power, log} +var + i, p: byte; +begin + {Power/Log tables} + p := 1; + for i:=0 to 254 do begin + GPow[i] := p; + GLog[p] := i; + if p and $80 = 0 then p := (p shl 1) xor p + else p := (p shl 1) xor p xor $1B; + end; + GPow[255] := 1; +end; + + +{---------------------------------------------------------------------------} +function GMul(x,y: byte): byte; + {-calculate x*y in GF(2^8)} +var + i: word; +begin + if (x=0) or (y=0) then GMul := 0 + else begin + i := word(GLog[x])+word(GLog[y]); + if i>=255 then dec(i,255); + GMul := GPow[i]; + end; +end; + + +{---------------------------------------------------------------------------} +function GM32(x,y: byte): longint; + {-calculate x*y in GF(2^8) result as longint} +begin + GM32 := GMul(x,y); +end; + + +{---------------------------------------------------------------------------} +procedure RotWord(var w: longint); + {-rotate AES word} +type + TBA4 = packed array[0..3] of byte; +var + b: TBA4 absolute w; + t: byte; +begin + t := b[0]; + b[0] := b[1]; + b[1] := b[2]; + b[2] := b[3]; + b[3] := t; +end; + + +{---------------------------------------------------------------------------} +procedure CalcEncrTables; + {-Calculate dynamic encr tables Te0..Te4, SBox} +var + i, p: byte; + t: longint; + + function rot(b,n: byte): byte; + begin + rot := (b shr n) xor (b shl (8-n)); + end; + +begin + for i:=0 to 255 do begin + end; + for i:=0 to 255 do begin + {SBox calculation, cf. [1] 5.1.1} + if i=0 then p:=0 else p:=GPow[255-GLog[i]]; {p*i = 1} + p := p xor rot(p,4) xor rot(p,5) xor rot(p,6) xor rot(p,7) xor $63; + Sbox[i] := p; + Te4[i] := $01010101*p; + {Tex tables} + t := GM32(2,p) or (longint(p) shl 8) or (longint(p) shl 16) or (GM32(3,p) shl 24); + Te0[i] := t; + RotWord(t); + Te3[i] := t; + RotWord(t); + Te2[i] := t; + RotWord(t); + Te1[i] := t; + end; +end; + + +{---------------------------------------------------------------------------} +procedure CalcDecrTables; + {-Calculate dynamic decr. tables: Td0..Td4, inverse SBox} +var + i, p: byte; + t: longint; +begin + {InvSBox} + for i:=0 to 255 do InvSBox[SBox[i]] := i; + {Tdx tables} + for i:=0 to 255 do begin + p := InvSBox[i]; + Td4[i] := $01010101*p; + t := GM32(14,p) or (GM32(9,p) shl 8) or (GM32(13,p) shl 16) or (GM32(11,p) shl 24); + Td0[i] := t; + RotWord(t); + Td3[i] := t; + RotWord(t); + Td2[i] := t; + RotWord(t); + Td1[i] := t; + end; +end; + + +{---------------------------------------------------------------------------} +procedure DumpByteTab(VName: string; var BA: bytearray); + {-dump an array of bytes} +var + i: integer; +begin + writeln; + writeln(VName, ': array[byte] of byte = ('); + for i:= 0 to 255 do begin + write(' $',HexByte(BA[i])); + if i=255 then writeln(');') + else if i and 15 = 15 then writeln(',') + else write(','); + end; +end; + + +{---------------------------------------------------------------------------} +procedure DumpLongTab(VName: string; var LA: longarray); + {-dump an array of longint} +var + i: integer; +begin + writeln; + writeln(VName, ': array[byte] of longint = ('); + for i:= 0 to 255 do begin + write(' $',HexLong(LA[i])); + if i=255 then writeln(');') + else if i and 7 = 7 then writeln(',') + else write(','); + end; +end; + + +begin + CalcBaseTables; + CalcEncrTables; + CalcDecrTables; + DumpByteTab('GLog', GLog); + DumpByteTab('GPow', GPow); + DumpByteTab('SBox', SBox); + DumpByteTab('InvSBox', InvSBox); + DumpLongTab('Te0', Te0); + DumpLongTab('Te1', Te1); + DumpLongTab('Te2', Te2); + DumpLongTab('Te3', Te3); + DumpLongTab('Te4', Te4); + DumpLongTab('Td0', Td0); + DumpLongTab('Td1', Td1); + DumpLongTab('Td2', Td2); + DumpLongTab('Td3', Td3); + DumpLongTab('Td4', Td4); +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_cbccts.pas b/Tocsg.Lib/VCL/EncLib/AES/t_cbccts.pas new file mode 100644 index 00000000..35095dea --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_cbccts.pas @@ -0,0 +1,198 @@ +{-Test prog for AES CBC cipher text stealing, we Sep.2003} + +program T_CBCCTS; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + {$ifdef USEDLL} + {$ifdef VirtualPascal} + AES_Intv, + {$else} + AES_Intf, + {$endif} + {$else} + aes_type, aes_cbc, + {$endif} + mem_util; + + +const + BSIZE = $400; + +var + Context: TAESContext; + pt, pt0, ct, ct0, pd: array[1..BSIZE+2] of byte; + + +{RFC 3962 Advanced Encryption Standard (AES) Encryption for Kerberos 5} +{Appendix B. Sample Test Vectors} + +const + key128 : array[0..15] of byte = ($63,$68,$69,$63,$6b,$65,$6e,$20, + $74,$65,$72,$69,$79,$61,$6b,$69); + + IV : TAESBlock = ($00,$00,$00,$00,$00,$00,$00,$00, + $00,$00,$00,$00,$00,$00,$00,$00); + + pt1: array[0..16] of byte = ($49,$20,$77,$6f,$75,$6c,$64,$20, + $6c,$69,$6b,$65,$20,$74,$68,$65, + $20); + + ct1: array[0..16] of byte = ($c6,$35,$35,$68,$f2,$bf,$8c,$b4, + $d8,$a5,$80,$36,$2d,$a7,$ff,$7f, + $97); + + + pt2: array[0..30] of byte = ($49,$20,$77,$6f,$75,$6c,$64,$20, + $6c,$69,$6b,$65,$20,$74,$68,$65, + $20,$47,$65,$6e,$65,$72,$61,$6c, + $20,$47,$61,$75,$27,$73,$20); + + ct2: array[0..30] of byte = ($fc,$00,$78,$3e,$0e,$fd,$b2,$c1, + $d4,$45,$d4,$c8,$ef,$f7,$ed,$22, + $97,$68,$72,$68,$d6,$ec,$cc,$c0, + $c0,$7b,$25,$e2,$5e,$cf,$e5); + + + pt3: array[0..31] of byte = ($49,$20,$77,$6f,$75,$6c,$64,$20, + $6c,$69,$6b,$65,$20,$74,$68,$65, + $20,$47,$65,$6e,$65,$72,$61,$6c, + $20,$47,$61,$75,$27,$73,$20,$43); + + ct3: array[0..31] of byte = ($39,$31,$25,$23,$a7,$86,$62,$d5, + $be,$7f,$cb,$cc,$98,$eb,$f5,$a8, + $97,$68,$72,$68,$d6,$ec,$cc,$c0, + $c0,$7b,$25,$e2,$5e,$cf,$e5,$84); + + + pt4: array[0..46] of byte = ($49,$20,$77,$6f,$75,$6c,$64,$20, + $6c,$69,$6b,$65,$20,$74,$68,$65, + $20,$47,$65,$6e,$65,$72,$61,$6c, + $20,$47,$61,$75,$27,$73,$20,$43, + $68,$69,$63,$6b,$65,$6e,$2c,$20, + $70,$6c,$65,$61,$73,$65,$2c); + + ct4: array[0..46] of byte = ($97,$68,$72,$68,$d6,$ec,$cc,$c0, + $c0,$7b,$25,$e2,$5e,$cf,$e5,$84, + $b3,$ff,$fd,$94,$0c,$16,$a1,$8c, + $1b,$55,$49,$d2,$f8,$38,$02,$9e, + $39,$31,$25,$23,$a7,$86,$62,$d5, + $be,$7f,$cb,$cc,$98,$eb,$f5); + + + + pt5: array[0..47] of byte = ($49,$20,$77,$6f,$75,$6c,$64,$20, + $6c,$69,$6b,$65,$20,$74,$68,$65, + $20,$47,$65,$6e,$65,$72,$61,$6c, + $20,$47,$61,$75,$27,$73,$20,$43, + $68,$69,$63,$6b,$65,$6e,$2c,$20, + $70,$6c,$65,$61,$73,$65,$2c,$20); + + ct5: array[0..47] of byte = ($97,$68,$72,$68,$d6,$ec,$cc,$c0, + $c0,$7b,$25,$e2,$5e,$cf,$e5,$84, + $9d,$ad,$8b,$bb,$96,$c4,$cd,$c0, + $3b,$c1,$03,$e1,$a1,$94,$bb,$d8, + $39,$31,$25,$23,$a7,$86,$62,$d5, + $be,$7f,$cb,$cc,$98,$eb,$f5,$a8); + + + +{---------------------------------------------------------------------------} +procedure RFC_Test; + {-Test with known vectors} + procedure SingleTest(pp,pc: pointer; lt,n: word); + var + cmp: boolean; + begin + if AES_CBC_Init_Encr(key128, 128, IV, context)<>0 then begin + writeln('*** Error CBC_Init'); + exit; + end; + if AES_CBC_Encrypt(pp, @ct, lt, context)<>0 then begin + writeln('*** Error CBC'); + exit; + end; + cmp := compmem(@ct,pc,lt); + write('Test vector ',n,': ',cmp:6); + {if lt multiple of block size results must not compare} + if (lt mod AESBLKSIZE=0) <> cmp then writeln(' OK') + else writeln('Error'); + end; + +begin + SingleTest(@pt1,@ct1,sizeof(pt1),1); + SingleTest(@pt2,@ct2,sizeof(pt2),2); + SingleTest(@pt3,@ct3,sizeof(pt3),3); + SingleTest(@pt4,@ct4,sizeof(pt4),4); + SingleTest(@pt5,@ct5,sizeof(pt5),5); +end; + + +{---------------------------------------------------------------------------} +procedure Rand_Test; + {-Test with random plain text} +var + n,Err: integer; +begin + + randmem(@pt0, sizeof(pt0)); + pt := pt0; + + for n:=1 to BSIZE do begin + if AES_CBC_Init_Encr(key128, 128, IV, context)<>0 then begin + writeln('*** Error CBC_Init_Encr'); + exit; + end; + Err := AES_CBC_Encrypt(@pt, @ct, n, context); + if not compmem(@pt,@pt0,n+2) then begin + writeln('Encr: src overwrite, n: ',n); + halt; + end; + if Err=0 then begin + ct0 := ct; + if AES_CBC_Init_Decr(key128, 128, IV, context)<>0 then begin + writeln('*** Error CBC_Init_Decr'); + exit; + end; + Err := AES_CBC_Decrypt(@ct, @pd, n, context); + if Err=0 then begin + if not CompMem(@pt, @pd, n) then writeln(n:6, ' Diff'); + end; + if not compmem(@ct,@ct0,n+2) then begin + writeln('Decr: src overwrite, n: ',n); + halt; + end; + end; + if Err<>0 then begin + write(n:6, ' Error: ', Err); + if (n0 then begin + writeln('AES_CMAC_Init Error'); + halt; + end; + if AES_CMAC_Update(@msg, ML, ctx)<>0 then begin + writeln('AES_CMAC_Update'); + halt; + end; + AES_CMAC_Final(tag, ctx); + write(Res[CompMem(@tag, @st, sizeof(tag))]:8); + if AES_CMAC_Init(key, KL, ctx)<>0 then begin + writeln('AES_CMAC_Init Error'); + halt; + end; + for i:=1 to ML do begin + if AES_CMAC_Update(@msg[i-1], 1, ctx)<>0 then begin + writeln('AES_CMAC_Update'); + halt; + end; + end; + AES_CMAC_Final(tag, ctx); + writeln(Res[CompMem(@tag, @st, sizeof(tag))]:8); +end; + +begin + writeln('Test program AES CMAC mode (C) 2004-2006 W.Ehrhardt'); + {$ifdef USEDLL} + writeln('DLL Version: ',AES_DLL_Version); + {$endif} + writeln('KL/ML: Key/Message length in bits/bytes'); + writeln('Single/Multi: process message with one/multiple call(s)'); + writeln(' KL/ML Single Multi'); + Test(key128, 128, 0, tag00, ' 128/00'); + Test(key128, 128, 16, tag01, ' 128/16'); + Test(key128, 128, 40, tag02, ' 128/40'); + Test(key128, 128, 64, tag03, ' 128/64'); + + Test(key192, 192, 0, tag10, ' 192/00'); + Test(key192, 192, 16, tag11, ' 192/16'); + Test(key192, 192, 40, tag12, ' 192/40'); + Test(key192, 192, 64, tag13, ' 192/64'); + + Test(key256, 256, 0, tag20, ' 256/00'); + Test(key256, 256, 16, tag21, ' 256/16'); + Test(key256, 256, 40, tag22, ' 256/40'); + Test(key256, 256, 64, tag23, ' 256/64'); +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_cprf.pas b/Tocsg.Lib/VCL/EncLib/AES/t_cprf.pas new file mode 100644 index 00000000..fccf1662 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_cprf.pas @@ -0,0 +1,19 @@ +{-Test program for aes_cprf, (c) we 05.2007} + +program T_CPRF; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_cprf; + +begin + writeln('Selftest AES CMAC PRF-128: ', AES_CPRF128_selftest); +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_eax2.pas b/Tocsg.Lib/VCL/EncLib/AES/t_eax2.pas new file mode 100644 index 00000000..428339a0 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_eax2.pas @@ -0,0 +1,142 @@ +{-Test prog for EAX, we AUg.2008} +{ 1. Reproduce AES part of Tom St Denis' EAX_TV.TXT} +{ 2. All-in-one EAX functions for message length >= 60K} + +program T_EAX2; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + AES_Type, AES_EAX, Mem_Util; + + +var + print: boolean; + +{---------------------------------------------------------------------------} +procedure test; + {-Reproduce AES part of Tom St Denis' EAX_TV.TXT} +const + hex32: array[1..32] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17, + $18,$19,$1a,$1b,$1c,$1d,$1e,$1f); + buf32: array[0..31] of byte = ($64,$d8,$42,$b6,$67,$96,$a7,$97, + $c2,$b4,$c6,$90,$57,$42,$fd,$f2, + $14,$8f,$fc,$44,$5e,$19,$2f,$9e, + $03,$b5,$38,$10,$c0,$82,$f7,$88); + + tag32: array[0..15] of byte = ($97,$78,$b3,$45,$ec,$12,$d2,$22, + $dc,$c6,$db,$ab,$d2,$65,$17,$50); +var + err,n: integer; + ctx: TAES_EAXContext; + key, tag: TAESBlock; + buf: array[0..63] of byte; +begin + writeln('Reproduce AES part of Tom St Denis'' EAX_TV.TXT'); + {Uppercase from HexStr} + HexUpper := true; + {Initial key from hex32} + move(hex32, key, sizeof(key)); + for n:=0 to 32 do begin + err := AES_EAX_Init(key, 128, hex32, n, ctx); + if err=0 then err := AES_EAX_Provide_Header(@hex32,n,ctx); + if err=0 then err := AES_EAX_Encrypt(@hex32, @buf, n, ctx); + if err=0 then begin + AES_EAX_Final(tag, ctx); + if print then writeln(n:3,': ', HexStr(@buf,n), ', ', HexStr(@tag,16)); + {key for step n>1 is the tag of the previous step repeated} + key := tag; + end + else begin + writeln('Error ',err); + exit; + end; + end; + {compare final values} + writeln('buf32 compares: ', compmem(@buf32, @buf, sizeof(buf32))); + writeln('tag32 compares: ', compmem(@tag32, @tag, sizeof(tag32))); +end; + +{$ifndef BIT16} +const + PAKETSIZE = $23456; +{$else} +const + PAKETSIZE = $F000; +{$endif} + + +{---------------------------------------------------------------------------} +procedure testallin1; +type + tpaket=array[1..PAKETSIZE] of byte; + ppaket=^ tpaket; +var + pt,ct: ppaket; + tag: TAESBlock; + i: longint; + err: integer; +const + key: array[1..16] of byte = ($91, $94, $5d, $3f, $4d, $cb, $ee, $0b, + $f4, $5e, $f5, $22, $55, $f0, $95, $a4); + non: array[1..16] of byte = ($be, $ca, $f0, $43, $b0, $a2, $3d, $84, + $31, $94, $ba, $97, $2c, $66, $de, $bd); + hdr: array[1..08] of byte = ($fa, $3b, $fd, $48, $06, $eb, $53, $fa); +begin + writeln('Test all-in-one EAX functions for large message length: ',PAKETSIZE); + new(pt); + new(ct); + for i:=1 to PAKETSIZE do begin + pt^[i] := i and $ff; + ct^[i] := (i and $ff) xor $ff; + end; + err := AES_EAX_Enc_Auth(tag,Key,128,non,sizeof(non),@hdr,sizeof(hdr),pt,PAKETSIZE,ct); + if err<>0 then writeln('Error from AES_EAX_Enc_Auth: ', err) + else begin + err := AES_EAX_Dec_Veri(@tag,sizeof(tag),key,128,non,sizeof(non),@hdr,sizeof(hdr),ct,PAKETSIZE,ct); + if err<>0 then writeln('Error from AES_EAX_Dec_Veri: ', err) + else begin + {change ciphertest, veri should fail and plaintext should be untouched} + ct^[2] := ct^[2] xor $ff; + ct^[PAKETSIZE-1] := ct^[PAKETSIZE-1] xor $ff; + err := AES_EAX_Dec_Veri(@tag,sizeof(tag),key,128,non,sizeof(non),@hdr,sizeof(hdr),ct,PAKETSIZE,pt); + if err=AES_Err_EAX_Verify_Tag then begin + err := 0; + for i:=1 to PAKETSIZE do begin + if pt^[i] <> (i and $ff) then err := 42; + end; + if err<>0 then writeln('Verification failed BUT decryption done!'); + end + else writeln('Detection of change in ciphertext failed!'); + end; + end; + if err=0 then writeln('OK'); + dispose(pt); + dispose(ct); +end; + + +var + {$ifdef D12Plus} + s: string; + {$else} + s: string[10]; + {$endif} + i: integer; +begin + s := paramstr(1); + for i:=1 to length(s) do s[i] := upcase(s[i]); + print := s<>'TEST'; + test; + writeln; + testallin1; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_ecbcts.pas b/Tocsg.Lib/VCL/EncLib/AES/t_ecbcts.pas new file mode 100644 index 00000000..1995b0ad --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_ecbcts.pas @@ -0,0 +1,62 @@ +{-Test prog for AES ECB cipher text stealing, we Sep.2003} + +program T_ECBCTS; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + aes_type, aes_ECB, mem_util; + + +const + BSIZE = $400; + +var + Context: TAESContext; + i,n,Err: integer; + pt, pt0, ct, ct0, pd: array[1..BSIZE+2] of byte; + +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); +begin + writeln; + writeln('====================================='); + writeln('Test for AES-ECB cipher text stealing'); + + for i:=1 to BSIZE do pt0[i] := random(256); + pt := pt0; + + for n:=1 to BSIZE do begin + Err := AES_ECB_Init_Encr(key128, 128, context); + Err := Err or AES_ECB_Encrypt(@pt, @ct, n, context); + if not compmem(@pt,@pt0,n+2) then begin + writeln('Encr: src overwrite, n: ',n); + halt; + end; + if Err=0 then begin + ct0 := ct; + Err := AES_ECB_Init_Decr(key128, 128, context); + Err := Err or AES_ECB_Decrypt(@ct, @pd, n, context); + if Err=0 then begin + if not CompMem(@pt, @pd, n) then writeln(n:6, ' Diff'); + end; + if not compmem(@ct,@ct0,n+2) then begin + writeln('Decr: src overwrite, n: ',n); + halt; + end; + end; + if Err<>0 then begin + write(n:6, ' Error: ', Err); + if (n0 then writeln(n:6, ' Error: ', Err); + end; + if GErr=0 then writeln(' OK.'); +end; + + +{---------------------------------------------------------------------------} +procedure Test_CFB; +var + i,n: integer; +begin + GErr := 0; + writeln('- CFB with full blocks first'); + + for i:=1 to BSIZE do pt0[i] := random(256); + pt := pt0; + + for n:=1 to BSIZE do begin + Err := AES_CFB_Init(key128, 128, IV, context); + Err := AES_CFB_Encrypt(@pt, @ct, n, context); + GErr:= GErr or Err; + if not compmem(@pt,@pt0,n+EXT) then begin + writeln(' Encr: src overwrite, n: ',n); + halt; + end; + if Err=0 then begin + ct0 := ct; + Err := AES_CFB_Init(key128, 128, IV, context); + Err := AES_CFB_Decrypt(@ct, @pd, n, context); + GErr:= GErr or Err; + if Err=0 then begin + if not CompMem(@pt, @pd, n) then writeln(' Diff:', n:6); + end; + if not compmem(@ct,@ct0,n+EXT) then begin + writeln(' Decr: src overwrite, n: ',n); + halt; + end; + end; + if Err<>0 then writeln(n:6, ' Error: ', Err); + end; + if GErr=0 then writeln(' OK.'); +end; + + +{---------------------------------------------------------------------------} +procedure Test_OFB; +var + i,n: integer; +begin + GErr := 0; + writeln('- OFB with full blocks first'); + + for i:=1 to BSIZE do pt0[i] := random(256); + pt := pt0; + + for n:=1 to BSIZE do begin + Err := AES_OFB_Init(key128, 128, IV, context); + Err := AES_OFB_Encrypt(@pt, @ct, n, context); + GErr:= GErr or Err; + if not compmem(@pt,@pt0,n+EXT) then begin + writeln(' Encr: src overwrite, n: ',n); + halt; + end; + if Err=0 then begin + ct0 := ct; + Err := AES_OFB_Init(key128, 128, IV, context); + Err := AES_OFB_Decrypt(@ct, @pd, n, context); + GErr:= GErr or Err; + if Err=0 then begin + if not CompMem(@pt, @pd, n) then writeln(' Diff:', n:6); + end; + if not compmem(@ct,@ct0,n+EXT) then begin + writeln(' Decr: src overwrite, n: ',n); + halt; + end; + end; + if Err<>0 then writeln(n:6, ' Error: ', Err); + end; + if GErr=0 then writeln(' OK.'); +end; + + +begin + writeln; + writeln('Test AES CTR/CFB/OFB with full blocks first, WE Jan.2004'); + Test_CTR; + Test_CFB; + Test_OFB; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_gsp128.pas b/Tocsg.Lib/VCL/EncLib/AES/t_gsp128.pas new file mode 100644 index 00000000..941e1e95 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_gsp128.pas @@ -0,0 +1,218 @@ +{-Test program to measure AES encr/decr speed for 128 bit keys, we 07.2006} +{ displays alignment info for compressed encryption table (if available)} + +program t_gsp128; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +{$ifndef FPC} + {$N+} +{$endif} + +{$ifdef X_Opt} + {$x+} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + AES_Type, AES_Encr, AES_Decr, hrtimer; + +{$i aes_conf.inc} + +const + LOOPS = 100; + +var + ctx: TAESContext; + key: array[0..31] of byte; + ct : TAESBlock; + pt : TAESBlock; + + + +{---------------------------------------------------------------------------} +procedure RandFill(var block; size: word); +var + ba: array[1..$F000] of byte absolute block; + i: word; +begin + for i:=1 to size do ba[i] := random(256); +end; + + +{---------------------------------------------------------------------------} +function EncrCycles(keybits: word): longint; +var + i: integer; + cyc0, cyc1, cyc2: comp; + t1,t2,c1,c2: longint; +begin + RandFill(key, sizeof(key)); + RandFill(pt, sizeof(pt)); + i := AES_Init_Encr(Key, KeyBits, ctx); + if i<>0 then begin + writeln('Error AES_Init_Encr'); + halt; + end; + AES_Encrypt(ctx, pt, ct); + c1 := MaxLongint; + c2 := MaxLongint; + for i:=1 to LOOPS do begin + RandFill(pt, sizeof(pt)); + ReadTSC(cyc0); + AES_Encrypt(ctx, pt, ct); + ReadTSC(cyc1); + AES_Encrypt(ctx, ct, ct); + AES_Encrypt(ctx, ct, ct); + AES_Encrypt(ctx, ct, ct); + AES_Encrypt(ctx, ct, ct); + AES_Encrypt(ctx, ct, ct); + ReadTSC(cyc2); + t2 := round(cyc2-cyc1); + t1 := round(cyc1-cyc0); + if t10 then begin + writeln('Error AES_Init_Decr'); + halt; + end; + AES_Decrypt(ctx, pt, ct); + AES_Decrypt(ctx, pt, ct); + c1 := MaxLongint; + c2 := MaxLongint; + for i:=1 to LOOPS do begin + RandFill(pt, sizeof(pt)); + ReadTSC(cyc0); + AES_Decrypt(ctx, pt, ct); + ReadTSC(cyc1); + AES_Decrypt(ctx, ct, ct); + AES_Decrypt(ctx, ct, ct); + AES_Decrypt(ctx, ct, ct); + AES_Decrypt(ctx, ct, ct); + AES_Decrypt(ctx, ct, ct); + ReadTSC(cyc2); + t2 := round(cyc2-cyc1); + t1 := round(cyc1-cyc0); + if t10 then begin + writeln('Error AES_Init_Encr'); + halt; + end; + for i:=1 to LOOPS do begin + RandFill(key, sizeof(key)); + ReadTSC(cyc0); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + ReadTSC(cyc1); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + ReadTSC(cyc2); + t2 := round(cyc2-cyc1); + t1 := round(cyc1-cyc0); + if t10 then begin + writeln('Error AES_Init_Encr'); + halt; + end; + for i:=1 to LOOPS do begin + RandFill(key, sizeof(key)); + ReadTSC(cyc0); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + ReadTSC(cyc1); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + ReadTSC(cyc2); + t2 := round(cyc2-cyc1); + t1 := round(cyc1-cyc0); + if t10 then begin + writeln('Error AES_Init_Encr'); + halt; + end; + AES_Encrypt(ctx, pt, ct); + c1 := MaxLongint; + c2 := MaxLongint; + for i:=1 to LOOPS do begin + RandFill(pt, sizeof(pt)); + ReadTSC(cyc0); + AES_Encrypt(ctx, pt, ct); + ReadTSC(cyc1); + AES_Encrypt(ctx, ct, ct); + AES_Encrypt(ctx, ct, ct); + AES_Encrypt(ctx, ct, ct); + AES_Encrypt(ctx, ct, ct); + AES_Encrypt(ctx, ct, ct); + ReadTSC(cyc2); + t2 := round(cyc2-cyc1); + t1 := round(cyc1-cyc0); + if t10 then begin + writeln('Error AES_Init_Decr'); + halt; + end; + AES_Decrypt(ctx, pt, ct); + AES_Decrypt(ctx, pt, ct); + c1 := MaxLongint; + c2 := MaxLongint; + for i:=1 to LOOPS do begin + RandFill(pt, sizeof(pt)); + ReadTSC(cyc0); + AES_Decrypt(ctx, pt, ct); + ReadTSC(cyc1); + AES_Decrypt(ctx, ct, ct); + AES_Decrypt(ctx, ct, ct); + AES_Decrypt(ctx, ct, ct); + AES_Decrypt(ctx, ct, ct); + AES_Decrypt(ctx, ct, ct); + ReadTSC(cyc2); + t2 := round(cyc2-cyc1); + t1 := round(cyc1-cyc0); + if t10 then begin + writeln('Error AES_Init_Encr'); + halt; + end; + for i:=1 to LOOPS do begin + RandFill(key, sizeof(key)); + ReadTSC(cyc0); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + ReadTSC(cyc1); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Encr(Key, KeyBits, ctx); + ReadTSC(cyc2); + t2 := round(cyc2-cyc1); + t1 := round(cyc1-cyc0); + if t10 then begin + writeln('Error AES_Init_Encr'); + halt; + end; + for i:=1 to LOOPS do begin + RandFill(key, sizeof(key)); + ReadTSC(cyc0); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + ReadTSC(cyc1); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + {$ifndef X_Opt} j := {$endif} AES_Init_Decr(Key, KeyBits, ctx); + ReadTSC(cyc2); + t2 := round(cyc2-cyc1); + t1 := round(cyc1-cyc0); + if t10 then begin + writeln('AES_ECB_Init_Encr error: ', Err); + halt; + end; + for j:=0 to JMAX do begin + PT := CT; + Err := AES_ECB_Encrypt(@CT, @CT, 16, ctx); + if Err<>0 then begin + writeln('AES_ECB_Encrypt error: ', Err); + halt; + end; + end; + case kbits of + 128: for j:=0 to 15 do Key[j] := Key[j] xor CT[j]; + 192: begin + for j:=0 to 7 do Key[j] := Key[j] xor PT[8+j]; + for j:=0 to 15 do Key[j+8] := Key[j+8] xor CT[j]; + end; + 256: begin + for j:=0 to 15 do Key[j] := Key[j] xor PT[j]; + for j:=0 to 15 do Key[j+16] := Key[j+16] xor CT[j]; + end; + end; + end; + writeln(' ', ts=HexStr(@CT,16)); + end; + +const + CT128='A04377ABE259B0D0B5BA2D40A501971B'; + CT192='4E46F8C5092B29E29A971A0CD1F610FB'; + CT256='1F6763DF807A7E70960D4CD3118E601A'; +begin + writeln('ecb_e_m'); + TestBits(128, CT128); + TestBits(192, CT192); + TestBits(256, CT256); +end; + +{---------------------------------------------------------------------------} +procedure ECBDecr; + {-Reproduce ecb_d_m.txt} + + procedure TestBits(kbits: word; ts: BString); + {-generate part for keysize kbits} + var + i,j,Err: Integer; + PT, CT: TAESBlock; + Key: array[0..31] of byte; + ctx: TAESContext; + begin + write(kbits, ' bits '); + fillchar(Key, sizeof(Key), 0); + fillchar(PT, sizeof(PT), 0); + CT := PT; + for i:=0 to IMAX do begin + if i and 7 = 0 then write('.'); + Err := AES_ECB_Init_Decr(Key, kbits, ctx); + if Err<>0 then begin + writeln('AES_ECB_Init_Decr error: ', Err); + halt; + end; + for j:=0 to JMAX do begin + PT := CT; + Err := AES_ECB_Decrypt(@CT, @CT, 16, ctx); + if Err<>0 then begin + writeln('AES_ECB_Decrypt error: ', Err); + halt; + end; + end; + case kbits of + 128: for j:=0 to 15 do Key[j] := Key[j] xor CT[j]; + 192: begin + for j:=0 to 7 do Key[j] := Key[j] xor PT[8+j]; + for j:=0 to 15 do Key[j+8] := Key[j+8] xor CT[j]; + end; + 256: begin + for j:=0 to 15 do Key[j] := Key[j] xor PT[j]; + for j:=0 to 15 do Key[j+16] := Key[j+16] xor CT[j]; + end; + end; + end; + writeln(' ', ts=HexStr(@CT,16)); + end; + +const + PT128='F5BF8B37136F2E1F6BEC6F572021E3BA'; + PT192='F1A81B68F6E5A6271A8CB24E7D9491EF'; + PT256='4DE0C6DF7CB1697284604D60271BC59A'; +begin + writeln('ecb_d_m'); + TestBits(128, PT128); + TestBits(192, PT192); + TestBits(256, PT256); +end; + + +{---------------------------------------------------------------------------} +procedure CBCEncr; + {-Reproduce cbc_e_m.txt} + + procedure TestBits(kbits: word; ts: BString); + {-generate part for keysize kbits} + var + i,j,Err: Integer; + IV, PT, CT: TAESBlock; + Key: array[0..31] of byte; + ctx: TAESContext; + begin + write(kbits, ' bits '); + fillchar(Key, sizeof(Key), 0); + fillchar(PT, sizeof(PT), 0); + fillchar(IV, sizeof(IV), 0); + CT := PT; + for i:=0 to IMAX do begin + if i and 7 = 0 then write('.'); + Err := AES_CBC_Init_Encr(Key, kbits, IV, ctx); + if Err<>0 then begin + writeln('AES_CBC_Init_Encr error: ', Err); + halt; + end; + for j:=0 to JMAX do begin + CT := PT; + PT := ctx.IV; + Err := AES_CBC_Encrypt(@CT, @CT, 16, ctx); + if Err<>0 then begin + writeln('AES_CBC_Encrypt error: ', Err); + halt; + end; + end; + IV := CT; + case kbits of + 128: for j:=0 to 15 do Key[j] := Key[j] xor CT[j]; + 192: begin + for j:=0 to 7 do Key[j] := Key[j] xor PT[8+j]; + for j:=0 to 15 do Key[j+8] := Key[j+8] xor CT[j]; + end; + 256: begin + for j:=0 to 15 do Key[j] := Key[j] xor PT[j]; + for j:=0 to 15 do Key[j+16] := Key[j+16] xor CT[j]; + end; + end; + end; + writeln(' ',ts=HexStr(@CT,16)); + end; + +const + CT128='2F844CBF78EBA70DA7A49601388F1AB6'; + CT192='BA50C94440C04A8C0899D42658E25437'; + CT256='C0FEFFF07506A0B4CD7B8B0CF25D3664'; +begin + writeln('cbc_e_m'); + TestBits(128, CT128); + TestBits(192, CT192); + TestBits(256, CT256); +end; + + +{---------------------------------------------------------------------------} +procedure CBCDecr; + {-Reproduce cbc_d_m.txt} + + procedure TestBits(kbits: word; ts: BString); + {-generate part for keysize kbits} + var + i,j,Err: Integer; + IV, PT, CT: TAESBlock; + Key: array[0..31] of byte; + ctx: TAESContext; + begin + write(kbits, ' bits '); + fillchar(Key, sizeof(Key), 0); + fillchar(PT, sizeof(PT), 0); + fillchar(IV, sizeof(IV), 0); + for i:=0 to IMAX do begin + if i and 7 = 0 then write('.'); + CT := PT; + Err := AES_CBC_Init_Decr(Key, kbits, IV, ctx); + if Err<>0 then begin + writeln('AES_CBC_Init_Decr error: ', Err); + halt; + end; + PT := CT; + for j:=0 to JMAX do begin + CT := PT; + Err := AES_CBC_Decrypt(@PT, @PT, 16, ctx); + if Err<>0 then begin + writeln('AES_CBC_Decrypt error: ', Err); + halt; + end; + end; + IV := ctx.IV; + case kbits of + 128: for j:=0 to 15 do Key[j] := Key[j] xor PT[j]; + 192: begin + for j:=0 to 7 do Key[j] := Key[j] xor CT[8+j]; + for j:=0 to 15 do Key[j+8] := Key[j+8] xor PT[j]; + end; + 256: begin + for j:=0 to 15 do Key[j] := Key[j] xor CT[j]; + for j:=0 to 15 do Key[j+16] := Key[j+16] xor PT[j]; + end; + end; + end; + writeln(' ',ts=HexStr(@PT,16)); + end; + +const + PT128='9B8FB71E035CEFF9CBFA1346E5ACEFE0'; + PT192='6342BFDDD2F6610350458B6695463484'; + PT256='CD6429CF3F81F8B4F82BC627A8283096'; +begin + writeln('cbc_d_m'); + TestBits(128, PT128); + TestBits(192, PT192); + TestBits(256, PT256); +end; + + +begin + writeln('T_MCST - AES Monte Carlo Self Tests (c) 2006 W.Ehrhardt'); + HexUpper := true; + ECBEncr; + ECBDecr; + CBCEncr; + CBCDecr; +end. + diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_mctful.pas b/Tocsg.Lib/VCL/EncLib/AES/t_mctful.pas new file mode 100644 index 00000000..7692d24f --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_mctful.pas @@ -0,0 +1,374 @@ +{AES 'Monte Carlo Tests' from rijndael-vals.zip, we 06.2006} + +program T_MCTFUL; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +{$ifndef FPC} + {$N+} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + BTypes,aes_type,aes_base,aes_cbc,aes_ecb,mem_util; + + +var + logfile: text; + +const + IMAX = 399; + JMAX = 9999; + +{---------------------------------------------------------------------------} +procedure output({$ifdef CONST} const {$endif} s: str255); + {-writeln to logfile} +begin + writeln(logfile,s); +end; + + +{---------------------------------------------------------------------------} +function i2s(L: longint): str255; +var + s: string[20]; +begin + str(L,s); + i2s := s; +end; + + +{---------------------------------------------------------------------------} +procedure ECBEncr; + {-Reproduce ecb_e_m.txt} + + procedure TestBits(kbits: word); + {-generate part for keysize kbits} + var + i,j,Err: Integer; + PT, CT: TAESBlock; + Key: array[0..31] of byte; + ctx: TAESContext; + begin + write(kbits, ' bits '); + output('========================='); + output(''); + output('KEYSIZE='+i2s(kbits)); + output(''); + fillchar(Key, sizeof(Key), 0); + fillchar(PT, sizeof(PT), 0); + CT := PT; + for i:=0 to IMAX do begin + if i and 7 = 0 then write('.'); + Err := AES_ECB_Init_Encr(Key, kbits, ctx); + if Err<>0 then begin + writeln('AES_ECB_Init_Encr error: ', Err); + halt; + end; + output('I='+i2s(I)); + output('KEY='+HexStr(@Key, kbits div 8)); + output('PT='+HexStr(@CT,16)); + for j:=0 to JMAX do begin + PT := CT; + Err := AES_ECB_Encrypt(@CT, @CT, 16, ctx); + if Err<>0 then begin + writeln('AES_ECB_Encrypt error: ', Err); + halt; + end; + end; + output('CT='+HexStr(@CT,16)); + output(''); + case kbits of + 128: for j:=0 to 15 do Key[j] := Key[j] xor CT[j]; + 192: begin + for j:=0 to 7 do Key[j] := Key[j] xor PT[8+j]; + for j:=0 to 15 do Key[j+8] := Key[j+8] xor CT[j]; + end; + 256: begin + for j:=0 to 15 do Key[j] := Key[j] xor PT[j]; + for j:=0 to 15 do Key[j+16] := Key[j+16] xor CT[j]; + end; + end; + end; + writeln; + end; + +begin + assign(logfile, 'ecb_e_m.log'); + rewrite(logfile); + writeln('ecb_e_m.log'); + output(''); + output('========================='); + output(''); + output('FILENAME: "ecb_e_m.txt"'); + output(''); + output('Electronic Codebook (ECB) Mode - ENCRYPTION'); + output('Monte Carlo Test'); + output(''); + output('Algorithm Name: Rijndael'); + output('Principal Submitter: Joan Daemen'); + output(''); + TestBits(128); + TestBits(192); + TestBits(256); + output('==========='); + close(logfile); +end; + +{---------------------------------------------------------------------------} +procedure ECBDecr; + {-Reproduce ecb_d_m.txt} + + procedure TestBits(kbits: word); + {-generate part for keysize kbits} + var + i,j,Err: Integer; + PT, CT: TAESBlock; + Key: array[0..31] of byte; + ctx: TAESContext; + begin + write(kbits, ' bits '); + output('========================='); + output(''); + output('KEYSIZE='+i2s(kbits)); + output(''); + fillchar(Key, sizeof(Key), 0); + fillchar(PT, sizeof(PT), 0); + CT := PT; + for i:=0 to IMAX do begin + if i and 7 = 0 then write('.'); + Err := AES_ECB_Init_Decr(Key, kbits, ctx); + if Err<>0 then begin + writeln('AES_ECB_Init_Decr error: ', Err); + halt; + end; + output('I='+i2s(I)); + output('KEY='+HexStr(@Key, kbits div 8)); + output('CT='+HexStr(@CT,16)); + for j:=0 to JMAX do begin + PT := CT; + Err := AES_ECB_Decrypt(@CT, @CT, 16, ctx); + if Err<>0 then begin + writeln('AES_ECB_Decrypt error: ', Err); + halt; + end; + end; + output('PT='+HexStr(@CT,16)); + output(''); + case kbits of + 128: for j:=0 to 15 do Key[j] := Key[j] xor CT[j]; + 192: begin + for j:=0 to 7 do Key[j] := Key[j] xor PT[8+j]; + for j:=0 to 15 do Key[j+8] := Key[j+8] xor CT[j]; + end; + 256: begin + for j:=0 to 15 do Key[j] := Key[j] xor PT[j]; + for j:=0 to 15 do Key[j+16] := Key[j+16] xor CT[j]; + end; + end; + end; + writeln; + end; + +begin + assign(logfile, 'ecb_d_m.log'); + rewrite(logfile); + writeln('ecb_d_m.log'); + output(''); + output('========================='); + output(''); + output('FILENAME: "ecb_d_m.txt"'); + output(''); + output('Electronic Codebook (ECB) Mode - DECRYPTION'); + output('Monte Carlo Test'); + output(''); + output('Algorithm Name: Rijndael'); + output('Principal Submitter: Joan Daemen'); + output(''); + TestBits(128); + TestBits(192); + TestBits(256); + output('==========='); + close(logfile); +end; + + +{---------------------------------------------------------------------------} +procedure CBCEncr; + {-Reproduce cbc_e_m.txt} + + procedure TestBits(kbits: word); + {-generate part for keysize kbits} + var + i,j,Err: Integer; + IV, PT, CT: TAESBlock; + Key: array[0..31] of byte; + ctx: TAESContext; + begin + write(kbits, ' bits '); + output('=========='); + output(''); + output('KEYSIZE='+i2s(kbits)); + output(''); + fillchar(Key, sizeof(Key), 0); + fillchar(PT, sizeof(PT), 0); + fillchar(IV, sizeof(IV), 0); + CT := PT; + for i:=0 to IMAX do begin + if i and 7 = 0 then write('.'); + Err := AES_CBC_Init_Encr(Key, kbits, IV, ctx); + if Err<>0 then begin + writeln('AES_CBC_Init_Encr error: ', Err); + halt; + end; + output('I='+i2s(I)); + output('KEY='+HexStr(@Key, kbits div 8)); + output('IV='+HexStr(@IV,16)); + output('PT='+HexStr(@PT,16)); + for j:=0 to JMAX do begin + CT := PT; + PT := ctx.IV; + Err := AES_CBC_Encrypt(@CT, @CT, 16, ctx); + if Err<>0 then begin + writeln('AES_CBC_Encrypt error: ', Err); + halt; + end; + end; + IV := CT; + output('CT='+HexStr(@CT,16)); + output(''); + case kbits of + 128: for j:=0 to 15 do Key[j] := Key[j] xor CT[j]; + 192: begin + for j:=0 to 7 do Key[j] := Key[j] xor PT[8+j]; + for j:=0 to 15 do Key[j+8] := Key[j+8] xor CT[j]; + end; + 256: begin + for j:=0 to 15 do Key[j] := Key[j] xor PT[j]; + for j:=0 to 15 do Key[j+16] := Key[j+16] xor CT[j]; + end; + end; + end; + writeln; + end; + +begin + assign(logfile, 'cbc_e_m.log'); + rewrite(logfile); + writeln('cbc_e_m.log'); + output(''); + output('========================='); + output(''); + output('FILENAME: "cbc_e_m.txt"'); + output(''); + output('Cipher Block Chaining (CBC) Mode - ENCRYPTION'); + output('Monte Carlo Test'); + output(''); + output('Algorithm Name: Rijndael'); + output('Principal Submitter: Joan Daemen'); + output(''); + TestBits(128); + TestBits(192); + TestBits(256); + output('==========='); + close(logfile); +end; + + +{---------------------------------------------------------------------------} +procedure CBCDecr; + {-Reproduce cbc_d_m.txt} + + procedure TestBits(kbits: word); + {-generate part for keysize kbits} + var + i,j,Err: Integer; + IV, PT, CT: TAESBlock; + Key: array[0..31] of byte; + ctx: TAESContext; + begin + write(kbits, ' bits '); + output('=========='); + output(''); + output('KEYSIZE='+i2s(kbits)); + output(''); + fillchar(Key, sizeof(Key), 0); + fillchar(PT, sizeof(PT), 0); + fillchar(IV, sizeof(IV), 0); + for i:=0 to IMAX do begin + if i and 7 = 0 then write('.'); + CT := PT; + Err := AES_CBC_Init_Decr(Key, kbits, IV, ctx); + if Err<>0 then begin + writeln('AES_CBC_Init_Decr error: ', Err); + halt; + end; + output('I='+i2s(I)); + output('KEY='+HexStr(@Key, kbits div 8)); + output('IV='+HexStr(@IV,16)); + output('CT='+HexStr(@CT,16)); + PT := CT; + for j:=0 to JMAX do begin + CT := PT; + Err := AES_CBC_Decrypt(@PT, @PT, 16, ctx); + if Err<>0 then begin + writeln('AES_CBC_Decrypt error: ', Err); + halt; + end; + end; + IV := ctx.IV; + output('PT='+HexStr(@PT,16)); + output(''); + case kbits of + 128: for j:=0 to 15 do Key[j] := Key[j] xor PT[j]; + 192: begin + for j:=0 to 7 do Key[j] := Key[j] xor CT[8+j]; + for j:=0 to 15 do Key[j+8] := Key[j+8] xor PT[j]; + end; + 256: begin + for j:=0 to 15 do Key[j] := Key[j] xor CT[j]; + for j:=0 to 15 do Key[j+16] := Key[j+16] xor PT[j]; + end; + end; + end; + writeln; + end; + +begin + assign(logfile, 'cbc_d_m.log'); + rewrite(logfile); + writeln('cbc_d_m.log'); + output(''); + output('========================='); + output(''); + output('FILENAME: "cbc_d_m.txt"'); + output(''); + output('Cipher Block Chaining (CBC) Mode - DECRYPTION'); + output('Monte Carlo Test'); + output(''); + output('Algorithm Name: Rijndael'); + output('Principal Submitter: Joan Daemen'); + output(''); + TestBits(128); + TestBits(192); + TestBits(256); + output('==========='); + close(logfile); +end; + + +begin + writeln('T_MCTFUL - Full Monte Carlo Tests to .LOG (c) 2006 W.Ehrhardt'); + HexUpper := true; + ECBEncr; + ECBDecr; + CBCEncr; + CBCDecr; +end. + diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_mkctab.pas b/Tocsg.Lib/VCL/EncLib/AES/t_mkctab.pas new file mode 100644 index 00000000..d229a390 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_mkctab.pas @@ -0,0 +1,187 @@ +program t_mkctab; + +(************************************************************************* + + DESCRIPTION : Calculate compressed AES tables + + REQUIREMENTS : TP5-7, D1-D7/D9-D10, FPC, VP, WDOSX + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : [1] http://csrc.nist.gov/fips/fips-197.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 08.07.06 we Initial version using existing static tables + 0.11 12.07.06 we Use (Inv)SBox bytes instead of zero fill bytes + 0.12 13.07.06 we Without static tables +**************************************************************************) + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + mem_util; + + + +{---------------------------------------------------------------------------} +{Encrypt} +{ 3 2 1 0} +{ a5 63 63 c6} +{ xx xx xx c6 63 63 a5 xx + xx xx a5 c6 63 63 xx xx + xx 63 a5 c6 63 xx xx xx + 63 63 a5 c6 xx xx xx xx} + +{If (b0,b1,b2,b3) are the bytes of an Te0 longint the} +{TCe entry has the 8 bytes (b1,b2,b3,b0,b1,b2,b3,SBox) } + +{---------------------------------------------------------------------------} +{Decrypt} +{ 3 2 1 0} +{ 50 a7 f4 51} + +{ xx xx xx 51 f4 a7 50 xx + xx xx 50 51 f4 a7 xx xx + xx a7 50 51 f4 xx xx xx + f4 a7 50 51 xx xx xx xx} + +{If (b0,b1,b2,b3) are the bytes of an Td0 longint the} +{TCd entry has the 8 bytes (b1,b2,b3,b0,b1,b2,b3,InvSBox) } + + +{---------------------------------------------------------------------------} +{types to access table: Tex[i] = TCe[i].Ex.L, Tdx[i] = TCd[i].Ex.L} +(* +type + TH0 = packed record TH1 = packed record + b0,b1,b2: byte; b0,b1: byte; + L: longint; L: longint; + box: byte; b2,box: byte; + end; end; + + TH2 = packed record TH3 = packed record + b0: byte; L: longint; + L: longint; b0,b1,b2,box: byte; + b1,b2,box: byte; end; + end; + + THU = record TDU = record + case integer of case integer of + 0: (E0: TH0); 0: (D0: TH0); + 1: (E1: TH1); 1: (D1: TH1); + 2: (E2: TH2); 2: (D2: TH2); + 3: (E3: TH3); 3: (D3: TH3); + end; end; +*) + + +var + GLog, GPow: array[byte] of byte; + + +{---------------------------------------------------------------------------} +procedure CalcBaseTables; + {-Calculate dynamic tables: power, log} +var + i, p: byte; +begin + {Power/Log tables} + p := 1; + for i:=0 to 254 do begin + GPow[i] := p; + GLog[p] := i; + if p and $80 = 0 then p := (p shl 1) xor p + else p := (p shl 1) xor p xor $1B; + end; + GPow[255] := 1; +end; + + +{---------------------------------------------------------------------------} +function GMul(x,y: byte): byte; + {-calculate x*y in GF(2^8)} +var + i: word; +begin + if (x=0) or (y=0) then GMul := 0 + else begin + i := word(GLog[x])+word(GLog[y]); + if i>=255 then dec(i,255); + GMul := GPow[i]; + end; +end; + + +{---------------------------------------------------------------------------} +function rot(b,n: byte): byte; + {-rotate byte right n bits} +begin + rot := (b shr n) xor (b shl (8-n)); +end; + + +{---------------------------------------------------------------------------} +procedure MakeCompressedTables; + {-Calculate and dump compressed AES tables} +var + i,j: integer; + p: byte; + b: array[0..3] of byte; + s: array[0..4] of string[4]; + InvSBox: array[byte] of byte; +begin + CalcBaseTables; + writeln('const'); + writeln(' TCe: packed array[0..2047] of byte = ('); + for i:=0 to 255 do begin + {SBox calculation, cf. [1] 5.1.1} + if i=0 then p:=0 else p:=GPow[255-GLog[i]]; {p*i = 1} + p := p xor rot(p,4) xor rot(p,5) xor rot(p,6) xor rot(p,7) xor $63; + InvSBox[p] := i; + b[0] := GMul(2,p); + b[1] := p; + b[2] := p; + b[3] := GMul(3,p); + for j:=0 to 3 do s[j] := '$'+HexByte(b[j])+','; + s[4] := '$'+HexByte(p); + if odd(i) then begin + write(s[1],s[2],s[3],s[0],s[1],s[2],s[3],s[4]); + if i=255 then writeln(');') else writeln(','); + end + else write('':9,s[1],s[2],s[3],s[0],s[1],s[2],s[3],s[4],','); + end; + writeln; + writeln('const'); + writeln(' TCd: packed array[0..2047] of byte = ('); + for i:=0 to 255 do begin + p := InvSbox[i]; + b[0] := GMul(14,p); + b[1] := GMul( 9,p); + b[2] := GMul(13,p); + b[3] := GMul(11,p); + for j:=0 to 3 do s[j] := '$'+HexByte(b[j])+','; + s[4] := '$'+HexByte(p); + if odd(i) then begin + write(s[1],s[2],s[3],s[0],s[1],s[2],s[3],s[4]); + if i=255 then writeln(');') else writeln(','); + end + else write('':9,s[1],s[2],s[3],s[0],s[1],s[2],s[3],s[4],','); + end; +end; + +begin + MakeCompressedTables; +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_omac.pas b/Tocsg.Lib/VCL/EncLib/AES/t_omac.pas new file mode 100644 index 00000000..5adbb0f7 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_omac.pas @@ -0,0 +1,155 @@ +{-Test prog for OMAC1/2, we 05.2004} + +program T_OMAC; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +{$ifdef J_OPT} + {$J+} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + AES_Type, AES_OMAC, Mem_Util; + +{Common keys and msg data} +{from http://www.nuee.nagoya-u.ac.jp/labs/tiwata/omac/tv/omac?-tv.txt} +const + key128 : array[0..15] of byte = ($2b,$7e,$15,$16,$28,$ae,$d2,$a6, + $ab,$f7,$15,$88,$09,$cf,$4f,$3c); + + key192 : array[0..23] of byte = ($8e,$73,$b0,$f7,$da,$0e,$64,$52, + $c8,$10,$f3,$2b,$80,$90,$79,$e5, + $62,$f8,$ea,$d2,$52,$2c,$6b,$7b); + + key256 : array[0..31] of byte = ($60,$3d,$eb,$10,$15,$ca,$71,$be, + $2b,$73,$ae,$f0,$85,$7d,$77,$81, + $1f,$35,$2c,$07,$3b,$61,$08,$d7, + $2d,$98,$10,$a3,$09,$14,$df,$f4); + +const + msg : array[0..63] of byte = ($6b,$c1,$be,$e2,$2e,$40,$9f,$96, + $e9,$3d,$7e,$11,$73,$93,$17,$2a, + $ae,$2d,$8a,$57,$1e,$03,$ac,$9c, + $9e,$b7,$6f,$ac,$45,$af,$8e,$51, + $30,$c8,$1c,$46,$a3,$5c,$e4,$11, + $e5,$fb,$c1,$19,$1a,$0a,$52,$ef, + $f6,$9f,$24,$45,$df,$4f,$9b,$17, + $ad,$2b,$41,$7b,$e6,$6c,$37,$10); + +{from http://www.nuee.nagoya-u.ac.jp/labs/tiwata/omac/tv/omac1-tv.txt} +const + tag00: TAESBlock = ($bb,$1d,$69,$29,$e9,$59,$37,$28,$7f,$a3,$7d,$12,$9b,$75,$67,$46); + tag01: TAESBlock = ($07,$0a,$16,$b4,$6b,$4d,$41,$44,$f7,$9b,$dd,$9d,$d0,$4a,$28,$7c); + tag02: TAESBlock = ($df,$a6,$67,$47,$de,$9a,$e6,$30,$30,$ca,$32,$61,$14,$97,$c8,$27); + tag03: TAESBlock = ($51,$f0,$be,$bf,$7e,$3b,$9d,$92,$fc,$49,$74,$17,$79,$36,$3c,$fe); + + tag10: TAESBlock = ($d1,$7d,$df,$46,$ad,$aa,$cd,$e5,$31,$ca,$c4,$83,$de,$7a,$93,$67); + tag11: TAESBlock = ($9e,$99,$a7,$bf,$31,$e7,$10,$90,$06,$62,$f6,$5e,$61,$7c,$51,$84); + tag12: TAESBlock = ($8a,$1d,$e5,$be,$2e,$b3,$1a,$ad,$08,$9a,$82,$e6,$ee,$90,$8b,$0e); + tag13: TAESBlock = ($a1,$d5,$df,$0e,$ed,$79,$0f,$79,$4d,$77,$58,$96,$59,$f3,$9a,$11); + + tag20: TAESBlock = ($02,$89,$62,$f6,$1b,$7b,$f8,$9e,$fc,$6b,$55,$1f,$46,$67,$d9,$83); + tag21: TAESBlock = ($28,$a7,$02,$3f,$45,$2e,$8f,$82,$bd,$4b,$f2,$8d,$8c,$37,$c3,$5c); + tag22: TAESBlock = ($aa,$f3,$d8,$f1,$de,$56,$40,$c2,$32,$f5,$b1,$69,$b9,$c9,$11,$e6); + tag23: TAESBlock = ($e1,$99,$21,$90,$54,$9f,$6e,$d5,$69,$6a,$2c,$05,$6c,$31,$54,$10); + +{http://www.nuee.nagoya-u.ac.jp/labs/tiwata/omac/tv/omac2-tv.txt} +const + tag30: TAESBlock = ($f6,$bc,$6a,$41,$f4,$f8,$45,$93,$80,$9e,$59,$b7,$19,$29,$9c,$fe); + tag31: TAESBlock = ($07,$0a,$16,$b4,$6b,$4d,$41,$44,$f7,$9b,$dd,$9d,$d0,$4a,$28,$7c); + tag32: TAESBlock = ($23,$fd,$aa,$08,$31,$cd,$31,$44,$91,$ce,$4b,$25,$ac,$b6,$02,$3b); + tag33: TAESBlock = ($51,$f0,$be,$bf,$7e,$3b,$9d,$92,$fc,$49,$74,$17,$79,$36,$3c,$fe); + + tag40: TAESBlock = ($14,$9f,$57,$9d,$f2,$12,$9d,$45,$a6,$92,$66,$89,$8f,$55,$ae,$b2); + tag41: TAESBlock = ($9e,$99,$a7,$bf,$31,$e7,$10,$90,$06,$62,$f6,$5e,$61,$7c,$51,$84); + tag42: TAESBlock = ($b3,$5e,$2d,$1b,$73,$ae,$d4,$9b,$78,$bd,$bd,$fe,$61,$f6,$46,$df); + tag43: TAESBlock = ($a1,$d5,$df,$0e,$ed,$79,$0f,$79,$4d,$77,$58,$96,$59,$f3,$9a,$11); + + tag50: TAESBlock = ($47,$fb,$de,$71,$86,$6e,$ae,$60,$80,$35,$5b,$5f,$c7,$ff,$70,$4c); + tag51: TAESBlock = ($28,$a7,$02,$3f,$45,$2e,$8f,$82,$bd,$4b,$f2,$8d,$8c,$37,$c3,$5c); + tag52: TAESBlock = ($f0,$18,$e6,$05,$36,$11,$b3,$4b,$c8,$72,$d6,$b7,$ff,$24,$74,$9f); + tag53: TAESBlock = ($e1,$99,$21,$90,$54,$9f,$6e,$d5,$69,$6a,$2c,$05,$6c,$31,$54,$10); + +var + ctx: TAESContext; + tag: TAESBlock; + +{---------------------------------------------------------------------------} +procedure Test(Alg: integer; var key; KL,ML: word; var st: TAESBlock; Hdr: string); + {-Test for OMAC(Alg) with key and message lenght ML, st: known tag } + { tags are calculated two times: 1. single call of AES_OMAC_Update with} + { complete msg, 2. AES_OMAC_Update for each byte of msg } +const + Res: array[boolean] of string[5] = ('Error', 'OK'); +var + i: word; +begin + write(Alg:4, hdr); + if AES_OMAC_Init(key, KL, ctx)<>0 then begin + writeln('AES_OMAC_Init Error'); + halt; + end; + if AES_OMAC_Update(@msg, ML, ctx)<>0 then begin + writeln('AES_OMAC_Update Error'); + halt; + end; + if Alg=2 then AES_OMAC2_Final(tag, ctx) + else AES_OMAC1_Final(tag, ctx); + write(Res[CompMem(@tag, @st, sizeof(tag))]:8); + if AES_OMAC_Init(key, KL, ctx)<>0 then begin + writeln('AES_OMAC_Init Error'); + halt; + end; + for i:=1 to ML do begin + if AES_OMAC_Update(@msg[i-1], 1, ctx)<>0 then begin + writeln('AES_OMAC_Update Error'); + halt; + end; + end; + if Alg=2 then AES_OMAC2_Final(tag, ctx) + else AES_OMAC1_Final(tag, ctx); + writeln(Res[CompMem(@tag, @st, sizeof(tag))]:8); +end; + +begin + writeln('Test program AES OMAC 1/2 modes (C) 2004-2006 W.Ehrhardt'); + writeln('KL/ML: Key/Message length in bits/bytes'); + writeln('Single/Multi: process message with one/multiple call(s)'); + writeln('OMAC KL/ML Single Multi'); + Test(1, key128, 128, 0, tag00, ' 128/00'); + Test(1, key128, 128, 16, tag01, ' 128/16'); + Test(1, key128, 128, 40, tag02, ' 128/40'); + Test(1, key128, 128, 64, tag03, ' 128/64'); + + Test(1, key192, 192, 0, tag10, ' 192/00'); + Test(1, key192, 192, 16, tag11, ' 192/16'); + Test(1, key192, 192, 40, tag12, ' 192/40'); + Test(1, key192, 192, 64, tag13, ' 192/64'); + + Test(1, key256, 256, 0, tag20, ' 256/00'); + Test(1, key256, 256, 16, tag21, ' 256/16'); + Test(1, key256, 256, 40, tag22, ' 256/40'); + Test(1, key256, 256, 64, tag23, ' 256/64'); + + Test(2, key128, 128, 0, tag30, ' 128/00'); + Test(2, key128, 128, 16, tag31, ' 128/16'); + Test(2, key128, 128, 40, tag32, ' 128/40'); + Test(2, key128, 128, 64, tag33, ' 128/64'); + + Test(2, key192, 192, 0, tag40, ' 192/00'); + Test(2, key192, 192, 16, tag41, ' 192/16'); + Test(2, key192, 192, 40, tag42, ' 192/40'); + Test(2, key192, 192, 64, tag43, ' 192/64'); + + Test(2, key256, 256, 0, tag50, ' 256/00'); + Test(2, key256, 256, 16, tag51, ' 256/16'); + Test(2, key256, 256, 40, tag52, ' 256/40'); + Test(2, key256, 256, 64, tag53, ' 256/64'); +end. diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_ppp.pas b/Tocsg.Lib/VCL/EncLib/AES/t_ppp.pas new file mode 100644 index 00000000..bfa9fa0b --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_ppp.pas @@ -0,0 +1,235 @@ +{Test program for PPP unit (GRC's Perfect Paper Passwords)} + +program t_ppp; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +{.$define usesha256} {demo: use sha256/hash for a Sequence Key calculation} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + {$ifdef usesha256} + hash, sha256, + {$endif} + mem_util, BTypes, ppp; + +{Some tests: pppNET v0.9.1 from http://sourceforge.net/projects/pppnet/} + +{---------------------------------------------------------------------------} +procedure dotest; +var + pctx: TPPPctx; + SeqKey: TPPPKey; + kl: word; + err,i, dcnt: integer; + si: str255; +const + testdef: array[0..69] of string[4] = ( {GRC} + '32YT', '65!@', 'S3mg', 'skAf', 'wVmK', 'nSge', 'MsXd', + 'DzRA', 't%#f', 'vxDa', 'v!nz', '?S9G', 'u9Um', 'HA72', + '944=', 'Rgai', 'pNv=', 'n5FU', 'SUKU', 'C+wp', 'C+7G', + 'jsKV', 'uSGn', 'EH?F', 'R3pW', 'EMd?', 'k=vv', '@+rC', + 't5yt', 'c:xD', 'BmeV', 'cex4', 'Zh4t', 'J:oK', 'nUxV', + 'EbA@', 'BHn%', 'G9Sa', 'Fo:i', 'MM97', '@Urg', 'fkPL', + '%EU+', 'U8GF', 'F%fY', 'dxXE', 'H5M%', ':%B7', '4YDR', + 'vGYq', 'uL%5', '7#cE', 'hi+6', '99bS', '5FVh', 'ZhNr', + '#DnV', '8sr7', 'Dnj3', 'xf=U', '4%a%', 'J#sE', 'pS?e', + 'CsCU', 'iYGg', 'KPFV', 'j8@2', 'dsLf', '3#yE', 'BWbj'); + + testext: array[0..69] of string[4] = ( {pppNET} + '(EON', 't.ix', 'L>:?', 'u|[&', '', + '>J[i', 'm|sk', 'H#hm', ',u:F', ';NUP', 'iSD}', '}Y6&', + 'bN''c', 'pVMk', '7e^{', ':HP8', '-CMu', 'ivN:', '-(Mr', + '"L?G', 'kpru', 'q.Kk', 'NP7j', 'x6?%', 'vK!<', '>[5}', + '@WCX', 'E}qG', 'az=W', 'nLHa', '{-6G', ')Xjg', '>iW6', + 'K\pU', '85E8', '9:D!', '+2-_', 'UYR5', ';LvV', 'v&[O', + '&TwS', 'mNPO', 'q6%E', 'm9gf', 'Jc@{', 'vb?R', 'L.]*', + 'h<@2', '8-ef', '^Cdy', 'qjGr', 'o^Aa','''[3r', 'DRdv', + '$\?p', '=:(<', 'RHBR','G''o>', ')~Mx', 'U:D,', 'ero9'); + testcst: array[0..69] of string[4] = ( {pppNET} + 'hvRG', '*sXy', 'NS)X', 'nkT$', '*mu(', '=NSz', 'JisZ', + 'JBW%', '!g=X', '_TJS', '~Eyh', 'whp@', '^)jr', 'uuE=', + 'RiaP', 'uy*K', '?L>&', 'Tua~', 'Pttw', '(KUc', 'xhP&', + '&=e_', '*ah&', 'P*Hh', 'MDD>', 'YC_A', 'UrTh', 'UhAh', + 'W!=h', 'tdqH', 'hfJH', 's$GE', 'a$FU', 'LtsG', 'Ae&+', + 'FcJk', 'nF_k', '^ZrC', 'VefW', 'wq-', 'nNFx', 'Nkzd', 'a*Sv', 'r=mG', + 'pV%P', '_j$d', 'G_0 then begin + writeln(' *** PPP_Init4Standard = ', Err); + end + else begin + writeln('-------------------------------------'); + writeln('Test 1 with Standard 64-character set'); + writeln('-------------------------------------'); + si := PPP_First32(pctx,0); + write(si,' '); + i:=0; + if si<>testdef[i] then ShowDiff(testdef[i]); + for i:=1 to 69 do begin + si := PPP_Next(pctx); + write(si,' '); + if si<>testdef[i] then ShowDiff(testdef[i]); + if i mod 7 = 6 then writeln; + end; + writeln; + end; + + Hex2Mem(key1h, @SeqKey, sizeof(SeqKey), kl); + PPP_Init(pctx, SeqKey, map64, 6, Err); + if Err<>0 then begin + writeln(' *** PPP_Init error = ', Err); + end + else begin + PPP_SetCodesPerCard(pctx, 50); + writeln('-------------------------------------'); + writeln('Test 2 with Standard 64-character set'); + writeln('-------------------------------------'); + si := PPP_FirstCard(pctx,3); + write(si,' '); + i:=0; + if si<>test6c3[i] then ShowDiff(test6c3[i]); + for i:=1 to 49 do begin + si := PPP_Next(pctx); + write(si,' '); + if si<>test6c3[i] then ShowDiff(test6c3[i]); + if i mod 5 = 4 then writeln; + end; + writeln; + end; + + {$ifdef usesha256} + {demo: simple sha256('zombie')} + SHA256Full(TSHA256Digest(SeqKey), @zombie, sizeof(zombie)); + {$else} + Hex2Mem(key2h, @SeqKey, sizeof(SeqKey), kl); + {$endif} + + PPP_Init4Extended(pctx, SeqKey, Err); + if Err<>0 then begin + writeln(' *** PPP_Init4Extended error = ', Err); + end + else begin + writeln('-------------------------------------'); + writeln('Test 3 with Extended 88-character set'); + writeln('-------------------------------------'); + si := PPP_FirstCard(pctx,3); + write(si,' '); + i:=0; + if si<>testext[i] then ShowDiff(testext[i]); + for i:=1 to 69 do begin + si := PPP_Next(pctx); + write(si,' '); + if si<>testext[i] then ShowDiff(testext[i]); + if i mod 7 = 6 then writeln; + end; + writeln; + end; + + Hex2Mem(key2h, @SeqKey, sizeof(SeqKey), kl); + PPP_Init(pctx, SeqKey, cmap, 4, Err); + if Err<>0 then begin + writeln(' *** PPP_Init error = ', Err); + end + else begin + writeln('-------------------------------------'); + writeln('Test 4 with a custom 66-character set'); + writeln('-------------------------------------'); + si := PPP_FirstCard(pctx,2); + write(si,' '); + i:=0; + if si<>testcst[i] then ShowDiff(testcst[i]); + for i:=1 to 69 do begin + si := PPP_Next(pctx); + write(si,' '); + if si<>testcst[i] then ShowDiff(testcst[i]); + if i mod 7 = 6 then writeln; + end; + writeln; + end; + + Hex2Mem(key2h, @SeqKey, sizeof(SeqKey), kl); + PPP_Init4Standard(pctx, SeqKey, Err); + if Err<>0 then begin + writeln(' *** PPP_Init4Standard error = ', Err); + end + else begin + writeln('-------------------------------------'); + writeln('Test 5: CardNr 1400 with standard set'); + writeln('-------------------------------------'); + si := PPP_FirstCard(pctx,1400); + write(si,' '); + i:=0; + if si<>test1400[i] then ShowDiff(test1400[i]); + for i:=1 to 69 do begin + si := PPP_Next(pctx); + write(si,' '); + if si<>test1400[i] then ShowDiff(test1400[i]); + if i mod 7 = 6 then writeln; + end; + writeln; + end; + if dcnt=0 then writeln('All tests passed.') + else writeln('*** test failed, ',dcnt,' differences found!') +end; + + +begin + writeln('T_PPP - Test PPP unit [Perfect Paper Passwords] (c) 2010 W.Ehrhardt'); + writeln; + dotest; +end. + diff --git a/Tocsg.Lib/VCL/EncLib/AES/t_xts.pas b/Tocsg.Lib/VCL/EncLib/AES/t_xts.pas new file mode 100644 index 00000000..fab329f6 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/AES/t_xts.pas @@ -0,0 +1,521 @@ +{Test program AES XTS mode functions, we Oct.2007} + +program T_XTS; + +{$i STD.INC} + +{$ifdef APPCONS} + {$apptype console} +{$endif} + +uses + {$ifdef WINCRT} + wincrt, + {$endif} + {$ifdef USEDLL} + {$ifdef VirtualPascal} + AES_Intv, + {$else} + AES_Intf, + {$endif} + {$else} + aes_type, aes_xts, + {$endif} + mem_util; + + +var + ctx: TAES_XTSContext; + tmp: array[0..511] of byte; + +{Test vectors from IEEE P1619} + +{---------------------------------------------------------------------------} +procedure test_v01; +var + pt: array[0..31] of byte; + k1,k2: array[0..15] of byte; + twk: TAESBlock; + err: integer; +const + ct: array[0..31] of byte = ($91,$7c,$f6,$9e,$bd,$68,$b2,$ec, + $9b,$9f,$e9,$a3,$ea,$dd,$a6,$92, + $cd,$43,$d2,$f5,$95,$98,$ed,$85, + $8c,$02,$c2,$65,$2f,$bf,$92,$2e); +begin + fillchar(pt,sizeof(pt),0); + fillchar(k1,sizeof(k1),0); + fillchar(k2,sizeof(k2),0); + fillchar(twk,sizeof(twk),0); + writeln('Test vector 01'); + err := AES_XTS_Init_Encr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Encr = ', err); + halt; + end; + err := AES_XTS_Encrypt(@pt, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Encrypt = ', err); + halt; + end; + writeln(' Enc: ',CompMem(@ct, @tmp, sizeof(ct))); + + err := AES_XTS_Init_Decr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Decr = ', err); + halt; + end; + err := AES_XTS_Decrypt(@tmp, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Decrypt = ', err); + halt; + end; + writeln(' Dec: ',CompMem(@pt, @tmp, sizeof(pt))); +end; + + +{---------------------------------------------------------------------------} +procedure test_v02; +const + k1 : array[0..15] of byte = ($11,$11,$11,$11,$11,$11,$11,$11, + $11,$11,$11,$11,$11,$11,$11,$11); + + k2 : array[0..15] of byte = ($22,$22,$22,$22,$22,$22,$22,$22, + $22,$22,$22,$22,$22,$22,$22,$22); + + twk: TAESBlock = ($33,$33,$33,$33,$33,0,0,0,0,0,0,0,0,0,0,0); + + pt : array[0..31] of byte = ($44,$44,$44,$44,$44,$44,$44,$44, + $44,$44,$44,$44,$44,$44,$44,$44, + $44,$44,$44,$44,$44,$44,$44,$44, + $44,$44,$44,$44,$44,$44,$44,$44); + + ct : array[0..31] of byte = ($c4,$54,$18,$5e,$6a,$16,$93,$6e, + $39,$33,$40,$38,$ac,$ef,$83,$8b, + $fb,$18,$6f,$ff,$74,$80,$ad,$c4, + $28,$93,$82,$ec,$d6,$d3,$94,$f0); + +var + err: integer; +begin + writeln('Test vector 02'); + err := AES_XTS_Init_Encr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Encr = ', err); + halt; + end; + err := AES_XTS_Encrypt(@pt, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Encrypt = ', err); + halt; + end; + writeln(' Enc: ',CompMem(@ct, @tmp, sizeof(ct))); + + err := AES_XTS_Init_Decr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Decr = ', err); + halt; + end; + err := AES_XTS_Decrypt(@tmp, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Decrypt = ', err); + halt; + end; + writeln(' Dec: ',CompMem(@pt, @tmp, sizeof(pt))); +end; + + + +{---------------------------------------------------------------------------} +procedure test_v04; +const + k1 : array[0..15] of byte = ($27,$18,$28,$18,$28,$45,$90,$45,$23,$53,$60,$28,$74,$71,$35,$26); + + k2 : array[0..15] of byte = ($31,$41,$59,$26,$53,$58,$97,$93,$23,$84,$62,$64,$33,$83,$27,$95); + + pt : array[0..511] of byte =( + $00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1a,$1b,$1c,$1d,$1e,$1f, + $20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3a,$3b,$3c,$3d,$3e,$3f, + $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5a,$5b,$5c,$5d,$5e,$5f, + $60,$61,$62,$63,$64,$65,$66,$67,$68,$69,$6a,$6b,$6c,$6d,$6e,$6f, + $70,$71,$72,$73,$74,$75,$76,$77,$78,$79,$7a,$7b,$7c,$7d,$7e,$7f, + $80,$81,$82,$83,$84,$85,$86,$87,$88,$89,$8a,$8b,$8c,$8d,$8e,$8f, + $90,$91,$92,$93,$94,$95,$96,$97,$98,$99,$9a,$9b,$9c,$9d,$9e,$9f, + $a0,$a1,$a2,$a3,$a4,$a5,$a6,$a7,$a8,$a9,$aa,$ab,$ac,$ad,$ae,$af, + $b0,$b1,$b2,$b3,$b4,$b5,$b6,$b7,$b8,$b9,$ba,$bb,$bc,$bd,$be,$bf, + $c0,$c1,$c2,$c3,$c4,$c5,$c6,$c7,$c8,$c9,$ca,$cb,$cc,$cd,$ce,$cf, + $d0,$d1,$d2,$d3,$d4,$d5,$d6,$d7,$d8,$d9,$da,$db,$dc,$dd,$de,$df, + $e0,$e1,$e2,$e3,$e4,$e5,$e6,$e7,$e8,$e9,$ea,$eb,$ec,$ed,$ee,$ef, + $f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7,$f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff, + $00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1a,$1b,$1c,$1d,$1e,$1f, + $20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3a,$3b,$3c,$3d,$3e,$3f, + $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5a,$5b,$5c,$5d,$5e,$5f, + $60,$61,$62,$63,$64,$65,$66,$67,$68,$69,$6a,$6b,$6c,$6d,$6e,$6f, + $70,$71,$72,$73,$74,$75,$76,$77,$78,$79,$7a,$7b,$7c,$7d,$7e,$7f, + $80,$81,$82,$83,$84,$85,$86,$87,$88,$89,$8a,$8b,$8c,$8d,$8e,$8f, + $90,$91,$92,$93,$94,$95,$96,$97,$98,$99,$9a,$9b,$9c,$9d,$9e,$9f, + $a0,$a1,$a2,$a3,$a4,$a5,$a6,$a7,$a8,$a9,$aa,$ab,$ac,$ad,$ae,$af, + $b0,$b1,$b2,$b3,$b4,$b5,$b6,$b7,$b8,$b9,$ba,$bb,$bc,$bd,$be,$bf, + $c0,$c1,$c2,$c3,$c4,$c5,$c6,$c7,$c8,$c9,$ca,$cb,$cc,$cd,$ce,$cf, + $d0,$d1,$d2,$d3,$d4,$d5,$d6,$d7,$d8,$d9,$da,$db,$dc,$dd,$de,$df, + $e0,$e1,$e2,$e3,$e4,$e5,$e6,$e7,$e8,$e9,$ea,$eb,$ec,$ed,$ee,$ef, + $f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7,$f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff); + + ct : array[0..511] of byte = ( + $27,$a7,$47,$9b,$ef,$a1,$d4,$76,$48,$9f,$30,$8c,$d4,$cf,$a6,$e2, + $a9,$6e,$4b,$be,$32,$08,$ff,$25,$28,$7d,$d3,$81,$96,$16,$e8,$9c, + $c7,$8c,$f7,$f5,$e5,$43,$44,$5f,$83,$33,$d8,$fa,$7f,$56,$00,$00, + $05,$27,$9f,$a5,$d8,$b5,$e4,$ad,$40,$e7,$36,$dd,$b4,$d3,$54,$12, + $32,$80,$63,$fd,$2a,$ab,$53,$e5,$ea,$1e,$0a,$9f,$33,$25,$00,$a5, + $df,$94,$87,$d0,$7a,$5c,$92,$cc,$51,$2c,$88,$66,$c7,$e8,$60,$ce, + $93,$fd,$f1,$66,$a2,$49,$12,$b4,$22,$97,$61,$46,$ae,$20,$ce,$84, + $6b,$b7,$dc,$9b,$a9,$4a,$76,$7a,$ae,$f2,$0c,$0d,$61,$ad,$02,$65, + $5e,$a9,$2d,$c4,$c4,$e4,$1a,$89,$52,$c6,$51,$d3,$31,$74,$be,$51, + $a1,$0c,$42,$11,$10,$e6,$d8,$15,$88,$ed,$e8,$21,$03,$a2,$52,$d8, + $a7,$50,$e8,$76,$8d,$ef,$ff,$ed,$91,$22,$81,$0a,$ae,$b9,$9f,$91, + $72,$af,$82,$b6,$04,$dc,$4b,$8e,$51,$bc,$b0,$82,$35,$a6,$f4,$34, + $13,$32,$e4,$ca,$60,$48,$2a,$4b,$a1,$a0,$3b,$3e,$65,$00,$8f,$c5, + $da,$76,$b7,$0b,$f1,$69,$0d,$b4,$ea,$e2,$9c,$5f,$1b,$ad,$d0,$3c, + $5c,$cf,$2a,$55,$d7,$05,$dd,$cd,$86,$d4,$49,$51,$1c,$eb,$7e,$c3, + $0b,$f1,$2b,$1f,$a3,$5b,$91,$3f,$9f,$74,$7a,$8a,$fd,$1b,$13,$0e, + $94,$bf,$f9,$4e,$ff,$d0,$1a,$91,$73,$5c,$a1,$72,$6a,$cd,$0b,$19, + $7c,$4e,$5b,$03,$39,$36,$97,$e1,$26,$82,$6f,$b6,$bb,$de,$8e,$cc, + $1e,$08,$29,$85,$16,$e2,$c9,$ed,$03,$ff,$3c,$1b,$78,$60,$f6,$de, + $76,$d4,$ce,$cd,$94,$c8,$11,$98,$55,$ef,$52,$97,$ca,$67,$e9,$f3, + $e7,$ff,$72,$b1,$e9,$97,$85,$ca,$0a,$7e,$77,$20,$c5,$b3,$6d,$c6, + $d7,$2c,$ac,$95,$74,$c8,$cb,$bc,$2f,$80,$1e,$23,$e5,$6f,$d3,$44, + $b0,$7f,$22,$15,$4b,$eb,$a0,$f0,$8c,$e8,$89,$1e,$64,$3e,$d9,$95, + $c9,$4d,$9a,$69,$c9,$f1,$b5,$f4,$99,$02,$7a,$78,$57,$2a,$ee,$bd, + $74,$d2,$0c,$c3,$98,$81,$c2,$13,$ee,$77,$0b,$10,$10,$e4,$be,$a7, + $18,$84,$69,$77,$ae,$11,$9f,$7a,$02,$3a,$b5,$8c,$ca,$0a,$d7,$52, + $af,$e6,$56,$bb,$3c,$17,$25,$6a,$9f,$6e,$9b,$f1,$9f,$dd,$5a,$38, + $fc,$82,$bb,$e8,$72,$c5,$53,$9e,$db,$60,$9e,$f4,$f7,$9c,$20,$3e, + $bb,$14,$0f,$2e,$58,$3c,$b2,$ad,$15,$b4,$aa,$5b,$65,$50,$16,$a8, + $44,$92,$77,$db,$d4,$77,$ef,$2c,$8d,$6c,$01,$7d,$b7,$38,$b1,$8d, + $eb,$4a,$42,$7d,$19,$23,$ce,$3f,$f2,$62,$73,$57,$79,$a4,$18,$f2, + $0a,$28,$2d,$f9,$20,$14,$7b,$ea,$be,$42,$1e,$e5,$31,$9d,$05,$68); + + twk: TAESBlock = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); +var + err: integer; +begin + writeln('Test vector 04'); + err := AES_XTS_Init_Encr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Encr = ', err); + halt; + end; + err := AES_XTS_Encrypt(@pt, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Encrypt = ', err); + halt; + end; + writeln(' Enc: ',CompMem(@ct, @tmp, sizeof(ct))); + + err := AES_XTS_Init_Decr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Decr = ', err); + halt; + end; + err := AES_XTS_Decrypt(@tmp, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' * Error AES_XTS_Decrypt = ', err); + halt; + end; + writeln(' Dec: ',CompMem(@pt, @tmp, sizeof(pt))); +end; + + +{---------------------------------------------------------------------------} +procedure test_v10; +const + k1 : array[0.. 31] of byte = ($27,$18,$28,$18,$28,$45,$90,$45,$23,$53,$60,$28,$74,$71,$35,$26, + $62,$49,$77,$57,$24,$70,$93,$69,$99,$59,$57,$49,$66,$96,$76,$27); + + k2 : array[0.. 31] of byte = ($31,$41,$59,$26,$53,$58,$97,$93,$23,$84,$62,$64,$33,$83,$27,$95, + $02,$88,$41,$97,$16,$93,$99,$37,$51,$05,$82,$09,$74,$94,$45,$92); + + pt : array[0..511] of byte =( + $00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1a,$1b,$1c,$1d,$1e,$1f, + $20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3a,$3b,$3c,$3d,$3e,$3f, + $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5a,$5b,$5c,$5d,$5e,$5f, + $60,$61,$62,$63,$64,$65,$66,$67,$68,$69,$6a,$6b,$6c,$6d,$6e,$6f, + $70,$71,$72,$73,$74,$75,$76,$77,$78,$79,$7a,$7b,$7c,$7d,$7e,$7f, + $80,$81,$82,$83,$84,$85,$86,$87,$88,$89,$8a,$8b,$8c,$8d,$8e,$8f, + $90,$91,$92,$93,$94,$95,$96,$97,$98,$99,$9a,$9b,$9c,$9d,$9e,$9f, + $a0,$a1,$a2,$a3,$a4,$a5,$a6,$a7,$a8,$a9,$aa,$ab,$ac,$ad,$ae,$af, + $b0,$b1,$b2,$b3,$b4,$b5,$b6,$b7,$b8,$b9,$ba,$bb,$bc,$bd,$be,$bf, + $c0,$c1,$c2,$c3,$c4,$c5,$c6,$c7,$c8,$c9,$ca,$cb,$cc,$cd,$ce,$cf, + $d0,$d1,$d2,$d3,$d4,$d5,$d6,$d7,$d8,$d9,$da,$db,$dc,$dd,$de,$df, + $e0,$e1,$e2,$e3,$e4,$e5,$e6,$e7,$e8,$e9,$ea,$eb,$ec,$ed,$ee,$ef, + $f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7,$f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff, + $00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1a,$1b,$1c,$1d,$1e,$1f, + $20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3a,$3b,$3c,$3d,$3e,$3f, + $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5a,$5b,$5c,$5d,$5e,$5f, + $60,$61,$62,$63,$64,$65,$66,$67,$68,$69,$6a,$6b,$6c,$6d,$6e,$6f, + $70,$71,$72,$73,$74,$75,$76,$77,$78,$79,$7a,$7b,$7c,$7d,$7e,$7f, + $80,$81,$82,$83,$84,$85,$86,$87,$88,$89,$8a,$8b,$8c,$8d,$8e,$8f, + $90,$91,$92,$93,$94,$95,$96,$97,$98,$99,$9a,$9b,$9c,$9d,$9e,$9f, + $a0,$a1,$a2,$a3,$a4,$a5,$a6,$a7,$a8,$a9,$aa,$ab,$ac,$ad,$ae,$af, + $b0,$b1,$b2,$b3,$b4,$b5,$b6,$b7,$b8,$b9,$ba,$bb,$bc,$bd,$be,$bf, + $c0,$c1,$c2,$c3,$c4,$c5,$c6,$c7,$c8,$c9,$ca,$cb,$cc,$cd,$ce,$cf, + $d0,$d1,$d2,$d3,$d4,$d5,$d6,$d7,$d8,$d9,$da,$db,$dc,$dd,$de,$df, + $e0,$e1,$e2,$e3,$e4,$e5,$e6,$e7,$e8,$e9,$ea,$eb,$ec,$ed,$ee,$ef, + $f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7,$f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff); + + ct : array[0..511] of byte = ( + $1c,$3b,$3a,$10,$2f,$77,$03,$86,$e4,$83,$6c,$99,$e3,$70,$cf,$9b, + $ea,$00,$80,$3f,$5e,$48,$23,$57,$a4,$ae,$12,$d4,$14,$a3,$e6,$3b, + $5d,$31,$e2,$76,$f8,$fe,$4a,$8d,$66,$b3,$17,$f9,$ac,$68,$3f,$44, + $68,$0a,$86,$ac,$35,$ad,$fc,$33,$45,$be,$fe,$cb,$4b,$b1,$88,$fd, + $57,$76,$92,$6c,$49,$a3,$09,$5e,$b1,$08,$fd,$10,$98,$ba,$ec,$70, + $aa,$a6,$69,$99,$a7,$2a,$82,$f2,$7d,$84,$8b,$21,$d4,$a7,$41,$b0, + $c5,$cd,$4d,$5f,$ff,$9d,$ac,$89,$ae,$ba,$12,$29,$61,$d0,$3a,$75, + $71,$23,$e9,$87,$0f,$8a,$cf,$10,$00,$02,$08,$87,$89,$14,$29,$ca, + $2a,$3e,$7a,$7d,$7d,$f7,$b1,$03,$55,$16,$5c,$8b,$9a,$6d,$0a,$7d, + $e8,$b0,$62,$c4,$50,$0d,$c4,$cd,$12,$0c,$0f,$74,$18,$da,$e3,$d0, + $b5,$78,$1c,$34,$80,$3f,$a7,$54,$21,$c7,$90,$df,$e1,$de,$18,$34, + $f2,$80,$d7,$66,$7b,$32,$7f,$6c,$8c,$d7,$55,$7e,$12,$ac,$3a,$0f, + $93,$ec,$05,$c5,$2e,$04,$93,$ef,$31,$a1,$2d,$3d,$92,$60,$f7,$9a, + $28,$9d,$6a,$37,$9b,$c7,$0c,$50,$84,$14,$73,$d1,$a8,$cc,$81,$ec, + $58,$3e,$96,$45,$e0,$7b,$8d,$96,$70,$65,$5b,$a5,$bb,$cf,$ec,$c6, + $dc,$39,$66,$38,$0a,$d8,$fe,$cb,$17,$b6,$ba,$02,$46,$9a,$02,$0a, + $84,$e1,$8e,$8f,$84,$25,$20,$70,$c1,$3e,$9f,$1f,$28,$9b,$e5,$4f, + $bc,$48,$14,$57,$77,$8f,$61,$60,$15,$e1,$32,$7a,$02,$b1,$40,$f1, + $50,$5e,$b3,$09,$32,$6d,$68,$37,$8f,$83,$74,$59,$5c,$84,$9d,$84, + $f4,$c3,$33,$ec,$44,$23,$88,$51,$43,$cb,$47,$bd,$71,$c5,$ed,$ae, + $9b,$e6,$9a,$2f,$fe,$ce,$b1,$be,$c9,$de,$24,$4f,$be,$15,$99,$2b, + $11,$b7,$7c,$04,$0f,$12,$bd,$8f,$6a,$97,$5a,$44,$a0,$f9,$0c,$29, + $a9,$ab,$c3,$d4,$d8,$93,$92,$72,$84,$c5,$87,$54,$cc,$e2,$94,$52, + $9f,$86,$14,$dc,$d2,$ab,$a9,$91,$92,$5f,$ed,$c4,$ae,$74,$ff,$ac, + $6e,$33,$3b,$93,$eb,$4a,$ff,$04,$79,$da,$9a,$41,$0e,$44,$50,$e0, + $dd,$7a,$e4,$c6,$e2,$91,$09,$00,$57,$5d,$a4,$01,$fc,$07,$05,$9f, + $64,$5e,$8b,$7e,$9b,$fd,$ef,$33,$94,$30,$54,$ff,$84,$01,$14,$93, + $c2,$7b,$34,$29,$ea,$ed,$b4,$ed,$53,$76,$44,$1a,$77,$ed,$43,$85, + $1a,$d7,$7f,$16,$f5,$41,$df,$d2,$69,$d5,$0d,$6a,$5f,$14,$fb,$0a, + $ab,$1c,$bb,$4c,$15,$50,$be,$97,$f7,$ab,$40,$66,$19,$3c,$4c,$aa, + $77,$3d,$ad,$38,$01,$4b,$d2,$09,$2f,$a7,$55,$c8,$24,$bb,$5e,$54, + $c4,$f3,$6f,$fd,$a9,$fc,$ea,$70,$b9,$c6,$e6,$93,$e1,$48,$c1,$51); + + twk: TAESBlock = ($ff,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); +var + err: integer; +begin + writeln('Test vector 10'); + err := AES_XTS_Init_Encr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Encr = ', err); + halt; + end; + err := AES_XTS_Encrypt(@pt, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Encrypt = ', err); + halt; + end; + writeln(' Enc: ',CompMem(@ct, @tmp, sizeof(ct))); + + err := AES_XTS_Init_Decr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Decr = ', err); + halt; + end; + err := AES_XTS_Decrypt(@tmp, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Decrypt = ', err); + halt; + end; + writeln(' Dec: ',CompMem(@pt, @tmp, sizeof(pt))); +end; + + +{---------------------------------------------------------------------------} +procedure test_v15; +const + k1 : array[0..15] of byte = ($ff,$fe,$fd,$fc,$fb,$fa,$f9,$f8, + $f7,$f6,$f5,$f4,$f3,$f2,$f1,$f0); + k2 : array[0..15] of byte = ($bf,$be,$bd,$bc,$bb,$ba,$b9,$b8, + $b7,$b6,$b5,$b4,$b3,$b2,$b1,$b0); + pt : array[0..16] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f,$10); + ct : array[0..16] of byte = ($6c,$16,$25,$db,$46,$71,$52,$2d, + $3d,$75,$99,$60,$1d,$e7,$ca,$09,$ed); + twk: TAESBlock = ($9a,$78,$56,$34,$12,0,0,0,0,0,0,0,0,0,0,0); +var + err: integer; +begin + writeln('Test vector 15'); + err := AES_XTS_Init_Encr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Encr = ', err); + halt; + end; + err := AES_XTS_Encrypt(@pt, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Encrypt = ', err); + halt; + end; + writeln(' Enc: ',CompMem(@ct, @tmp, sizeof(ct))); + err := AES_XTS_Init_Decr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Decr = ', err); + halt; + end; + err := AES_XTS_Decrypt(@tmp, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Decrypt = ', err); + halt; + end; + writeln(' Dec: ',CompMem(@pt, @tmp, sizeof(pt))); +end; + + +{---------------------------------------------------------------------------} +procedure test_v16; +const + k1 : array[0..15] of byte = ($ff,$fe,$fd,$fc,$fb,$fa,$f9,$f8, + $f7,$f6,$f5,$f4,$f3,$f2,$f1,$f0); + k2 : array[0..15] of byte = ($bf,$be,$bd,$bc,$bb,$ba,$b9,$b8, + $b7,$b6,$b5,$b4,$b3,$b2,$b1,$b0); + pt : array[0..17] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f,$10,$11); + ct : array[0..17] of byte = ($d0,$69,$44,$4b,$7a,$7e,$0c,$ab, + $09,$e2,$44,$47,$d2,$4d,$eb,$1f,$ed,$bf); + twk: TAESBlock = ($9a,$78,$56,$34,$12,0,0,0,0,0,0,0,0,0,0,0); +var + err: integer; +begin + writeln('Test vector 16'); + err := AES_XTS_Init_Encr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Encr = ', err); + halt; + end; + err := AES_XTS_Encrypt(@pt, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Encrypt = ', err); + halt; + end; + writeln(' Enc: ',CompMem(@ct, @tmp, sizeof(ct))); + err := AES_XTS_Init_Decr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Decr = ', err); + halt; + end; + err := AES_XTS_Decrypt(@tmp, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Decrypt = ', err); + halt; + end; + writeln(' Dec: ',CompMem(@pt, @tmp, sizeof(pt))); +end; + + +{---------------------------------------------------------------------------} +procedure test_v17; +const + k1 : array[0..15] of byte = ($ff,$fe,$fd,$fc,$fb,$fa,$f9,$f8, + $f7,$f6,$f5,$f4,$f3,$f2,$f1,$f0); + k2 : array[0..15] of byte = ($bf,$be,$bd,$bc,$bb,$ba,$b9,$b8, + $b7,$b6,$b5,$b4,$b3,$b2,$b1,$b0); + pt : array[0..18] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f,$10,$11,$12); + ct : array[0..18] of byte = ($e5,$df,$13,$51,$c0,$54,$4b,$a1, + $35,$0b,$33,$63,$cd,$8e,$f4,$be,$ed,$bf,$9d); + twk: TAESBlock = ($9a,$78,$56,$34,$12,0,0,0,0,0,0,0,0,0,0,0); +var + err: integer; +begin + writeln('Test vector 17'); + err := AES_XTS_Init_Encr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Encr = ', err); + halt; + end; + err := AES_XTS_Encrypt(@pt, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Encrypt = ', err); + halt; + end; + writeln(' Enc: ',CompMem(@ct, @tmp, sizeof(ct))); + err := AES_XTS_Init_Decr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Decr = ', err); + halt; + end; + err := AES_XTS_Decrypt(@tmp, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Decrypt = ', err); + halt; + end; + writeln(' Dec: ',CompMem(@pt, @tmp, sizeof(pt))); +end; + + +{---------------------------------------------------------------------------} +procedure test_v18; +const + k1 : array[0..15] of byte = ($ff,$fe,$fd,$fc,$fb,$fa,$f9,$f8, + $f7,$f6,$f5,$f4,$f3,$f2,$f1,$f0); + k2 : array[0..15] of byte = ($bf,$be,$bd,$bc,$bb,$ba,$b9,$b8, + $b7,$b6,$b5,$b4,$b3,$b2,$b1,$b0); + pt : array[0..19] of byte = ($00,$01,$02,$03,$04,$05,$06,$07, + $08,$09,$0a,$0b,$0c,$0d,$0e,$0f,$10,$11,$12,$13); + ct : array[0..19] of byte = ($9d,$84,$c8,$13,$f7,$19,$aa,$2c, + $7b,$e3,$f6,$61,$71,$c7,$c5,$c2,$ed,$bf,$9d,$ac); + twk: TAESBlock = ($9a,$78,$56,$34,$12,0,0,0,0,0,0,0,0,0,0,0); +var + err: integer; +begin + writeln('Test vector 18'); + err := AES_XTS_Init_Encr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Encr = ', err); + halt; + end; + err := AES_XTS_Encrypt(@pt, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Encrypt = ', err); + halt; + end; + writeln(' Enc: ',CompMem(@ct, @tmp, sizeof(ct))); + err := AES_XTS_Init_Decr(k1,k2,sizeof(k1)*8,ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Init_Decr = ', err); + halt; + end; + err := AES_XTS_Decrypt(@tmp, @tmp, sizeof(pt), twk, ctx); + if err<>0 then begin + writeln(' - Error AES_XTS_Decrypt = ', err); + halt; + end; + writeln(' Dec: ',CompMem(@pt, @tmp, sizeof(pt))); +end; + + +begin + writeln('Test program AES-XTS mode (c) 2007 W.Ehrhardt'); + {$ifdef USEDLL} + writeln('DLL Version: ',AES_DLL_Version); + {$endif} + writeln('Test vectors from IEEE P1619:'); + test_v01; + test_v02; + test_v04; + test_v10; + test_v15; + test_v16; + test_v17; + test_v18; +end. diff --git a/Tocsg.Lib/VCL/EncLib/EM.CRC32.pas b/Tocsg.Lib/VCL/EncLib/EM.CRC32.pas new file mode 100644 index 00000000..18ddf184 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.CRC32.pas @@ -0,0 +1,133 @@ +unit EM.CRC32; + +interface + +uses + Windows, Classes, SysUtils; + +procedure CRC32File(FileName: String; var CRC32: dword); +procedure CRC32String(S: String; var CRC32: dword); +procedure CRC32Data(var Data; Size: Integer; var CRC32: dword); + +implementation + +const Table: Array[0..255] of DWord = + ($00000000, $77073096, $EE0E612C, $990951BA, + $076DC419, $706AF48F, $E963A535, $9E6495A3, + $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, + $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, + $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, + $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, + $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, + $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5, + $3B6E20C8, $4C69105E, $D56041E4, $A2677172, + $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B, + $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, + $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59, + $26D930AC, $51DE003A, $C8D75180, $BFD06116, + $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F, + $2802B89E, $5F058808, $C60CD9B2, $B10BE924, + $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, + $76DC4190, $01DB7106, $98D220BC, $EFD5102A, + $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, + $7807C9A2, $0F00F934, $9609A88E, $E10E9818, + $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, + $6B6B51F4, $1C6C6162, $856530D8, $F262004E, + $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457, + $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, + $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65, + $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, + $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB, + $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, + $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9, + $5005713C, $270241AA, $BE0B1010, $C90C2086, + $5768B525, $206F85B3, $B966D409, $CE61E49F, + $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, + $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, + $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, + $EAD54739, $9DD277AF, $04DB2615, $73DC1683, + $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, + $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1, + $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, + $F762575D, $806567CB, $196C3671, $6E6B06E7, + $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, + $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5, + $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, + $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B, + $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, + $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, + $CB61B38C, $BC66831A, $256FD2A0, $5268E236, + $CC0C7795, $BB0B4703, $220216B9, $5505262F, + $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, + $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, + $9B64C2B0, $EC63F226, $756AA39C, $026D930A, + $9C0906A9, $EB0E363F, $72076785, $05005713, + $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, + $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21, + $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, + $81BE16CD, $F6B9265B, $6FB077E1, $18B74777, + $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, + $8F659EFF, $F862AE69, $616BFFD3, $166CCF45, + $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, + $A7672661, $D06016F7, $4969474D, $3E6E77DB, + $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, + $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, + $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, + $BAD03605, $CDD70693, $54DE5729, $23D967BF, + $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, + $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D); + +// type Buffer = Array[1..65521] of byte; +{largest buffer that can be allocated on heap } + +procedure CRC32File(FileName: String; var CRC32: dword); +var + F: file; + BytesRead: dword; + Buffer: Array[1..65521] of byte; + i: Word; +begin + FileMode := 0; + CRC32 := $ffffffff; + {$I-} + AssignFile(F, FileName); Reset(F, 1); + if IOResult = 0 then begin + repeat + BlockRead(F, Buffer, SizeOf(Buffer), BytesRead); + for i := 1 to BytesRead do + CRC32 := (CRC32 shr 8) xor Table[Buffer[i] xor (CRC32 and $000000FF)]; + until BytesRead = 0; + end; + CloseFile(F); + {$I+} + CRC32 := not CRC32; +end; + +procedure CRC32String(S: String; var CRC32: dword); +var +// Buffer: Array[1..65521] of byte; + i: Word; +begin + CRC32 := $ffffffff; + {$I-} + for i := 1 to Length(S) do + CRC32 := (CRC32 shr 8) xor Table[Byte(S[i]) xor (CRC32 and $000000FF)]; + {$I+} + CRC32 := not CRC32; +end; + +//procedure CRC32Data(var Data; Size: Integer; var CRC32: dword); +procedure CRC32Data; +var +// Buffer: Array[1..65521] of byte; + i: Word; +begin + CRC32 := $ffffffff; + {$I-} + for i := 0 to Size-1 do + CRC32 := (CRC32 shr 8) xor Table[PByteArray(@Data)[i] xor (CRC32 and $000000FF)]; + {$I+} + CRC32 := not CRC32; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/EM.MD5.pas b/Tocsg.Lib/VCL/EncLib/EM.MD5.pas new file mode 100644 index 00000000..97d237c2 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.MD5.pas @@ -0,0 +1,393 @@ +// tabs = 2 +// ----------------------------------------------------------------------------------------------- +// +// MD5 Message-Digest for Delphi 4 +// +// Delphi 4 Unit implementing the +// RSA Data Security, Inc. MD5 Message-Digest Algorithm +// +// Implementation of Ronald L. Rivest's RFC 1321 +// +// Copyright ?1997-1999 Medienagentur Fichtner & Meyer +// Written by Matthias Fichtner +// +// ----------------------------------------------------------------------------------------------- +// See RFC 1321 for RSA Data Security's copyright and license notice! +// ----------------------------------------------------------------------------------------------- +// +// 14-Jun-97 mf Implemented MD5 according to RFC 1321 RFC 1321 +// 16-Jun-97 mf Initial release of the compiled unit (no source code) RFC 1321 +// 28-Feb-99 mf Added MD5Match function for comparing two digests RFC 1321 +// 13-Sep-99 mf Reworked the entire unit RFC 1321 +// 17-Sep-99 mf Reworked the "Test Driver" project RFC 1321 +// 19-Sep-99 mf Release of sources for MD5 unit and "Test Driver" project RFC 1321 +// +// ----------------------------------------------------------------------------------------------- +// The latest release of md5.pas will always be available from +// the distribution site at: http://www.fichtner.net/delphi/md5/ +// ----------------------------------------------------------------------------------------------- +// Please send questions, bug reports and suggestions +// regarding this code to: mfichtner@fichtner-meyer.com +// ----------------------------------------------------------------------------------------------- +// This code is provided "as is" without express or +// implied warranty of any kind. Use it at your own risk. +// ----------------------------------------------------------------------------------------------- + +unit EM.MD5; + +// ----------------------------------------------------------------------------------------------- +INTERFACE +// ----------------------------------------------------------------------------------------------- + +uses + Windows; + +type + TMD5Count = array[0..1] of DWORD; + TMD5State = array[0..3] of DWORD; + TMD5Block = array[0..15] of DWORD; + TMD5CBits = array[0..7] of Byte; + TMD5Digest = array[0..15] of Byte; + TMD5Buffer = array[0..63] of Byte; + + TMD5Context = record + State : TMD5State; + Count : TMD5Count; + Buffer : TMD5Buffer; + end; + +procedure MD5Init(var Context: TMD5Context); +procedure MD5Update(var Context: TMD5Context; Input: PAnsiChar; Length: longword); +procedure MD5Final(var Context: TMD5Context; var Digest: TMD5Digest); + +function MD5String(M: AnsiString): TMD5Digest; +function MD5File(N: string): TMD5Digest; +function MD5Print(D: TMD5Digest): string; + +function MD5Match(D1, D2: TMD5Digest): boolean; + +// ----------------------------------------------------------------------------------------------- +IMPLEMENTATION +// ----------------------------------------------------------------------------------------------- + +var + PADDING: TMD5Buffer = ( + $80, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00 + ); + +function F(x, y, z: DWORD): DWORD; +begin + Result := (x and y) or ((not x) and z); +end; + +function G(x, y, z: DWORD): DWORD; +begin + Result := (x and z) or (y and (not z)); +end; + +function H(x, y, z: DWORD): DWORD; +begin + Result := x xor y xor z; +end; + +function I(x, y, z: DWORD): DWORD; +begin + Result := y xor (x or (not z)); +end; + +procedure rot(var x: DWORD; n: BYTE); +begin + x := (x shl n) or (x shr (32 - n)); +end; + +procedure FF(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD); +begin + inc(a, F(b, c, d) + x + ac); + rot(a, s); + inc(a, b); +end; + +procedure GG(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD); +begin + inc(a, G(b, c, d) + x + ac); + rot(a, s); + inc(a, b); +end; + +procedure HH(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD); +begin + inc(a, H(b, c, d) + x + ac); + rot(a, s); + inc(a, b); +end; + +procedure II(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD); +begin + inc(a, I(b, c, d) + x + ac); + rot(a, s); + inc(a, b); +end; + +// ----------------------------------------------------------------------------------------------- + +// Encode Count bytes at Source into (Count / 4) DWORDs at Target +procedure Encode(Source, Target: pointer; Count: longword); +var + S: PByte; + T: PDWORD; + I: longword; +begin + S := Source; + T := Target; + for I := 1 to Count div 4 do begin + T^ := S^; + inc(S); + T^ := T^ or (S^ shl 8); + inc(S); + T^ := T^ or (S^ shl 16); + inc(S); + T^ := T^ or (S^ shl 24); + inc(S); + inc(T); + end; +end; + +// Decode Count DWORDs at Source into (Count * 4) Bytes at Target +procedure Decode(Source, Target: pointer; Count: longword); +var + S: PDWORD; + T: PByte; + I: longword; +begin + S := Source; + T := Target; + for I := 1 to Count do begin + T^ := S^ and $ff; + inc(T); + T^ := (S^ shr 8) and $ff; + inc(T); + T^ := (S^ shr 16) and $ff; + inc(T); + T^ := (S^ shr 24) and $ff; + inc(T); + inc(S); + end; +end; + +// Transform State according to first 64 bytes at Buffer +procedure Transform(Buffer: pointer; var State: TMD5State); +var + a, b, c, d: DWORD; + Block: TMD5Block; +begin + Encode(Buffer, @Block, 64); + a := State[0]; + b := State[1]; + c := State[2]; + d := State[3]; + FF (a, b, c, d, Block[ 0], 7, $d76aa478); + FF (d, a, b, c, Block[ 1], 12, $e8c7b756); + FF (c, d, a, b, Block[ 2], 17, $242070db); + FF (b, c, d, a, Block[ 3], 22, $c1bdceee); + FF (a, b, c, d, Block[ 4], 7, $f57c0faf); + FF (d, a, b, c, Block[ 5], 12, $4787c62a); + FF (c, d, a, b, Block[ 6], 17, $a8304613); + FF (b, c, d, a, Block[ 7], 22, $fd469501); + FF (a, b, c, d, Block[ 8], 7, $698098d8); + FF (d, a, b, c, Block[ 9], 12, $8b44f7af); + FF (c, d, a, b, Block[10], 17, $ffff5bb1); + FF (b, c, d, a, Block[11], 22, $895cd7be); + FF (a, b, c, d, Block[12], 7, $6b901122); + FF (d, a, b, c, Block[13], 12, $fd987193); + FF (c, d, a, b, Block[14], 17, $a679438e); + FF (b, c, d, a, Block[15], 22, $49b40821); + GG (a, b, c, d, Block[ 1], 5, $f61e2562); + GG (d, a, b, c, Block[ 6], 9, $c040b340); + GG (c, d, a, b, Block[11], 14, $265e5a51); + GG (b, c, d, a, Block[ 0], 20, $e9b6c7aa); + GG (a, b, c, d, Block[ 5], 5, $d62f105d); + GG (d, a, b, c, Block[10], 9, $2441453); + GG (c, d, a, b, Block[15], 14, $d8a1e681); + GG (b, c, d, a, Block[ 4], 20, $e7d3fbc8); + GG (a, b, c, d, Block[ 9], 5, $21e1cde6); + GG (d, a, b, c, Block[14], 9, $c33707d6); + GG (c, d, a, b, Block[ 3], 14, $f4d50d87); + GG (b, c, d, a, Block[ 8], 20, $455a14ed); + GG (a, b, c, d, Block[13], 5, $a9e3e905); + GG (d, a, b, c, Block[ 2], 9, $fcefa3f8); + GG (c, d, a, b, Block[ 7], 14, $676f02d9); + GG (b, c, d, a, Block[12], 20, $8d2a4c8a); + HH (a, b, c, d, Block[ 5], 4, $fffa3942); + HH (d, a, b, c, Block[ 8], 11, $8771f681); + HH (c, d, a, b, Block[11], 16, $6d9d6122); + HH (b, c, d, a, Block[14], 23, $fde5380c); + HH (a, b, c, d, Block[ 1], 4, $a4beea44); + HH (d, a, b, c, Block[ 4], 11, $4bdecfa9); + HH (c, d, a, b, Block[ 7], 16, $f6bb4b60); + HH (b, c, d, a, Block[10], 23, $bebfbc70); + HH (a, b, c, d, Block[13], 4, $289b7ec6); + HH (d, a, b, c, Block[ 0], 11, $eaa127fa); + HH (c, d, a, b, Block[ 3], 16, $d4ef3085); + HH (b, c, d, a, Block[ 6], 23, $4881d05); + HH (a, b, c, d, Block[ 9], 4, $d9d4d039); + HH (d, a, b, c, Block[12], 11, $e6db99e5); + HH (c, d, a, b, Block[15], 16, $1fa27cf8); + HH (b, c, d, a, Block[ 2], 23, $c4ac5665); + II (a, b, c, d, Block[ 0], 6, $f4292244); + II (d, a, b, c, Block[ 7], 10, $432aff97); + II (c, d, a, b, Block[14], 15, $ab9423a7); + II (b, c, d, a, Block[ 5], 21, $fc93a039); + II (a, b, c, d, Block[12], 6, $655b59c3); + II (d, a, b, c, Block[ 3], 10, $8f0ccc92); + II (c, d, a, b, Block[10], 15, $ffeff47d); + II (b, c, d, a, Block[ 1], 21, $85845dd1); + II (a, b, c, d, Block[ 8], 6, $6fa87e4f); + II (d, a, b, c, Block[15], 10, $fe2ce6e0); + II (c, d, a, b, Block[ 6], 15, $a3014314); + II (b, c, d, a, Block[13], 21, $4e0811a1); + II (a, b, c, d, Block[ 4], 6, $f7537e82); + II (d, a, b, c, Block[11], 10, $bd3af235); + II (c, d, a, b, Block[ 2], 15, $2ad7d2bb); + II (b, c, d, a, Block[ 9], 21, $eb86d391); + inc(State[0], a); + inc(State[1], b); + inc(State[2], c); + inc(State[3], d); +end; + +// ----------------------------------------------------------------------------------------------- + +// Initialize given Context +procedure MD5Init(var Context: TMD5Context); +begin + with Context do begin + State[0] := $67452301; + State[1] := $efcdab89; + State[2] := $98badcfe; + State[3] := $10325476; + Count[0] := 0; + Count[1] := 0; + ZeroMemory(@Buffer, SizeOf(TMD5Buffer)); + end; +end; + +// Update given Context to include Length bytes of Input +procedure MD5Update(var Context: TMD5Context; Input: PAnsiChar; Length: longword); +var + Index: longword; + PartLen: longword; + I: longword; +begin + with Context do begin + Index := (Count[0] shr 3) and $3f; + inc(Count[0], Length shl 3); + if Count[0] < (Length shl 3) then inc(Count[1]); + inc(Count[1], Length shr 29); + end; + PartLen := 64 - Index; + if Length >= PartLen then begin + CopyMemory(@Context.Buffer[Index], Input, PartLen); + Transform(@Context.Buffer, Context.State); + I := PartLen; + while I + 63 < Length do begin + Transform(@Input[I], Context.State); + inc(I, 64); + end; + Index := 0; + end else I := 0; + CopyMemory(@Context.Buffer[Index], @Input[I], Length - I); +end; + +// Finalize given Context, create Digest and zeroize Context +procedure MD5Final(var Context: TMD5Context; var Digest: TMD5Digest); +var + Bits: TMD5CBits; + Index: longword; + PadLen: longword; +begin + Decode(@Context.Count, @Bits, 2); + Index := (Context.Count[0] shr 3) and $3f; + if Index < 56 then PadLen := 56 - Index else PadLen := 120 - Index; + MD5Update(Context, @PADDING, PadLen); + MD5Update(Context, @Bits, 8); + Decode(@Context.State, @Digest, 4); + ZeroMemory(@Context, SizeOf(TMD5Context)); +end; + +// ----------------------------------------------------------------------------------------------- + +// Create digest of given Message +function MD5String(M: AnsiString): TMD5Digest; +var + Context: TMD5Context; +begin + MD5Init(Context); + MD5Update(Context, PAnsiChar(M), length(M)); + MD5Final(Context, Result); +end; + +// Create digest of file with given Name +function MD5File(N: string): TMD5Digest; +var + FileHandle: THandle; + MapHandle: THandle; + ViewPointer: pointer; + Context: TMD5Context; +begin + MD5Init(Context); + FileHandle := CreateFile(pChar(N), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, + nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_SEQUENTIAL_SCAN, 0); + if FileHandle <> INVALID_HANDLE_VALUE then try + MapHandle := CreateFileMapping(FileHandle, nil, PAGE_READONLY, 0, 0, nil); + if MapHandle <> 0 then try + ViewPointer := MapViewOfFile(MapHandle, FILE_MAP_READ, 0, 0, 0); + if ViewPointer <> nil then try + MD5Update(Context, ViewPointer, GetFileSize(FileHandle, nil)); + finally + UnmapViewOfFile(ViewPointer); + end; + finally + CloseHandle(MapHandle); + end; + finally + CloseHandle(FileHandle); + end; + MD5Final(Context, Result); +end; + +// Create hex representation of given Digest +function MD5Print(D: TMD5Digest): string; +var + I: byte; +const + Digits: array[0..15] of char = + ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); +begin + Result := ''; + for I := 0 to 15 do Result := Result + Digits[(D[I] shr 4) and $0f] + Digits[D[I] and $0f]; +end; + +// ----------------------------------------------------------------------------------------------- + +// Compare two Digests +function MD5Match(D1, D2: TMD5Digest): boolean; +var + I: byte; +begin + I := 0; + Result := TRUE; + while Result and (I < 16) do begin + Result := D1[I] = D2[I]; + inc(I); + end; +end; + +end. + diff --git a/Tocsg.Lib/VCL/EncLib/EM.RC4.pas b/Tocsg.Lib/VCL/EncLib/EM.RC4.pas new file mode 100644 index 00000000..903d8c2e --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.RC4.pas @@ -0,0 +1,139 @@ +{ +*************************************************** +* A binary compatible RC4 implementation * +* written by Dave Barton (davebarton@bigfoot.com) * +*************************************************** +* Stream encryption * +* Variable size key - up to 2048bit * +*************************************************** +} +unit EM.RC4; + +interface + +uses + Windows, Sysutils; + +type + + TRC4Data= record + Key: array[0..255] of byte; { current key } + OrgKey: array[0..255] of byte; { original key } + end; + + function RC4SelfTest: boolean; + { performs a self test on this implementation } + procedure RC4Init(var Data: TRC4Data; Key: pointer; Len: integer); + { initializes the TRC4Data structure with the key information } + procedure RC4Burn(var Data: TRC4Data); + { erases all information about the key } + + procedure RC4Crypt(var Data: TRC4Data; InData, OutData: pointer; Len: integer); + { encrypts/decrypts Len bytes of data } + + procedure RC4Reset(var Data: TRC4Data); + { resets the key information } + + procedure RC4CryptData(PrivateKey: String; KeySize: Integer; + var InData, OutData; Size: Integer); + + +{******************************************************************************} +implementation + +function RC4SelfTest; +const + InBlock: array[0..4] of byte= ($dc,$ee,$4c,$f9,$2c); + OutBlock: array[0..4] of byte= ($f1,$38,$29,$c9,$de); + Key: array[0..4] of byte= ($61,$8a,$63,$d2,$fb); +var + Block: array[0..4] of byte; + Data: TRC4Data; +begin + RC4Init(Data,@Key,5); + RC4Crypt(Data,@InBlock,@Block,5); + Result:= CompareMem(@Block,@OutBlock,5); + RC4Reset(Data); + RC4Crypt(Data,@Block,@Block,5); + Result:= Result and CompareMem(@Block,@InBlock,5); + RC4Burn(Data); +end; + +procedure RC4Init; +var + xKey: array[0..255] of byte; + i, j: integer; + t: byte; +begin + if (Len<= 0) or (Len> 256) then + raise Exception.Create('RC4: Invalid key length'); + + for i:= 0 to 255 do + begin + Data.Key[i]:= i; + xKey[i]:= PByte(integer(Key)+(i mod Len))^; + end; + + j:= 0; + + i := 0; + while i <= 255 do + begin + j:= (j+Data.Key[i]+xKey[i]) and $FF; + t:= Data.Key[i]; + Data.Key[i]:= Data.Key[j]; + Data.Key[j]:= t; + Inc(i); + end; + +// for i:= 0 to 255 do +// begin +// j:= (j+Data.Key[i]+xKey[i]) and $FF; +// t:= Data.Key[i]; +// Data.Key[i]:= Data.Key[j]; +// Data.Key[j]:= t; +// end; + Move(Data.Key,Data.OrgKey,256); +end; + +procedure RC4Burn; +begin + FillChar(Data,Sizeof(Data),$FF); +end; + +procedure RC4Crypt; +var + t, i, j: byte; + k: integer; +begin + i:= 0; + j:= 0; + for k:= 0 to Len-1 do + begin + i:= (i+1) and $FF; + j:= (j+Data.Key[i]) and $FF; + t:= Data.Key[i]; + Data.Key[i]:= Data.Key[j]; + Data.Key[j]:= t; + t:= (Data.Key[i]+Data.Key[j]) and $FF; + PByteArray(OutData)[k]:= PByteArray(InData)[k] xor Data.Key[t]; + end; +end; + +procedure RC4Reset; +begin + Move(Data.OrgKey,Data.Key,256); +end; + +procedure RC4CryptData(PrivateKey: String; KeySize: Integer; + var InData, OutData; Size: Integer); +var + RC4Data: TRC4Data; +begin + RC4Init(RC4Data,PAnsiChar(PrivateKey),KeySize); + RC4Crypt(RC4Data,@InData,@OutData, Size); + RC4Burn(RC4Data); +end; + +end. + diff --git a/Tocsg.Lib/VCL/EncLib/EM.SHA1.pas b/Tocsg.Lib/VCL/EncLib/EM.SHA1.pas new file mode 100644 index 00000000..6eda1ee1 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.SHA1.pas @@ -0,0 +1,184 @@ + { +*************************************************** +* A binary compatible SHA1 implementation * +* written by Dave Barton (davebarton@bigfoot.com) * +*************************************************** +* 160bit hash size * +*************************************************** +} +unit EM.SHA1; + +interface +uses + Windows, Sysutils, EM.Tools; + +type + TSHA1Digest = array[0..19] of Byte; + TSHA1Context= record + Hash : array[0..4] of DWORD; + Hi, Lo : Integer; + Buffer : array[0..63] of Byte; + Index : Integer; + end; + +//function SHA1SelfTest: boolean; + +procedure SHA1Init(var Context: TSHA1Context); +procedure SHA1Update(var Context: TSHA1Context; Buffer: Pointer; Len: Integer); +procedure SHA1Final(var Context: TSHA1Context; var Digest: TSHA1Digest); + +//****************************************************************************** +implementation + +{$R-} + +//function SHA1SelfTest: boolean; +//const +// s: string= 'abc'; +// OutDigest: TSHA1Digest= +// ($a9,$99,$3e,$36,$47,$06,$81,$6a,$ba,$3e,$25,$71,$78,$50,$c2,$6c,$9c,$d0,$d8,$9d); +//var +// Context: TSHA1Context; +// Digest: TSHA1Digest; +//begin +// SHA1Init(Context); +// SHA1Update(Context,@s[1],length(s)); +// SHA1Final(Context,Digest); +// if CompareMem(@Digest,@OutDigest,Sizeof(Digest)) then +// Result:= true +// else +// Result:= false; +//end; + +//****************************************************************************** +function F1(x, y, z: DWORD): DWORD; +begin + Result:= z xor (x and (y xor z)); +end; +function F2(x, y, z: DWORD): DWORD; +begin + Result:= x xor y xor z; +end; +function F3(x, y, z: DWORD): DWORD; +begin + Result:= (x and y) or (z and (x or y)); +end; + +//****************************************************************************** +function RB(A: DWORD): DWORD; +begin + Result:= (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24); +end; + + +procedure SHA1Compress(var Data: TSHA1Context); +var + A, B, C, D, E, T: DWORD; + W: array[0..79] of DWORD; + i: integer; +begin + Move(Data.Buffer,W,Sizeof(Data.Buffer)); + for i:= 0 to 15 do + W[i]:= RB(W[i]); + for i:= 16 to 79 do + W[i]:= LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16],1); + A:= Data.Hash[0]; B:= Data.Hash[1]; C:= Data.Hash[2]; D:= Data.Hash[3]; E:= Data.Hash[4]; + for i:= 0 to 19 do + begin + T:= LRot32(A,5) + F1(B,C,D) + E + W[i] + $5A827999; + E:= D; D:= C; C:= LRot32(B,30); B:= A; A:= T; + end; + for i:= 20 to 39 do + begin + T:= LRot32(A,5) + F2(B,C,D) + E + W[i] + $6ED9EBA1; + E:= D; D:= C; C:= LRot32(B,30); B:= A; A:= T; + end; + for i:= 40 to 59 do + begin + T:= LRot32(A,5) + F3(B,C,D) + E + W[i] + $8F1BBCDC; + E:= D; D:= C; C:= LRot32(B,30); B:= A; A:= T; + end; + for i:= 60 to 79 do + begin + T:= LRot32(A,5) + F2(B,C,D) + E + W[i] + $CA62C1D6; + E:= D; D:= C; C:= LRot32(B,30); B:= A; A:= T; + end; + Data.Hash[0]:= Data.Hash[0] + A; + Data.Hash[1]:= Data.Hash[1] + B; + Data.Hash[2]:= Data.Hash[2] + C; + Data.Hash[3]:= Data.Hash[3] + D; + Data.Hash[4]:= Data.Hash[4] + E; + FillChar(W,Sizeof(W),0); + FillChar(Data.Buffer,Sizeof(Data.Buffer),0); +end; + +//****************************************************************************** +procedure SHA1Init(var Context: TSHA1Context); +begin + Context.Hi:= 0; Context.Lo:= 0; + Context.Index:= 0; + FillChar(Context.Buffer,Sizeof(Context.Buffer),0); + Context.Hash[0]:= $67452301; + Context.Hash[1]:= $EFCDAB89; + Context.Hash[2]:= $98BADCFE; + Context.Hash[3]:= $10325476; + Context.Hash[4]:= $C3D2E1F0; +end; + +//****************************************************************************** +procedure SHA1UpdateLen(var Context: TSHA1Context; Len: integer); +var + i, k: integer; +begin + for k:= 0 to 7 do + begin + i:= Context.Lo; + Inc(Context.Lo,Len); + if Context.Lo< i then + Inc(Context.Hi); + end; +end; + +//****************************************************************************** +procedure SHA1Update(var Context: TSHA1Context; Buffer: pointer; Len: integer); +type + PByte= ^Byte; +begin + SHA1UpdateLen(Context,Len); + while Len> 0 do + begin + Context.Buffer[Context.Index]:= PByte(Buffer)^; + Inc(PByte(Buffer)); + Inc(Context.Index); + Dec(Len); + if Context.Index= 64 then + begin + Context.Index:= 0; + SHA1Compress(Context); + end; + end; +end; + +//****************************************************************************** +procedure SHA1Final(var Context: TSHA1Context; var Digest: TSHA1Digest); +type + PDWORD= ^DWORD; +begin + Context.Buffer[Context.Index]:= $80; + if Context.Index>= 56 then + SHA1Compress(Context); + PDWORD(@Context.Buffer[56])^:= RB(Context.Hi); + PDWORD(@Context.Buffer[60])^:= RB(Context.Lo); + SHA1Compress(Context); + Context.Hash[0]:= RB(Context.Hash[0]); + Context.Hash[1]:= RB(Context.Hash[1]); + Context.Hash[2]:= RB(Context.Hash[2]); + Context.Hash[3]:= RB(Context.Hash[3]); + Context.Hash[4]:= RB(Context.Hash[4]); + Move(Context.Hash,Digest,Sizeof(Digest)); + FillChar(Context,Sizeof(Context),0); +end; + +end. + + diff --git a/Tocsg.Lib/VCL/EncLib/EM.Tocsg.hash.pas b/Tocsg.Lib/VCL/EncLib/EM.Tocsg.hash.pas new file mode 100644 index 00000000..b614fba2 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.Tocsg.hash.pas @@ -0,0 +1,413 @@ +unit EM.Tocsg.Hash; + +{General Hash Unit: This unit defines the common types, functions, and +procedures. Via Hash descriptors and corresponding pointers, algorithms +can be searched by name or by ID. More important: all supported algorithms +can be used in the HMAC and KDF constructions.} + + +interface + +(************************************************************************* + + DESCRIPTION : General hash unit: defines Algo IDs, digest types, etc + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17-D18/D25S, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : --- + + REMARK : TTgHashContext does not directly map the structure of the + context for SHA3 algorithms, a typecast with TSHA3State + from unit SHA3 should be used to access the fields. + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.10 15.01.06 W.Ehrhardt Initial version + 0.11 15.01.06 we FindHash_by_ID, $ifdef DLL: stdcall + 0.12 16.01.06 we FindHash_by_Name + 0.13 18.01.06 we Descriptor fields HAlgNum, HSig + 0.14 22.01.06 we Removed HSelfTest from descriptor + 0.14 31.01.06 we RIPEMD-160, C_MinHash, C_MaxHash + 0.15 11.02.06 we Fields: HDSize, HVersion, HPtrOID, HLenOID + 0.16 02.08.06 we Packed arrays + 0.17 07.08.06 we $ifdef BIT32: (const fname: shortstring...) + 0.18 07.08.06 we C_HashVers = $00010002 + 0.19 10.02.07 we HashFile: no eof, XL and filemode via $ifdef + 0.20 18.02.07 we MD4, C_HashVers = $00010003 + 0.21 22.02.07 we POID_Vec=^TOID_Vec, typed HPtrOID + 0.22 24.02.07 we added some checks for HSig=C_HashSig + 0.23 04.10.07 we TTgHashContext.Index now longint + 0.24 02.05.08 we type PHashDigest, function HashSameDigest + 0.25 04.05.08 we BitAPI_Mask, BitAPI_PBit + 0.26 05.05.08 we Descriptor with HFinalBit, C_HashVers=$00010004 + 0.27 20.05.08 we RMD160 as alias for RIPEMD160 + 0.28 12.11.08 we uses BTypes and Str255 + 0.29 19.07.09 we D12 fix: assign with typecast string(fname) + 0.30 08.03.12 we SHA512/224 and SHA512/256, C_HashVers=$00010005 + 0.31 10.03.12 we HashFile: {$ifndef BIT16} instead of {$ifdef WIN32} + + 0.32 08.08.18 we New enlarged padded context, _SHA3_224 .. _SHA3_512 + 0.33 08.08.18 we THMacBuffer, assert HASHCTXSIZE + 0.34 16.08.15 we Removed $ifdef DLL / stdcall + + 0.35 15.05.17 we Changes for Blake2s + 0.36 16.05.17 we MaxOIDLen = 11 and MaxC_HashVers = $00020002 + + 0.37 03.11.17 we TBlake2B_384/512Digest + + 0.38 29.11.17 we HashFile - fname: string + +**************************************************************************) + +(*------------------------------------------------------------------------- + (C) Copyright 2006-2017 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$i STD.INC} + +uses + BTypes; + +type + THashAlgorithm = (_MD4, _MD5, _RIPEMD160, _SHA1, + _SHA224, _SHA256, _SHA384, _SHA512, + _Whirlpool, _SHA512_224, _SHA512_256, + _SHA3_224, _SHA3_256, _SHA3_384, _SHA3_512, + _Blake2S_224, _Blake2S_256, + _Blake2B_384, _Blake2B_512); {Supported hash algorithms} + +const + _RMD160 = _RIPEMD160; {Alias} + +const + MaxBlockLen = 128; {Max. block length (buffer size), multiple of 4} + MaxDigestLen = 64; {Max. length of hash digest} + MaxStateLen = 16; {Max. size of internal state} + MaxOIDLen = 11; {Current max. OID length} + C_HashSig = $3D7A; {Signature for Hash descriptor} + C_HashVers = $00020002; {Version of Hash definitions} + C_MinHash = _MD4; {Lowest hash in THashAlgorithm} + C_MaxHash = _Blake2B_512;{Highest hash in THashAlgorithm} + +type + THashState = packed array[0..MaxStateLen-1] of longint; {Internal state} + THashBuffer = packed array[0..MaxBlockLen-1] of byte; {hash buffer block} + THashDigest = packed array[0..MaxDigestLen-1] of byte; {hash digest} + PHashDigest = ^THashDigest; {pointer to hash digest} + THashBuf32 = packed array[0..MaxBlockLen div 4 -1] of longint; {type cast helper} + THashDig32 = packed array[0..MaxDigestLen div 4 -1] of longint; {type cast helper} + THMacBuffer = packed array[0..143] of byte; {hmac buffer block} + +const + HASHCTXSIZE = 448; {Common size of enlarged padded old context} + {and new padded SHA3/SHAKE/Keccak context } + +type + TTgHashContext = packed record + Hash : THashState; {Working hash} + MLen : packed array[0..3] of longint; {max 128 bit msg length} + Buffer: THashBuffer; {Block buffer} + Index : longint; {Index in buffer} + Fill2 : packed array[213..HASHCTXSIZE] of byte; + end; + +type + TMD4Digest = packed array[0..15] of byte; {MD4 digest } + TMD5Digest = packed array[0..15] of byte; {MD5 digest } + TRMD160Digest = packed array[0..19] of byte; {RMD160 digest } + TSHA1Digest = packed array[0..19] of byte; {SHA1 digest } + TSHA224Digest = packed array[0..27] of byte; {SHA224 digest } + TSHA256Digest = packed array[0..31] of byte; {SHA256 digest } + TSHA384Digest = packed array[0..47] of byte; {SHA384 digest } + TSHA512Digest = packed array[0..63] of byte; {SHA512 digest } + TSHA5_224Digest = packed array[0..27] of byte; {SHA512/224 digest} + TSHA5_256Digest = packed array[0..31] of byte; {SHA512/256 digest} + TWhirlDigest = packed array[0..63] of byte; {Whirlpool digest } + TSHA3_224Digest = packed array[0..27] of byte; {SHA3_224 digest } + TSHA3_256Digest = packed array[0..31] of byte; {SHA3_256 digest } + TSHA3_384Digest = packed array[0..47] of byte; {SHA3_384 digest } + TSHA3_512Digest = packed array[0..63] of byte; {SHA3_512 digest } + TBlake2S_224Digest = packed array[0..27] of byte; {Blake2S digest } + TBlake2S_256Digest = packed array[0..31] of byte; {Blake2S digest } + TBlake2B_384Digest = packed array[0..47] of byte; {Blake2B-384 digest} + TBlake2B_512Digest = packed array[0..63] of byte; {Blake2B-512 digest} + + +type + HashInitProc = procedure(var Context: TTgHashContext); + {-initialize context} + + HashUpdateXLProc = procedure(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + + HashFinalProc = procedure(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize calculation, clear context} + + HashFinalBitProc = procedure(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize calculation with bitlen bits from BData, clear context} + +type + TOID_Vec = packed array[1..MaxOIDLen] of longint; {OID vector} + POID_Vec = ^TOID_Vec; {ptr to OID vector} + + Ptr2Inc = pByte; {Type cast to increment untyped pointer} + Str127 = string[127]; + +type + THashName = string[19]; {Hash algo name type } + PHashDesc = ^THashDesc; {Ptr to descriptor } + THashDesc = packed record + HSig : word; {Signature=C_HashSig } + HDSize : word; {sizeof(THashDesc) } + HDVersion : longint; {THashDesc Version } + HBlockLen : word; {Blocklength of hash, rate div 8 for SHA3} + HDigestlen: word; {Digestlength of hash} + HInit : HashInitProc; {Init procedure } + HFinal : HashFinalProc; {Final procedure } + HUpdateXL : HashUpdateXLProc; {Update procedure } + HAlgNum : longint; {Algo ID, longint avoids problems with enum size/DLL} + HName : THashName; {Name of hash algo } + HPtrOID : POID_Vec; {Pointer to OID vec } + HLenOID : word; {Length of OID vec } + HFill : word; + HFinalBit : HashFinalBitProc; {Bit-API Final proc } + HReserved : packed array[0..19] of byte; + end; + + +const + BitAPI_Mask: array[0..7] of byte = ($00,$80,$C0,$E0,$F0,$F8,$FC,$FE); + BitAPI_PBit: array[0..7] of byte = ($80,$40,$20,$10,$08,$04,$02,$01); + +procedure RegisterHash(AlgId: THashAlgorithm; PHash: PHashDesc); + {-Register algorithm with AlgID and Hash descriptor PHash^} + +function FindHash_by_ID(AlgoID: THashAlgorithm): PHashDesc; + {-Return PHashDesc of AlgoID, nil if not found/registered} + +function FindHash_by_Name(AlgoName: THashName): PHashDesc; + {-Return PHashDesc of Algo with AlgoName, nil if not found/registered} + +procedure HashFile({$ifdef CONST} const {$endif} fname: string; PHash: PHashDesc; + var Digest: THashDigest; var buf; bsize: word; var Err: word); + {-Calculate hash digest of file, buf: buffer with at least bsize bytes} + +procedure HashUpdate(PHash: PHashDesc; var Context: TTgHashContext; Msg: pointer; Len: word); + {-update context with Msg data} + +procedure HashFullXL(PHash: PHashDesc; var Digest: THashDigest; Msg: pointer; Len: longint); + {-Calulate hash digest of Msg with init/update/final} + +procedure HashFull(PHash: PHashDesc; var Digest: THashDigest; Msg: pointer; Len: word); + {-Calulate hash digest of Msg with init/update/final} + +function HashSameDigest(PHash: PHashDesc; PD1, PD2: PHashDigest): boolean; + {-Return true if same digests, using HDigestlen of PHash} + + +implementation + + +var + PHashVec : array[THashAlgorithm] of PHashDesc; + {Hash descriptor pointers of all defined hash algorithms} + +{---------------------------------------------------------------------------} +procedure RegisterHash(AlgId: THashAlgorithm; PHash: PHashDesc); + {-Register algorithm with AlgID and Hash descriptor PHash^} +begin + if (PHash<>nil) and + (PHash^.HAlgNum=longint(AlgId)) and + (PHash^.HSig=C_HashSig) and + (PHash^.HDVersion=C_HashVers) and + (PHash^.HDSize=sizeof(THashDesc)) then PHashVec[AlgId] := PHash; +end; + + +{---------------------------------------------------------------------------} +function FindHash_by_ID(AlgoID: THashAlgorithm): PHashDesc; + {-Return PHashDesc of AlgoID, nil if not found/registered} +var + p: PHashDesc; + A: longint; +begin + A := longint(AlgoID); + FindHash_by_ID := nil; + if (A>=ord(C_MinHash)) and (A<=ord(C_MaxHash)) then begin + p := PHashVec[AlgoID]; + if (p<>nil) and (p^.HSig=C_HashSig) and (p^.HAlgNum=A) then FindHash_by_ID := p; + end; +end; + + +{---------------------------------------------------------------------------} +function FindHash_by_Name(AlgoName: THashName): PHashDesc; + {-Return PHashDesc of Algo with AlgoName, nil if not found/registered} +var + algo : THashAlgorithm; + phash: PHashDesc; + + function StrUpcase(s: THashName): THashName; + {-Upcase for strings} + var + i: integer; + begin + for i:=1 to length(s) do s[i] := upcase(s[i]); + StrUpcase := s; + end; + +begin + AlgoName := StrUpcase(Algoname); + {Transform RMD160 alias to standard name} + if AlgoName='RMD160' then AlgoName:='RIPEMD160'; + FindHash_by_Name := nil; + for algo := C_MinHash to C_MaxHash do begin + phash := PHashVec[algo]; + if (phash<>nil) and (AlgoName=StrUpcase(phash^.HName)) + and (phash^.HSig=C_HashSig) and (phash^.HAlgNum=longint(algo)) + then begin + FindHash_by_Name := phash; + exit; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure HashUpdate(PHash: PHashDesc; var Context: TTgHashContext; Msg: pointer; Len: word); + {-update context with Msg data} +begin + if PHash<>nil then with PHash^ do begin + if HSig=C_HashSig then HUpdateXL(Context, Msg, Len); + end; +end; + + +{---------------------------------------------------------------------------} +procedure HashFullXL(PHash: PHashDesc; var Digest: THashDigest; Msg: pointer; Len: longint); + {-Calulate hash digest of Msg with init/update/final} +var + Context: TTgHashContext; +begin + if PHash<>nil then with PHash^ do begin + if HSig=C_HashSig then begin + HInit(Context); + HUpdateXL(Context, Msg, Len); + HFinal(Context, Digest); + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure HashFull(PHash: PHashDesc; var Digest: THashDigest; Msg: pointer; Len: word); + {-Calulate hash digest of Msg with init/update/final} +begin + {test PHash<>nil in HashFullXL} + HashFullXL(PHash, Digest, Msg, Len); +end; + + +{---------------------------------------------------------------------------} +function HashSameDigest(PHash: PHashDesc; PD1, PD2: PHashDigest): boolean; + {-Return true if same digests, using HDigestlen of PHash} +var + i: integer; +begin + HashSameDigest := false; + if PHash<>nil then with PHash^ do begin + if (HSig=C_HashSig) and (HDigestlen>0) then begin + for i:=0 to pred(HDigestlen) do begin + if PD1^[i]<>PD2^[i] then exit; + end; + HashSameDigest := true; + end; + end; +end; + + +{$i-} {Force I-} +{---------------------------------------------------------------------------} +procedure HashFile({$ifdef CONST} const {$endif} fname: string; PHash: PHashDesc; + var Digest: THashDigest; var buf; bsize: word; var Err: word); + {-Calculate hash digest of file, buf: buffer with at least bsize bytes} +var + {$ifdef VirtualPascal} + fms: word; + {$else} + fms: byte; + {$endif} + {$ifndef BIT16} + L: longint; + {$else} + L: word; + {$endif} +var + Context: TTgHashContext; + f: file; +begin + if (PHash=nil) or (Phash^.HSig<>C_HashSig) then begin + Err := 204; {Invalid pointer} + exit; + end; + fms := FileMode; + {$ifdef VirtualPascal} + FileMode := $40; {open_access_ReadOnly or open_share_DenyNone;} + {$else} + FileMode := 0; + {$endif} + system.assign(f,{$ifdef D12Plus} string {$endif} (fname)); + system.reset(f,1); + Err := IOResult; + FileMode := fms; + if Err<>0 then exit; + with PHash^ do begin + HInit(Context); + L := bsize; + while (Err=0) and (L=bsize) do begin + system.blockread(f,buf,bsize,L); + Err := IOResult; + HUpdateXL(Context, @buf, L); + end; + system.close(f); + if IOResult=0 then {}; + HFinal(Context, Digest); + end; +end; + + +begin +{$ifdef HAS_ASSERT} + assert(sizeof(TTgHashContext)=HASHCTXSIZE , '** Invalid sizeof(TTgHashContext)'); +{$else} + if sizeof(TTgHashContext)<>HASHCTXSIZE then RunError(227); +{$endif} + {Paranoia: initialize all descriptor pointers to nil (should} + {be done by compiler/linker because array is in global data)} + fillchar(PHashVec,sizeof(PHashVec),0); +end. diff --git a/Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha1.pas b/Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha1.pas new file mode 100644 index 00000000..9386355c --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha1.pas @@ -0,0 +1,905 @@ +unit EM.Tocsg.SHA1; + +{SHA1 - 160 bit Secure Hash Function} + + +interface + +(************************************************************************* + + DESCRIPTION : SHA1 - 160 bit Secure Hash Function + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17-D18/D25S, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : - Latest specification of Secure Hash Standard: + http://csrc.nist.gov/publications/fips/fips180-4/fips-180-4.pdf + - Test vectors and intermediate values: + http://csrc.nist.gov/groups/ST/toolkit/documents/Examples/SHA_All.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 1.00 03.01.02 W.Ehrhardt BP7 implementation + 1.01 14.03.02 we D1-D6, FPC, VP + 1.02 14.03.02 we TP6 + 1.03 14.03.02 we TP6/7 386-Code + 1.04 14.03.02 we TP5.5 + 1.10 15.03.02 we self test with 2 strings + 1.11 02.01.03 we const SFA with @ for FPC 1.0.6 + 1.20 23.07.03 we With SHA1File, SHA1Full + 1.21 26.07.03 we With SHA1Full in self test + 2.00 26.07.03 we common vers., longint for word32, D4+ - warnings + 2.01 03.08.03 we type TSHA1Block for HMAC + 2.02 23.08.03 we SHA1Compress in interface for prng + 2.10 29.08.03 we XL versions for Win32 + 2.20 27.09.03 we FPC/go32v2 + 2.30 05.10.03 we STD.INC, TP5.0 + 2.40 10.10.03 we common version, english comments + 2.45 11.10.03 we Speedup: partial unroll, no function calls + 2.50 16.11.03 we Speedup in update, don't clear W in compress + 2.51 17.11.03 we BIT16: partial unroll, BIT32: inline rot + 2.52 17.11.03 we ExpandMessageBlocks + 2.53 18.11.03 we LRot32, RB mit inline() + 2.54 20.11.03 we Full range UpdateLen + 2.55 30.11.03 we BIT16: {$F-} + 2.56 30.11.03 we BIT16: LRot_5, LRot_30 + 3.00 01.12.03 we Common version 3.0 + 3.01 22.12.03 we BIT16: Two INCs + 3.02 22.12.03 we BASM16: asm Lrot30 + 3.03 22.12.03 we TP5/5.5: LRot, RA inline + 3.04 22,12.03 we Changed UpdateLen: Definition and TP5/5.5 inline + 3.05 05.03.04 we Update fips180-2 URL + 3.06 26.02.05 we With {$ifdef StrictLong} + 3.07 05.05.05 we Use longint() in SH1Init to avoid D9 errors if $R+ + 3.08 17.12.05 we Force $I- in SHA1File + 3.09 08.01.06 we SHA1Compress removed from interface + 3.10 15.01.06 we uses Hash unit and THashDesc + 3.11 18.01.06 we Descriptor fields HAlgNum, HSig + 3.12 22.01.06 we Removed HSelfTest from descriptor + 3.13 11.02.06 we Descriptor as typed const + 3.14 26.03.06 we Round constants K1..K4, code reordering + 3.15 07.08.06 we $ifdef BIT32: (const fname: shortstring...) + 3.16 22.02.07 we values for OID vector + 3.17 30.06.07 we Use conditional define FPC_ProcVar + 3.18 04.10.07 we FPC: {$asmmode intel} + 3.19 02.05.08 we Bit-API: SHA1FinalBits/Ex + 3.20 05.05.08 we THashDesc constant with HFinalBit field + 3.21 12.11.08 we uses BTypes, Ptr2Inc and/or Str255/Str127 + 3.22 12.03.10 we Fix VP feature in ExpandMessageBlocks + 3.23 11.03.12 we Updated references + 3.24 26.12.12 we D17 and PurePascal + 3.25 16.08.15 we Removed $ifdef DLL / stdcall + 3.26 15.05.17 we adjust OID to new MaxOIDLen + 3.27 29.11.17 we SHA1File - fname: string + +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2017 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{NOTE: FIPS Ch and May functions can be optimized. Wei Dai (Crypto++ 3.1) +credits Rich Schroeppel (rcs@cs.arizona.edu), V 5.1 does not!?} + + +{$i STD.INC} + +{$ifdef BIT64} + {$ifndef PurePascal} + {$define PurePascal} + {$endif} +{$endif} + +uses +// BTypes,Hash; + EM.Tocsg.Hash; + + +procedure SHA1Init(var Context: TTgHashContext); + {-initialize context} + +procedure SHA1Update(var Context: TTgHashContext; Msg: pointer; Len: word); + {-update context with Msg data} + +procedure SHA1UpdateXL(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + +procedure SHA1Final(var Context: TTgHashContext; var Digest: TSHA1Digest); + {-finalize SHA1 calculation, clear context} + +procedure SHA1FinalEx(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize SHA1 calculation, clear context} + +procedure SHA1FinalBitsEx(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA1 calculation with bitlen bits from BData (big-endian), clear context} + +procedure SHA1FinalBits(var Context: TTgHashContext; var Digest: TSHA1Digest; BData: byte; bitlen: integer); + {-finalize SHA1 calculation with bitlen bits from BData (big-endian), clear context} + +function SHA1SelfTest: boolean; + {-self test SHA1: compare with known value} + +procedure SHA1Full(var Digest: TSHA1Digest; Msg: pointer; Len: word); + {-SHA1 of Msg with init/update/final} + +procedure SHA1FullXL(var Digest: TSHA1Digest; Msg: pointer; Len: longint); + {-SHA1 of Msg with init/update/final} + +procedure SHA1File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA1Digest; var buf; bsize: word; var Err: word); + {-SHA1 of file, buf: buffer with at least bsize bytes} + + +implementation + +{$ifdef BIT16} + {$F-} +{$endif} + +const + SHA1_BlockLen = 64; + +const {round constants} + K1 = longint($5A827999); {round 00..19} + K2 = longint($6ED9EBA1); {round 20..39} + K3 = longint($8F1BBCDC); {round 40..59} + K4 = longint($CA62C1D6); {round 60..79} + + +{Internal types} +type + TWorkBuf = array[0..79] of longint; + +{1.3.14.3.2.26} +{iso(1) identified-organization(3) oiw(14) secsig(3) algorithms(2) hashAlgorithmIdentifier(26)} +const + SHA1_OID : TOID_Vec = (1,3,14,3,2,26,-1,-1,-1,-1,-1); {Len=6} + +{$ifndef VER5X} +const + SHA1_Desc: THashDesc = ( + HSig : C_HashSig; + HDSize : sizeof(THashDesc); + HDVersion : C_HashVers; + HBlockLen : SHA1_BlockLen; + HDigestlen: sizeof(TSHA1Digest); + {$ifdef FPC_ProcVar} + HInit : @SHA1Init; + HFinal : @SHA1FinalEx; + HUpdateXL : @SHA1UpdateXL; + {$else} + HInit : SHA1Init; + HFinal : SHA1FinalEx; + HUpdateXL : SHA1UpdateXL; + {$endif} + HAlgNum : longint(_SHA1); + HName : 'SHA1'; + HPtrOID : @SHA1_OID; + HLenOID : 6; + HFill : 0; + {$ifdef FPC_ProcVar} + HFinalBit : @SHA1FinalBitsEx; + {$else} + HFinalBit : SHA1FinalBitsEx; + {$endif} + HReserved : (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0) + ); +{$else} +var + SHA1_Desc: THashDesc; +{$endif} + + + +{$ifndef BIT16} + +{$ifdef PurePascal} + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + var + tmp: int64; + begin + tmp := int64(cardinal(wlo))+Blen; + wlo := longint(tmp and $FFFFFFFF); + inc(whi,longint(tmp shr 32)); + end; + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; + {-reverse byte order in longint} + begin + RB := ((A and $FF) shl 24) or ((A and $FF00) shl 8) or ((A and $FF0000) shr 8) or ((A and longint($FF000000)) shr 24); + end; + + {---------------------------------------------------------------------------} + procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuffer); + {-Calculate "expanded message blocks"} + var + i,T: longint; + begin + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i]:= RB(THashBuf32(Buf)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 79 do begin + T := W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]; + W[i] := (T shl 1) or (T shr 31); + end; + end; + +{$else} + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + begin + asm + mov edx, [wlo] + mov ecx, [whi] + mov eax, [Blen] + add [edx], eax + adc dword ptr [ecx], 0 + end; + end; + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; assembler; + {-reverse byte order in longint} + asm + {$ifdef LoadArgs} + mov eax,[A] + {$endif} + xchg al,ah + rol eax,16 + xchg al,ah + end; + + {---------------------------------------------------------------------------} + procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuffer); assembler; + {-Calculate "expanded message blocks"} + asm + {$ifdef LoadArgs} + mov edx,Buf + mov ecx,W {load W before push ebx to avoid VP crash} + push ebx {if compiling with no ASM stack frames} + mov ebx,ecx + {$else} + push ebx + mov ebx,eax + {$endif} + {part1: W[i]:= RB(TW32Buf(Buf)[i])} + mov ecx,16 + @@1: mov eax,[edx] + xchg al,ah + rol eax,16 + xchg al,ah + mov [ebx],eax + add ebx,4 + add edx,4 + dec ecx + jnz @@1 + {part2: W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]);} + mov ecx,64 + @@2: mov eax,[ebx- 3*4] + xor eax,[ebx- 8*4] + xor eax,[ebx-14*4] + xor eax,[ebx-16*4] + rol eax,1 + mov [ebx],eax + add ebx,4 + dec ecx + jnz @@2 + pop ebx + end; +{$endif} + + +{---------------------------------------------------------------------------} +procedure SHA1Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; + A, B, C, D, E: longint; + W: TWorkBuf; +begin + + ExpandMessageBlocks(W, Data.Buffer); + + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + + {SHA1 compression function} + {Partial unroll for more speed, full unroll is only slightly faster} + {BIT32: rotateleft via inline} + i := 0; + while i<20 do begin + inc(E, (A shl 5 or A shr 27) + (D xor (B and (C xor D))) + W[i ] + K1); B := B shr 2 or B shl 30; + inc(D, (E shl 5 or E shr 27) + (C xor (A and (B xor C))) + W[i+1] + K1); A := A shr 2 or A shl 30; + inc(C, (D shl 5 or D shr 27) + (B xor (E and (A xor B))) + W[i+2] + K1); E := E shr 2 or E shl 30; + inc(B, (C shl 5 or C shr 27) + (A xor (D and (E xor A))) + W[i+3] + K1); D := D shr 2 or D shl 30; + inc(A, (B shl 5 or B shr 27) + (E xor (C and (D xor E))) + W[i+4] + K1); C := C shr 2 or C shl 30; + inc(i,5); + end; + while i<40 do begin + inc(E, (A shl 5 or A shr 27) + (D xor B xor C) + W[i ] + K2); B := B shr 2 or B shl 30; + inc(D, (E shl 5 or E shr 27) + (C xor A xor B) + W[i+1] + K2); A := A shr 2 or A shl 30; + inc(C, (D shl 5 or D shr 27) + (B xor E xor A) + W[i+2] + K2); E := E shr 2 or E shl 30; + inc(B, (C shl 5 or C shr 27) + (A xor D xor E) + W[i+3] + K2); D := D shr 2 or D shl 30; + inc(A, (B shl 5 or B shr 27) + (E xor C xor D) + W[i+4] + K2); C := C shr 2 or C shl 30; + inc(i,5); + end; + while i<60 do begin + inc(E, (A shl 5 or A shr 27) + ((B and C) or (D and (B or C))) + W[i ] + K3); B := B shr 2 or B shl 30; + inc(D, (E shl 5 or E shr 27) + ((A and B) or (C and (A or B))) + W[i+1] + K3); A := A shr 2 or A shl 30; + inc(C, (D shl 5 or D shr 27) + ((E and A) or (B and (E or A))) + W[i+2] + K3); E := E shr 2 or E shl 30; + inc(B, (C shl 5 or C shr 27) + ((D and E) or (A and (D or E))) + W[i+3] + K3); D := D shr 2 or D shl 30; + inc(A, (B shl 5 or B shr 27) + ((C and D) or (E and (C or D))) + W[i+4] + K3); C := C shr 2 or C shl 30; + inc(i,5); + end; + while i<80 do begin + inc(E, (A shl 5 or A shr 27) + (D xor B xor C) + W[i ] + K4); B := B shr 2 or B shl 30; + inc(D, (E shl 5 or E shr 27) + (C xor A xor B) + W[i+1] + K4); A := A shr 2 or A shl 30; + inc(C, (D shl 5 or D shr 27) + (B xor E xor A) + W[i+2] + K4); E := E shr 2 or E shl 30; + inc(B, (C shl 5 or C shr 27) + (A xor D xor E) + W[i+3] + K4); D := D shr 2 or D shl 30; + inc(A, (B shl 5 or B shr 27) + (E xor C xor D) + W[i+4] + K4); C := C shr 2 or C shl 30; + inc(i,5); + end; + + {Calculate new working hash} + inc(Data.Hash[0], A); + inc(Data.Hash[1], B); + inc(Data.Hash[2], C); + inc(Data.Hash[3], D); + inc(Data.Hash[4], E); +end; + + + +{$else} + + +{$ifdef BASM16} + +{TP6-7/Delphi1 for 386+} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); assembler; + {-Add BLen to 64 bit value (wlo, whi)} +asm + les di,[wlo] + db $66; mov ax,word ptr [BLen] + db $66; sub dx,dx + db $66; add es:[di],ax + les di,[whi] + db $66; adc es:[di],dx +end; + + +{---------------------------------------------------------------------------} +function LRot_5(x: longint): longint; + {-Rotate left 5} +inline( + $66/$58/ {pop eax } + $66/$C1/$C0/$05/ {rol eax,5 } + $66/$8B/$D0/ {mov edx,eax} + $66/$C1/$EA/$10); {shr edx,16 } + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; + {-reverse byte order in longint} +inline( + $58/ {pop ax } + $5A/ {pop dx } + $86/$C6/ {xchg dh,al } + $86/$E2); {xchg dl,ah } + + +{---------------------------------------------------------------------------} +procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuffer); assembler; + {-Calculate "expanded message blocks"} +asm + push ds + {part 1: W[i]:= RB(TW32Buf(Buf)[i])} + les di,[Buf] + lds si,[W] + mov cx,16 +@@1: db $66; mov ax,es:[di] + xchg al,ah + db $66; rol ax,16 + xchg al,ah + db $66; mov [si],ax + add si,4 + add di,4 + dec cx + jnz @@1 + {part 2: W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]);} + mov cx,64 +@@2: db $66; mov ax,[si- 3*4] + db $66; xor ax,[si- 8*4] + db $66; xor ax,[si-14*4] + db $66; xor ax,[si-16*4] + db $66; rol ax,1 + db $66; mov [si],ax + add si,4 + dec cx + jnz @@2 + pop ds +end; + +{---------------------------------------------------------------------------} +procedure SHA1Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; + A, B, C, D, E: longint; + W: TWorkBuf; +begin + ExpandMessageBlocks(W, Data.Buffer); + {Assign old working hash to variables A..E} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + + {SHA1 compression function} + {Partial unroll for more speed, full unroll only marginally faster} + {Two INCs, LRot_30 via BASM} + i := 0; + while i<20 do begin + inc(E,LRot_5(A)); inc(E,(D xor (B and (C xor D))) + W[i ] + K1); asm db $66; rol word[B],30 end; + inc(D,LRot_5(E)); inc(D,(C xor (A and (B xor C))) + W[i+1] + K1); asm db $66; rol word[A],30 end; + inc(C,LRot_5(D)); inc(C,(B xor (E and (A xor B))) + W[i+2] + K1); asm db $66; rol word[E],30 end; + inc(B,LRot_5(C)); inc(B,(A xor (D and (E xor A))) + W[i+3] + K1); asm db $66; rol word[D],30 end; + inc(A,LRot_5(B)); inc(A,(E xor (C and (D xor E))) + W[i+4] + K1); asm db $66; rol word[C],30 end; + inc(i,5); + end; + while i<40 do begin + inc(E,LRot_5(A)); inc(E,(B xor C xor D) + W[i ] + K2); asm db $66; rol word[B],30 end; + inc(D,LRot_5(E)); inc(D,(A xor B xor C) + W[i+1] + K2); asm db $66; rol word[A],30 end; + inc(C,LRot_5(D)); inc(C,(E xor A xor B) + W[i+2] + K2); asm db $66; rol word[E],30 end; + inc(B,LRot_5(C)); inc(B,(D xor E xor A) + W[i+3] + K2); asm db $66; rol word[D],30 end; + inc(A,LRot_5(B)); inc(A,(C xor D xor E) + W[i+4] + K2); asm db $66; rol word[C],30 end; + inc(i,5); + end; + while i<60 do begin + inc(E,LRot_5(A)); inc(E,((B and C) or (D and (B or C))) + W[i ] + K3); asm db $66; rol word[B],30 end; + inc(D,LRot_5(E)); inc(D,((A and B) or (C and (A or B))) + W[i+1] + K3); asm db $66; rol word[A],30 end; + inc(C,LRot_5(D)); inc(C,((E and A) or (B and (E or A))) + W[i+2] + K3); asm db $66; rol word[E],30 end; + inc(B,LRot_5(C)); inc(B,((D and E) or (A and (D or E))) + W[i+3] + K3); asm db $66; rol word[D],30 end; + inc(A,LRot_5(B)); inc(A,((C and D) or (E and (C or D))) + W[i+4] + K3); asm db $66; rol word[C],30 end; + inc(i,5); + end; + while i<80 do begin + inc(E,LRot_5(A)); inc(E,(B xor C xor D) + W[i ] + K4); asm db $66; rol word[B],30 end; + inc(D,LRot_5(E)); inc(D,(A xor B xor C) + W[i+1] + K4); asm db $66; rol word[A],30 end; + inc(C,LRot_5(D)); inc(C,(E xor A xor B) + W[i+2] + K4); asm db $66; rol word[E],30 end; + inc(B,LRot_5(C)); inc(B,(D xor E xor A) + W[i+3] + K4); asm db $66; rol word[D],30 end; + inc(A,LRot_5(B)); inc(A,(C xor D xor E) + W[i+4] + K4); asm db $66; rol word[C],30 end; + inc(i,5); + end; + + {Calculate new working hash} + inc(Data.Hash[0], A); + inc(Data.Hash[1], B); + inc(Data.Hash[2], C); + inc(Data.Hash[3], D); + inc(Data.Hash[4], E); + +end; + + +{$else} + +{TP5/5.5} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} +inline( + $58/ {pop ax } + $5A/ {pop dx } + $5B/ {pop bx } + $07/ {pop es } + $26/$01/$07/ {add es:[bx],ax } + $26/$11/$57/$02/ {adc es:[bx+02],dx} + $5B/ {pop bx } + $07/ {pop es } + $26/$83/$17/$00/ {adc es:[bx],0 } + $26/$83/$57/$02/$00);{adc es:[bx+02],0 } + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; + {-reverse byte order in longint} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $86/$C6/ { xchg dh,al} + $86/$E2); { xchg dl,ah} + + +{---------------------------------------------------------------------------} +function LRot_1(x: longint): longint; + {-Rotate left 1} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $2B/$C9/ { sub cx,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1); { adc ax,cx} + + +{---------------------------------------------------------------------------} +function LRot_5(x: longint): longint; + {-Rotate left 5} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $2B/$C9/ { sub cx,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1/ { adc ax,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1/ { adc ax,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1/ { adc ax,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1/ { adc ax,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1); { adc ax,cx} + + +{---------------------------------------------------------------------------} +function LRot_30(x: longint): longint; + {-Rotate left 30 = rot right 2} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $8B/$CA/ { mov cx,dx} + $D1/$E9/ { shr cx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA/ { rcr dx,1 } + $8B/$CA/ { mov cx,dx} + $D1/$E9/ { shr cx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA); { rcr dx,1 } + + +{---------------------------------------------------------------------------} +procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuffer); + {-Calculate "expanded message blocks"} +var + i: integer; +begin + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i]:= RB(THashBuf32(Buf)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 79 do W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; + A, B, C, D, E: longint; + W: TWorkBuf; +begin + ExpandMessageBlocks(W, Data.Buffer); + + {Assign old working hash to variables A..E} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + + {SHA1 compression function} + {Partial unroll for more speed, full unroll only marginally faster} + {BIT16: rotateleft via function call} + i := 0; + while i<20 do begin + inc(E,LRot_5(A) + (D xor (B and (C xor D))) + W[i ] + K1); B := LRot_30(B); + inc(D,LRot_5(E) + (C xor (A and (B xor C))) + W[i+1] + K1); A := LRot_30(A); + inc(C,LRot_5(D) + (B xor (E and (A xor B))) + W[i+2] + K1); E := LRot_30(E); + inc(B,LRot_5(C) + (A xor (D and (E xor A))) + W[i+3] + K1); D := LRot_30(D); + inc(A,LRot_5(B) + (E xor (C and (D xor E))) + W[i+4] + K1); C := LRot_30(C); + inc(i,5); + end; + while i<40 do begin + inc(E,LRot_5(A) + (B xor C xor D) + W[i ] + K2); B := LRot_30(B); + inc(D,LRot_5(E) + (A xor B xor C) + W[i+1] + K2); A := LRot_30(A); + inc(C,LRot_5(D) + (E xor A xor B) + W[i+2] + K2); E := LRot_30(E); + inc(B,LRot_5(C) + (D xor E xor A) + W[i+3] + K2); D := LRot_30(D); + inc(A,LRot_5(B) + (C xor D xor E) + W[i+4] + K2); C := LRot_30(C); + inc(i,5); + end; + while i<60 do begin + inc(E,LRot_5(A) + ((B and C) or (D and (B or C))) + W[i ] + K3); B := LRot_30(B); + inc(D,LRot_5(E) + ((A and B) or (C and (A or B))) + W[i+1] + K3); A := LRot_30(A); + inc(C,LRot_5(D) + ((E and A) or (B and (E or A))) + W[i+2] + K3); E := LRot_30(E); + inc(B,LRot_5(C) + ((D and E) or (A and (D or E))) + W[i+3] + K3); D := LRot_30(D); + inc(A,LRot_5(B) + ((C and D) or (E and (C or D))) + W[i+4] + K3); C := LRot_30(C); + inc(i,5); + end; + while i<80 do begin + inc(E,LRot_5(A) + (B xor C xor D) + W[i ] + K4); B := LRot_30(B); + inc(D,LRot_5(E) + (A xor B xor C) + W[i+1] + K4); A := LRot_30(A); + inc(C,LRot_5(D) + (E xor A xor B) + W[i+2] + K4); E := LRot_30(E); + inc(B,LRot_5(C) + (D xor E xor A) + W[i+3] + K4); D := LRot_30(D); + inc(A,LRot_5(B) + (C xor D xor E) + W[i+4] + K4); C := LRot_30(C); + inc(i,5); + end; + + {Calculate new working hash} + inc(Data.Hash[0], A); + inc(Data.Hash[1], B); + inc(Data.Hash[2], C); + inc(Data.Hash[3], D); + inc(Data.Hash[4], E); + +end; + +{$endif BASM16} + +{$endif BIT16} + + + +{---------------------------------------------------------------------------} +procedure SHA1Init(var Context: TTgHashContext); + {-initialize context} +begin + {Clear context, buffer=0!!} + fillchar(Context,sizeof(Context),0); + with Context do begin + Hash[0] := longint($67452301); + Hash[1] := longint($EFCDAB89); + Hash[2] := longint($98BADCFE); + Hash[3] := longint($10325476); + Hash[4] := longint($C3D2E1F0); + end; +end; + + +{---------------------------------------------------------------------------} +procedure SHA1UpdateXL(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} +var + i: integer; +begin + {Update message bit length} + if Len<=$1FFFFFFF then UpdateLen(Context.MLen[1], Context.MLen[0], Len shl 3) + else begin + for i:=1 to 8 do UpdateLen(Context.MLen[1], Context.MLen[0], Len) + end; + while Len > 0 do begin + {fill block with msg data} + Context.Buffer[Context.Index]:= pByte(Msg)^; + inc(Ptr2Inc(Msg)); + inc(Context.Index); + dec(Len); + if Context.Index=SHA1_BlockLen then begin + {If 512 bit transferred, compress a block} + Context.Index:= 0; + SHA1Compress(Context); + while Len>=SHA1_BlockLen do begin + move(Msg^,Context.Buffer,SHA1_BlockLen); + SHA1Compress(Context); + inc(Ptr2Inc(Msg),SHA1_BlockLen); + dec(Len,SHA1_BlockLen); + end; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure SHA1Update(var Context: TTgHashContext; Msg: pointer; Len: word); + {-update context with Msg data} +begin + SHA1UpdateXL(Context, Msg, Len); +end; + + + +{---------------------------------------------------------------------------} +procedure SHA1FinalBitsEx(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA1 calculation with bitlen bits from BData (big-endian), clear context} +var + i: integer; +begin + {Message padding} + {append bits from BData and a single '1' bit} + if (bitlen>0) and (bitlen<=7) then begin + Context.Buffer[Context.Index]:= (BData and BitAPI_Mask[bitlen]) or BitAPI_PBit[bitlen]; + UpdateLen(Context.MLen[1], Context.MLen[0], bitlen); + end + else Context.Buffer[Context.Index]:= $80; + + for i:=Context.Index+1 to 63 do Context.Buffer[i] := 0; + {2. Compress if more than 448 bits, (no room for 64 bit length} + if Context.Index>= 56 then begin + SHA1Compress(Context); + fillchar(Context.Buffer,56,0); + end; + {Write 64 bit msg length into the last bits of the last block} + {(in big endian format) and do a final compress} + THashBuf32(Context.Buffer)[14] := RB(Context.MLen[1]); + THashBuf32(Context.Buffer)[15] := RB(Context.MLen[0]); + SHA1Compress(Context); + {Hash->Digest to little endian format} + fillchar(Digest, sizeof(Digest), 0); + for i:=0 to 4 do THashDig32(Digest)[i]:= RB(Context.Hash[i]); + {Clear context} + fillchar(Context,sizeof(Context),0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1FinalBits(var Context: TTgHashContext; var Digest: TSHA1Digest; BData: byte; bitlen: integer); + {-finalize SHA1 calculation with bitlen bits from BData (big-endian), clear context} +var + tmp: THashDigest; +begin + SHA1FinalBitsEx(Context, tmp, BData, bitlen); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1FinalEx(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize SHA1 calculation, clear context} +begin + SHA1FinalBitsEx(Context,Digest,0,0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1Final(var Context: TTgHashContext; var Digest: TSHA1Digest); + {-finalize SHA1 calculation, clear context} +var + tmp: THashDigest; +begin + SHA1FinalBitsEx(Context, tmp, 0, 0); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +function SHA1SelfTest: boolean; + {-self test SHA1: compare with known value} +const + s1: string[ 3] = 'abc'; + s2: string[56] = 'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'; + D1: TSHA1Digest= ($a9,$99,$3e,$36,$47,$06,$81,$6a,$ba,$3e,$25,$71,$78,$50,$c2,$6c,$9c,$d0,$d8,$9d); + D2: TSHA1Digest= ($84,$98,$3E,$44,$1C,$3B,$D2,$6E,$BA,$AE,$4A,$A1,$F9,$51,$29,$E5,$E5,$46,$70,$F1); + D3: TSHA1Digest= ($bb,$6b,$3e,$18,$f0,$11,$5b,$57,$92,$52,$41,$67,$6f,$5b,$1a,$e8,$87,$47,$b0,$8a); + D4: TSHA1Digest= ($98,$23,$2a,$15,$34,$53,$14,$9a,$f8,$d5,$2a,$61,$50,$3a,$50,$74,$b8,$59,$70,$e8); +var + Context: TTgHashContext; + Digest : TSHA1Digest; + + function SingleTest(s: Str127; TDig: TSHA1Digest): boolean; + {-do a single test, const not allowed for VER<7} + { Two sub tests: 1. whole string, 2. one update per char} + var + i: integer; + begin + SingleTest := false; + {1. Hash complete string} + SHA1Full(Digest, @s[1],length(s)); + {Compare with known value} + if not HashSameDigest(@SHA1_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + {2. one update call for all chars} + SHA1Init(Context); + for i:=1 to length(s) do SHA1Update(Context,@s[i],1); + SHA1Final(Context,Digest); + {Compare with known value} + if not HashSameDigest(@SHA1_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + SingleTest := true; + end; + +begin + SHA1SelfTest := false; + {1 Zero bit from NESSIE test vectors} + SHA1Init(Context); + SHA1FinalBits(Context,Digest,0,1); + if not HashSameDigest(@SHA1_Desc, PHashDigest(@Digest), PHashDigest(@D3)) then exit; + {4 hightest bits of $50, D4 calculated with program shatest from RFC 4634} + SHA1Init(Context); + SHA1FinalBits(Context,Digest,$50,4); + if not HashSameDigest(@SHA1_Desc, PHashDigest(@Digest), PHashDigest(@D4)) then exit; + {strings from SHA1 document} + SHA1SelfTest := SingleTest(s1, D1) and SingleTest(s2, D2) +end; + + +{---------------------------------------------------------------------------} +procedure SHA1FullXL(var Digest: TSHA1Digest; Msg: pointer; Len: longint); + {-SHA1 of Msg with init/update/final} +var + Context: TTgHashContext; +begin + SHA1Init(Context); + SHA1UpdateXL(Context, Msg, Len); + SHA1Final(Context, Digest); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1Full(var Digest: TSHA1Digest; Msg: pointer; Len: word); + {-SHA1 of Msg with init/update/final} +begin + SHA1FullXL(Digest, Msg, Len); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA1Digest; var buf; bsize: word; var Err: word); + {-SHA1 of file, buf: buffer with at least bsize bytes} +var + tmp: THashDigest; +begin + HashFile(fname, @SHA1_Desc, tmp, buf, bsize, Err); + move(tmp, Digest, sizeof(Digest)); +end; + + +begin + {$ifdef VER5X} + fillchar(SHA1_Desc, sizeof(SHA1_Desc), 0); + with SHA1_Desc do begin + HSig := C_HashSig; + HDSize := sizeof(THashDesc); + HDVersion := C_HashVers; + HBlockLen := SHA1_BlockLen; + HDigestlen:= sizeof(TSHA1Digest); + HInit := SHA1Init; + HFinal := SHA1FinalEx; + HUpdateXL := SHA1UpdateXL; + HAlgNum := longint(_SHA1); + HName := 'SHA1'; + HPtrOID := @SHA1_OID; + HLenOID := 6; + HFinalBit := SHA1FinalBitsEx; + end; + {$endif} + RegisterHash(_SHA1, @SHA1_Desc); +end. diff --git a/Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha256.pas b/Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha256.pas new file mode 100644 index 00000000..821213f2 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.Tocsg.sha256.pas @@ -0,0 +1,1051 @@ +unit EM.Tocsg.sha256; + +{SHA256 - 256 bit Secure Hash Function} + + +interface + +(************************************************************************* + + DESCRIPTION : SHA256 - 256 bit Secure Hash Function + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17-D18/D25S, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : - Latest specification of Secure Hash Standard: + http://csrc.nist.gov/publications/fips/fips180-4/fips-180-4.pdf + - Test vectors and intermediate values: + http://csrc.nist.gov/groups/ST/toolkit/documents/Examples/SHA_All.pdf + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.1 03.01.02 W.Ehrhardt Reference implementation + 0.2 03.01.02 we BP7 optimization + 0.21 03.01.02 we TP6 changes + 0.3 03.01.02 we Delphi32 optimization + 0.4 03.01.02 we with TW32Buf and assignment via RB in SHA256Compress + 0.5 07.01.02 we Opt. Delphi UpdateLen + 0.6 23.02.02 we Free Pascal compatibility + 0.7 03.03.02 we VirtualPascal compatibility + 0.71 03.03.02 we FPC with ASM (intel) + 0.72 03.03.02 we TP55 compatibility + 0.80 23.07.03 we With SHA256File, SHA256Full + 0.81 26.07.03 we With SHA256Full in self test, D6+ - warnings + 2.00 26.07.03 we common vers., longint for word32, D4+ - warnings + 2.01 04.08.03 we type TSHA256Block for HMAC + 2.10 29.08.03 we XL versions for Win32 + 2.20 27.09.03 we FPC/go32v2 + 2.30 05.10.03 we STD.INC, TP5.0 + 2.40 10.10.03 we common version, english comments + 2.45 11.10.03 we Speedup: Inline for Maj(), Ch() + 2.50 17.11.03 we Speedup in update, don't clear W in compress + 2.51 20.11.03 we Full range UpdateLen + 3.00 01.12.03 we Common version 3.0 + 3.01 22.12.03 we TP5/5.5: RB, FS inline + 3.02 22.12.03 we TP5/5.5: FS -> FS1, FS2 + 3.03 22,12.03 we Changed UpdateLen: Definition and TP5/5.5 inline + 3.04 22.12.03 we TP5/5.5: inline function ISHR + 3.05 22.12.03 we ExpandMessageBlocks/BASM + 3.06 24.12.03 we FIPS notation: S[] -> A..H, partial unroll + 3.07 05.03.04 we Update fips180-2 URL + 3.08 26.02.05 we With {$ifdef StrictLong} + 3.09 05.05.05 we $R- for StrictLong, D9: errors if $R+ even if warnings off + 3.10 17.12.05 we Force $I- in SHA256File + 3.11 15.01.06 we uses Hash unit and THashDesc + 3.12 15.01.06 we BugFix for 16 bit without BASM + 3.13 18.01.06 we Descriptor fields HAlgNum, HSig + 3.14 22.01.06 we Removed HSelfTest from descriptor + 3.15 11.02.06 we Descriptor as typed const + 3.16 07.08.06 we $ifdef BIT32: (const fname: shortstring...) + 3.17 22.02.07 we values for OID vector + 3.18 30.06.07 we Use conditional define FPC_ProcVar + 3.19 04.10.07 we FPC: {$asmmode intel} + 3.20 02.05.08 we Bit-API: SHA256FinalBits/Ex + 3.21 05.05.08 we THashDesc constant with HFinalBit field + 3.22 12.11.08 we Uses BTypes, Ptr2Inc and/or Str255/Str127 + 3.23 11.03.12 we Updated references + 3.24 26.12.12 we D17 and PurePascal + 3.25 16.08.15 we Removed $ifdef DLL / stdcall + 3.26 15.05.17 we adjust OID to new MaxOIDLen + 3.27 29.11.17 we SHA256File - fname: string + +**************************************************************************) + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2017 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{NOTE: FIPS Ch and May functions can be optimized. Wei Dai (Crypto++ 3.1) +credits Rich Schroeppel (rcs@cs.arizona.edu), V 5.1 does not!?} + +{$i STD.INC} + +{$ifdef BIT64} + {$ifndef PurePascal} + {$define PurePascal} + {$endif} +{$endif} + +{$define UNROLL} {Speedup for all but TP5/5.5 and maybe VP} + +{$ifdef VER50} + {$undef UNROLL} {Only VER50, VER55 uses UNROLL} +{$endif} + +{$ifdef VirtualPascal} + {$undef UNROLL} +{$endif} + +uses + EM.Tocsg.Hash; + +procedure SHA256Init(var Context: TTgHashContext); + {-initialize context} + +procedure SHA256Update(var Context: TTgHashContext; Msg: pointer; Len: word); + {-update context with Msg data} + +procedure SHA256UpdateXL(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + +procedure SHA256Final(var Context: TTgHashContext; var Digest: TSHA256Digest); + {-finalize SHA256 calculation, clear context} + +procedure SHA256FinalEx(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize SHA256 calculation, clear context} + +procedure SHA256FinalBitsEx(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} + +procedure SHA256FinalBits(var Context: TTgHashContext; var Digest: TSHA256Digest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} + +function SHA256SelfTest: boolean; + {-self test for string from SHA256 document} + +procedure SHA256Full(var Digest: TSHA256Digest; Msg: pointer; Len: word); + {-SHA256 of Msg with init/update/final} + +procedure SHA256FullXL(var Digest: TSHA256Digest; Msg: pointer; Len: longint); + {-SHA256 of Msg with init/update/final} + +procedure SHA256File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA256Digest; var buf; bsize: word; var Err: word); + {-SHA256 of file, buf: buffer with at least bsize bytes} + + +implementation + + +{$ifdef BIT16} + {$F-} +{$endif} + +const + SHA256_BlockLen = 64; + +{Internal types for type casting} +type + TWorkBuf = array[0..63] of longint; + + +{2.16.840.1.101.3.4.2.1} +{joint-iso-itu-t(2) country(16) us(840) organization(1) gov(101) csor(3) nistAlgorithm(4) hashAlgs(2) sha256(1)} +const + SHA256_OID : TOID_Vec = (2,16,840,1,101,3,4,2,1,-1,-1); {Len=9} + + +{$ifndef VER5X} +const + SHA256_Desc: THashDesc = ( + HSig : C_HashSig; + HDSize : sizeof(THashDesc); + HDVersion : C_HashVers; + HBlockLen : SHA256_BlockLen; + HDigestlen: sizeof(TSHA256Digest); + {$ifdef FPC_ProcVar} + HInit : @SHA256Init; + HFinal : @SHA256FinalEx; + HUpdateXL : @SHA256UpdateXL; + {$else} + HInit : SHA256Init; + HFinal : SHA256FinalEx; + HUpdateXL : SHA256UpdateXL; + {$endif} + HAlgNum : longint(_SHA256); + HName : 'SHA256'; + HPtrOID : @SHA256_OID; + HLenOID : 9; + HFill : 0; + {$ifdef FPC_ProcVar} + HFinalBit : @SHA256FinalBitsEx; + {$else} + HFinalBit : SHA256FinalBitsEx; + {$endif} + HReserved : (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0) + ); +{$else} +var + SHA256_Desc: THashDesc; +{$endif} + + +{$ifndef BIT16} + +{$ifdef PurePascal} + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + var + tmp: int64; + begin + tmp := int64(cardinal(wlo))+Blen; + wlo := longint(tmp and $FFFFFFFF); + inc(whi,longint(tmp shr 32)); + end; + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; + {-reverse byte order in longint} + begin + RB := ((A and $FF) shl 24) or ((A and $FF00) shl 8) or ((A and $FF0000) shr 8) or ((A and longint($FF000000)) shr 24); + end; +{$else} + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; assembler; {&frame-} + {-reverse byte order in longint} + asm + {$ifdef LoadArgs} + mov eax,[A] + {$endif} + xchg al,ah + rol eax,16 + xchg al,ah + end; + + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + begin + asm + mov edx, wlo + mov ecx, whi + mov eax, Blen + add [edx], eax + adc dword ptr [ecx], 0 + end; + end; + + {---------------------------------------------------------------------------} + function Sum0(x: longint): longint; assembler; {&frame-} + {-Big sigma 0: RotRight(x,2) xor RotRight(x,13) xor RotRight(x,22)} + asm + {$ifdef LoadArgs} + mov eax,[x] + {$endif} + mov ecx,eax + mov edx,eax + ror eax,2 + ror edx,13 + ror ecx,22 + xor eax,edx + xor eax,ecx + end; + + {---------------------------------------------------------------------------} + function Sum1(x: longint): longint; assembler; {&frame-} + {-Big sigma 1: RotRight(x,6) xor RotRight(x,11) xor RotRight(x,25)} + asm + {$ifdef LoadArgs} + mov eax,[x] + {$endif} + mov ecx,eax + mov edx,eax + ror eax,6 + ror edx,11 + ror ecx,25 + xor eax,edx + xor eax,ecx + end; + + {$define USE_ExpandMessageBlocks} + + {---------------------------------------------------------------------------} + procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuf32); + {-Calculate "expanded message blocks"} + begin + asm + push esi + push edi + push ebx + mov esi,[W] + mov edx,[Buf] + {part 1: W[i]:= RB(TW32Buf(Buf)[i])} + mov ecx,16 + @@1: mov eax,[edx] + xchg al,ah + rol eax,16 + xchg al,ah + mov [esi],eax + add esi,4 + add edx,4 + dec ecx + jnz @@1 + {part2: W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]);} + mov ecx,48 + @@2: mov edi,[esi-7*4] {W[i-7]} + mov eax,[esi-2*4] {W[i-2]} + mov ebx,eax {Sig1: RR17 xor RR19 xor SRx,10} + mov edx,eax + ror eax,17 + ror edx,19 + shr ebx,10 + xor eax,edx + xor eax,ebx + add edi,eax + mov eax,[esi-15*4] {W[i-15]} + mov ebx,eax {Sig0: RR7 xor RR18 xor SR3} + mov edx,eax + ror eax,7 + ror edx,18 + shr ebx,3 + xor eax,edx + xor eax,ebx + add eax,edi + add eax,[esi-16*4] {W[i-16]} + mov [esi],eax + add esi,4 + dec ecx + jnz @@2 + pop ebx + pop edi + pop esi + end; + end; +{$endif} + +{$else} + +{$ifndef BASM16} + +{TP5/5.5} + +{$undef USE_ExpandMessageBlocks} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} +inline( + $58/ {pop ax } + $5A/ {pop dx } + $5B/ {pop bx } + $07/ {pop es } + $26/$01/$07/ {add es:[bx],ax } + $26/$11/$57/$02/ {adc es:[bx+02],dx} + $5B/ {pop bx } + $07/ {pop es } + $26/$83/$17/$00/ {adc es:[bx],0 } + $26/$83/$57/$02/$00);{adc es:[bx+02],0 } + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; + {-reverse byte order in longint} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $86/$C6/ { xchg dh,al} + $86/$E2); { xchg dl,ah} + + +{---------------------------------------------------------------------------} +function FS1(x: longint; c: integer): longint; + {-Rotate x right, c<=16!!} +inline( + $59/ { pop cx } + $58/ { pop ax } + $5A/ { pop dx } + $8B/$DA/ { mov bx,dx} + $D1/$EB/ {L:shr bx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA/ { rcr dx,1 } + $49/ { dec cx } + $75/$F7); { jne L } + + +{---------------------------------------------------------------------------} +function FS2(x: longint; c: integer): longint; + {-Rotate x right, c+16, c<16!!} +inline( + $59/ { pop cx } + $5A/ { pop dx } + $58/ { pop ax } + $8B/$DA/ { mov bx,dx} + $D1/$EB/ {L:shr bx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA/ { rcr dx,1 } + $49/ { dec cx } + $75/$F7); { jne L } + + +{---------------------------------------------------------------------------} +function ISHR(x: longint; c: integer): longint; + {-Shift x right} +inline( + $59/ { pop cx } + $58/ { pop ax } + $5A/ { pop dx } + $D1/$EA/ {L:shr dx,1 } + $D1/$D8/ { rcr ax,1 } + $49/ { dec cx } + $75/$F9); { jne L } + + +{---------------------------------------------------------------------------} +function Sig0(x: longint): longint; + {-Small sigma 0} +begin + Sig0 := FS1(x,7) xor FS2(x,18-16) xor ISHR(x,3); +end; + + +{---------------------------------------------------------------------------} +function Sig1(x: longint): longint; + {-Small sigma 1} +begin + Sig1 := FS2(x,17-16) xor FS2(x,19-16) xor ISHR(x,10); +end; + + +{---------------------------------------------------------------------------} +function Sum0(x: longint): longint; + {-Big sigma 0} +begin + Sum0 := FS1(x,2) xor FS1(x,13) xor FS2(x,22-16); +end; + + +{---------------------------------------------------------------------------} +function Sum1(x: longint): longint; + {-Big sigma 1} +begin + Sum1 := FS1(x,6) xor FS1(x,11) xor FS2(x,25-16); +end; + + +{$else} + +{TP 6/7/Delphi1 for 386+} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); assembler; + {-Add BLen to 64 bit value (wlo, whi)} +asm + les di,[wlo] + db $66; mov ax,word ptr [BLen] + db $66; sub dx,dx + db $66; add es:[di],ax + les di,[whi] + db $66; adc es:[di],dx +end; + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; assembler; + {-reverse byte order in longint} +asm + mov ax,word ptr [A] + mov dx,word ptr [A+2] + xchg al,dh + xchg ah,dl +end; + + +{---------------------------------------------------------------------------} +function Sum0(x: longint): longint; assembler; + {-Big sigma 0: RotRight(x,2) xor RotRight(x,13) xor RotRight(x,22)} +asm + db $66; mov ax,word ptr x + db $66; mov bx,ax + db $66; mov dx,ax + db $66; ror ax,2 + db $66; ror dx,13 + db $66; ror bx,22 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; mov dx,ax + db $66; shr dx,16 +end; + + +{---------------------------------------------------------------------------} +function Sum1(x: longint): longint; assembler; + {-Big sigma 1: RotRight(x,6) xor RotRight(x,11) xor RotRight(x,25)} +asm + db $66; mov ax,word ptr x + db $66; mov bx,ax + db $66; mov dx,ax + db $66; ror ax,6 + db $66; ror dx,11 + db $66; ror bx,25 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; mov dx,ax + db $66; shr dx,16 +end; + + +{$define USE_ExpandMessageBlocks} +{---------------------------------------------------------------------------} +procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuf32); assembler; + {-Calculate "expanded message blocks"} +asm + push ds + {part 1: W[i]:= RB(TW32Buf(Buf)[i])} + les di,[Buf] + lds si,[W] + mov cx,16 +@@1: db $66; mov ax,es:[di] + xchg al,ah + db $66; rol ax,16 + xchg al,ah + db $66; mov [si],ax + add si,4 + add di,4 + dec cx + jnz @@1 + {part 2: W[i]:= Sig1(W[i-2]) + W[i-7] + Sig0(W[i-15]) + W[i-16];} + mov cx,48 +@@2: db $66; mov di,[si-7*4] {W[i-7]} + db $66; mov ax,[si-2*4] {W[i-2]} + db $66; mov bx,ax {Sig1: RR17 xor RR19 xor SRx,10} + db $66; mov dx,ax + db $66; ror ax,17 + db $66; ror dx,19 + db $66; shr bx,10 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; add di,ax + db $66; mov ax,[si-15*4] {W[i-15]} + db $66; mov bx,ax {Sig0: RR7 xor RR18 xor SR3} + db $66; mov dx,ax + db $66; ror ax,7 + db $66; ror dx,18 + db $66; shr bx,3 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; add ax,di + db $66; add ax,[si-16*4] {W[i-16]} + db $66; mov [si],ax + add si,4 + dec cx + jnz @@2 + pop ds +end; + + +{$endif BASM16} + +{$endif BIT16} + + + +{$ifdef PurePascal} +{---------------------------------------------------------------------------} +procedure SHA256Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; + T, A, B, C, D, E, F, G, H: longint; + W: TWorkBuf; +const +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} + K: array[0..63] of longint = ( + $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5, + $3956c25b, $59f111f1, $923f82a4, $ab1c5ed5, + $d807aa98, $12835b01, $243185be, $550c7dc3, + $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174, + $e49b69c1, $efbe4786, $0fc19dc6, $240ca1cc, + $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da, + $983e5152, $a831c66d, $b00327c8, $bf597fc7, + $c6e00bf3, $d5a79147, $06ca6351, $14292967, + $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13, + $650a7354, $766a0abb, $81c2c92e, $92722c85, + $a2bfe8a1, $a81a664b, $c24b8b70, $c76c51a3, + $d192e819, $d6990624, $f40e3585, $106aa070, + $19a4c116, $1e376c08, $2748774c, $34b0bcb5, + $391c0cb3, $4ed8aa4a, $5b9cca4f, $682e6ff3, + $748f82ee, $78a5636f, $84c87814, $8cc70208, + $90befffa, $a4506ceb, $bef9a3f7, $c67178f2 + ); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + + {-Calculate "expanded message blocks"} + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i] := RB(THashBuf32(Data.Buffer)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 63 do begin + {A=Sig1(W[i-2]), B=Sig0(W[i-15])} + A := W[i-2]; A := ((A shr 17) or (A shl 15)) xor ((A shr 19) or (A shl 13)) xor (A shr 10); + B := W[i-15]; B := ((B shr 7) or (B shl 25)) xor ((B shr 18) or (B shl 14)) xor (B shr 3); + W[i]:= A + W[i-7] + B + W[i-16]; + end; + + {Assign old working hasg to variables A..H} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + F := Data.Hash[5]; + G := Data.Hash[6]; + H := Data.Hash[7]; + + {SHA256 compression function} + {partially unrolled loop} + i := 0; + repeat + T := H + (((E shr 6) or (E shl 26)) xor ((E shr 11) or (E shl 21)) xor ((E shr 25) or (E shl 7))) + + (((F xor G) and E) xor G) + W[i ] + K[i ]; + H := T + (((A shr 2) or (A shl 30)) xor ((A shr 13) or (A shl 19)) xor ((A shr 22) or (A shl 10))) + + (((A or B) and C) or (A and B)); + inc(D,T); + T := G + (((D shr 6) or (D shl 26)) xor ((D shr 11) or (D shl 21)) xor ((D shr 25) or (D shl 7))) + + (((E xor F) and D) xor F) + W[i+1] + K[i+1]; + G := T + (((H shr 2) or (H shl 30)) xor ((H shr 13) or (H shl 19)) xor ((H shr 22) or (H shl 10))) + + (((H or A) and B) or (H and A)); + inc(C,T); + T := F + (((C shr 6) or (C shl 26)) xor ((C shr 11) or (C shl 21)) xor ((C shr 25) or (C shl 7))) + + (((D xor E) and C) xor E) + W[i+2] + K[i+2]; + F := T + (((G shr 2) or (G shl 30)) xor ((G shr 13) or (G shl 19)) xor ((G shr 22) or (G shl 10))) + + (((G or H) and A) or (G and H)); + inc(B,T); + T := E + (((B shr 6) or (B shl 26)) xor ((B shr 11) or (B shl 21)) xor ((B shr 25) or (B shl 7))) + + (((C xor D) and B) xor D) + W[i+3] + K[i+3]; + E := T + (((F shr 2) or (F shl 30)) xor ((F shr 13) or (F shl 19)) xor ((F shr 22) or (F shl 10))) + + (((F or G) and H) or (F and G)); + inc(A,T); + T := D + (((A shr 6) or (A shl 26)) xor ((A shr 11) or (A shl 21)) xor ((A shr 25) or (A shl 7))) + + (((B xor C) and A) xor C) + W[i+4] + K[i+4]; + D := T + (((E shr 2) or (E shl 30)) xor ((E shr 13) or (E shl 19)) xor ((E shr 22) or (E shl 10))) + + (((E or F) and G) or (E and F)); + inc(H,T); + T := C + (((H shr 6) or (H shl 26)) xor ((H shr 11) or (H shl 21)) xor ((H shr 25) or (H shl 7))) + + (((A xor B) and H) xor B) + W[i+5] + K[i+5]; + C := T + (((D shr 2) or (D shl 30)) xor ((D shr 13) or (D shl 19)) xor ((D shr 22) or (D shl 10))) + + (((D or E) and F) or (D and E)); + inc(G,T); + T := B + (((G shr 6) or (G shl 26)) xor ((G shr 11) or (G shl 21)) xor ((G shr 25) or (G shl 7))) + + (((H xor A) and G) xor A) + W[i+6] + K[i+6]; + B := T + (((C shr 2) or (C shl 30)) xor ((C shr 13) or (C shl 19)) xor ((C shr 22) or (C shl 10))) + + (((C or D) and E) or (C and D)); + inc(F,T); + T := A + (((F shr 6) or (F shl 26)) xor ((F shr 11) or (F shl 21)) xor ((F shr 25) or (F shl 7))) + + (((G xor H) and F) xor H) + W[i+7] + K[i+7]; + A := T + (((B shr 2) or (B shl 30)) xor ((B shr 13) or (B shl 19)) xor ((B shr 22) or (B shl 10))) + + (((B or C) and D) or (B and C)); + inc(E,T); + inc(i,8) + until i>63; + + {Calculate new working hash} + inc(Data.Hash[0],A); + inc(Data.Hash[1],B); + inc(Data.Hash[2],C); + inc(Data.Hash[3],D); + inc(Data.Hash[4],E); + inc(Data.Hash[5],F); + inc(Data.Hash[6],G); + inc(Data.Hash[7],H); +end; + +{$else} + +{---------------------------------------------------------------------------} +procedure SHA256Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; +{$ifdef UNROLL} + T, +{$else} + T1,T2: longint; +{$endif} + A, B, C, D, E, F, G, H: longint; + W: TWorkBuf; +const +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} + K: array[0..63] of longint = ( + $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5, + $3956c25b, $59f111f1, $923f82a4, $ab1c5ed5, + $d807aa98, $12835b01, $243185be, $550c7dc3, + $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174, + $e49b69c1, $efbe4786, $0fc19dc6, $240ca1cc, + $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da, + $983e5152, $a831c66d, $b00327c8, $bf597fc7, + $c6e00bf3, $d5a79147, $06ca6351, $14292967, + $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13, + $650a7354, $766a0abb, $81c2c92e, $92722c85, + $a2bfe8a1, $a81a664b, $c24b8b70, $c76c51a3, + $d192e819, $d6990624, $f40e3585, $106aa070, + $19a4c116, $1e376c08, $2748774c, $34b0bcb5, + $391c0cb3, $4ed8aa4a, $5b9cca4f, $682e6ff3, + $748f82ee, $78a5636f, $84c87814, $8cc70208, + $90befffa, $a4506ceb, $bef9a3f7, $c67178f2 + ); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + {-Calculate "expanded message blocks"} + {$ifdef USE_ExpandMessageBlocks} + {Use BASM-Code} + ExpandMessageBlocks(W, THashBuf32(Data.Buffer)); + {$else} + {Avoid proc call overhead for TP5/5.5} + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i]:= RB(THashBuf32(Data.Buffer)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 63 do W[i]:= Sig1(W[i-2]) + W[i-7] + Sig0(W[i-15]) + W[i-16]; + {$endif} + + {Assign old working hasg to variables A..H} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + F := Data.Hash[5]; + G := Data.Hash[6]; + H := Data.Hash[7]; + + {SHA256 compression function} + +{$ifdef UNROLL} + + {partially unrolled loop} + i := 0; + repeat + T := H + Sum1(E) + (((F xor G) and E) xor G) + W[i ] + K[i ]; + H := T + Sum0(A) + (((A or B) and C) or (A and B)); + inc(D,T); + T := G + Sum1(D) + (((E xor F) and D) xor F) + W[i+1] + K[i+1]; + G := T + Sum0(H) + (((H or A) and B) or (H and A)); + inc(C,T); + T := F + Sum1(C) + (((D xor E) and C) xor E) + W[i+2] + K[i+2]; + F := T + Sum0(G) + (((G or H) and A) or (G and H)); + inc(B,T); + T := E + Sum1(B) + (((C xor D) and B) xor D) + W[i+3] + K[i+3]; + E := T + Sum0(F) + (((F or G) and H) or (F and G)); + inc(A,T); + T := D + Sum1(A) + (((B xor C) and A) xor C) + W[i+4] + K[i+4]; + D := T + Sum0(E) + (((E or F) and G) or (E and F)); + inc(H,T); + T := C + Sum1(H) + (((A xor B) and H) xor B) + W[i+5] + K[i+5]; + C := T + Sum0(D) + (((D or E) and F) or (D and E)); + inc(G,T); + T := B + Sum1(G) + (((H xor A) and G) xor A) + W[i+6] + K[i+6]; + B := T + Sum0(C) + (((C or D) and E) or (C and D)); + inc(F,T); + T := A + Sum1(F) + (((G xor H) and F) xor H) + W[i+7] + K[i+7]; + A := T + Sum0(B) + (((B or C) and D) or (B and C)); + inc(E,T); + inc(i,8) + until i>63; + +{$else} + for i:=0 to 63 do begin + T1:= H + Sum1(E) + (((F xor G) and E) xor G) + K[i] + W[i]; + T2:= Sum0(A) + (((A or B) and C) or (A and B)); + H := G; + G := F; + F := E; + E := D + T1; + D := C; + C := B; + B := A; + A := T1 + T2; + end; +{$endif} + + {Calculate new working hash} + inc(Data.Hash[0],A); + inc(Data.Hash[1],B); + inc(Data.Hash[2],C); + inc(Data.Hash[3],D); + inc(Data.Hash[4],E); + inc(Data.Hash[5],F); + inc(Data.Hash[6],G); + inc(Data.Hash[7],H); +end; + +{$endif} + +{---------------------------------------------------------------------------} +procedure SHA256Init(var Context: TTgHashContext); + {-initialize context} +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} +const + SIV: array[0..7] of longint = ($6a09e667, $bb67ae85, $3c6ef372, $a54ff53a, $510e527f, $9b05688c, $1f83d9ab, $5be0cd19); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + {Clear context, buffer=0!!} + fillchar(Context,sizeof(Context),0); + move(SIV,Context.Hash,sizeof(SIV)); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256UpdateXL(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} +var + i: integer; +begin + {Update message bit length} + if Len<=$1FFFFFFF then UpdateLen(Context.MLen[1], Context.MLen[0], Len shl 3) + else begin + for i:=1 to 8 do UpdateLen(Context.MLen[1], Context.MLen[0], Len) + end; + while Len > 0 do begin + {fill block with msg data} + Context.Buffer[Context.Index]:= pByte(Msg)^; + inc(Ptr2Inc(Msg)); + inc(Context.Index); + dec(Len); + if Context.Index=SHA256_BlockLen then begin + {If 512 bit transferred, compress a block} + Context.Index:= 0; + SHA256Compress(Context); + while Len>=SHA256_BlockLen do begin + move(Msg^,Context.Buffer,SHA256_BlockLen); + SHA256Compress(Context); + inc(Ptr2Inc(Msg),SHA256_BlockLen); + dec(Len,SHA256_BlockLen); + end; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Update(var Context: TTgHashContext; Msg: pointer; Len: word); + {-update context with Msg data} +begin + SHA256UpdateXL(Context, Msg, Len); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalBitsEx(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} +var + i: integer; +begin + {Message padding} + {append bits from BData and a single '1' bit} + if (bitlen>0) and (bitlen<=7) then begin + Context.Buffer[Context.Index]:= (BData and BitAPI_Mask[bitlen]) or BitAPI_PBit[bitlen]; + UpdateLen(Context.MLen[1], Context.MLen[0], bitlen); + end + else Context.Buffer[Context.Index]:= $80; + for i:=Context.Index+1 to 63 do Context.Buffer[i] := 0; + {2. Compress if more than 448 bits, (no room for 64 bit length} + if Context.Index>= 56 then begin + SHA256Compress(Context); + fillchar(Context.Buffer,56,0); + end; + {Write 64 bit msg length into the last bits of the last block} + {(in big endian format) and do a final compress} + THashBuf32(Context.Buffer)[14]:= RB(Context.MLen[1]); + THashBuf32(Context.Buffer)[15]:= RB(Context.MLen[0]); + SHA256Compress(Context); + {Hash -> Digest to little endian format} + for i:=0 to 7 do THashDig32(Digest)[i]:= RB(Context.Hash[i]); + {Clear context} + fillchar(Context,sizeof(Context),0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalBits(var Context: TTgHashContext; var Digest: TSHA256Digest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} +var + tmp: THashDigest; +begin + SHA256FinalBitsEx(Context, tmp, BData, bitlen); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalEx(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize SHA256 calculation, clear context} +begin + SHA256FinalBitsEx(Context,Digest,0,0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Final(var Context: TTgHashContext; var Digest: TSHA256Digest); + {-finalize SHA256 calculation, clear context} +var + tmp: THashDigest; +begin + SHA256FinalBitsEx(Context, tmp, 0, 0); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +function SHA256SelfTest: boolean; + {-self test for string from SHA256 document} +const + s1: string[ 3] = 'abc'; + s2: string[56] = 'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'; + D1: TSHA256Digest = ($ba,$78,$16,$bf,$8f,$01,$cf,$ea,$41,$41,$40,$de,$5d,$ae,$22,$23, + $b0,$03,$61,$a3,$96,$17,$7a,$9c,$b4,$10,$ff,$61,$f2,$00,$15,$ad); + D2: TSHA256Digest = ($24,$8d,$6a,$61,$d2,$06,$38,$b8,$e5,$c0,$26,$93,$0c,$3e,$60,$39, + $a3,$3c,$e4,$59,$64,$ff,$21,$67,$f6,$ec,$ed,$d4,$19,$db,$06,$c1); + D3: TSHA256Digest = ($bd,$4f,$9e,$98,$be,$b6,$8c,$6e,$ad,$32,$43,$b1,$b4,$c7,$fe,$d7, + $5f,$a4,$fe,$aa,$b1,$f8,$47,$95,$cb,$d8,$a9,$86,$76,$a2,$a3,$75); + D4: TSHA256Digest = ($f1,$54,$1d,$eb,$68,$d1,$34,$eb,$a9,$9f,$82,$cf,$d8,$7e,$2a,$b3, + $1d,$33,$af,$4b,$6d,$e0,$08,$6a,$9b,$ed,$15,$c2,$ec,$69,$cc,$cb); +var + Context: TTgHashContext; + Digest : TSHA256Digest; + + function SingleTest(s: Str127; TDig: TSHA256Digest): boolean; + {-do a single test, const not allowed for VER<7} + { Two sub tests: 1. whole string, 2. one update per char} + var + i: integer; + begin + SingleTest := false; + {1. Hash complete string} + SHA256Full(Digest, @s[1],length(s)); + {Compare with known value} + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + {2. one update call for all chars} + SHA256Init(Context); + for i:=1 to length(s) do SHA256Update(Context,@s[i],1); + SHA256Final(Context,Digest); + {Compare with known value} + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + SingleTest := true; + end; + +begin + SHA256SelfTest := false; + {1 Zero bit from NESSIE test vectors} + SHA256Init(Context); + SHA256FinalBits(Context,Digest,0,1); + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@D3)) then exit; + {4 hightest bits of $50, D4 calculated with program shatest from RFC 4634} + SHA256Init(Context); + SHA256FinalBits(Context,Digest,$50,4); + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@D4)) then exit; + {strings from SHA256 document} + SHA256SelfTest := SingleTest(s1, D1) and SingleTest(s2, D2) +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FullXL(var Digest: TSHA256Digest; Msg: pointer; Len: longint); + {-SHA256 of Msg with init/update/final} +var + Context: TTgHashContext; +begin + SHA256Init(Context); + SHA256UpdateXL(Context, Msg, Len); + SHA256Final(Context, Digest); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Full(var Digest: TSHA256Digest; Msg: pointer; Len: word); + {-SHA256 of Msg with init/update/final} +begin + SHA256FullXL(Digest, Msg, Len); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA256Digest; var buf; bsize: word; var Err: word); + {-SHA256 of file, buf: buffer with at least bsize bytes} +var + tmp: THashDigest; +begin + HashFile(fname, @SHA256_Desc, tmp, buf, bsize, Err); + move(tmp,Digest,sizeof(Digest)); +end; + + +begin + {$ifdef VER5X} + fillchar(SHA256_Desc, sizeof(SHA256_Desc), 0); + with SHA256_Desc do begin + HSig := C_HashSig; + HDSize := sizeof(THashDesc); + HDVersion := C_HashVers; + HBlockLen := SHA256_BlockLen; + HDigestlen:= sizeof(TSHA256Digest); + HInit := SHA256Init; + HFinal := SHA256FinalEx; + HUpdateXL := SHA256UpdateXL; + HAlgNum := longint(_SHA256); + HName := 'SHA256'; + HPtrOID := @SHA256_OID; + HLenOID := 9; + HFinalBit := SHA256FinalBitsEx; + end; + {$endif} + RegisterHash(_SHA256, @SHA256_Desc); +end. diff --git a/Tocsg.Lib/VCL/EncLib/EM.Tools.pas b/Tocsg.Lib/VCL/EncLib/EM.Tools.pas new file mode 100644 index 00000000..657f92b8 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.Tools.pas @@ -0,0 +1,74 @@ +unit EM.Tools; + +interface +uses + Windows, Sysutils; + +//type +//{$IFDEF VER120} +// dword= longword; +//{$ELSE} +// dword= longint; +//{$ENDIF} + +function LRot16(X: word; c: integer): word; assembler; +function RRot16(X: word; c: integer): word; assembler; +function LRot32(X: dword; c: integer): dword; assembler; +function RRot32(X: dword; c: integer): dword; assembler; +procedure XorBlock(I1, I2, O1: PByteArray; Len: integer); +procedure IncBlock(P: PByteArray; Len: integer); + +implementation + +function LRot16(X: word; c: integer): word; assembler; +asm + mov ecx,&c + mov ax,&X + rol ax,cl + mov &Result,ax +end; + +function RRot16(X: word; c: integer): word; assembler; +asm + mov ecx,&c + mov ax,&X + ror ax,cl + mov &Result,ax +end; + +function LRot32(X: dword; c: integer): dword; register; assembler; +asm +{$IFDEF CPUX64} + mov rax, rcx; +{$ENDIF} + mov ecx, edx + rol eax, cl +end; + +function RRot32(X: dword; c: integer): dword; register; assembler; +asm +{$IFDEF CPUX64} + mov rax, rcx; +{$ENDIF} + mov ecx, edx + ror eax, cl +end; + +procedure XorBlock(I1, I2, O1: PByteArray; Len: integer); +var + i: integer; +begin + for i:= 0 to Len-1 do + O1[i]:= I1[i] xor I2[i]; +end; + +procedure IncBlock(P: PByteArray; Len: integer); +begin + Inc(P[Len-1]); + if (P[Len-1]= 0) and (Len> 1) then + IncBlock(P,Len-1); +end; + +end. + + diff --git a/Tocsg.Lib/VCL/EncLib/EM.WtsApi32.pas b/Tocsg.Lib/VCL/EncLib/EM.WtsApi32.pas new file mode 100644 index 00000000..927f766e --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.WtsApi32.pas @@ -0,0 +1,802 @@ +unit EM.WtsApi32; + +interface +uses Windows, Messages, SysUtils, Controls; +// Windows Terminal Server public APIs +// +// Copyright 1995-1999, Citrix Systems Inc. +// Copyright (c) 1997-1999 Microsoft Corporation + +//============================================================================== +// Defines +//============================================================================== + +// +// Specifies the current server +// + +const + WTS_CURRENT_SERVER = THandle(0); + {$EXTERNALSYM WTS_CURRENT_SERVER} + WTS_CURRENT_SERVER_HANDLE = THandle(0); + {$EXTERNALSYM WTS_CURRENT_SERVER_HANDLE} + WTS_CURRENT_SERVER_NAME = ''; + {$EXTERNALSYM WTS_CURRENT_SERVER_NAME} + +// +// Specifies the current session (SessionId) +// + + WTS_CURRENT_SESSION = DWORD(-1); + {$EXTERNALSYM WTS_CURRENT_SESSION} + +// +// Possible pResponse values from WTSSendMessage() +// + + IDTIMEOUT = 32000; + {$EXTERNALSYM IDTIMEOUT} + IDASYNC = 32001; + {$EXTERNALSYM IDASYNC} + +// +// Shutdown flags +// + + WTS_WSD_LOGOFF = $00000001; // log off all users except + {$EXTERNALSYM WTS_WSD_LOGOFF} // current user; deletes + // WinStations (a reboot is + // required to recreate the + // WinStations) + WTS_WSD_SHUTDOWN = $00000002; // shutdown system + {$EXTERNALSYM WTS_WSD_SHUTDOWN} + WTS_WSD_REBOOT = $00000004; // shutdown and reboot + {$EXTERNALSYM WTS_WSD_REBOOT} + WTS_WSD_POWEROFF = $00000008; // shutdown and power off (on + {$EXTERNALSYM WTS_WSD_POWEROFF} + // machines that support power + // off through software) + WTS_WSD_FASTREBOOT = $00000010; // reboot without logging users + {$EXTERNALSYM WTS_WSD_FASTREBOOT} // off or shutting down + +//============================================================================== +// WTS_CONNECTSTATE_CLASS - Session connect state +//============================================================================== + +type + _WTS_CONNECTSTATE_CLASS = ( + WTSActive, // User logged on to WinStation + WTSConnected, // WinStation connected to client + WTSConnectQuery, // In the process of connecting to client + WTSShadow, // Shadowing another WinStation + WTSDisconnected, // WinStation logged on without client + WTSIdle, // Waiting for client to connect + WTSListen, // WinStation is listening for connection + WTSReset, // WinStation is being reset + WTSDown, // WinStation is down due to error + WTSInit); // WinStation in initialization + {$EXTERNALSYM _WTS_CONNECTSTATE_CLASS} + WTS_CONNECTSTATE_CLASS = _WTS_CONNECTSTATE_CLASS; + {$EXTERNALSYM WTS_CONNECTSTATE_CLASS} + TWtsConnectStateClass = WTS_CONNECTSTATE_CLASS; + + HANDLE = THANDLE; + PVOID = Pointer; + +//============================================================================== +// WTS_SERVER_INFO - returned by WTSEnumerateServers (version 1) +//============================================================================== + +// +// WTSEnumerateServers() returns two variables: pServerInfo and Count. +// The latter is the number of WTS_SERVER_INFO structures contained in +// the former. In order to read each server, iterate i from 0 to +// Count-1 and reference the server name as +// pServerInfo[i].pServerName; for example: +// +// for ( i=0; i < Count; i++ ) { +// _tprintf( TEXT("%s "), pServerInfo[i].pServerName ); +// } +// +// The memory returned looks like the following. P is a pServerInfo +// pointer, and D is the string data for that pServerInfo: +// +// P1 P2 P3 P4 ... Pn D1 D2 D3 D4 ... Dn +// +// This makes it easier to iterate the servers, using code similar to +// the above. +// + +type + PWTS_SERVER_INFOW = ^WTS_SERVER_INFOW; + {$EXTERNALSYM PWTS_SERVER_INFOW} + _WTS_SERVER_INFOW = record + pServerName: LPWSTR; // server name + end; + {$EXTERNALSYM _WTS_SERVER_INFOW} + WTS_SERVER_INFOW = _WTS_SERVER_INFOW; + {$EXTERNALSYM WTS_SERVER_INFOW} + TWtsServerInfoW = WTS_SERVER_INFOW; + PWtsServerInfoW = PWTS_SERVER_INFOW; + + PWTS_SERVER_INFOA = ^WTS_SERVER_INFOA; + {$EXTERNALSYM PWTS_SERVER_INFOA} + _WTS_SERVER_INFOA = record + pServerName: LPSTR; // server name + end; + {$EXTERNALSYM _WTS_SERVER_INFOA} + WTS_SERVER_INFOA = _WTS_SERVER_INFOA; + {$EXTERNALSYM WTS_SERVER_INFOA} + TWtsServerInfoA = WTS_SERVER_INFOA; + PWtsServerInfoA = PWTS_SERVER_INFOA; + +{$IFDEF UNICODE} + WTS_SERVER_INFO = WTS_SERVER_INFOW; + {$EXTERNALSYM WTS_SERVER_INFO} + PWTS_SERVER_INFO = PWTS_SERVER_INFOW; + {$EXTERNALSYM PWTS_SERVER_INFO} + TWtsServerInfo = TWtsServerInfoW; + PWtsServerInfo = PWtsServerInfoW; +{$ELSE} + WTS_SERVER_INFO = WTS_SERVER_INFOA; + {$EXTERNALSYM WTS_SERVER_INFO} + PWTS_SERVER_INFO = PWTS_SERVER_INFOA; + {$EXTERNALSYM PWTS_SERVER_INFO} + TWtsServerInfo = TWtsServerInfoA; + PWtsServerInfo = PWtsServerInfoA; +{$ENDIF} + +//============================================================================== +// WTS_SESSION_INFO - returned by WTSEnumerateSessions (version 1) +//============================================================================== + +// +// WTSEnumerateSessions() returns data in a similar format to the above +// WTSEnumerateServers(). It returns two variables: pSessionInfo and +// Count. The latter is the number of WTS_SESSION_INFO structures +// contained in the former. Iteration is similar, except that there +// are three parts to each entry, so it would look like this: +// +// for ( i=0; i < Count; i++ ) { +// _tprintf( TEXT("%-5u %-20s %u\n"), +// pSessionInfo[i].SessionId, +// pSessionInfo[i].pWinStationName, +// pSessionInfo[i].State ); +// } +// +// The memory returned is also segmented as the above, with all the +// structures allocated at the start and the string data at the end. +// We'll use S for the SessionId, P for the pWinStationName pointer +// and D for the string data, and C for the connect State: +// +// S1 P1 C1 S2 P2 C2 S3 P3 C3 S4 P4 C4 ... Sn Pn Cn D1 D2 D3 D4 ... Dn +// +// As above, this makes it easier to iterate the sessions. +// + +type + PWTS_SESSION_INFOW = ^WTS_SESSION_INFOW; + {$EXTERNALSYM PWTS_SESSION_INFOW} + _WTS_SESSION_INFOW = record + SessionId: DWORD; // session id + pWinStationName: LPWSTR; // name of WinStation this session is connected to + State: WTS_CONNECTSTATE_CLASS; // connection state (see enum) + end; + {$EXTERNALSYM _WTS_SESSION_INFOW} + WTS_SESSION_INFOW = _WTS_SESSION_INFOW; + {$EXTERNALSYM WTS_SESSION_INFOW} + TWtsSessionInfoW = WTS_SESSION_INFOW; + PWtsSessionInfoW = PWTS_SESSION_INFOW; + + PWTS_SESSION_INFOA = ^WTS_SESSION_INFOA; + {$EXTERNALSYM PWTS_SESSION_INFOA} + _WTS_SESSION_INFOA = record + SessionId: DWORD; // session id + pWinStationName: LPSTR; // name of WinStation this session is connected to + State: WTS_CONNECTSTATE_CLASS; // connection state (see enum) + end; + {$EXTERNALSYM _WTS_SESSION_INFOA} + WTS_SESSION_INFOA = _WTS_SESSION_INFOA; + {$EXTERNALSYM WTS_SESSION_INFOA} + TWtsSessionInfoA = WTS_SESSION_INFOA; + PWtsSessionInfoA = PWTS_SESSION_INFOA; + +{$IFDEF UNICODE} + WTS_SESSION_INFO = WTS_SESSION_INFOW; + PWTS_SESSION_INFO = PWTS_SESSION_INFOW; + TWtsSessionInfo = TWtsSessionInfoW; + PWtsSessionInfo = PWtsSessionInfoW; +{$ELSE} + WTS_SESSION_INFO = WTS_SESSION_INFOA; + PWTS_SESSION_INFO = PWTS_SESSION_INFOA; + TWtsSessionInfo = TWtsSessionInfoA; + PWtsSessionInfo = PWtsSessionInfoA; +{$ENDIF} + +//============================================================================== +// WTS_PROCESS_INFO - returned by WTSEnumerateProcesses (version 1) +//============================================================================== + +// +// WTSEnumerateProcesses() also returns data similar to +// WTSEnumerateServers(). It returns two variables: pProcessInfo and +// Count. The latter is the number of WTS_PROCESS_INFO structures +// contained in the former. Iteration is similar, except that there +// are four parts to each entry, so it would look like this: +// +// for ( i=0; i < Count; i++ ) { +// GetUserNameFromSid( pProcessInfo[i].pUserSid, UserName, +// sizeof(UserName) ); +// _tprintf( TEXT("%-5u %-20s %-5u %s\n"), +// pProcessInfo[i].SessionId, +// UserName, +// pProcessInfo[i].ProcessId, +// pProcessInfo[i].pProcessName ); +// } +// +// The memory returned is also segmented as the above, with all the +// structures allocated at the start and the string data at the end. +// We'll use S for the SessionId, R for the ProcessId, P for the +// pProcessName pointer and D for the string data, and U for pUserSid: +// +// S1 R1 P1 U1 S2 R2 P2 U2 S3 R3 P3 U3 ... Sn Rn Pn Un D1 D2 D3 ... Dn +// +// As above, this makes it easier to iterate the processes. +// + +type + PWTS_PROCESS_INFOW = ^WTS_PROCESS_INFOW; + {$EXTERNALSYM PWTS_PROCESS_INFOW} + _WTS_PROCESS_INFOW = record + SessionId: DWORD; // session id + ProcessId: DWORD; // process id + pProcessName: LPWSTR; // name of process + pUserSid: PSID; // user's SID + end; + {$EXTERNALSYM _WTS_PROCESS_INFOW} + WTS_PROCESS_INFOW = _WTS_PROCESS_INFOW; + {$EXTERNALSYM WTS_PROCESS_INFOW} + TWtsProcessInfoW = WTS_PROCESS_INFOW; + PWtsProcessInfoW = PWTS_PROCESS_INFOW; + + PWTS_PROCESS_INFOA = ^WTS_PROCESS_INFOA; + {$EXTERNALSYM PWTS_PROCESS_INFOA} + _WTS_PROCESS_INFOA = record + SessionId: DWORD; // session id + ProcessId: DWORD; // process id + pProcessName: LPSTR; // name of process + pUserSid: PSID; // user's SID + end; + {$EXTERNALSYM _WTS_PROCESS_INFOA} + WTS_PROCESS_INFOA = _WTS_PROCESS_INFOA; + {$EXTERNALSYM WTS_PROCESS_INFOA} + TWtsProcessInfoA = WTS_PROCESS_INFOA; + PWtsProcessInfoA = PWTS_PROCESS_INFOA; + +{$IFDEF UNICODE} + WTS_PROCESS_INFO = WTS_PROCESS_INFOW; + {$EXTERNALSYM WTS_PROCESS_INFO} + PWTS_PROCESS_INFO = PWTS_PROCESS_INFOW; + {$EXTERNALSYM PWTS_PROCESS_INFO} + TWtsProcessInfo = TWtsProcessInfoW; + PWtsProcessInfo = PWtsProcessInfoW; +{$ELSE} + WTS_PROCESS_INFO = WTS_PROCESS_INFOA; + {$EXTERNALSYM WTS_PROCESS_INFO} + PWTS_PROCESS_INFO = PWTS_PROCESS_INFOA; + {$EXTERNALSYM PWTS_PROCESS_INFO} + TWtsProcessInfo = TWtsProcessInfoA; + PWtsProcessInfo = PWtsProcessInfoA; +{$ENDIF} + +//============================================================================== +// WTS_INFO_CLASS - WTSQuerySessionInformation +// (See additional typedefs for more info on structures) +//============================================================================== + +const + WTS_PROTOCOL_TYPE_CONSOLE = 0; // Console + {$EXTERNALSYM WTS_PROTOCOL_TYPE_CONSOLE} + WTS_PROTOCOL_TYPE_ICA = 1; // ICA Protocol + {$EXTERNALSYM WTS_PROTOCOL_TYPE_ICA} + WTS_PROTOCOL_TYPE_RDP = 2; // RDP Protocol + {$EXTERNALSYM WTS_PROTOCOL_TYPE_RDP} + +{$IFDEF false} +type + _WTS_INFO_CLASS = ( + WTSInitialProgram, + WTSApplicationName, + WTSWorkingDirectory, + WTSOEMId, + WTSSessionId, + WTSUserName, + WTSWinStationName, + WTSDomainName, + WTSConnectState, + WTSClientBuildNumber, + WTSClientName, + WTSClientDirectory, + WTSClientProductId, + WTSClientHardwareId, + WTSClientAddress, + WTSClientDisplay, + WTSClientProtocolType); + {$EXTERNALSYM _WTS_INFO_CLASS} + WTS_INFO_CLASS = _WTS_INFO_CLASS; + TWtsInfoClass = WTS_INFO_CLASS; +{$ELSE} +// xe2에서 위처럼 선언하고 하면.. WTSQuerySessionInformation에서 자꾸 87에러 뱉는다 14_0319 16:26:01 sunk +const + WTSInitialProgram = 0; + WTSApplicationName = 1; + WTSWorkingDirectory = 2; + WTSOEMId = 3; + WTSSessionId = 4; + WTSUserName = 5; + WTSWinStationName = 6; + WTSDomainName = 7; + WTSConnectState = 8; + WTSClientBuildNumber = 9; + WTSClientName = 10; + WTSClientDirectory = 11; + WTSClientProductId = 12; + WTSClientHardwareId = 13; + WTSClientAddress = 14; + WTSClientDisplay = 15; + WTSClientProtocolType = 16; +type + WTS_INFO_CLASS = DWORD; + TWtsInfoClass = WTS_INFO_CLASS; +{$ENDIF} + +//============================================================================== +// WTSQuerySessionInformation - (WTSClientAddress) +//============================================================================== + +type + PWTS_CLIENT_ADDRESS = ^WTS_CLIENT_ADDRESS; + {$EXTERNALSYM PWTS_CLIENT_ADDRESS} + _WTS_CLIENT_ADDRESS = record + AddressFamily: DWORD; // AF_INET, AF_IPX, AF_NETBIOS, AF_UNSPEC + Address: array [0..19] of BYTE; // client network address + end; + {$EXTERNALSYM _WTS_CLIENT_ADDRESS} + WTS_CLIENT_ADDRESS = _WTS_CLIENT_ADDRESS; + {$EXTERNALSYM WTS_CLIENT_ADDRESS} + TWtsClientAddress = WTS_CLIENT_ADDRESS; + PWtsClientAddress = PWTS_CLIENT_ADDRESS; + +//============================================================================== +// WTSQuerySessionInformation - (WTSClientDisplay) +//============================================================================== + +type + PWTS_CLIENT_DISPLAY = ^WTS_CLIENT_DISPLAY; + {$EXTERNALSYM PWTS_CLIENT_DISPLAY} + _WTS_CLIENT_DISPLAY = record + HorizontalResolution: DWORD; // horizontal dimensions, in pixels + VerticalResolution: DWORD; // vertical dimensions, in pixels + ColorDepth: DWORD; // 1=16, 2=256, 4=64K, 8=16M + end; + {$EXTERNALSYM _WTS_CLIENT_DISPLAY} + WTS_CLIENT_DISPLAY = _WTS_CLIENT_DISPLAY; + {$EXTERNALSYM WTS_CLIENT_DISPLAY} + TWtsClientDisplay = WTS_CLIENT_DISPLAY; + PWtsClientDisplay = PWTS_CLIENT_DISPLAY; + +//============================================================================== +// WTS_CONFIG_CLASS - WTSQueryUserConfig/WTSSetUserConfig +//============================================================================== + +type + _WTS_CONFIG_CLASS = ( + //Initial program settings + WTSUserConfigInitialProgram, // string returned/expected + WTSUserConfigWorkingDirectory, // string returned/expected + WTSUserConfigfInheritInitialProgram, // DWORD returned/expected + // + WTSUserConfigfAllowLogonTerminalServer, //DWORD returned/expected + //Timeout settings + WTSUserConfigTimeoutSettingsConnections, //DWORD returned/expected + WTSUserConfigTimeoutSettingsDisconnections, //DWORD returned/expected + WTSUserConfigTimeoutSettingsIdle, //DWORD returned/expected + //Client device settings + WTSUserConfigfDeviceClientDrives, //DWORD returned/expected + WTSUserConfigfDeviceClientPrinters, //DWORD returned/expected + WTSUserConfigfDeviceClientDefaultPrinter, //DWORD returned/expected + //Connection settings + WTSUserConfigBrokenTimeoutSettings, //DWORD returned/expected + WTSUserConfigReconnectSettings, //DWORD returned/expected + //Modem settings + WTSUserConfigModemCallbackSettings, //DWORD returned/expected + WTSUserConfigModemCallbackPhoneNumber, // string returned/expected + //Shadow settings + WTSUserConfigShadowingSettings, //DWORD returned/expected + //User Profile settings + WTSUserConfigTerminalServerProfilePath, // string returned/expected + //Terminal Server home directory + WTSUserConfigTerminalServerHomeDir, // string returned/expected + WTSUserConfigTerminalServerHomeDirDrive, // string returned/expected + WTSUserConfigfTerminalServerRemoteHomeDir); // DWORD 0:LOCAL 1:REMOTE + {$EXTERNALSYM _WTS_CONFIG_CLASS} + WTS_CONFIG_CLASS = _WTS_CONFIG_CLASS; + TWtsConfigClass = WTS_CONFIG_CLASS; + + PWTS_USER_CONFIG_SET_NWSERVERW = ^WTS_USER_CONFIG_SET_NWSERVERW; + {$EXTERNALSYM PWTS_USER_CONFIG_SET_NWSERVERW} + _WTS_USER_CONFIG_SET_NWSERVERW = record + pNWServerName: LPWSTR; + pNWDomainAdminName: LPWSTR; + pNWDomainAdminPassword: LPWSTR; + end; + {$EXTERNALSYM _WTS_USER_CONFIG_SET_NWSERVERW} + WTS_USER_CONFIG_SET_NWSERVERW = _WTS_USER_CONFIG_SET_NWSERVERW; + {$EXTERNALSYM WTS_USER_CONFIG_SET_NWSERVERW} + TWtsUserConfigSetNwserverW = WTS_USER_CONFIG_SET_NWSERVERW; + PWtsUserConfigSetNwserverW = PWTS_USER_CONFIG_SET_NWSERVERW; + + PWTS_USER_CONFIG_SET_NWSERVERA = ^WTS_USER_CONFIG_SET_NWSERVERA; + {$EXTERNALSYM PWTS_USER_CONFIG_SET_NWSERVERA} + _WTS_USER_CONFIG_SET_NWSERVERA = record + pNWServerName: LPSTR; + pNWDomainAdminName: LPSTR; + pNWDomainAdminPassword: LPSTR; + end; + {$EXTERNALSYM _WTS_USER_CONFIG_SET_NWSERVERA} + WTS_USER_CONFIG_SET_NWSERVERA = _WTS_USER_CONFIG_SET_NWSERVERA; + {$EXTERNALSYM WTS_USER_CONFIG_SET_NWSERVERA} + TWtsUserConfigSetNwserverA = WTS_USER_CONFIG_SET_NWSERVERA; + PWtsUserConfigSetNwserverA = PWTS_USER_CONFIG_SET_NWSERVERA; + +{$IFDEF UNICODE} + WTS_USER_CONFIG_SET_NWSERVER = WTS_USER_CONFIG_SET_NWSERVERW; + {$EXTERNALSYM WTS_USER_CONFIG_SET_NWSERVER} + PWTS_USER_CONFIG_SET_NWSERVER = PWTS_USER_CONFIG_SET_NWSERVERW; + {$EXTERNALSYM PWTS_USER_CONFIG_SET_NWSERVER} + TWtsUserConfigSetNwserver = TWtsUserConfigSetNwserverW; + PWtsUserConfigSetNwserver = PWtsUserConfigSetNwserverW; +{$ELSE} + WTS_USER_CONFIG_SET_NWSERVER = WTS_USER_CONFIG_SET_NWSERVERA; + {$EXTERNALSYM WTS_USER_CONFIG_SET_NWSERVER} + PWTS_USER_CONFIG_SET_NWSERVER = PWTS_USER_CONFIG_SET_NWSERVERA; + {$EXTERNALSYM PWTS_USER_CONFIG_SET_NWSERVER} + TWtsUserConfigSetNwserver = TWtsUserConfigSetNwserverA; + PWtsUserConfigSetNwserver = PWtsUserConfigSetNwserverA; +{$ENDIF} + +//============================================================================== +// WTS_EVENT - Event flags for WTSWaitSystemEvent +//============================================================================== + +const + WTS_EVENT_NONE = $00000000; // return no event + {$EXTERNALSYM WTS_EVENT_NONE} + WTS_EVENT_CREATE = $00000001; // new WinStation created + {$EXTERNALSYM WTS_EVENT_CREATE} + WTS_EVENT_DELETE = $00000002; // existing WinStation deleted + {$EXTERNALSYM WTS_EVENT_DELETE} + WTS_EVENT_RENAME = $00000004; // existing WinStation renamed + {$EXTERNALSYM WTS_EVENT_RENAME} + WTS_EVENT_CONNECT = $00000008; // WinStation connect to client + {$EXTERNALSYM WTS_EVENT_CONNECT} + WTS_EVENT_DISCONNECT = $00000010; // WinStation logged on without client + {$EXTERNALSYM WTS_EVENT_DISCONNECT} + WTS_EVENT_LOGON = $00000020; // user logged on to existing WinStation + {$EXTERNALSYM WTS_EVENT_LOGON} + WTS_EVENT_LOGOFF = $00000040; // user logged off from existing WinStation + {$EXTERNALSYM WTS_EVENT_LOGOFF} + WTS_EVENT_STATECHANGE = $00000080; // WinStation state change + {$EXTERNALSYM WTS_EVENT_STATECHANGE} + WTS_EVENT_LICENSE = $00000100; // license state change + {$EXTERNALSYM WTS_EVENT_LICENSE} + WTS_EVENT_ALL = $7fffffff; // wait for all event types + {$EXTERNALSYM WTS_EVENT_ALL} + WTS_EVENT_FLUSH = DWORD($80000000); // unblock all waiters + {$EXTERNALSYM WTS_EVENT_FLUSH} + +//============================================================================== +// WTS_VIRTUAL_CLASS - WTSVirtualChannelQuery +//============================================================================== + +type + _WTS_VIRTUAL_CLASS = (WTSVirtualClientData); // Virtual channel client module data (C2H data) + {$EXTERNALSYM _WTS_VIRTUAL_CLASS} + WTS_VIRTUAL_CLASS = _WTS_VIRTUAL_CLASS; + {$EXTERNALSYM WTS_VIRTUAL_CLASS} + TWtsVirtualClass = WTS_VIRTUAL_CLASS; + +//============================================================================== +// Windows Terminal Server public APIs +//============================================================================== + +function WTSEnumerateServersA(pDomainName: LPSTR; Reserved, Version: DWORD; + var ppServerInfo: PWTS_SERVER_INFOA; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateServersA} +function WTSEnumerateServersW(pDomainName: LPWSTR; Reserved, Version: DWORD; + var ppServerInfo: PWTS_SERVER_INFOW; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateServersW} + +{$IFDEF UNICODE} +function WTSEnumerateServers(pDomainName: LPWSTR; Reserved, Version: DWORD; + var ppServerInfo: PWTS_SERVER_INFOW; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateServers} +{$ELSE} +function WTSEnumerateServers(pDomainName: LPSTR; Reserved, Version: DWORD; + var ppServerInfo: PWTS_SERVER_INFOA; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateServers} +{$ENDIF} + +//------------------------------------------------------------------------------ + +function WTSOpenServerA(pServerName: LPSTR): HANDLE; stdcall; +{$EXTERNALSYM WTSOpenServerA} +function WTSOpenServerW(pServerName: LPWSTR): HANDLE; stdcall; +{$EXTERNALSYM WTSOpenServerW} + +{$IFDEF UNICODE} +function WTSOpenServer(pServerName: LPWSTR): HANDLE; stdcall; +{$EXTERNALSYM WTSOpenServer} +{$ELSE} +function WTSOpenServer(pServerName: LPSTR): HANDLE; stdcall; +{$EXTERNALSYM WTSOpenServer} +{$ENDIF} + +//------------------------------------------------------------------------------ + +procedure WTSCloseServer(hServer: HANDLE); stdcall; +{$EXTERNALSYM WTSCloseServer} + +//------------------------------------------------------------------------------ + +function WTSEnumerateSessionsA(hServer: HANDLE; Reserved: DWORD; Version: DWORD; + var ppSessionInfo: PWTS_SESSION_INFOA; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateSessionsA} +function WTSEnumerateSessionsW(hServer: HANDLE; Reserved: DWORD; Version: DWORD; + var ppSessionInfo: PWTS_SESSION_INFOW; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateSessionsW} + +{$IFDEF UNICODE} +function WTSEnumerateSessions(hServer: HANDLE; Reserved: DWORD; Version: DWORD; + var ppSessionInfo: PWTS_SESSION_INFOW; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateSessions} +{$ELSE} +function WTSEnumerateSessions(hServer: HANDLE; Reserved: DWORD; Version: DWORD; + var ppSessionInfo: PWTS_SESSION_INFOA; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateSessions} +{$ENDIF} + +//------------------------------------------------------------------------------ + +function WTSEnumerateProcessesA(hServer: HANDLE; Reserved: DWORD; Version: DWORD; + var ppProcessInfo: PWTS_PROCESS_INFOA; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateProcessesA} +function WTSEnumerateProcessesW(hServer: HANDLE; Reserved: DWORD; Version: DWORD; + var ppProcessInfo: PWTS_PROCESS_INFOW; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateProcessesW} + +{$IFDEF UNICODE} +function WTSEnumerateProcesses(hServer: HANDLE; Reserved: DWORD; Version: DWORD; + var ppProcessInfo: PWTS_PROCESS_INFOW; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateProcesses} +{$ELSE} +function WTSEnumerateProcesses(hServer: HANDLE; Reserved: DWORD; Version: DWORD; + var ppProcessInfo: PWTS_PROCESS_INFOA; var pCount: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSEnumerateProcesses} +{$ENDIF} + +//------------------------------------------------------------------------------ + +function WTSTerminateProcess(hServer: HANDLE; ProcessId, ExitCode: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSTerminateProcess} + +//------------------------------------------------------------------------------ + +function WTSQuerySessionInformationA(hServer: HANDLE; SessionId: DWORD; + WTSInfoClass: WTS_INFO_CLASS; var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSQuerySessionInformationA} +function WTSQuerySessionInformationW(hServer: HANDLE; SessionId: DWORD; + WTSInfoClass: WTS_INFO_CLASS; var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSQuerySessionInformationW} + +{$IFDEF UNICODE} +function WTSQuerySessionInformation(hServer: HANDLE; SessionId: DWORD; + WTSInfoClass: WTS_INFO_CLASS; var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSQuerySessionInformation} +{$ELSE} +function WTSQuerySessionInformation(hServer: HANDLE; SessionId: DWORD; + WTSInfoClass: WTS_INFO_CLASS; var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSQuerySessionInformation} +{$ENDIF} + +//------------------------------------------------------------------------------ + +function WTSQueryUserConfigA(pServerName, pUserName: LPSTR; WTSConfigClass: WTS_CONFIG_CLASS; + var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSQueryUserConfigA} +function WTSQueryUserConfigW(pServerName, pUserName: LPWSTR; WTSConfigClass: WTS_CONFIG_CLASS; + var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSQueryUserConfigW} + +{$IFDEF UNICODE} +function WTSQueryUserConfig(pServerName, pUserName: LPWSTR; WTSConfigClass: WTS_CONFIG_CLASS; + var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSQueryUserConfig} +{$ELSE} +function WTSQueryUserConfig(pServerName, pUserName: LPSTR; WTSConfigClass: WTS_CONFIG_CLASS; + var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSQueryUserConfig} +{$ENDIF} + +//------------------------------------------------------------------------------ + +function WTSSetUserConfigA(pServerName, pUserName: LPSTR; WTSConfigClass: WTS_CONFIG_CLASS; + pBuffer: LPSTR; DataLength: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSSetUserConfigA} +function WTSSetUserConfigW(pServerName, pUserName: LPWSTR; WTSConfigClass: WTS_CONFIG_CLASS; + pBuffer: LPWSTR; DataLength: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSSetUserConfigW} + +{$IFDEF UNICODE} +function WTSSetUserConfig(pServerName, pUserName: LPWSTR; WTSConfigClass: WTS_CONFIG_CLASS; + pBuffer: LPWSTR; DataLength: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSSetUserConfig} +{$ELSE} +function WTSSetUserConfig(pServerName, pUserName: LPSTR; WTSConfigClass: WTS_CONFIG_CLASS; + pBuffer: LPSTR; DataLength: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSSetUserConfig} +{$ENDIF} + +//------------------------------------------------------------------------------ + +function WTSSendMessageA(hServer: HANDLE; SessionId: DWORD; pTitle: LPSTR; + TitleLength: DWORD; pMessage: LPSTR; MessageLength: DWORD; Style: DWORD; + Timeout: DWORD; var pResponse: DWORD; bWait: BOOL): BOOL; stdcall; +{$EXTERNALSYM WTSSendMessageA} +function WTSSendMessageW(hServer: HANDLE; SessionId: DWORD; pTitle: LPWSTR; + TitleLength: DWORD; pMessage: LPWSTR; MessageLength: DWORD; Style: DWORD; + Timeout: DWORD; var pResponse: DWORD; bWait: BOOL): BOOL; stdcall; +{$EXTERNALSYM WTSSendMessageW} + +{$IFDEF UNICODE} +function WTSSendMessage(hServer: HANDLE; SessionId: DWORD; pTitle: LPWSTR; + TitleLength: DWORD; pMessage: LPWSTR; MessageLength: DWORD; Style: DWORD; + Timeout: DWORD; var pResponse: DWORD; bWait: BOOL): BOOL; stdcall; +{$EXTERNALSYM WTSSendMessage} +{$ELSE} +function WTSSendMessage(hServer: HANDLE; SessionId: DWORD; pTitle: LPSTR; + TitleLength: DWORD; pMessage: LPSTR; MessageLength: DWORD; Style: DWORD; + Timeout: DWORD; var pResponse: DWORD; bWait: BOOL): BOOL; stdcall; +{$EXTERNALSYM WTSSendMessage} +{$ENDIF} + +//------------------------------------------------------------------------------ + +function WTSDisconnectSession(hServer: HANDLE; SessionId: DWORD; bWait: BOOL): BOOL; stdcall; +{$EXTERNALSYM WTSDisconnectSession} + +//------------------------------------------------------------------------------ + +function WTSLogoffSession(hServer: HANDLE; SessionId: DWORD; bWait: BOOL): BOOL; stdcall; +{$EXTERNALSYM WTSLogoffSession} + +//------------------------------------------------------------------------------ + +function WTSShutdownSystem(hServer: HANDLE; ShutdownFlag: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSShutdownSystem} + +//------------------------------------------------------------------------------ + +function WTSWaitSystemEvent(hServer: HANDLE; EventMask: DWORD; + var pEventFlags: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSWaitSystemEvent} + +//------------------------------------------------------------------------------ + +function WTSVirtualChannelOpen(hServer: HANDLE; SessionId: DWORD; + pVirtualName: LPSTR): HANDLE; stdcall; +{$EXTERNALSYM WTSVirtualChannelOpen} + +function WTSVirtualChannelClose(hChannelHandle: HANDLE): BOOL; stdcall; +{$EXTERNALSYM WTSVirtualChannelClose} + +function WTSVirtualChannelRead(hChannelHandle: HANDLE; TimeOut: ULONG; + Buffer: PCHAR; BufferSize: ULONG; var pBytesRead: ULONG): BOOL; stdcall; +{$EXTERNALSYM WTSVirtualChannelRead} + +function WTSVirtualChannelWrite(hChannelHandle: HANDLE; Buffer: PCHAR; + Length: ULONG; var pBytesWritten: ULONG): BOOL; stdcall; +{$EXTERNALSYM WTSVirtualChannelWrite} + +function WTSVirtualChannelPurgeInput(hChannelHandle: HANDLE): BOOL; stdcall; +{$EXTERNALSYM WTSVirtualChannelPurgeInput} + +function WTSVirtualChannelPurgeOutput(hChannelHandle: HANDLE): BOOL; stdcall; +{$EXTERNALSYM WTSVirtualChannelPurgeOutput} + +function WTSVirtualChannelQuery(hChannelHandle: HANDLE; VirtualClass: WTS_VIRTUAL_CLASS; + ppBuffer: PVOID; var pBytesReturned: DWORD): BOOL; stdcall; +{$EXTERNALSYM WTSVirtualChannelQuery} + +//------------------------------------------------------------------------------ + +procedure WTSFreeMemory(pMemory: PVOID); stdcall; +{$EXTERNALSYM WTSFreeMemory} + +implementation + +const + wtsapi = 'wtsapi32.dll'; + +function WTSEnumerateServersA; external wtsapi name 'WTSEnumerateServersA'; +function WTSEnumerateServersW; external wtsapi name 'WTSEnumerateServersW'; +{$IFDEF UNICODE} +function WTSEnumerateServers; external wtsapi name 'WTSEnumerateServersW'; +{$ELSE} +function WTSEnumerateServers; external wtsapi name 'WTSEnumerateServersA'; +{$ENDIF} +function WTSOpenServerA; external wtsapi name 'WTSOpenServerA'; +function WTSOpenServerW; external wtsapi name 'WTSOpenServerW'; +{$IFDEF UNICODE} +function WTSOpenServer; external wtsapi name 'WTSOpenServerW'; +{$ELSE} +function WTSOpenServer; external wtsapi name 'WTSOpenServerA'; +{$ENDIF} +procedure WTSCloseServer; external wtsapi name 'WTSCloseServer'; +function WTSEnumerateSessionsA; external wtsapi name 'WTSEnumerateSessionsA'; +function WTSEnumerateSessionsW; external wtsapi name 'WTSEnumerateSessionsW'; +{$IFDEF UNICODE} +function WTSEnumerateSessions; external wtsapi name 'WTSEnumerateSessionsW'; +{$ELSE} +function WTSEnumerateSessions; external wtsapi name 'WTSEnumerateSessionsA'; +{$ENDIF} +function WTSEnumerateProcessesA; external wtsapi name 'WTSEnumerateProcessesA'; +function WTSEnumerateProcessesW; external wtsapi name 'WTSEnumerateProcessesW'; +{$IFDEF UNICODE} +function WTSEnumerateProcesses; external wtsapi name 'WTSEnumerateProcessesW'; +{$ELSE} +function WTSEnumerateProcesses; external wtsapi name 'WTSEnumerateProcessesA'; +{$ENDIF} +function WTSTerminateProcess; external wtsapi name 'WTSTerminateProcess'; +function WTSQuerySessionInformationA; external wtsapi name 'WTSQuerySessionInformationA'; +function WTSQuerySessionInformationW; external wtsapi name 'WTSQuerySessionInformationW'; +{$IFDEF UNICODE} +function WTSQuerySessionInformation; external wtsapi name 'WTSQuerySessionInformationW'; +{$ELSE} +function WTSQuerySessionInformation; external wtsapi name 'WTSQuerySessionInformationA +{$ENDIF} +function WTSQueryUserConfigA; external wtsapi name 'WTSQueryUserConfigA'; +function WTSQueryUserConfigW; external wtsapi name 'WTSQueryUserConfigW'; +{$IFDEF UNICODE} +function WTSQueryUserConfig; external wtsapi name 'WTSQueryUserConfigW'; +{$ELSE} +function WTSQueryUserConfig; external wtsapi name 'WTSQueryUserConfigA; +{$ENDIF} +function WTSSetUserConfigA; external wtsapi name 'WTSSetUserConfigA'; +function WTSSetUserConfigW; external wtsapi name 'WTSSetUserConfigW'; +{$IFDEF UNICODE} +function WTSSetUserConfig; external wtsapi name 'WTSSetUserConfigW'; +{$ELSE} +function WTSSetUserConfig; external wtsapi name 'WTSSetUserConfigA; +{$ENDIF} +function WTSSendMessageA; external wtsapi name 'WTSSendMessageA'; +function WTSSendMessageW; external wtsapi name 'WTSSendMessageW'; +{$IFDEF UNICODE} +function WTSSendMessage; external wtsapi name 'WTSSendMessageW' +{$ELSE} +function WTSSendMessage; external wtsapi name 'WTSSendMessageA'; +{$ENDIF} +function WTSDisconnectSession; external wtsapi name 'WTSDisconnectSession'; +function WTSLogoffSession; external wtsapi name 'WTSLogoffSession'; +function WTSShutdownSystem; external wtsapi name 'WTSShutdownSystem'; +function WTSWaitSystemEvent; external wtsapi name 'WTSWaitSystemEvent'; +function WTSVirtualChannelOpen; external wtsapi name 'WTSVirtualChannelOpen'; +function WTSVirtualChannelClose; external wtsapi name 'WTSVirtualChannelClose'; +function WTSVirtualChannelRead; external wtsapi name 'WTSVirtualChannelRead'; +function WTSVirtualChannelWrite; external wtsapi name 'WTSVirtualChannelWrite'; +function WTSVirtualChannelPurgeInput; external wtsapi name 'WTSVirtualChannelPurgeInput'; +function WTSVirtualChannelPurgeOutput; external wtsapi name 'WTSVirtualChannelPurgeOutput'; +function WTSVirtualChannelQuery; external wtsapi name 'WTSVirtualChannelQuery'; +procedure WTSFreeMemory; external wtsapi name 'WTSFreeMemory'; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/EM.base64.pas b/Tocsg.Lib/VCL/EncLib/EM.base64.pas new file mode 100644 index 00000000..b3bdb3cd --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.base64.pas @@ -0,0 +1,212 @@ +unit base64; + +interface + +function base64decode(instr : string): string; +function base64encode(instr : string) : string; + +implementation + +uses + SysUtils,classes; + +function base64decode(instr : string) : string; +var + inidx ,len: integer; + outstr : String; + in1, in2, in3, in4 : char; + v1, v2, v3, v4 : integer; + out1, out2, out3 : char; + + function ct(inchar : char) : integer; + begin + ct := 0; + case inchar of + 'A' : ct := 0 ; 'B' : ct := 1 ; 'C' : ct := 2 ; 'D' : ct := 3 ; + 'E' : ct := 4 ; 'F' : ct := 5 ; 'G' : ct := 6 ; 'H' : ct := 7 ; + 'I' : ct := 8 ; 'J' : ct := 9 ; 'K' : ct := 10 ; 'L' : ct := 11 ; + 'M' : ct := 12 ; 'N' : ct := 13 ; 'O' : ct := 14 ; 'P' : ct := 15 ; + 'Q' : ct := 16 ; 'R' : ct := 17 ; 'S' : ct := 18 ; 'T' : ct := 19 ; + 'U' : ct := 20 ; 'V' : ct := 21 ; 'W' : ct := 22 ; 'X' : ct := 23 ; + 'Y' : ct := 24 ; 'Z' : ct := 25 ; 'a' : ct := 26 ; 'b' : ct := 27 ; + 'c' : ct := 28 ; 'd' : ct := 29 ; 'e' : ct := 30 ; 'f' : ct := 31 ; + 'g' : ct := 32 ; 'h' : ct := 33 ; 'i' : ct := 34 ; 'j' : ct := 35 ; + 'k' : ct := 36 ; 'l' : ct := 37 ; 'm' : ct := 38 ; 'n' : ct := 39 ; + 'o' : ct := 40 ; 'p' : ct := 41 ; 'q' : ct := 42 ; 'r' : ct := 43 ; + 's' : ct := 44 ; 't' : ct := 45 ; 'u' : ct := 46 ; 'v' : ct := 47 ; + 'w' : ct := 48 ; 'x' : ct := 49 ; 'y' : ct := 50 ; 'z' : ct := 51 ; + '0' : ct := 52 ; '1' : ct := 53 ; '2' : ct := 54 ; '3' : ct := 55 ; + '4' : ct := 56 ; '5' : ct := 57 ; '6' : ct := 58 ; '7' : ct := 59 ; + '8' : ct := 60 ; '9' : ct := 61 ; '+' : ct := 62 ; '/' : ct := 63 ; + end; + end; + +begin + try + inidx := 1; + len := Length ( instr); + outstr := ''; + while inidx < len do + begin + in1 := instr[inidx]; + inc(inidx); + in2 := instr[inidx]; + inc(inidx); + in3 := instr[inidx]; + inc(inidx); + in4 := instr[inidx]; + inc(inidx); + + if instr[inidx] = #13 then + begin + inidx := inidx+2; + end; + + v1 := ct(in1); + v2 := ct(in2); + v3 := ct(in3); + v4 := ct(in4); + + if ((in3 = '=') and (in4 = '=')) then + begin + out1 := chr((v1 shl 2)+(v2 shr 4)); + outstr := concat(outstr,out1); + break; + end + else if ((in3 <> '=') and (in4 = '=')) then + begin + out1 := chr((v1 shl 2)+(v2 shr 4)); + out2 := chr((v2 shl 4)+(v3 shr 2)); + outstr := concat(outstr,out1); + outstr := concat(outstr,out2); + break; + end + else + begin + out1 := chr((v1 shl 2)+(v2 shr 4)); + out2 := chr((v2 shl 4)+(v3 shr 2)); + out3 := chr((v3 shl 6)+v4); + outstr := concat(outstr,out1); + outstr := concat(outstr,out2); + outstr := concat(outstr,out3); + end; + end; + finally + result := outstr; + end; +end; + +function base64encode(instr : string): string; +var + inidx,len : integer; + outstr : String; + nsize : longInt; + in1, in2, in3, t : char; + out1, out2, out3, out4 : integer; + index, final : integer; + tmpstr : String; + + function ct(inchar : integer) : char; + begin + ct := ' '; + case inchar of + 0 : ct := 'A' ; 1 : ct := 'B' ; 2 : ct := 'C' ; 3 : ct := 'D' ; + 4 : ct := 'E' ; 5 : ct := 'F' ; 6 : ct := 'G' ; 7 : ct := 'H' ; + 8 : ct := 'I' ; 9 : ct := 'J' ; 10 : ct := 'K' ; 11 : ct := 'L' ; + 12 : ct := 'M' ; 13 : ct := 'N' ; 14 : ct := 'O' ; 15 : ct := 'P' ; + 16 : ct := 'Q' ; 17 : ct := 'R' ; 18 : ct := 'S' ; 19 : ct := 'T' ; + 20 : ct := 'U' ; 21 : ct := 'V' ; 22 : ct := 'W' ; 23 : ct := 'X' ; + 24 : ct := 'Y' ; 25 : ct := 'Z' ; 26 : ct := 'a' ; 27 : ct := 'b' ; + 28 : ct := 'c' ; 29 : ct := 'd' ; 30 : ct := 'e' ; 31 : ct := 'f' ; + 32 : ct := 'g' ; 33 : ct := 'h' ; 34 : ct := 'i' ; 35 : ct := 'j' ; + 36 : ct := 'k' ; 37 : ct := 'l' ; 38 : ct := 'm' ; 39 : ct := 'n' ; + 40 : ct := 'o' ; 41 : ct := 'p' ; 42 : ct := 'q' ; 43 : ct := 'r' ; + 44 : ct := 's' ; 45 : ct := 't' ; 46 : ct := 'u' ; 47 : ct := 'v' ; + 48 : ct := 'w' ; 49 : ct := 'x' ; 50 : ct := 'y' ; 51 : ct := 'z' ; + 52 : ct := '0' ; 53 : ct := '1' ; 54 : ct := '2' ; 55 : ct := '3' ; + 56 : ct := '4' ; 57 : ct := '5' ; 58 : ct := '6' ; 59 : ct := '7' ; + 60 : ct := '8' ; 61 : ct := '9' ; 62 : ct := '+' ; 63 : ct := '/' ; + end; + end; + +begin + outstr := ''; + try + inidx := 1; + len := length(instr); + nsize := 0; + index := 0; + + while (nsize < len) do + begin + inc(nsize); + in1 := instr[inidx]; + inc(inidx); + final := 8; + if (nsize < len) then + begin + inc(nsize); + in2 := instr[inidx]; + inc(inidx); + + final := 16; + end + else in2 := chr(0); + + if (nsize < len) then + begin + inc(nsize); + in3 := instr[inidx]; + inc(inidx); + + final := 24; + end + else in3 := chr(0); + + out1 := ord(in1) shr 2; + out2 := ((ord(in1) and 3) shl 4) + (ord(in2) shr 4); + out3 := ((ord(in2) and 15) shl 2) + ((ord(in3) and 192) shr 6); + out4 := ord(in3) and 63; + + t := ct(out1); + inc(index); + outstr := concat(outstr,t); + + t := ct(out2); + inc(index); + outstr := concat(outstr,t); + + if ((final = 8) and (nsize = len)) then + begin + tmpstr := '=='+#$D+#$A; + outstr := concat(outstr,tmpstr); + break; + end; + t := ct(out3); + inc(index); + outstr := concat(outstr,t); + + if ((final = 16) and (nsize = len)) then + begin + tmpstr := '='+#$D+#$A; + outstr := concat(outstr,tmpstr); + break; + end; + + t := ct(out4); + inc(index); + outstr := concat(outstr,t); + if index = 72 then + begin + tmpstr := #$D+#$A; + outstr := concat(outstr,tmpstr); + index := 0; + end; + + end; + finally + result := outstr; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/EncLib/EM.sha256.pas b/Tocsg.Lib/VCL/EncLib/EM.sha256.pas new file mode 100644 index 00000000..1e837d51 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/EM.sha256.pas @@ -0,0 +1,1209 @@ +unit EM.sha256; + +// crc_hash_2018-01-01.zip 에서 sha256.pas 파일을 가져온 것이고, +// 필요한 정의는 동일 경로에 있는btypes.pas, hash.pas에서 가져왔다. 18_0621 10:49:56 sunk + +{SHA256 - 256 bit Secure Hash Function} + + +interface + +(************************************************************************* + + DESCRIPTION : SHA256 - 256 bit Secure Hash Function + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17-D18/D25S, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : - Latest specification of Secure Hash Standard: + http://csrc.nist.gov/publications/fips/fips180-4/fips-180-4.pdf + - Test vectors and intermediate values: + http://csrc.nist.gov/groups/ST/toolkit/documents/Examples/SHA_All.pdf + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.1 03.01.02 W.Ehrhardt Reference implementation + 0.2 03.01.02 we BP7 optimization + 0.21 03.01.02 we TP6 changes + 0.3 03.01.02 we Delphi32 optimization + 0.4 03.01.02 we with TW32Buf and assignment via RB in SHA256Compress + 0.5 07.01.02 we Opt. Delphi UpdateLen + 0.6 23.02.02 we Free Pascal compatibility + 0.7 03.03.02 we VirtualPascal compatibility + 0.71 03.03.02 we FPC with ASM (intel) + 0.72 03.03.02 we TP55 compatibility + 0.80 23.07.03 we With SHA256File, SHA256Full + 0.81 26.07.03 we With SHA256Full in self test, D6+ - warnings + 2.00 26.07.03 we common vers., longint for word32, D4+ - warnings + 2.01 04.08.03 we type TSHA256Block for HMAC + 2.10 29.08.03 we XL versions for Win32 + 2.20 27.09.03 we FPC/go32v2 + 2.30 05.10.03 we STD.INC, TP5.0 + 2.40 10.10.03 we common version, english comments + 2.45 11.10.03 we Speedup: Inline for Maj(), Ch() + 2.50 17.11.03 we Speedup in update, don't clear W in compress + 2.51 20.11.03 we Full range UpdateLen + 3.00 01.12.03 we Common version 3.0 + 3.01 22.12.03 we TP5/5.5: RB, FS inline + 3.02 22.12.03 we TP5/5.5: FS -> FS1, FS2 + 3.03 22,12.03 we Changed UpdateLen: Definition and TP5/5.5 inline + 3.04 22.12.03 we TP5/5.5: inline function ISHR + 3.05 22.12.03 we ExpandMessageBlocks/BASM + 3.06 24.12.03 we FIPS notation: S[] -> A..H, partial unroll + 3.07 05.03.04 we Update fips180-2 URL + 3.08 26.02.05 we With {$ifdef StrictLong} + 3.09 05.05.05 we $R- for StrictLong, D9: errors if $R+ even if warnings off + 3.10 17.12.05 we Force $I- in SHA256File + 3.11 15.01.06 we uses Hash unit and THashDesc + 3.12 15.01.06 we BugFix for 16 bit without BASM + 3.13 18.01.06 we Descriptor fields HAlgNum, HSig + 3.14 22.01.06 we Removed HSelfTest from descriptor + 3.15 11.02.06 we Descriptor as typed const + 3.16 07.08.06 we $ifdef BIT32: (const fname: shortstring...) + 3.17 22.02.07 we values for OID vector + 3.18 30.06.07 we Use conditional define FPC_ProcVar + 3.19 04.10.07 we FPC: {$asmmode intel} + 3.20 02.05.08 we Bit-API: SHA256FinalBits/Ex + 3.21 05.05.08 we THashDesc constant with HFinalBit field + 3.22 12.11.08 we Uses BTypes, Ptr2Inc and/or Str255/Str127 + 3.23 11.03.12 we Updated references + 3.24 26.12.12 we D17 and PurePascal + 3.25 16.08.15 we Removed $ifdef DLL / stdcall + 3.26 15.05.17 we adjust OID to new MaxOIDLen + 3.27 29.11.17 we SHA256File - fname: string + +**************************************************************************) + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2017 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{NOTE: FIPS Ch and May functions can be optimized. Wei Dai (Crypto++ 3.1) +credits Rich Schroeppel (rcs@cs.arizona.edu), V 5.1 does not!?} + +{$i STD.INC} + +{$ifdef BIT64} + {$ifndef PurePascal} + {$define PurePascal} + {$endif} +{$endif} + +{$define UNROLL} {Speedup for all but TP5/5.5 and maybe VP} + +{$ifdef VER50} + {$undef UNROLL} {Only VER50, VER55 uses UNROLL} +{$endif} + +{$ifdef VirtualPascal} + {$undef UNROLL} +{$endif} + +//uses +// BTypes,Hash; + +const + MaxBlockLen = 128; {Max. block length (buffer size), multiple of 4} + MaxDigestLen = 64; {Max. length of hash digest} + MaxStateLen = 16; {Max. size of internal state} + MaxOIDLen = 11; {Current max. OID length} + C_HashSig = $3D7A; {Signature for Hash descriptor} + C_HashVers = $00020002; {Version of Hash definitions} + + HASHCTXSIZE = 448; {Common size of enlarged padded old context} + {and new padded SHA3/SHAKE/Keccak context } + + BitAPI_Mask: array[0..7] of byte = ($00,$80,$C0,$E0,$F0,$F8,$FC,$FE); + BitAPI_PBit: array[0..7] of byte = ($80,$40,$20,$10,$08,$04,$02,$01); + +type + Ptr2Inc = pByte; {Type cast to increment untyped pointer} + Str127 = string[127]; + + THashState = packed array[0..MaxStateLen-1] of longint; {Internal state} + THashBuffer = packed array[0..MaxBlockLen-1] of byte; {hash buffer block} + THashDigest = packed array[0..MaxDigestLen-1] of byte; {hash digest} + PHashDigest = ^THashDigest; {pointer to hash digest} + THashBuf32 = packed array[0..MaxBlockLen div 4 -1] of longint; {type cast helper} + THashDig32 = packed array[0..MaxDigestLen div 4 -1] of longint; {type cast helper} + +// 원래 이름은 THashContext이고, 범용적인 이름을 피하기 위해 변경 18_0621 10:52:19 sunk + TKzHashContext = packed record + Hash : THashState; {Working hash} + MLen : packed array[0..3] of longint; {max 128 bit msg length} + Buffer: THashBuffer; {Block buffer} + Index : longint; {Index in buffer} + Fill2 : packed array[213..HASHCTXSIZE] of byte; + end; + + TSHA256Digest = packed array[0..31] of byte; {SHA256 digest } + + TOID_Vec = packed array[1..MaxOIDLen] of longint; {OID vector} + POID_Vec = ^TOID_Vec; {ptr to OID vector} + + HashInitProc = procedure(var Context: TKzHashContext); + {-initialize context} + + HashUpdateXLProc = procedure(var Context: TKzHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + + HashFinalProc = procedure(var Context: TKzHashContext; var Digest: THashDigest); + {-finalize calculation, clear context} + + HashFinalBitProc = procedure(var Context: TKzHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize calculation with bitlen bits from BData, clear context} + + THashName = string[19]; {Hash algo name type } + PHashDesc = ^THashDesc; {Ptr to descriptor } + THashDesc = packed record + HSig : word; {Signature=C_HashSig } + HDSize : word; {sizeof(THashDesc) } + HDVersion : longint; {THashDesc Version } + HBlockLen : word; {Blocklength of hash, rate div 8 for SHA3} + HDigestlen: word; {Digestlength of hash} + HInit : HashInitProc; {Init procedure } + HFinal : HashFinalProc; {Final procedure } + HUpdateXL : HashUpdateXLProc; {Update procedure } + HAlgNum : longint; {Algo ID, longint avoids problems with enum size/DLL} + HName : THashName; {Name of hash algo } + HPtrOID : POID_Vec; {Pointer to OID vec } + HLenOID : word; {Length of OID vec } + HFill : word; + HFinalBit : HashFinalBitProc; {Bit-API Final proc } + HReserved : packed array[0..19] of byte; + end; + +procedure SHA256Init(var Context: TKzHashContext); + {-initialize context} + +procedure SHA256Update(var Context: TKzHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + +procedure SHA256UpdateXL(var Context: TKzHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + +procedure SHA256Final(var Context: TKzHashContext; var Digest: TSHA256Digest); + {-finalize SHA256 calculation, clear context} + +procedure SHA256FinalEx(var Context: TKzHashContext; var Digest: THashDigest); + {-finalize SHA256 calculation, clear context} + +procedure SHA256FinalBitsEx(var Context: TKzHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} + +procedure SHA256FinalBits(var Context: TKzHashContext; var Digest: TSHA256Digest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} + +function SHA256SelfTest: boolean; + {-self test for string from SHA256 document} + +procedure SHA256Full(var Digest: TSHA256Digest; Msg: pointer; Len: word); + {-SHA256 of Msg with init/update/final} + +procedure SHA256FullXL(var Digest: TSHA256Digest; Msg: pointer; Len: longint); + {-SHA256 of Msg with init/update/final} + +procedure SHA256File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA256Digest; var buf; bsize: word; var Err: word); + {-SHA256 of file, buf: buffer with at least bsize bytes} + + +implementation + + +{$ifdef BIT16} + {$F-} +{$endif} + +const + SHA256_BlockLen = 64; + +{Internal types for type casting} +type + TWorkBuf = array[0..63] of longint; + + THashAlgorithm = (_MD4, _MD5, _RIPEMD160, _SHA1, + _SHA224, _SHA256, _SHA384, _SHA512, + _Whirlpool, _SHA512_224, _SHA512_256, + _SHA3_224, _SHA3_256, _SHA3_384, _SHA3_512, + _Blake2S_224, _Blake2S_256, + _Blake2B_384, _Blake2B_512); {Supported hash algorithms} + +var + PHashVec : array[THashAlgorithm] of PHashDesc; + {Hash descriptor pointers of all defined hash algorithms} + + +{2.16.840.1.101.3.4.2.1} +{joint-iso-itu-t(2) country(16) us(840) organization(1) gov(101) csor(3) nistAlgorithm(4) hashAlgs(2) sha256(1)} +const + SHA256_OID : TOID_Vec = (2,16,840,1,101,3,4,2,1,-1,-1); {Len=9} + + +{$ifndef VER5X} +const + SHA256_Desc: THashDesc = ( + HSig : C_HashSig; + HDSize : sizeof(THashDesc); + HDVersion : C_HashVers; + HBlockLen : SHA256_BlockLen; + HDigestlen: sizeof(TSHA256Digest); + {$ifdef FPC_ProcVar} + HInit : @SHA256Init; + HFinal : @SHA256FinalEx; + HUpdateXL : @SHA256UpdateXL; + {$else} + HInit : SHA256Init; + HFinal : SHA256FinalEx; + HUpdateXL : SHA256UpdateXL; + {$endif} + HAlgNum : longint(_SHA256); + HName : 'SHA256'; + HPtrOID : @SHA256_OID; + HLenOID : 9; + HFill : 0; + {$ifdef FPC_ProcVar} + HFinalBit : @SHA256FinalBitsEx; + {$else} + HFinalBit : SHA256FinalBitsEx; + {$endif} + HReserved : (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0) + ); +{$else} +var + SHA256_Desc: THashDesc; +{$endif} + +function HashSameDigest(PHash: PHashDesc; PD1, PD2: PHashDigest): boolean; + {-Return true if same digests, using HDigestlen of PHash} +var + i: integer; +begin + HashSameDigest := false; + if PHash<>nil then with PHash^ do begin + if (HSig=C_HashSig) and (HDigestlen>0) then begin + for i:=0 to pred(HDigestlen) do begin + if PD1^[i]<>PD2^[i] then exit; + end; + HashSameDigest := true; + end; + end; +end; + +procedure HashFile({$ifdef CONST} const {$endif} fname: string; PHash: PHashDesc; + var Digest: THashDigest; var buf; bsize: word; var Err: word); + {-Calculate hash digest of file, buf: buffer with at least bsize bytes} +var + {$ifdef VirtualPascal} + fms: word; + {$else} + fms: byte; + {$endif} + {$ifndef BIT16} + L: longint; + {$else} + L: word; + {$endif} +var + Context: TKzHashContext; + f: file; +begin + if (PHash=nil) or (Phash^.HSig<>C_HashSig) then begin + Err := 204; {Invalid pointer} + exit; + end; + fms := FileMode; + {$ifdef VirtualPascal} + FileMode := $40; {open_access_ReadOnly or open_share_DenyNone;} + {$else} + FileMode := 0; + {$endif} + system.assign(f,{$ifdef D12Plus} string {$endif} (fname)); + system.reset(f,1); + Err := IOResult; + FileMode := fms; + if Err<>0 then exit; + with PHash^ do begin + HInit(Context); + L := bsize; + while (Err=0) and (L=bsize) do begin + system.blockread(f,buf,bsize,L); + Err := IOResult; + HUpdateXL(Context, @buf, L); + end; + system.close(f); + if IOResult=0 then {}; + HFinal(Context, Digest); + end; +end; + +procedure RegisterHash(AlgId: THashAlgorithm; PHash: PHashDesc); + {-Register algorithm with AlgID and Hash descriptor PHash^} +begin + if (PHash<>nil) and + (PHash^.HAlgNum=longint(AlgId)) and + (PHash^.HSig=C_HashSig) and + (PHash^.HDVersion=C_HashVers) and + (PHash^.HDSize=sizeof(THashDesc)) then PHashVec[AlgId] := PHash; +end; + + +{$ifndef BIT16} + +{$ifdef PurePascal} + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + var + tmp: int64; + begin + tmp := int64(cardinal(wlo))+Blen; + wlo := longint(tmp and $FFFFFFFF); + inc(whi,longint(tmp shr 32)); + end; + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; + {-reverse byte order in longint} + begin + RB := ((A and $FF) shl 24) or ((A and $FF00) shl 8) or ((A and $FF0000) shr 8) or ((A and longint($FF000000)) shr 24); + end; +{$else} + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; assembler; {&frame-} + {-reverse byte order in longint} + asm + {$ifdef LoadArgs} + mov eax,[A] + {$endif} + xchg al,ah + rol eax,16 + xchg al,ah + end; + + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + begin + asm + mov edx, wlo + mov ecx, whi + mov eax, Blen + add [edx], eax + adc dword ptr [ecx], 0 + end; + end; + + {---------------------------------------------------------------------------} + function Sum0(x: longint): longint; assembler; {&frame-} + {-Big sigma 0: RotRight(x,2) xor RotRight(x,13) xor RotRight(x,22)} + asm + {$ifdef LoadArgs} + mov eax,[x] + {$endif} + mov ecx,eax + mov edx,eax + ror eax,2 + ror edx,13 + ror ecx,22 + xor eax,edx + xor eax,ecx + end; + + {---------------------------------------------------------------------------} + function Sum1(x: longint): longint; assembler; {&frame-} + {-Big sigma 1: RotRight(x,6) xor RotRight(x,11) xor RotRight(x,25)} + asm + {$ifdef LoadArgs} + mov eax,[x] + {$endif} + mov ecx,eax + mov edx,eax + ror eax,6 + ror edx,11 + ror ecx,25 + xor eax,edx + xor eax,ecx + end; + + {$define USE_ExpandMessageBlocks} + + {---------------------------------------------------------------------------} + procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuf32); + {-Calculate "expanded message blocks"} + begin + asm + push esi + push edi + push ebx + mov esi,[W] + mov edx,[Buf] + {part 1: W[i]:= RB(TW32Buf(Buf)[i])} + mov ecx,16 + @@1: mov eax,[edx] + xchg al,ah + rol eax,16 + xchg al,ah + mov [esi],eax + add esi,4 + add edx,4 + dec ecx + jnz @@1 + {part2: W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]);} + mov ecx,48 + @@2: mov edi,[esi-7*4] {W[i-7]} + mov eax,[esi-2*4] {W[i-2]} + mov ebx,eax {Sig1: RR17 xor RR19 xor SRx,10} + mov edx,eax + ror eax,17 + ror edx,19 + shr ebx,10 + xor eax,edx + xor eax,ebx + add edi,eax + mov eax,[esi-15*4] {W[i-15]} + mov ebx,eax {Sig0: RR7 xor RR18 xor SR3} + mov edx,eax + ror eax,7 + ror edx,18 + shr ebx,3 + xor eax,edx + xor eax,ebx + add eax,edi + add eax,[esi-16*4] {W[i-16]} + mov [esi],eax + add esi,4 + dec ecx + jnz @@2 + pop ebx + pop edi + pop esi + end; + end; +{$endif} + +{$else} + +{$ifndef BASM16} + +{TP5/5.5} + +{$undef USE_ExpandMessageBlocks} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} +inline( + $58/ {pop ax } + $5A/ {pop dx } + $5B/ {pop bx } + $07/ {pop es } + $26/$01/$07/ {add es:[bx],ax } + $26/$11/$57/$02/ {adc es:[bx+02],dx} + $5B/ {pop bx } + $07/ {pop es } + $26/$83/$17/$00/ {adc es:[bx],0 } + $26/$83/$57/$02/$00);{adc es:[bx+02],0 } + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; + {-reverse byte order in longint} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $86/$C6/ { xchg dh,al} + $86/$E2); { xchg dl,ah} + + +{---------------------------------------------------------------------------} +function FS1(x: longint; c: integer): longint; + {-Rotate x right, c<=16!!} +inline( + $59/ { pop cx } + $58/ { pop ax } + $5A/ { pop dx } + $8B/$DA/ { mov bx,dx} + $D1/$EB/ {L:shr bx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA/ { rcr dx,1 } + $49/ { dec cx } + $75/$F7); { jne L } + + +{---------------------------------------------------------------------------} +function FS2(x: longint; c: integer): longint; + {-Rotate x right, c+16, c<16!!} +inline( + $59/ { pop cx } + $5A/ { pop dx } + $58/ { pop ax } + $8B/$DA/ { mov bx,dx} + $D1/$EB/ {L:shr bx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA/ { rcr dx,1 } + $49/ { dec cx } + $75/$F7); { jne L } + + +{---------------------------------------------------------------------------} +function ISHR(x: longint; c: integer): longint; + {-Shift x right} +inline( + $59/ { pop cx } + $58/ { pop ax } + $5A/ { pop dx } + $D1/$EA/ {L:shr dx,1 } + $D1/$D8/ { rcr ax,1 } + $49/ { dec cx } + $75/$F9); { jne L } + + +{---------------------------------------------------------------------------} +function Sig0(x: longint): longint; + {-Small sigma 0} +begin + Sig0 := FS1(x,7) xor FS2(x,18-16) xor ISHR(x,3); +end; + + +{---------------------------------------------------------------------------} +function Sig1(x: longint): longint; + {-Small sigma 1} +begin + Sig1 := FS2(x,17-16) xor FS2(x,19-16) xor ISHR(x,10); +end; + + +{---------------------------------------------------------------------------} +function Sum0(x: longint): longint; + {-Big sigma 0} +begin + Sum0 := FS1(x,2) xor FS1(x,13) xor FS2(x,22-16); +end; + + +{---------------------------------------------------------------------------} +function Sum1(x: longint): longint; + {-Big sigma 1} +begin + Sum1 := FS1(x,6) xor FS1(x,11) xor FS2(x,25-16); +end; + + +{$else} + +{TP 6/7/Delphi1 for 386+} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); assembler; + {-Add BLen to 64 bit value (wlo, whi)} +asm + les di,[wlo] + db $66; mov ax,word ptr [BLen] + db $66; sub dx,dx + db $66; add es:[di],ax + les di,[whi] + db $66; adc es:[di],dx +end; + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; assembler; + {-reverse byte order in longint} +asm + mov ax,word ptr [A] + mov dx,word ptr [A+2] + xchg al,dh + xchg ah,dl +end; + + +{---------------------------------------------------------------------------} +function Sum0(x: longint): longint; assembler; + {-Big sigma 0: RotRight(x,2) xor RotRight(x,13) xor RotRight(x,22)} +asm + db $66; mov ax,word ptr x + db $66; mov bx,ax + db $66; mov dx,ax + db $66; ror ax,2 + db $66; ror dx,13 + db $66; ror bx,22 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; mov dx,ax + db $66; shr dx,16 +end; + + +{---------------------------------------------------------------------------} +function Sum1(x: longint): longint; assembler; + {-Big sigma 1: RotRight(x,6) xor RotRight(x,11) xor RotRight(x,25)} +asm + db $66; mov ax,word ptr x + db $66; mov bx,ax + db $66; mov dx,ax + db $66; ror ax,6 + db $66; ror dx,11 + db $66; ror bx,25 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; mov dx,ax + db $66; shr dx,16 +end; + + +{$define USE_ExpandMessageBlocks} +{---------------------------------------------------------------------------} +procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuf32); assembler; + {-Calculate "expanded message blocks"} +asm + push ds + {part 1: W[i]:= RB(TW32Buf(Buf)[i])} + les di,[Buf] + lds si,[W] + mov cx,16 +@@1: db $66; mov ax,es:[di] + xchg al,ah + db $66; rol ax,16 + xchg al,ah + db $66; mov [si],ax + add si,4 + add di,4 + dec cx + jnz @@1 + {part 2: W[i]:= Sig1(W[i-2]) + W[i-7] + Sig0(W[i-15]) + W[i-16];} + mov cx,48 +@@2: db $66; mov di,[si-7*4] {W[i-7]} + db $66; mov ax,[si-2*4] {W[i-2]} + db $66; mov bx,ax {Sig1: RR17 xor RR19 xor SRx,10} + db $66; mov dx,ax + db $66; ror ax,17 + db $66; ror dx,19 + db $66; shr bx,10 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; add di,ax + db $66; mov ax,[si-15*4] {W[i-15]} + db $66; mov bx,ax {Sig0: RR7 xor RR18 xor SR3} + db $66; mov dx,ax + db $66; ror ax,7 + db $66; ror dx,18 + db $66; shr bx,3 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; add ax,di + db $66; add ax,[si-16*4] {W[i-16]} + db $66; mov [si],ax + add si,4 + dec cx + jnz @@2 + pop ds +end; + + +{$endif BASM16} + +{$endif BIT16} + + + +{$ifdef PurePascal} +{---------------------------------------------------------------------------} +procedure SHA256Compress(var Data: THashContext); + {-Actual hashing function} +var + i: integer; + T, A, B, C, D, E, F, G, H: longint; + W: TWorkBuf; +const +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} + K: array[0..63] of longint = ( + $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5, + $3956c25b, $59f111f1, $923f82a4, $ab1c5ed5, + $d807aa98, $12835b01, $243185be, $550c7dc3, + $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174, + $e49b69c1, $efbe4786, $0fc19dc6, $240ca1cc, + $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da, + $983e5152, $a831c66d, $b00327c8, $bf597fc7, + $c6e00bf3, $d5a79147, $06ca6351, $14292967, + $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13, + $650a7354, $766a0abb, $81c2c92e, $92722c85, + $a2bfe8a1, $a81a664b, $c24b8b70, $c76c51a3, + $d192e819, $d6990624, $f40e3585, $106aa070, + $19a4c116, $1e376c08, $2748774c, $34b0bcb5, + $391c0cb3, $4ed8aa4a, $5b9cca4f, $682e6ff3, + $748f82ee, $78a5636f, $84c87814, $8cc70208, + $90befffa, $a4506ceb, $bef9a3f7, $c67178f2 + ); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + + {-Calculate "expanded message blocks"} + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i] := RB(THashBuf32(Data.Buffer)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 63 do begin + {A=Sig1(W[i-2]), B=Sig0(W[i-15])} + A := W[i-2]; A := ((A shr 17) or (A shl 15)) xor ((A shr 19) or (A shl 13)) xor (A shr 10); + B := W[i-15]; B := ((B shr 7) or (B shl 25)) xor ((B shr 18) or (B shl 14)) xor (B shr 3); + W[i]:= A + W[i-7] + B + W[i-16]; + end; + + {Assign old working hasg to variables A..H} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + F := Data.Hash[5]; + G := Data.Hash[6]; + H := Data.Hash[7]; + + {SHA256 compression function} + {partially unrolled loop} + i := 0; + repeat + T := H + (((E shr 6) or (E shl 26)) xor ((E shr 11) or (E shl 21)) xor ((E shr 25) or (E shl 7))) + + (((F xor G) and E) xor G) + W[i ] + K[i ]; + H := T + (((A shr 2) or (A shl 30)) xor ((A shr 13) or (A shl 19)) xor ((A shr 22) or (A shl 10))) + + (((A or B) and C) or (A and B)); + inc(D,T); + T := G + (((D shr 6) or (D shl 26)) xor ((D shr 11) or (D shl 21)) xor ((D shr 25) or (D shl 7))) + + (((E xor F) and D) xor F) + W[i+1] + K[i+1]; + G := T + (((H shr 2) or (H shl 30)) xor ((H shr 13) or (H shl 19)) xor ((H shr 22) or (H shl 10))) + + (((H or A) and B) or (H and A)); + inc(C,T); + T := F + (((C shr 6) or (C shl 26)) xor ((C shr 11) or (C shl 21)) xor ((C shr 25) or (C shl 7))) + + (((D xor E) and C) xor E) + W[i+2] + K[i+2]; + F := T + (((G shr 2) or (G shl 30)) xor ((G shr 13) or (G shl 19)) xor ((G shr 22) or (G shl 10))) + + (((G or H) and A) or (G and H)); + inc(B,T); + T := E + (((B shr 6) or (B shl 26)) xor ((B shr 11) or (B shl 21)) xor ((B shr 25) or (B shl 7))) + + (((C xor D) and B) xor D) + W[i+3] + K[i+3]; + E := T + (((F shr 2) or (F shl 30)) xor ((F shr 13) or (F shl 19)) xor ((F shr 22) or (F shl 10))) + + (((F or G) and H) or (F and G)); + inc(A,T); + T := D + (((A shr 6) or (A shl 26)) xor ((A shr 11) or (A shl 21)) xor ((A shr 25) or (A shl 7))) + + (((B xor C) and A) xor C) + W[i+4] + K[i+4]; + D := T + (((E shr 2) or (E shl 30)) xor ((E shr 13) or (E shl 19)) xor ((E shr 22) or (E shl 10))) + + (((E or F) and G) or (E and F)); + inc(H,T); + T := C + (((H shr 6) or (H shl 26)) xor ((H shr 11) or (H shl 21)) xor ((H shr 25) or (H shl 7))) + + (((A xor B) and H) xor B) + W[i+5] + K[i+5]; + C := T + (((D shr 2) or (D shl 30)) xor ((D shr 13) or (D shl 19)) xor ((D shr 22) or (D shl 10))) + + (((D or E) and F) or (D and E)); + inc(G,T); + T := B + (((G shr 6) or (G shl 26)) xor ((G shr 11) or (G shl 21)) xor ((G shr 25) or (G shl 7))) + + (((H xor A) and G) xor A) + W[i+6] + K[i+6]; + B := T + (((C shr 2) or (C shl 30)) xor ((C shr 13) or (C shl 19)) xor ((C shr 22) or (C shl 10))) + + (((C or D) and E) or (C and D)); + inc(F,T); + T := A + (((F shr 6) or (F shl 26)) xor ((F shr 11) or (F shl 21)) xor ((F shr 25) or (F shl 7))) + + (((G xor H) and F) xor H) + W[i+7] + K[i+7]; + A := T + (((B shr 2) or (B shl 30)) xor ((B shr 13) or (B shl 19)) xor ((B shr 22) or (B shl 10))) + + (((B or C) and D) or (B and C)); + inc(E,T); + inc(i,8) + until i>63; + + {Calculate new working hash} + inc(Data.Hash[0],A); + inc(Data.Hash[1],B); + inc(Data.Hash[2],C); + inc(Data.Hash[3],D); + inc(Data.Hash[4],E); + inc(Data.Hash[5],F); + inc(Data.Hash[6],G); + inc(Data.Hash[7],H); +end; + +{$else} + +{---------------------------------------------------------------------------} +procedure SHA256Compress(var Data: TKzHashContext); + {-Actual hashing function} +var + i: integer; +{$ifdef UNROLL} + T, +{$else} + T1,T2: longint; +{$endif} + A, B, C, D, E, F, G, H: longint; + W: TWorkBuf; +const +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} + K: array[0..63] of longint = ( + $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5, + $3956c25b, $59f111f1, $923f82a4, $ab1c5ed5, + $d807aa98, $12835b01, $243185be, $550c7dc3, + $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174, + $e49b69c1, $efbe4786, $0fc19dc6, $240ca1cc, + $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da, + $983e5152, $a831c66d, $b00327c8, $bf597fc7, + $c6e00bf3, $d5a79147, $06ca6351, $14292967, + $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13, + $650a7354, $766a0abb, $81c2c92e, $92722c85, + $a2bfe8a1, $a81a664b, $c24b8b70, $c76c51a3, + $d192e819, $d6990624, $f40e3585, $106aa070, + $19a4c116, $1e376c08, $2748774c, $34b0bcb5, + $391c0cb3, $4ed8aa4a, $5b9cca4f, $682e6ff3, + $748f82ee, $78a5636f, $84c87814, $8cc70208, + $90befffa, $a4506ceb, $bef9a3f7, $c67178f2 + ); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + {-Calculate "expanded message blocks"} + {$ifdef USE_ExpandMessageBlocks} + {Use BASM-Code} + ExpandMessageBlocks(W, THashBuf32(Data.Buffer)); + {$else} + {Avoid proc call overhead for TP5/5.5} + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i]:= RB(THashBuf32(Data.Buffer)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 63 do W[i]:= Sig1(W[i-2]) + W[i-7] + Sig0(W[i-15]) + W[i-16]; + {$endif} + + {Assign old working hasg to variables A..H} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + F := Data.Hash[5]; + G := Data.Hash[6]; + H := Data.Hash[7]; + + {SHA256 compression function} + +{$ifdef UNROLL} + + {partially unrolled loop} + i := 0; + repeat + T := H + Sum1(E) + (((F xor G) and E) xor G) + W[i ] + K[i ]; + H := T + Sum0(A) + (((A or B) and C) or (A and B)); + inc(D,T); + T := G + Sum1(D) + (((E xor F) and D) xor F) + W[i+1] + K[i+1]; + G := T + Sum0(H) + (((H or A) and B) or (H and A)); + inc(C,T); + T := F + Sum1(C) + (((D xor E) and C) xor E) + W[i+2] + K[i+2]; + F := T + Sum0(G) + (((G or H) and A) or (G and H)); + inc(B,T); + T := E + Sum1(B) + (((C xor D) and B) xor D) + W[i+3] + K[i+3]; + E := T + Sum0(F) + (((F or G) and H) or (F and G)); + inc(A,T); + T := D + Sum1(A) + (((B xor C) and A) xor C) + W[i+4] + K[i+4]; + D := T + Sum0(E) + (((E or F) and G) or (E and F)); + inc(H,T); + T := C + Sum1(H) + (((A xor B) and H) xor B) + W[i+5] + K[i+5]; + C := T + Sum0(D) + (((D or E) and F) or (D and E)); + inc(G,T); + T := B + Sum1(G) + (((H xor A) and G) xor A) + W[i+6] + K[i+6]; + B := T + Sum0(C) + (((C or D) and E) or (C and D)); + inc(F,T); + T := A + Sum1(F) + (((G xor H) and F) xor H) + W[i+7] + K[i+7]; + A := T + Sum0(B) + (((B or C) and D) or (B and C)); + inc(E,T); + inc(i,8) + until i>63; + +{$else} + for i:=0 to 63 do begin + T1:= H + Sum1(E) + (((F xor G) and E) xor G) + K[i] + W[i]; + T2:= Sum0(A) + (((A or B) and C) or (A and B)); + H := G; + G := F; + F := E; + E := D + T1; + D := C; + C := B; + B := A; + A := T1 + T2; + end; +{$endif} + + {Calculate new working hash} + inc(Data.Hash[0],A); + inc(Data.Hash[1],B); + inc(Data.Hash[2],C); + inc(Data.Hash[3],D); + inc(Data.Hash[4],E); + inc(Data.Hash[5],F); + inc(Data.Hash[6],G); + inc(Data.Hash[7],H); +end; + +{$endif} + +{---------------------------------------------------------------------------} +procedure SHA256Init(var Context: TKzHashContext); + {-initialize context} +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} +const + SIV: array[0..7] of longint = ($6a09e667, $bb67ae85, $3c6ef372, $a54ff53a, $510e527f, $9b05688c, $1f83d9ab, $5be0cd19); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + {Clear context, buffer=0!!} + fillchar(Context,sizeof(Context),0); + move(SIV,Context.Hash,sizeof(SIV)); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256UpdateXL(var Context: TKzHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} +var + i: integer; +begin + {Update message bit length} + if Len<=$1FFFFFFF then UpdateLen(Context.MLen[1], Context.MLen[0], Len shl 3) + else begin + for i:=1 to 8 do UpdateLen(Context.MLen[1], Context.MLen[0], Len) + end; + while Len > 0 do begin + {fill block with msg data} + Context.Buffer[Context.Index]:= pByte(Msg)^; + inc(Ptr2Inc(Msg)); + inc(Context.Index); + dec(Len); + if Context.Index=SHA256_BlockLen then begin + {If 512 bit transferred, compress a block} + Context.Index:= 0; + SHA256Compress(Context); + while Len>=SHA256_BlockLen do begin + move(Msg^,Context.Buffer,SHA256_BlockLen); + SHA256Compress(Context); + inc(Ptr2Inc(Msg),SHA256_BlockLen); + dec(Len,SHA256_BlockLen); + end; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Update(var Context: TKzHashContext; Msg: pointer; Len: longint {word}); // word 형식을 longint으로 변경 18_0621 14:02:57 sunk + {-update context with Msg data} +begin + SHA256UpdateXL(Context, Msg, Len); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalBitsEx(var Context: TKzHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} +var + i: integer; +begin + {Message padding} + {append bits from BData and a single '1' bit} + if (bitlen>0) and (bitlen<=7) then begin + Context.Buffer[Context.Index]:= (BData and BitAPI_Mask[bitlen]) or BitAPI_PBit[bitlen]; + UpdateLen(Context.MLen[1], Context.MLen[0], bitlen); + end + else Context.Buffer[Context.Index]:= $80; + for i:=Context.Index+1 to 63 do Context.Buffer[i] := 0; + {2. Compress if more than 448 bits, (no room for 64 bit length} + if Context.Index>= 56 then begin + SHA256Compress(Context); + fillchar(Context.Buffer,56,0); + end; + {Write 64 bit msg length into the last bits of the last block} + {(in big endian format) and do a final compress} + THashBuf32(Context.Buffer)[14]:= RB(Context.MLen[1]); + THashBuf32(Context.Buffer)[15]:= RB(Context.MLen[0]); + SHA256Compress(Context); + {Hash -> Digest to little endian format} + for i:=0 to 7 do THashDig32(Digest)[i]:= RB(Context.Hash[i]); + {Clear context} + fillchar(Context,sizeof(Context),0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalBits(var Context: TKzHashContext; var Digest: TSHA256Digest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} +var + tmp: THashDigest; +begin + SHA256FinalBitsEx(Context, tmp, BData, bitlen); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalEx(var Context: TKzHashContext; var Digest: THashDigest); + {-finalize SHA256 calculation, clear context} +begin + SHA256FinalBitsEx(Context,Digest,0,0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Final(var Context: TKzHashContext; var Digest: TSHA256Digest); + {-finalize SHA256 calculation, clear context} +var + tmp: THashDigest; +begin + SHA256FinalBitsEx(Context, tmp, 0, 0); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +function SHA256SelfTest: boolean; + {-self test for string from SHA256 document} +const + s1: string[ 3] = 'abc'; + s2: string[56] = 'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'; + D1: TSHA256Digest = ($ba,$78,$16,$bf,$8f,$01,$cf,$ea,$41,$41,$40,$de,$5d,$ae,$22,$23, + $b0,$03,$61,$a3,$96,$17,$7a,$9c,$b4,$10,$ff,$61,$f2,$00,$15,$ad); + D2: TSHA256Digest = ($24,$8d,$6a,$61,$d2,$06,$38,$b8,$e5,$c0,$26,$93,$0c,$3e,$60,$39, + $a3,$3c,$e4,$59,$64,$ff,$21,$67,$f6,$ec,$ed,$d4,$19,$db,$06,$c1); + D3: TSHA256Digest = ($bd,$4f,$9e,$98,$be,$b6,$8c,$6e,$ad,$32,$43,$b1,$b4,$c7,$fe,$d7, + $5f,$a4,$fe,$aa,$b1,$f8,$47,$95,$cb,$d8,$a9,$86,$76,$a2,$a3,$75); + D4: TSHA256Digest = ($f1,$54,$1d,$eb,$68,$d1,$34,$eb,$a9,$9f,$82,$cf,$d8,$7e,$2a,$b3, + $1d,$33,$af,$4b,$6d,$e0,$08,$6a,$9b,$ed,$15,$c2,$ec,$69,$cc,$cb); +var + Context: TKzHashContext; + Digest : TSHA256Digest; + + function SingleTest(s: Str127; TDig: TSHA256Digest): boolean; + {-do a single test, const not allowed for VER<7} + { Two sub tests: 1. whole string, 2. one update per char} + var + i: integer; + begin + SingleTest := false; + {1. Hash complete string} + SHA256Full(Digest, @s[1],length(s)); + {Compare with known value} + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + {2. one update call for all chars} + SHA256Init(Context); + for i:=1 to length(s) do SHA256Update(Context,@s[i],1); + SHA256Final(Context,Digest); + {Compare with known value} + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + SingleTest := true; + end; + +begin + SHA256SelfTest := false; + {1 Zero bit from NESSIE test vectors} + SHA256Init(Context); + SHA256FinalBits(Context,Digest,0,1); + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@D3)) then exit; + {4 hightest bits of $50, D4 calculated with program shatest from RFC 4634} + SHA256Init(Context); + SHA256FinalBits(Context,Digest,$50,4); + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@D4)) then exit; + {strings from SHA256 document} + SHA256SelfTest := SingleTest(s1, D1) and SingleTest(s2, D2) +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FullXL(var Digest: TSHA256Digest; Msg: pointer; Len: longint); + {-SHA256 of Msg with init/update/final} +var + Context: TKzHashContext; +begin + SHA256Init(Context); + SHA256UpdateXL(Context, Msg, Len); + SHA256Final(Context, Digest); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Full(var Digest: TSHA256Digest; Msg: pointer; Len: word); + {-SHA256 of Msg with init/update/final} +begin + SHA256FullXL(Digest, Msg, Len); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA256Digest; var buf; bsize: word; var Err: word); + {-SHA256 of file, buf: buffer with at least bsize bytes} +var + tmp: THashDigest; +begin + HashFile(fname, @SHA256_Desc, tmp, buf, bsize, Err); + move(tmp,Digest,sizeof(Digest)); +end; + + +begin + {$ifdef VER5X} + fillchar(SHA256_Desc, sizeof(SHA256_Desc), 0); + with SHA256_Desc do begin + HSig := C_HashSig; + HDSize := sizeof(THashDesc); + HDVersion := C_HashVers; + HBlockLen := SHA256_BlockLen; + HDigestlen:= sizeof(TSHA256Digest); + HInit := SHA256Init; + HFinal := SHA256FinalEx; + HUpdateXL := SHA256UpdateXL; + HAlgNum := longint(_SHA256); + HName := 'SHA256'; + HPtrOID := @SHA256_OID; + HLenOID := 9; + HFinalBit := SHA256FinalBitsEx; + end; + {$endif} + RegisterHash(_SHA256, @SHA256_Desc); +end. diff --git a/Tocsg.Lib/VCL/EncLib/_EM.Tocsg.Sha1.pas b/Tocsg.Lib/VCL/EncLib/_EM.Tocsg.Sha1.pas new file mode 100644 index 00000000..68326616 --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/_EM.Tocsg.Sha1.pas @@ -0,0 +1,1060 @@ +unit EM.Tocsg.SHA1; + +// crc_hash_2018-01-01.zip 에서 sha256.pas 파일을 가져온 것이고, +// 필요한 정의는 동일 경로에 있는btypes.pas, hash.pas에서 가져왔다. 22_0419 08:30:23 kku + +{SHA1 - 160 bit Secure Hash Function} + + +interface + +(************************************************************************* + + DESCRIPTION : SHA1 - 160 bit Secure Hash Function + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17-D18/D25S, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : - Latest specification of Secure Hash Standard: + http://csrc.nist.gov/publications/fips/fips180-4/fips-180-4.pdf + - Test vectors and intermediate values: + http://csrc.nist.gov/groups/ST/toolkit/documents/Examples/SHA_All.pdf + + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 1.00 03.01.02 W.Ehrhardt BP7 implementation + 1.01 14.03.02 we D1-D6, FPC, VP + 1.02 14.03.02 we TP6 + 1.03 14.03.02 we TP6/7 386-Code + 1.04 14.03.02 we TP5.5 + 1.10 15.03.02 we self test with 2 strings + 1.11 02.01.03 we const SFA with @ for FPC 1.0.6 + 1.20 23.07.03 we With SHA1File, SHA1Full + 1.21 26.07.03 we With SHA1Full in self test + 2.00 26.07.03 we common vers., longint for word32, D4+ - warnings + 2.01 03.08.03 we type TSHA1Block for HMAC + 2.02 23.08.03 we SHA1Compress in interface for prng + 2.10 29.08.03 we XL versions for Win32 + 2.20 27.09.03 we FPC/go32v2 + 2.30 05.10.03 we STD.INC, TP5.0 + 2.40 10.10.03 we common version, english comments + 2.45 11.10.03 we Speedup: partial unroll, no function calls + 2.50 16.11.03 we Speedup in update, don't clear W in compress + 2.51 17.11.03 we BIT16: partial unroll, BIT32: inline rot + 2.52 17.11.03 we ExpandMessageBlocks + 2.53 18.11.03 we LRot32, RB mit inline() + 2.54 20.11.03 we Full range UpdateLen + 2.55 30.11.03 we BIT16: {$F-} + 2.56 30.11.03 we BIT16: LRot_5, LRot_30 + 3.00 01.12.03 we Common version 3.0 + 3.01 22.12.03 we BIT16: Two INCs + 3.02 22.12.03 we BASM16: asm Lrot30 + 3.03 22.12.03 we TP5/5.5: LRot, RA inline + 3.04 22,12.03 we Changed UpdateLen: Definition and TP5/5.5 inline + 3.05 05.03.04 we Update fips180-2 URL + 3.06 26.02.05 we With {$ifdef StrictLong} + 3.07 05.05.05 we Use longint() in SH1Init to avoid D9 errors if $R+ + 3.08 17.12.05 we Force $I- in SHA1File + 3.09 08.01.06 we SHA1Compress removed from interface + 3.10 15.01.06 we uses Hash unit and THashDesc + 3.11 18.01.06 we Descriptor fields HAlgNum, HSig + 3.12 22.01.06 we Removed HSelfTest from descriptor + 3.13 11.02.06 we Descriptor as typed const + 3.14 26.03.06 we Round constants K1..K4, code reordering + 3.15 07.08.06 we $ifdef BIT32: (const fname: shortstring...) + 3.16 22.02.07 we values for OID vector + 3.17 30.06.07 we Use conditional define FPC_ProcVar + 3.18 04.10.07 we FPC: {$asmmode intel} + 3.19 02.05.08 we Bit-API: SHA1FinalBits/Ex + 3.20 05.05.08 we THashDesc constant with HFinalBit field + 3.21 12.11.08 we uses BTypes, Ptr2Inc and/or Str255/Str127 + 3.22 12.03.10 we Fix VP feature in ExpandMessageBlocks + 3.23 11.03.12 we Updated references + 3.24 26.12.12 we D17 and PurePascal + 3.25 16.08.15 we Removed $ifdef DLL / stdcall + 3.26 15.05.17 we adjust OID to new MaxOIDLen + 3.27 29.11.17 we SHA1File - fname: string + +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2017 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{NOTE: FIPS Ch and May functions can be optimized. Wei Dai (Crypto++ 3.1) +credits Rich Schroeppel (rcs@cs.arizona.edu), V 5.1 does not!?} + + +{$i STD.INC} + +{$ifdef BIT64} + {$ifndef PurePascal} + {$define PurePascal} + {$endif} +{$endif} + +//uses +// BTypes,Hash; + +const + MaxBlockLen = 128; {Max. block length (buffer size), multiple of 4} + MaxDigestLen = 64; {Max. length of hash digest} + MaxStateLen = 16; {Max. size of internal state} + MaxOIDLen = 11; {Current max. OID length} + C_HashSig = $3D7A; {Signature for Hash descriptor} + C_HashVers = $00020002; {Version of Hash definitions} + + HASHCTXSIZE = 448; {Common size of enlarged padded old context} + {and new padded SHA3/SHAKE/Keccak context } + + BitAPI_Mask: array[0..7] of byte = ($00,$80,$C0,$E0,$F0,$F8,$FC,$FE); + BitAPI_PBit: array[0..7] of byte = ($80,$40,$20,$10,$08,$04,$02,$01); + +type + Ptr2Inc = pByte; {Type cast to increment untyped pointer} + Str127 = string[127]; + + THashState = packed array[0..MaxStateLen-1] of longint; {Internal state} + THashBuffer = packed array[0..MaxBlockLen-1] of byte; {hash buffer block} + THashDigest = packed array[0..MaxDigestLen-1] of byte; {hash digest} + PHashDigest = ^THashDigest; {pointer to hash digest} + THashBuf32 = packed array[0..MaxBlockLen div 4 -1] of longint; {type cast helper} + THashDig32 = packed array[0..MaxDigestLen div 4 -1] of longint; {type cast helper} + TSHA1Digest = packed array[0..19] of byte; {SHA1 digest } + +// 원래 이름은 TTgHashContext이고, 범용적인 이름을 피하기 위해 변경 18_0621 10:52:19 sunk + TTgHashContext = packed record + Hash : THashState; {Working hash} + MLen : packed array[0..3] of longint; {max 128 bit msg length} + Buffer: THashBuffer; {Block buffer} + Index : longint; {Index in buffer} + Fill2 : packed array[213..HASHCTXSIZE] of byte; + end; + + +procedure SHA1Init(var Context: TTgHashContext); + {-initialize context} + +procedure SHA1Update(var Context: TTgHashContext; Msg: pointer; Len: word); + {-update context with Msg data} + +procedure SHA1UpdateXL(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + +procedure SHA1Final(var Context: TTgHashContext; var Digest: TSHA1Digest); + {-finalize SHA1 calculation, clear context} + +procedure SHA1FinalEx(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize SHA1 calculation, clear context} + +procedure SHA1FinalBitsEx(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA1 calculation with bitlen bits from BData (big-endian), clear context} + +procedure SHA1FinalBits(var Context: TTgHashContext; var Digest: TSHA1Digest; BData: byte; bitlen: integer); + {-finalize SHA1 calculation with bitlen bits from BData (big-endian), clear context} + +function SHA1SelfTest: boolean; + {-self test SHA1: compare with known value} + +procedure SHA1Full(var Digest: TSHA1Digest; Msg: pointer; Len: word); + {-SHA1 of Msg with init/update/final} + +procedure SHA1FullXL(var Digest: TSHA1Digest; Msg: pointer; Len: longint); + {-SHA1 of Msg with init/update/final} + +procedure SHA1File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA1Digest; var buf; bsize: word; var Err: word); + {-SHA1 of file, buf: buffer with at least bsize bytes} + + +implementation + +{$ifdef BIT16} + {$F-} +{$endif} + +const + SHA1_BlockLen = 64; + +const {round constants} + K1 = longint($5A827999); {round 00..19} + K2 = longint($6ED9EBA1); {round 20..39} + K3 = longint($8F1BBCDC); {round 40..59} + K4 = longint($CA62C1D6); {round 60..79} + + +{Internal types} +type + TWorkBuf = array[0..79] of longint; + TOID_Vec = packed array[1..MaxOIDLen] of longint; {OID vector} + POID_Vec = ^TOID_Vec; {ptr to OID vector} + + HashInitProc = procedure(var Context: TTgHashContext); + {-initialize context} + + HashUpdateXLProc = procedure(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + + HashFinalProc = procedure(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize calculation, clear context} + + HashFinalBitProc = procedure(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize calculation with bitlen bits from BData, clear context} + + THashName = string[19]; {Hash algo name type } + + PHashDesc = ^THashDesc; {Ptr to descriptor } + THashDesc = packed record + HSig : word; {Signature=C_HashSig } + HDSize : word; {sizeof(THashDesc) } + HDVersion : longint; {THashDesc Version } + HBlockLen : word; {Blocklength of hash, rate div 8 for SHA3} + HDigestlen: word; {Digestlength of hash} + HInit : HashInitProc; {Init procedure } + HFinal : HashFinalProc; {Final procedure } + HUpdateXL : HashUpdateXLProc; {Update procedure } + HAlgNum : longint; {Algo ID, longint avoids problems with enum size/DLL} + HName : THashName; {Name of hash algo } + HPtrOID : POID_Vec; {Pointer to OID vec } + HLenOID : word; {Length of OID vec } + HFill : word; + HFinalBit : HashFinalBitProc; {Bit-API Final proc } + HReserved : packed array[0..19] of byte; + end; + + THashAlgorithm = (_MD4, _MD5, _RIPEMD160, _SHA1, + _SHA224, _SHA256, _SHA384, _SHA512, + _Whirlpool, _SHA512_224, _SHA512_256, + _SHA3_224, _SHA3_256, _SHA3_384, _SHA3_512, + _Blake2S_224, _Blake2S_256, + _Blake2B_384, _Blake2B_512); {Supported hash algorithms} + +var + PHashVec : array[THashAlgorithm] of PHashDesc; + +{1.3.14.3.2.26} +{iso(1) identified-organization(3) oiw(14) secsig(3) algorithms(2) hashAlgorithmIdentifier(26)} +const + SHA1_OID : TOID_Vec = (1,3,14,3,2,26,-1,-1,-1,-1,-1); {Len=6} + +{$ifndef VER5X} +const + SHA1_Desc: THashDesc = ( + HSig : C_HashSig; + HDSize : sizeof(THashDesc); + HDVersion : C_HashVers; + HBlockLen : SHA1_BlockLen; + HDigestlen: sizeof(TSHA1Digest); + {$ifdef FPC_ProcVar} + HInit : @SHA1Init; + HFinal : @SHA1FinalEx; + HUpdateXL : @SHA1UpdateXL; + {$else} + HInit : SHA1Init; + HFinal : SHA1FinalEx; + HUpdateXL : SHA1UpdateXL; + {$endif} + HAlgNum : longint(_SHA1); + HName : 'SHA1'; + HPtrOID : @SHA1_OID; + HLenOID : 6; + HFill : 0; + {$ifdef FPC_ProcVar} + HFinalBit : @SHA1FinalBitsEx; + {$else} + HFinalBit : SHA1FinalBitsEx; + {$endif} + HReserved : (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0) + ); +{$else} +var + SHA1_Desc: THashDesc; +{$endif} + + + +{$ifndef BIT16} + +{$ifdef PurePascal} + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + var + tmp: int64; + begin + tmp := int64(cardinal(wlo))+Blen; + wlo := longint(tmp and $FFFFFFFF); + inc(whi,longint(tmp shr 32)); + end; + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; + {-reverse byte order in longint} + begin + RB := ((A and $FF) shl 24) or ((A and $FF00) shl 8) or ((A and $FF0000) shr 8) or ((A and longint($FF000000)) shr 24); + end; + + {---------------------------------------------------------------------------} + procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuffer); + {-Calculate "expanded message blocks"} + var + i,T: longint; + begin + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i]:= RB(THashBuf32(Buf)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 79 do begin + T := W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]; + W[i] := (T shl 1) or (T shr 31); + end; + end; + +{$else} + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + begin + asm + mov edx, [wlo] + mov ecx, [whi] + mov eax, [Blen] + add [edx], eax + adc dword ptr [ecx], 0 + end; + end; + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; assembler; + {-reverse byte order in longint} + asm + {$ifdef LoadArgs} + mov eax,[A] + {$endif} + xchg al,ah + rol eax,16 + xchg al,ah + end; + + {---------------------------------------------------------------------------} + procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuffer); assembler; + {-Calculate "expanded message blocks"} + asm + {$ifdef LoadArgs} + mov edx,Buf + mov ecx,W {load W before push ebx to avoid VP crash} + push ebx {if compiling with no ASM stack frames} + mov ebx,ecx + {$else} + push ebx + mov ebx,eax + {$endif} + {part1: W[i]:= RB(TW32Buf(Buf)[i])} + mov ecx,16 + @@1: mov eax,[edx] + xchg al,ah + rol eax,16 + xchg al,ah + mov [ebx],eax + add ebx,4 + add edx,4 + dec ecx + jnz @@1 + {part2: W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]);} + mov ecx,64 + @@2: mov eax,[ebx- 3*4] + xor eax,[ebx- 8*4] + xor eax,[ebx-14*4] + xor eax,[ebx-16*4] + rol eax,1 + mov [ebx],eax + add ebx,4 + dec ecx + jnz @@2 + pop ebx + end; +{$endif} + + +{---------------------------------------------------------------------------} +procedure SHA1Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; + A, B, C, D, E: longint; + W: TWorkBuf; +begin + + ExpandMessageBlocks(W, Data.Buffer); + + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + + {SHA1 compression function} + {Partial unroll for more speed, full unroll is only slightly faster} + {BIT32: rotateleft via inline} + i := 0; + while i<20 do begin + inc(E, (A shl 5 or A shr 27) + (D xor (B and (C xor D))) + W[i ] + K1); B := B shr 2 or B shl 30; + inc(D, (E shl 5 or E shr 27) + (C xor (A and (B xor C))) + W[i+1] + K1); A := A shr 2 or A shl 30; + inc(C, (D shl 5 or D shr 27) + (B xor (E and (A xor B))) + W[i+2] + K1); E := E shr 2 or E shl 30; + inc(B, (C shl 5 or C shr 27) + (A xor (D and (E xor A))) + W[i+3] + K1); D := D shr 2 or D shl 30; + inc(A, (B shl 5 or B shr 27) + (E xor (C and (D xor E))) + W[i+4] + K1); C := C shr 2 or C shl 30; + inc(i,5); + end; + while i<40 do begin + inc(E, (A shl 5 or A shr 27) + (D xor B xor C) + W[i ] + K2); B := B shr 2 or B shl 30; + inc(D, (E shl 5 or E shr 27) + (C xor A xor B) + W[i+1] + K2); A := A shr 2 or A shl 30; + inc(C, (D shl 5 or D shr 27) + (B xor E xor A) + W[i+2] + K2); E := E shr 2 or E shl 30; + inc(B, (C shl 5 or C shr 27) + (A xor D xor E) + W[i+3] + K2); D := D shr 2 or D shl 30; + inc(A, (B shl 5 or B shr 27) + (E xor C xor D) + W[i+4] + K2); C := C shr 2 or C shl 30; + inc(i,5); + end; + while i<60 do begin + inc(E, (A shl 5 or A shr 27) + ((B and C) or (D and (B or C))) + W[i ] + K3); B := B shr 2 or B shl 30; + inc(D, (E shl 5 or E shr 27) + ((A and B) or (C and (A or B))) + W[i+1] + K3); A := A shr 2 or A shl 30; + inc(C, (D shl 5 or D shr 27) + ((E and A) or (B and (E or A))) + W[i+2] + K3); E := E shr 2 or E shl 30; + inc(B, (C shl 5 or C shr 27) + ((D and E) or (A and (D or E))) + W[i+3] + K3); D := D shr 2 or D shl 30; + inc(A, (B shl 5 or B shr 27) + ((C and D) or (E and (C or D))) + W[i+4] + K3); C := C shr 2 or C shl 30; + inc(i,5); + end; + while i<80 do begin + inc(E, (A shl 5 or A shr 27) + (D xor B xor C) + W[i ] + K4); B := B shr 2 or B shl 30; + inc(D, (E shl 5 or E shr 27) + (C xor A xor B) + W[i+1] + K4); A := A shr 2 or A shl 30; + inc(C, (D shl 5 or D shr 27) + (B xor E xor A) + W[i+2] + K4); E := E shr 2 or E shl 30; + inc(B, (C shl 5 or C shr 27) + (A xor D xor E) + W[i+3] + K4); D := D shr 2 or D shl 30; + inc(A, (B shl 5 or B shr 27) + (E xor C xor D) + W[i+4] + K4); C := C shr 2 or C shl 30; + inc(i,5); + end; + + {Calculate new working hash} + inc(Data.Hash[0], A); + inc(Data.Hash[1], B); + inc(Data.Hash[2], C); + inc(Data.Hash[3], D); + inc(Data.Hash[4], E); +end; + + + +{$else} + + +{$ifdef BASM16} + +{TP6-7/Delphi1 for 386+} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); assembler; + {-Add BLen to 64 bit value (wlo, whi)} +asm + les di,[wlo] + db $66; mov ax,word ptr [BLen] + db $66; sub dx,dx + db $66; add es:[di],ax + les di,[whi] + db $66; adc es:[di],dx +end; + + +{---------------------------------------------------------------------------} +function LRot_5(x: longint): longint; + {-Rotate left 5} +inline( + $66/$58/ {pop eax } + $66/$C1/$C0/$05/ {rol eax,5 } + $66/$8B/$D0/ {mov edx,eax} + $66/$C1/$EA/$10); {shr edx,16 } + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; + {-reverse byte order in longint} +inline( + $58/ {pop ax } + $5A/ {pop dx } + $86/$C6/ {xchg dh,al } + $86/$E2); {xchg dl,ah } + + +{---------------------------------------------------------------------------} +procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuffer); assembler; + {-Calculate "expanded message blocks"} +asm + push ds + {part 1: W[i]:= RB(TW32Buf(Buf)[i])} + les di,[Buf] + lds si,[W] + mov cx,16 +@@1: db $66; mov ax,es:[di] + xchg al,ah + db $66; rol ax,16 + xchg al,ah + db $66; mov [si],ax + add si,4 + add di,4 + dec cx + jnz @@1 + {part 2: W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]);} + mov cx,64 +@@2: db $66; mov ax,[si- 3*4] + db $66; xor ax,[si- 8*4] + db $66; xor ax,[si-14*4] + db $66; xor ax,[si-16*4] + db $66; rol ax,1 + db $66; mov [si],ax + add si,4 + dec cx + jnz @@2 + pop ds +end; + +{---------------------------------------------------------------------------} +procedure SHA1Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; + A, B, C, D, E: longint; + W: TWorkBuf; +begin + ExpandMessageBlocks(W, Data.Buffer); + {Assign old working hash to variables A..E} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + + {SHA1 compression function} + {Partial unroll for more speed, full unroll only marginally faster} + {Two INCs, LRot_30 via BASM} + i := 0; + while i<20 do begin + inc(E,LRot_5(A)); inc(E,(D xor (B and (C xor D))) + W[i ] + K1); asm db $66; rol word[B],30 end; + inc(D,LRot_5(E)); inc(D,(C xor (A and (B xor C))) + W[i+1] + K1); asm db $66; rol word[A],30 end; + inc(C,LRot_5(D)); inc(C,(B xor (E and (A xor B))) + W[i+2] + K1); asm db $66; rol word[E],30 end; + inc(B,LRot_5(C)); inc(B,(A xor (D and (E xor A))) + W[i+3] + K1); asm db $66; rol word[D],30 end; + inc(A,LRot_5(B)); inc(A,(E xor (C and (D xor E))) + W[i+4] + K1); asm db $66; rol word[C],30 end; + inc(i,5); + end; + while i<40 do begin + inc(E,LRot_5(A)); inc(E,(B xor C xor D) + W[i ] + K2); asm db $66; rol word[B],30 end; + inc(D,LRot_5(E)); inc(D,(A xor B xor C) + W[i+1] + K2); asm db $66; rol word[A],30 end; + inc(C,LRot_5(D)); inc(C,(E xor A xor B) + W[i+2] + K2); asm db $66; rol word[E],30 end; + inc(B,LRot_5(C)); inc(B,(D xor E xor A) + W[i+3] + K2); asm db $66; rol word[D],30 end; + inc(A,LRot_5(B)); inc(A,(C xor D xor E) + W[i+4] + K2); asm db $66; rol word[C],30 end; + inc(i,5); + end; + while i<60 do begin + inc(E,LRot_5(A)); inc(E,((B and C) or (D and (B or C))) + W[i ] + K3); asm db $66; rol word[B],30 end; + inc(D,LRot_5(E)); inc(D,((A and B) or (C and (A or B))) + W[i+1] + K3); asm db $66; rol word[A],30 end; + inc(C,LRot_5(D)); inc(C,((E and A) or (B and (E or A))) + W[i+2] + K3); asm db $66; rol word[E],30 end; + inc(B,LRot_5(C)); inc(B,((D and E) or (A and (D or E))) + W[i+3] + K3); asm db $66; rol word[D],30 end; + inc(A,LRot_5(B)); inc(A,((C and D) or (E and (C or D))) + W[i+4] + K3); asm db $66; rol word[C],30 end; + inc(i,5); + end; + while i<80 do begin + inc(E,LRot_5(A)); inc(E,(B xor C xor D) + W[i ] + K4); asm db $66; rol word[B],30 end; + inc(D,LRot_5(E)); inc(D,(A xor B xor C) + W[i+1] + K4); asm db $66; rol word[A],30 end; + inc(C,LRot_5(D)); inc(C,(E xor A xor B) + W[i+2] + K4); asm db $66; rol word[E],30 end; + inc(B,LRot_5(C)); inc(B,(D xor E xor A) + W[i+3] + K4); asm db $66; rol word[D],30 end; + inc(A,LRot_5(B)); inc(A,(C xor D xor E) + W[i+4] + K4); asm db $66; rol word[C],30 end; + inc(i,5); + end; + + {Calculate new working hash} + inc(Data.Hash[0], A); + inc(Data.Hash[1], B); + inc(Data.Hash[2], C); + inc(Data.Hash[3], D); + inc(Data.Hash[4], E); + +end; + + +{$else} + +{TP5/5.5} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} +inline( + $58/ {pop ax } + $5A/ {pop dx } + $5B/ {pop bx } + $07/ {pop es } + $26/$01/$07/ {add es:[bx],ax } + $26/$11/$57/$02/ {adc es:[bx+02],dx} + $5B/ {pop bx } + $07/ {pop es } + $26/$83/$17/$00/ {adc es:[bx],0 } + $26/$83/$57/$02/$00);{adc es:[bx+02],0 } + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; + {-reverse byte order in longint} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $86/$C6/ { xchg dh,al} + $86/$E2); { xchg dl,ah} + + +{---------------------------------------------------------------------------} +function LRot_1(x: longint): longint; + {-Rotate left 1} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $2B/$C9/ { sub cx,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1); { adc ax,cx} + + +{---------------------------------------------------------------------------} +function LRot_5(x: longint): longint; + {-Rotate left 5} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $2B/$C9/ { sub cx,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1/ { adc ax,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1/ { adc ax,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1/ { adc ax,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1/ { adc ax,cx} + $D1/$D0/ { rcl ax,1 } + $D1/$D2/ { rcl dx,1 } + $13/$C1); { adc ax,cx} + + +{---------------------------------------------------------------------------} +function LRot_30(x: longint): longint; + {-Rotate left 30 = rot right 2} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $8B/$CA/ { mov cx,dx} + $D1/$E9/ { shr cx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA/ { rcr dx,1 } + $8B/$CA/ { mov cx,dx} + $D1/$E9/ { shr cx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA); { rcr dx,1 } + + +{---------------------------------------------------------------------------} +procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuffer); + {-Calculate "expanded message blocks"} +var + i: integer; +begin + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i]:= RB(THashBuf32(Buf)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 79 do W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; + A, B, C, D, E: longint; + W: TWorkBuf; +begin + ExpandMessageBlocks(W, Data.Buffer); + + {Assign old working hash to variables A..E} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + + {SHA1 compression function} + {Partial unroll for more speed, full unroll only marginally faster} + {BIT16: rotateleft via function call} + i := 0; + while i<20 do begin + inc(E,LRot_5(A) + (D xor (B and (C xor D))) + W[i ] + K1); B := LRot_30(B); + inc(D,LRot_5(E) + (C xor (A and (B xor C))) + W[i+1] + K1); A := LRot_30(A); + inc(C,LRot_5(D) + (B xor (E and (A xor B))) + W[i+2] + K1); E := LRot_30(E); + inc(B,LRot_5(C) + (A xor (D and (E xor A))) + W[i+3] + K1); D := LRot_30(D); + inc(A,LRot_5(B) + (E xor (C and (D xor E))) + W[i+4] + K1); C := LRot_30(C); + inc(i,5); + end; + while i<40 do begin + inc(E,LRot_5(A) + (B xor C xor D) + W[i ] + K2); B := LRot_30(B); + inc(D,LRot_5(E) + (A xor B xor C) + W[i+1] + K2); A := LRot_30(A); + inc(C,LRot_5(D) + (E xor A xor B) + W[i+2] + K2); E := LRot_30(E); + inc(B,LRot_5(C) + (D xor E xor A) + W[i+3] + K2); D := LRot_30(D); + inc(A,LRot_5(B) + (C xor D xor E) + W[i+4] + K2); C := LRot_30(C); + inc(i,5); + end; + while i<60 do begin + inc(E,LRot_5(A) + ((B and C) or (D and (B or C))) + W[i ] + K3); B := LRot_30(B); + inc(D,LRot_5(E) + ((A and B) or (C and (A or B))) + W[i+1] + K3); A := LRot_30(A); + inc(C,LRot_5(D) + ((E and A) or (B and (E or A))) + W[i+2] + K3); E := LRot_30(E); + inc(B,LRot_5(C) + ((D and E) or (A and (D or E))) + W[i+3] + K3); D := LRot_30(D); + inc(A,LRot_5(B) + ((C and D) or (E and (C or D))) + W[i+4] + K3); C := LRot_30(C); + inc(i,5); + end; + while i<80 do begin + inc(E,LRot_5(A) + (B xor C xor D) + W[i ] + K4); B := LRot_30(B); + inc(D,LRot_5(E) + (A xor B xor C) + W[i+1] + K4); A := LRot_30(A); + inc(C,LRot_5(D) + (E xor A xor B) + W[i+2] + K4); E := LRot_30(E); + inc(B,LRot_5(C) + (D xor E xor A) + W[i+3] + K4); D := LRot_30(D); + inc(A,LRot_5(B) + (C xor D xor E) + W[i+4] + K4); C := LRot_30(C); + inc(i,5); + end; + + {Calculate new working hash} + inc(Data.Hash[0], A); + inc(Data.Hash[1], B); + inc(Data.Hash[2], C); + inc(Data.Hash[3], D); + inc(Data.Hash[4], E); + +end; + +{$endif BASM16} + +{$endif BIT16} + + + +{---------------------------------------------------------------------------} +procedure SHA1Init(var Context: TTgHashContext); + {-initialize context} +begin + {Clear context, buffer=0!!} + fillchar(Context,sizeof(Context),0); + with Context do begin + Hash[0] := longint($67452301); + Hash[1] := longint($EFCDAB89); + Hash[2] := longint($98BADCFE); + Hash[3] := longint($10325476); + Hash[4] := longint($C3D2E1F0); + end; +end; + + +{---------------------------------------------------------------------------} +procedure SHA1UpdateXL(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} +var + i: integer; +begin + {Update message bit length} + if Len<=$1FFFFFFF then UpdateLen(Context.MLen[1], Context.MLen[0], Len shl 3) + else begin + for i:=1 to 8 do UpdateLen(Context.MLen[1], Context.MLen[0], Len) + end; + while Len > 0 do begin + {fill block with msg data} + Context.Buffer[Context.Index]:= pByte(Msg)^; + inc(Ptr2Inc(Msg)); + inc(Context.Index); + dec(Len); + if Context.Index=SHA1_BlockLen then begin + {If 512 bit transferred, compress a block} + Context.Index:= 0; + SHA1Compress(Context); + while Len>=SHA1_BlockLen do begin + move(Msg^,Context.Buffer,SHA1_BlockLen); + SHA1Compress(Context); + inc(Ptr2Inc(Msg),SHA1_BlockLen); + dec(Len,SHA1_BlockLen); + end; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure SHA1Update(var Context: TTgHashContext; Msg: pointer; Len: word); + {-update context with Msg data} +begin + SHA1UpdateXL(Context, Msg, Len); +end; + + + +{---------------------------------------------------------------------------} +procedure SHA1FinalBitsEx(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA1 calculation with bitlen bits from BData (big-endian), clear context} +var + i: integer; +begin + {Message padding} + {append bits from BData and a single '1' bit} + if (bitlen>0) and (bitlen<=7) then begin + Context.Buffer[Context.Index]:= (BData and BitAPI_Mask[bitlen]) or BitAPI_PBit[bitlen]; + UpdateLen(Context.MLen[1], Context.MLen[0], bitlen); + end + else Context.Buffer[Context.Index]:= $80; + + for i:=Context.Index+1 to 63 do Context.Buffer[i] := 0; + {2. Compress if more than 448 bits, (no room for 64 bit length} + if Context.Index>= 56 then begin + SHA1Compress(Context); + fillchar(Context.Buffer,56,0); + end; + {Write 64 bit msg length into the last bits of the last block} + {(in big endian format) and do a final compress} + THashBuf32(Context.Buffer)[14] := RB(Context.MLen[1]); + THashBuf32(Context.Buffer)[15] := RB(Context.MLen[0]); + SHA1Compress(Context); + {Hash->Digest to little endian format} + fillchar(Digest, sizeof(Digest), 0); + for i:=0 to 4 do THashDig32(Digest)[i]:= RB(Context.Hash[i]); + {Clear context} + fillchar(Context,sizeof(Context),0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1FinalBits(var Context: TTgHashContext; var Digest: TSHA1Digest; BData: byte; bitlen: integer); + {-finalize SHA1 calculation with bitlen bits from BData (big-endian), clear context} +var + tmp: THashDigest; +begin + SHA1FinalBitsEx(Context, tmp, BData, bitlen); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1FinalEx(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize SHA1 calculation, clear context} +begin + SHA1FinalBitsEx(Context,Digest,0,0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1Final(var Context: TTgHashContext; var Digest: TSHA1Digest); + {-finalize SHA1 calculation, clear context} +var + tmp: THashDigest; +begin + SHA1FinalBitsEx(Context, tmp, 0, 0); + move(tmp, Digest, sizeof(Digest)); +end; + +function HashSameDigest(PHash: PHashDesc; PD1, PD2: PHashDigest): boolean; + {-Return true if same digests, using HDigestlen of PHash} +var + i: integer; +begin + HashSameDigest := false; + if PHash<>nil then with PHash^ do begin + if (HSig=C_HashSig) and (HDigestlen>0) then begin + for i:=0 to pred(HDigestlen) do begin + if PD1^[i]<>PD2^[i] then exit; + end; + HashSameDigest := true; + end; + end; +end; + + +{---------------------------------------------------------------------------} +function SHA1SelfTest: boolean; + {-self test SHA1: compare with known value} +const + s1: string[ 3] = 'abc'; + s2: string[56] = 'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'; + D1: TSHA1Digest= ($a9,$99,$3e,$36,$47,$06,$81,$6a,$ba,$3e,$25,$71,$78,$50,$c2,$6c,$9c,$d0,$d8,$9d); + D2: TSHA1Digest= ($84,$98,$3E,$44,$1C,$3B,$D2,$6E,$BA,$AE,$4A,$A1,$F9,$51,$29,$E5,$E5,$46,$70,$F1); + D3: TSHA1Digest= ($bb,$6b,$3e,$18,$f0,$11,$5b,$57,$92,$52,$41,$67,$6f,$5b,$1a,$e8,$87,$47,$b0,$8a); + D4: TSHA1Digest= ($98,$23,$2a,$15,$34,$53,$14,$9a,$f8,$d5,$2a,$61,$50,$3a,$50,$74,$b8,$59,$70,$e8); +var + Context: TTgHashContext; + Digest : TSHA1Digest; + + function SingleTest(s: Str127; TDig: TSHA1Digest): boolean; + {-do a single test, const not allowed for VER<7} + { Two sub tests: 1. whole string, 2. one update per char} + var + i: integer; + begin + SingleTest := false; + {1. Hash complete string} + SHA1Full(Digest, @s[1],length(s)); + {Compare with known value} + if not HashSameDigest(@SHA1_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + {2. one update call for all chars} + SHA1Init(Context); + for i:=1 to length(s) do SHA1Update(Context,@s[i],1); + SHA1Final(Context,Digest); + {Compare with known value} + if not HashSameDigest(@SHA1_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + SingleTest := true; + end; + +begin + SHA1SelfTest := false; + {1 Zero bit from NESSIE test vectors} + SHA1Init(Context); + SHA1FinalBits(Context,Digest,0,1); + if not HashSameDigest(@SHA1_Desc, PHashDigest(@Digest), PHashDigest(@D3)) then exit; + {4 hightest bits of $50, D4 calculated with program shatest from RFC 4634} + SHA1Init(Context); + SHA1FinalBits(Context,Digest,$50,4); + if not HashSameDigest(@SHA1_Desc, PHashDigest(@Digest), PHashDigest(@D4)) then exit; + {strings from SHA1 document} + SHA1SelfTest := SingleTest(s1, D1) and SingleTest(s2, D2) +end; + + +{---------------------------------------------------------------------------} +procedure SHA1FullXL(var Digest: TSHA1Digest; Msg: pointer; Len: longint); + {-SHA1 of Msg with init/update/final} +var + Context: TTgHashContext; +begin + SHA1Init(Context); + SHA1UpdateXL(Context, Msg, Len); + SHA1Final(Context, Digest); +end; + + +{---------------------------------------------------------------------------} +procedure SHA1Full(var Digest: TSHA1Digest; Msg: pointer; Len: word); + {-SHA1 of Msg with init/update/final} +begin + SHA1FullXL(Digest, Msg, Len); +end; + + +procedure HashFile({$ifdef CONST} const {$endif} fname: string; PHash: PHashDesc; + var Digest: THashDigest; var buf; bsize: word; var Err: word); + {-Calculate hash digest of file, buf: buffer with at least bsize bytes} +var + {$ifdef VirtualPascal} + fms: word; + {$else} + fms: byte; + {$endif} + {$ifndef BIT16} + L: longint; + {$else} + L: word; + {$endif} +var + Context: TTgHashContext; + f: file; +begin + if (PHash=nil) or (Phash^.HSig<>C_HashSig) then begin + Err := 204; {Invalid pointer} + exit; + end; + fms := FileMode; + {$ifdef VirtualPascal} + FileMode := $40; {open_access_ReadOnly or open_share_DenyNone;} + {$else} + FileMode := 0; + {$endif} + system.assign(f,{$ifdef D12Plus} string {$endif} (fname)); + system.reset(f,1); + Err := IOResult; + FileMode := fms; + if Err<>0 then exit; + with PHash^ do begin + HInit(Context); + L := bsize; + while (Err=0) and (L=bsize) do begin + system.blockread(f,buf,bsize,L); + Err := IOResult; + HUpdateXL(Context, @buf, L); + end; + system.close(f); + if IOResult=0 then {}; + HFinal(Context, Digest); + end; +end; + +procedure RegisterHash(AlgId: THashAlgorithm; PHash: PHashDesc); + {-Register algorithm with AlgID and Hash descriptor PHash^} +begin + if (PHash<>nil) and + (PHash^.HAlgNum=longint(AlgId)) and + (PHash^.HSig=C_HashSig) and + (PHash^.HDVersion=C_HashVers) and + (PHash^.HDSize=sizeof(THashDesc)) then PHashVec[AlgId] := PHash; +end; + +{---------------------------------------------------------------------------} +procedure SHA1File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA1Digest; var buf; bsize: word; var Err: word); + {-SHA1 of file, buf: buffer with at least bsize bytes} +var + tmp: THashDigest; +begin + HashFile(fname, @SHA1_Desc, tmp, buf, bsize, Err); + move(tmp, Digest, sizeof(Digest)); +end; + + +begin + {$ifdef VER5X} + fillchar(SHA1_Desc, sizeof(SHA1_Desc), 0); + with SHA1_Desc do begin + HSig := C_HashSig; + HDSize := sizeof(THashDesc); + HDVersion := C_HashVers; + HBlockLen := SHA1_BlockLen; + HDigestlen:= sizeof(TSHA1Digest); + HInit := SHA1Init; + HFinal := SHA1FinalEx; + HUpdateXL := SHA1UpdateXL; + HAlgNum := longint(_SHA1); + HName := 'SHA1'; + HPtrOID := @SHA1_OID; + HLenOID := 6; + HFinalBit := SHA1FinalBitsEx; + end; + {$endif} + RegisterHash(_SHA1, @SHA1_Desc); +end. diff --git a/Tocsg.Lib/VCL/EncLib/_EM.Tocsg.sha256.pas b/Tocsg.Lib/VCL/EncLib/_EM.Tocsg.sha256.pas new file mode 100644 index 00000000..46c485bc --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/_EM.Tocsg.sha256.pas @@ -0,0 +1,1209 @@ +unit EM.Tocsg.sha256; + +// crc_hash_2018-01-01.zip 에서 sha256.pas 파일을 가져온 것이고, +// 필요한 정의는 동일 경로에 있는btypes.pas, hash.pas에서 가져왔다. 18_0621 10:49:56 sunk + +{SHA256 - 256 bit Secure Hash Function} + + +interface + +(************************************************************************* + + DESCRIPTION : SHA256 - 256 bit Secure Hash Function + + REQUIREMENTS : TP5-7, D1-D7/D9-D10/D12/D17-D18/D25S, FPC, VP + + EXTERNAL DATA : --- + + MEMORY USAGE : --- + + DISPLAY MODE : --- + + REFERENCES : - Latest specification of Secure Hash Standard: + http://csrc.nist.gov/publications/fips/fips180-4/fips-180-4.pdf + - Test vectors and intermediate values: + http://csrc.nist.gov/groups/ST/toolkit/documents/Examples/SHA_All.pdf + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 0.1 03.01.02 W.Ehrhardt Reference implementation + 0.2 03.01.02 we BP7 optimization + 0.21 03.01.02 we TP6 changes + 0.3 03.01.02 we Delphi32 optimization + 0.4 03.01.02 we with TW32Buf and assignment via RB in SHA256Compress + 0.5 07.01.02 we Opt. Delphi UpdateLen + 0.6 23.02.02 we Free Pascal compatibility + 0.7 03.03.02 we VirtualPascal compatibility + 0.71 03.03.02 we FPC with ASM (intel) + 0.72 03.03.02 we TP55 compatibility + 0.80 23.07.03 we With SHA256File, SHA256Full + 0.81 26.07.03 we With SHA256Full in self test, D6+ - warnings + 2.00 26.07.03 we common vers., longint for word32, D4+ - warnings + 2.01 04.08.03 we type TSHA256Block for HMAC + 2.10 29.08.03 we XL versions for Win32 + 2.20 27.09.03 we FPC/go32v2 + 2.30 05.10.03 we STD.INC, TP5.0 + 2.40 10.10.03 we common version, english comments + 2.45 11.10.03 we Speedup: Inline for Maj(), Ch() + 2.50 17.11.03 we Speedup in update, don't clear W in compress + 2.51 20.11.03 we Full range UpdateLen + 3.00 01.12.03 we Common version 3.0 + 3.01 22.12.03 we TP5/5.5: RB, FS inline + 3.02 22.12.03 we TP5/5.5: FS -> FS1, FS2 + 3.03 22,12.03 we Changed UpdateLen: Definition and TP5/5.5 inline + 3.04 22.12.03 we TP5/5.5: inline function ISHR + 3.05 22.12.03 we ExpandMessageBlocks/BASM + 3.06 24.12.03 we FIPS notation: S[] -> A..H, partial unroll + 3.07 05.03.04 we Update fips180-2 URL + 3.08 26.02.05 we With {$ifdef StrictLong} + 3.09 05.05.05 we $R- for StrictLong, D9: errors if $R+ even if warnings off + 3.10 17.12.05 we Force $I- in SHA256File + 3.11 15.01.06 we uses Hash unit and THashDesc + 3.12 15.01.06 we BugFix for 16 bit without BASM + 3.13 18.01.06 we Descriptor fields HAlgNum, HSig + 3.14 22.01.06 we Removed HSelfTest from descriptor + 3.15 11.02.06 we Descriptor as typed const + 3.16 07.08.06 we $ifdef BIT32: (const fname: shortstring...) + 3.17 22.02.07 we values for OID vector + 3.18 30.06.07 we Use conditional define FPC_ProcVar + 3.19 04.10.07 we FPC: {$asmmode intel} + 3.20 02.05.08 we Bit-API: SHA256FinalBits/Ex + 3.21 05.05.08 we THashDesc constant with HFinalBit field + 3.22 12.11.08 we Uses BTypes, Ptr2Inc and/or Str255/Str127 + 3.23 11.03.12 we Updated references + 3.24 26.12.12 we D17 and PurePascal + 3.25 16.08.15 we Removed $ifdef DLL / stdcall + 3.26 15.05.17 we adjust OID to new MaxOIDLen + 3.27 29.11.17 we SHA256File - fname: string + +**************************************************************************) + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2017 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{NOTE: FIPS Ch and May functions can be optimized. Wei Dai (Crypto++ 3.1) +credits Rich Schroeppel (rcs@cs.arizona.edu), V 5.1 does not!?} + +{$i STD.INC} + +{$ifdef BIT64} + {$ifndef PurePascal} + {$define PurePascal} + {$endif} +{$endif} + +{$define UNROLL} {Speedup for all but TP5/5.5 and maybe VP} + +{$ifdef VER50} + {$undef UNROLL} {Only VER50, VER55 uses UNROLL} +{$endif} + +{$ifdef VirtualPascal} + {$undef UNROLL} +{$endif} + +//uses +// BTypes,Hash; + +const + MaxBlockLen = 128; {Max. block length (buffer size), multiple of 4} + MaxDigestLen = 64; {Max. length of hash digest} + MaxStateLen = 16; {Max. size of internal state} + MaxOIDLen = 11; {Current max. OID length} + C_HashSig = $3D7A; {Signature for Hash descriptor} + C_HashVers = $00020002; {Version of Hash definitions} + + HASHCTXSIZE = 448; {Common size of enlarged padded old context} + {and new padded SHA3/SHAKE/Keccak context } + + BitAPI_Mask: array[0..7] of byte = ($00,$80,$C0,$E0,$F0,$F8,$FC,$FE); + BitAPI_PBit: array[0..7] of byte = ($80,$40,$20,$10,$08,$04,$02,$01); + +type + Ptr2Inc = pByte; {Type cast to increment untyped pointer} + Str127 = string[127]; + + THashState = packed array[0..MaxStateLen-1] of longint; {Internal state} + THashBuffer = packed array[0..MaxBlockLen-1] of byte; {hash buffer block} + THashDigest = packed array[0..MaxDigestLen-1] of byte; {hash digest} + PHashDigest = ^THashDigest; {pointer to hash digest} + THashBuf32 = packed array[0..MaxBlockLen div 4 -1] of longint; {type cast helper} + THashDig32 = packed array[0..MaxDigestLen div 4 -1] of longint; {type cast helper} + +// 원래 이름은 THashContext이고, 범용적인 이름을 피하기 위해 변경 18_0621 10:52:19 sunk + TTgHashContext = packed record + Hash : THashState; {Working hash} + MLen : packed array[0..3] of longint; {max 128 bit msg length} + Buffer: THashBuffer; {Block buffer} + Index : longint; {Index in buffer} + Fill2 : packed array[213..HASHCTXSIZE] of byte; + end; + + TSHA256Digest = packed array[0..31] of byte; {SHA256 digest } + + TOID_Vec = packed array[1..MaxOIDLen] of longint; {OID vector} + POID_Vec = ^TOID_Vec; {ptr to OID vector} + + HashInitProc = procedure(var Context: TTgHashContext); + {-initialize context} + + HashUpdateXLProc = procedure(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + + HashFinalProc = procedure(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize calculation, clear context} + + HashFinalBitProc = procedure(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize calculation with bitlen bits from BData, clear context} + + THashName = string[19]; {Hash algo name type } + PHashDesc = ^THashDesc; {Ptr to descriptor } + THashDesc = packed record + HSig : word; {Signature=C_HashSig } + HDSize : word; {sizeof(THashDesc) } + HDVersion : longint; {THashDesc Version } + HBlockLen : word; {Blocklength of hash, rate div 8 for SHA3} + HDigestlen: word; {Digestlength of hash} + HInit : HashInitProc; {Init procedure } + HFinal : HashFinalProc; {Final procedure } + HUpdateXL : HashUpdateXLProc; {Update procedure } + HAlgNum : longint; {Algo ID, longint avoids problems with enum size/DLL} + HName : THashName; {Name of hash algo } + HPtrOID : POID_Vec; {Pointer to OID vec } + HLenOID : word; {Length of OID vec } + HFill : word; + HFinalBit : HashFinalBitProc; {Bit-API Final proc } + HReserved : packed array[0..19] of byte; + end; + +procedure SHA256Init(var Context: TTgHashContext); + {-initialize context} + +procedure SHA256Update(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + +procedure SHA256UpdateXL(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} + +procedure SHA256Final(var Context: TTgHashContext; var Digest: TSHA256Digest); + {-finalize SHA256 calculation, clear context} + +procedure SHA256FinalEx(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize SHA256 calculation, clear context} + +procedure SHA256FinalBitsEx(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} + +procedure SHA256FinalBits(var Context: TTgHashContext; var Digest: TSHA256Digest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} + +function SHA256SelfTest: boolean; + {-self test for string from SHA256 document} + +procedure SHA256Full(var Digest: TSHA256Digest; Msg: pointer; Len: word); + {-SHA256 of Msg with init/update/final} + +procedure SHA256FullXL(var Digest: TSHA256Digest; Msg: pointer; Len: longint); + {-SHA256 of Msg with init/update/final} + +procedure SHA256File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA256Digest; var buf; bsize: word; var Err: word); + {-SHA256 of file, buf: buffer with at least bsize bytes} + + +implementation + + +{$ifdef BIT16} + {$F-} +{$endif} + +const + SHA256_BlockLen = 64; + +{Internal types for type casting} +type + TWorkBuf = array[0..63] of longint; + + THashAlgorithm = (_MD4, _MD5, _RIPEMD160, _SHA1, + _SHA224, _SHA256, _SHA384, _SHA512, + _Whirlpool, _SHA512_224, _SHA512_256, + _SHA3_224, _SHA3_256, _SHA3_384, _SHA3_512, + _Blake2S_224, _Blake2S_256, + _Blake2B_384, _Blake2B_512); {Supported hash algorithms} + +var + PHashVec : array[THashAlgorithm] of PHashDesc; + {Hash descriptor pointers of all defined hash algorithms} + + +{2.16.840.1.101.3.4.2.1} +{joint-iso-itu-t(2) country(16) us(840) organization(1) gov(101) csor(3) nistAlgorithm(4) hashAlgs(2) sha256(1)} +const + SHA256_OID : TOID_Vec = (2,16,840,1,101,3,4,2,1,-1,-1); {Len=9} + + +{$ifndef VER5X} +const + SHA256_Desc: THashDesc = ( + HSig : C_HashSig; + HDSize : sizeof(THashDesc); + HDVersion : C_HashVers; + HBlockLen : SHA256_BlockLen; + HDigestlen: sizeof(TSHA256Digest); + {$ifdef FPC_ProcVar} + HInit : @SHA256Init; + HFinal : @SHA256FinalEx; + HUpdateXL : @SHA256UpdateXL; + {$else} + HInit : SHA256Init; + HFinal : SHA256FinalEx; + HUpdateXL : SHA256UpdateXL; + {$endif} + HAlgNum : longint(_SHA256); + HName : 'SHA256'; + HPtrOID : @SHA256_OID; + HLenOID : 9; + HFill : 0; + {$ifdef FPC_ProcVar} + HFinalBit : @SHA256FinalBitsEx; + {$else} + HFinalBit : SHA256FinalBitsEx; + {$endif} + HReserved : (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0) + ); +{$else} +var + SHA256_Desc: THashDesc; +{$endif} + +function HashSameDigest(PHash: PHashDesc; PD1, PD2: PHashDigest): boolean; + {-Return true if same digests, using HDigestlen of PHash} +var + i: integer; +begin + HashSameDigest := false; + if PHash<>nil then with PHash^ do begin + if (HSig=C_HashSig) and (HDigestlen>0) then begin + for i:=0 to pred(HDigestlen) do begin + if PD1^[i]<>PD2^[i] then exit; + end; + HashSameDigest := true; + end; + end; +end; + +procedure HashFile({$ifdef CONST} const {$endif} fname: string; PHash: PHashDesc; + var Digest: THashDigest; var buf; bsize: word; var Err: word); + {-Calculate hash digest of file, buf: buffer with at least bsize bytes} +var + {$ifdef VirtualPascal} + fms: word; + {$else} + fms: byte; + {$endif} + {$ifndef BIT16} + L: longint; + {$else} + L: word; + {$endif} +var + Context: TTgHashContext; + f: file; +begin + if (PHash=nil) or (Phash^.HSig<>C_HashSig) then begin + Err := 204; {Invalid pointer} + exit; + end; + fms := FileMode; + {$ifdef VirtualPascal} + FileMode := $40; {open_access_ReadOnly or open_share_DenyNone;} + {$else} + FileMode := 0; + {$endif} + system.assign(f,{$ifdef D12Plus} string {$endif} (fname)); + system.reset(f,1); + Err := IOResult; + FileMode := fms; + if Err<>0 then exit; + with PHash^ do begin + HInit(Context); + L := bsize; + while (Err=0) and (L=bsize) do begin + system.blockread(f,buf,bsize,L); + Err := IOResult; + HUpdateXL(Context, @buf, L); + end; + system.close(f); + if IOResult=0 then {}; + HFinal(Context, Digest); + end; +end; + +procedure RegisterHash(AlgId: THashAlgorithm; PHash: PHashDesc); + {-Register algorithm with AlgID and Hash descriptor PHash^} +begin + if (PHash<>nil) and + (PHash^.HAlgNum=longint(AlgId)) and + (PHash^.HSig=C_HashSig) and + (PHash^.HDVersion=C_HashVers) and + (PHash^.HDSize=sizeof(THashDesc)) then PHashVec[AlgId] := PHash; +end; + + +{$ifndef BIT16} + +{$ifdef PurePascal} + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + var + tmp: int64; + begin + tmp := int64(cardinal(wlo))+Blen; + wlo := longint(tmp and $FFFFFFFF); + inc(whi,longint(tmp shr 32)); + end; + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; + {-reverse byte order in longint} + begin + RB := ((A and $FF) shl 24) or ((A and $FF00) shl 8) or ((A and $FF0000) shr 8) or ((A and longint($FF000000)) shr 24); + end; +{$else} + + {---------------------------------------------------------------------------} + function RB(A: longint): longint; assembler; {&frame-} + {-reverse byte order in longint} + asm + {$ifdef LoadArgs} + mov eax,[A] + {$endif} + xchg al,ah + rol eax,16 + xchg al,ah + end; + + {---------------------------------------------------------------------------} + procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} + begin + asm + mov edx, wlo + mov ecx, whi + mov eax, Blen + add [edx], eax + adc dword ptr [ecx], 0 + end; + end; + + {---------------------------------------------------------------------------} + function Sum0(x: longint): longint; assembler; {&frame-} + {-Big sigma 0: RotRight(x,2) xor RotRight(x,13) xor RotRight(x,22)} + asm + {$ifdef LoadArgs} + mov eax,[x] + {$endif} + mov ecx,eax + mov edx,eax + ror eax,2 + ror edx,13 + ror ecx,22 + xor eax,edx + xor eax,ecx + end; + + {---------------------------------------------------------------------------} + function Sum1(x: longint): longint; assembler; {&frame-} + {-Big sigma 1: RotRight(x,6) xor RotRight(x,11) xor RotRight(x,25)} + asm + {$ifdef LoadArgs} + mov eax,[x] + {$endif} + mov ecx,eax + mov edx,eax + ror eax,6 + ror edx,11 + ror ecx,25 + xor eax,edx + xor eax,ecx + end; + + {$define USE_ExpandMessageBlocks} + + {---------------------------------------------------------------------------} + procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuf32); + {-Calculate "expanded message blocks"} + begin + asm + push esi + push edi + push ebx + mov esi,[W] + mov edx,[Buf] + {part 1: W[i]:= RB(TW32Buf(Buf)[i])} + mov ecx,16 + @@1: mov eax,[edx] + xchg al,ah + rol eax,16 + xchg al,ah + mov [esi],eax + add esi,4 + add edx,4 + dec ecx + jnz @@1 + {part2: W[i]:= LRot_1(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16]);} + mov ecx,48 + @@2: mov edi,[esi-7*4] {W[i-7]} + mov eax,[esi-2*4] {W[i-2]} + mov ebx,eax {Sig1: RR17 xor RR19 xor SRx,10} + mov edx,eax + ror eax,17 + ror edx,19 + shr ebx,10 + xor eax,edx + xor eax,ebx + add edi,eax + mov eax,[esi-15*4] {W[i-15]} + mov ebx,eax {Sig0: RR7 xor RR18 xor SR3} + mov edx,eax + ror eax,7 + ror edx,18 + shr ebx,3 + xor eax,edx + xor eax,ebx + add eax,edi + add eax,[esi-16*4] {W[i-16]} + mov [esi],eax + add esi,4 + dec ecx + jnz @@2 + pop ebx + pop edi + pop esi + end; + end; +{$endif} + +{$else} + +{$ifndef BASM16} + +{TP5/5.5} + +{$undef USE_ExpandMessageBlocks} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); + {-Add BLen to 64 bit value (wlo, whi)} +inline( + $58/ {pop ax } + $5A/ {pop dx } + $5B/ {pop bx } + $07/ {pop es } + $26/$01/$07/ {add es:[bx],ax } + $26/$11/$57/$02/ {adc es:[bx+02],dx} + $5B/ {pop bx } + $07/ {pop es } + $26/$83/$17/$00/ {adc es:[bx],0 } + $26/$83/$57/$02/$00);{adc es:[bx+02],0 } + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; + {-reverse byte order in longint} +inline( + $58/ { pop ax } + $5A/ { pop dx } + $86/$C6/ { xchg dh,al} + $86/$E2); { xchg dl,ah} + + +{---------------------------------------------------------------------------} +function FS1(x: longint; c: integer): longint; + {-Rotate x right, c<=16!!} +inline( + $59/ { pop cx } + $58/ { pop ax } + $5A/ { pop dx } + $8B/$DA/ { mov bx,dx} + $D1/$EB/ {L:shr bx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA/ { rcr dx,1 } + $49/ { dec cx } + $75/$F7); { jne L } + + +{---------------------------------------------------------------------------} +function FS2(x: longint; c: integer): longint; + {-Rotate x right, c+16, c<16!!} +inline( + $59/ { pop cx } + $5A/ { pop dx } + $58/ { pop ax } + $8B/$DA/ { mov bx,dx} + $D1/$EB/ {L:shr bx,1 } + $D1/$D8/ { rcr ax,1 } + $D1/$DA/ { rcr dx,1 } + $49/ { dec cx } + $75/$F7); { jne L } + + +{---------------------------------------------------------------------------} +function ISHR(x: longint; c: integer): longint; + {-Shift x right} +inline( + $59/ { pop cx } + $58/ { pop ax } + $5A/ { pop dx } + $D1/$EA/ {L:shr dx,1 } + $D1/$D8/ { rcr ax,1 } + $49/ { dec cx } + $75/$F9); { jne L } + + +{---------------------------------------------------------------------------} +function Sig0(x: longint): longint; + {-Small sigma 0} +begin + Sig0 := FS1(x,7) xor FS2(x,18-16) xor ISHR(x,3); +end; + + +{---------------------------------------------------------------------------} +function Sig1(x: longint): longint; + {-Small sigma 1} +begin + Sig1 := FS2(x,17-16) xor FS2(x,19-16) xor ISHR(x,10); +end; + + +{---------------------------------------------------------------------------} +function Sum0(x: longint): longint; + {-Big sigma 0} +begin + Sum0 := FS1(x,2) xor FS1(x,13) xor FS2(x,22-16); +end; + + +{---------------------------------------------------------------------------} +function Sum1(x: longint): longint; + {-Big sigma 1} +begin + Sum1 := FS1(x,6) xor FS1(x,11) xor FS2(x,25-16); +end; + + +{$else} + +{TP 6/7/Delphi1 for 386+} + +{---------------------------------------------------------------------------} +procedure UpdateLen(var whi, wlo: longint; BLen: longint); assembler; + {-Add BLen to 64 bit value (wlo, whi)} +asm + les di,[wlo] + db $66; mov ax,word ptr [BLen] + db $66; sub dx,dx + db $66; add es:[di],ax + les di,[whi] + db $66; adc es:[di],dx +end; + + +{---------------------------------------------------------------------------} +function RB(A: longint): longint; assembler; + {-reverse byte order in longint} +asm + mov ax,word ptr [A] + mov dx,word ptr [A+2] + xchg al,dh + xchg ah,dl +end; + + +{---------------------------------------------------------------------------} +function Sum0(x: longint): longint; assembler; + {-Big sigma 0: RotRight(x,2) xor RotRight(x,13) xor RotRight(x,22)} +asm + db $66; mov ax,word ptr x + db $66; mov bx,ax + db $66; mov dx,ax + db $66; ror ax,2 + db $66; ror dx,13 + db $66; ror bx,22 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; mov dx,ax + db $66; shr dx,16 +end; + + +{---------------------------------------------------------------------------} +function Sum1(x: longint): longint; assembler; + {-Big sigma 1: RotRight(x,6) xor RotRight(x,11) xor RotRight(x,25)} +asm + db $66; mov ax,word ptr x + db $66; mov bx,ax + db $66; mov dx,ax + db $66; ror ax,6 + db $66; ror dx,11 + db $66; ror bx,25 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; mov dx,ax + db $66; shr dx,16 +end; + + +{$define USE_ExpandMessageBlocks} +{---------------------------------------------------------------------------} +procedure ExpandMessageBlocks(var W: TWorkBuf; var Buf: THashBuf32); assembler; + {-Calculate "expanded message blocks"} +asm + push ds + {part 1: W[i]:= RB(TW32Buf(Buf)[i])} + les di,[Buf] + lds si,[W] + mov cx,16 +@@1: db $66; mov ax,es:[di] + xchg al,ah + db $66; rol ax,16 + xchg al,ah + db $66; mov [si],ax + add si,4 + add di,4 + dec cx + jnz @@1 + {part 2: W[i]:= Sig1(W[i-2]) + W[i-7] + Sig0(W[i-15]) + W[i-16];} + mov cx,48 +@@2: db $66; mov di,[si-7*4] {W[i-7]} + db $66; mov ax,[si-2*4] {W[i-2]} + db $66; mov bx,ax {Sig1: RR17 xor RR19 xor SRx,10} + db $66; mov dx,ax + db $66; ror ax,17 + db $66; ror dx,19 + db $66; shr bx,10 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; add di,ax + db $66; mov ax,[si-15*4] {W[i-15]} + db $66; mov bx,ax {Sig0: RR7 xor RR18 xor SR3} + db $66; mov dx,ax + db $66; ror ax,7 + db $66; ror dx,18 + db $66; shr bx,3 + db $66; xor ax,dx + db $66; xor ax,bx + db $66; add ax,di + db $66; add ax,[si-16*4] {W[i-16]} + db $66; mov [si],ax + add si,4 + dec cx + jnz @@2 + pop ds +end; + + +{$endif BASM16} + +{$endif BIT16} + + + +{$ifdef PurePascal} +{---------------------------------------------------------------------------} +procedure SHA256Compress(var Data: THashContext); + {-Actual hashing function} +var + i: integer; + T, A, B, C, D, E, F, G, H: longint; + W: TWorkBuf; +const +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} + K: array[0..63] of longint = ( + $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5, + $3956c25b, $59f111f1, $923f82a4, $ab1c5ed5, + $d807aa98, $12835b01, $243185be, $550c7dc3, + $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174, + $e49b69c1, $efbe4786, $0fc19dc6, $240ca1cc, + $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da, + $983e5152, $a831c66d, $b00327c8, $bf597fc7, + $c6e00bf3, $d5a79147, $06ca6351, $14292967, + $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13, + $650a7354, $766a0abb, $81c2c92e, $92722c85, + $a2bfe8a1, $a81a664b, $c24b8b70, $c76c51a3, + $d192e819, $d6990624, $f40e3585, $106aa070, + $19a4c116, $1e376c08, $2748774c, $34b0bcb5, + $391c0cb3, $4ed8aa4a, $5b9cca4f, $682e6ff3, + $748f82ee, $78a5636f, $84c87814, $8cc70208, + $90befffa, $a4506ceb, $bef9a3f7, $c67178f2 + ); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + + {-Calculate "expanded message blocks"} + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i] := RB(THashBuf32(Data.Buffer)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 63 do begin + {A=Sig1(W[i-2]), B=Sig0(W[i-15])} + A := W[i-2]; A := ((A shr 17) or (A shl 15)) xor ((A shr 19) or (A shl 13)) xor (A shr 10); + B := W[i-15]; B := ((B shr 7) or (B shl 25)) xor ((B shr 18) or (B shl 14)) xor (B shr 3); + W[i]:= A + W[i-7] + B + W[i-16]; + end; + + {Assign old working hasg to variables A..H} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + F := Data.Hash[5]; + G := Data.Hash[6]; + H := Data.Hash[7]; + + {SHA256 compression function} + {partially unrolled loop} + i := 0; + repeat + T := H + (((E shr 6) or (E shl 26)) xor ((E shr 11) or (E shl 21)) xor ((E shr 25) or (E shl 7))) + + (((F xor G) and E) xor G) + W[i ] + K[i ]; + H := T + (((A shr 2) or (A shl 30)) xor ((A shr 13) or (A shl 19)) xor ((A shr 22) or (A shl 10))) + + (((A or B) and C) or (A and B)); + inc(D,T); + T := G + (((D shr 6) or (D shl 26)) xor ((D shr 11) or (D shl 21)) xor ((D shr 25) or (D shl 7))) + + (((E xor F) and D) xor F) + W[i+1] + K[i+1]; + G := T + (((H shr 2) or (H shl 30)) xor ((H shr 13) or (H shl 19)) xor ((H shr 22) or (H shl 10))) + + (((H or A) and B) or (H and A)); + inc(C,T); + T := F + (((C shr 6) or (C shl 26)) xor ((C shr 11) or (C shl 21)) xor ((C shr 25) or (C shl 7))) + + (((D xor E) and C) xor E) + W[i+2] + K[i+2]; + F := T + (((G shr 2) or (G shl 30)) xor ((G shr 13) or (G shl 19)) xor ((G shr 22) or (G shl 10))) + + (((G or H) and A) or (G and H)); + inc(B,T); + T := E + (((B shr 6) or (B shl 26)) xor ((B shr 11) or (B shl 21)) xor ((B shr 25) or (B shl 7))) + + (((C xor D) and B) xor D) + W[i+3] + K[i+3]; + E := T + (((F shr 2) or (F shl 30)) xor ((F shr 13) or (F shl 19)) xor ((F shr 22) or (F shl 10))) + + (((F or G) and H) or (F and G)); + inc(A,T); + T := D + (((A shr 6) or (A shl 26)) xor ((A shr 11) or (A shl 21)) xor ((A shr 25) or (A shl 7))) + + (((B xor C) and A) xor C) + W[i+4] + K[i+4]; + D := T + (((E shr 2) or (E shl 30)) xor ((E shr 13) or (E shl 19)) xor ((E shr 22) or (E shl 10))) + + (((E or F) and G) or (E and F)); + inc(H,T); + T := C + (((H shr 6) or (H shl 26)) xor ((H shr 11) or (H shl 21)) xor ((H shr 25) or (H shl 7))) + + (((A xor B) and H) xor B) + W[i+5] + K[i+5]; + C := T + (((D shr 2) or (D shl 30)) xor ((D shr 13) or (D shl 19)) xor ((D shr 22) or (D shl 10))) + + (((D or E) and F) or (D and E)); + inc(G,T); + T := B + (((G shr 6) or (G shl 26)) xor ((G shr 11) or (G shl 21)) xor ((G shr 25) or (G shl 7))) + + (((H xor A) and G) xor A) + W[i+6] + K[i+6]; + B := T + (((C shr 2) or (C shl 30)) xor ((C shr 13) or (C shl 19)) xor ((C shr 22) or (C shl 10))) + + (((C or D) and E) or (C and D)); + inc(F,T); + T := A + (((F shr 6) or (F shl 26)) xor ((F shr 11) or (F shl 21)) xor ((F shr 25) or (F shl 7))) + + (((G xor H) and F) xor H) + W[i+7] + K[i+7]; + A := T + (((B shr 2) or (B shl 30)) xor ((B shr 13) or (B shl 19)) xor ((B shr 22) or (B shl 10))) + + (((B or C) and D) or (B and C)); + inc(E,T); + inc(i,8) + until i>63; + + {Calculate new working hash} + inc(Data.Hash[0],A); + inc(Data.Hash[1],B); + inc(Data.Hash[2],C); + inc(Data.Hash[3],D); + inc(Data.Hash[4],E); + inc(Data.Hash[5],F); + inc(Data.Hash[6],G); + inc(Data.Hash[7],H); +end; + +{$else} + +{---------------------------------------------------------------------------} +procedure SHA256Compress(var Data: TTgHashContext); + {-Actual hashing function} +var + i: integer; +{$ifdef UNROLL} + T, +{$else} + T1,T2: longint; +{$endif} + A, B, C, D, E, F, G, H: longint; + W: TWorkBuf; +const +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} + K: array[0..63] of longint = ( + $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5, + $3956c25b, $59f111f1, $923f82a4, $ab1c5ed5, + $d807aa98, $12835b01, $243185be, $550c7dc3, + $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174, + $e49b69c1, $efbe4786, $0fc19dc6, $240ca1cc, + $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da, + $983e5152, $a831c66d, $b00327c8, $bf597fc7, + $c6e00bf3, $d5a79147, $06ca6351, $14292967, + $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13, + $650a7354, $766a0abb, $81c2c92e, $92722c85, + $a2bfe8a1, $a81a664b, $c24b8b70, $c76c51a3, + $d192e819, $d6990624, $f40e3585, $106aa070, + $19a4c116, $1e376c08, $2748774c, $34b0bcb5, + $391c0cb3, $4ed8aa4a, $5b9cca4f, $682e6ff3, + $748f82ee, $78a5636f, $84c87814, $8cc70208, + $90befffa, $a4506ceb, $bef9a3f7, $c67178f2 + ); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + {-Calculate "expanded message blocks"} + {$ifdef USE_ExpandMessageBlocks} + {Use BASM-Code} + ExpandMessageBlocks(W, THashBuf32(Data.Buffer)); + {$else} + {Avoid proc call overhead for TP5/5.5} + {Part 1: Transfer buffer with little -> big endian conversion} + for i:= 0 to 15 do W[i]:= RB(THashBuf32(Data.Buffer)[i]); + {Part 2: Calculate remaining "expanded message blocks"} + for i:= 16 to 63 do W[i]:= Sig1(W[i-2]) + W[i-7] + Sig0(W[i-15]) + W[i-16]; + {$endif} + + {Assign old working hasg to variables A..H} + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + F := Data.Hash[5]; + G := Data.Hash[6]; + H := Data.Hash[7]; + + {SHA256 compression function} + +{$ifdef UNROLL} + + {partially unrolled loop} + i := 0; + repeat + T := H + Sum1(E) + (((F xor G) and E) xor G) + W[i ] + K[i ]; + H := T + Sum0(A) + (((A or B) and C) or (A and B)); + inc(D,T); + T := G + Sum1(D) + (((E xor F) and D) xor F) + W[i+1] + K[i+1]; + G := T + Sum0(H) + (((H or A) and B) or (H and A)); + inc(C,T); + T := F + Sum1(C) + (((D xor E) and C) xor E) + W[i+2] + K[i+2]; + F := T + Sum0(G) + (((G or H) and A) or (G and H)); + inc(B,T); + T := E + Sum1(B) + (((C xor D) and B) xor D) + W[i+3] + K[i+3]; + E := T + Sum0(F) + (((F or G) and H) or (F and G)); + inc(A,T); + T := D + Sum1(A) + (((B xor C) and A) xor C) + W[i+4] + K[i+4]; + D := T + Sum0(E) + (((E or F) and G) or (E and F)); + inc(H,T); + T := C + Sum1(H) + (((A xor B) and H) xor B) + W[i+5] + K[i+5]; + C := T + Sum0(D) + (((D or E) and F) or (D and E)); + inc(G,T); + T := B + Sum1(G) + (((H xor A) and G) xor A) + W[i+6] + K[i+6]; + B := T + Sum0(C) + (((C or D) and E) or (C and D)); + inc(F,T); + T := A + Sum1(F) + (((G xor H) and F) xor H) + W[i+7] + K[i+7]; + A := T + Sum0(B) + (((B or C) and D) or (B and C)); + inc(E,T); + inc(i,8) + until i>63; + +{$else} + for i:=0 to 63 do begin + T1:= H + Sum1(E) + (((F xor G) and E) xor G) + K[i] + W[i]; + T2:= Sum0(A) + (((A or B) and C) or (A and B)); + H := G; + G := F; + F := E; + E := D + T1; + D := C; + C := B; + B := A; + A := T1 + T2; + end; +{$endif} + + {Calculate new working hash} + inc(Data.Hash[0],A); + inc(Data.Hash[1],B); + inc(Data.Hash[2],C); + inc(Data.Hash[3],D); + inc(Data.Hash[4],E); + inc(Data.Hash[5],F); + inc(Data.Hash[6],G); + inc(Data.Hash[7],H); +end; + +{$endif} + +{---------------------------------------------------------------------------} +procedure SHA256Init(var Context: TTgHashContext); + {-initialize context} +{$ifdef StrictLong} + {$warnings off} + {$R-} {avoid D9 errors!} +{$endif} +const + SIV: array[0..7] of longint = ($6a09e667, $bb67ae85, $3c6ef372, $a54ff53a, $510e527f, $9b05688c, $1f83d9ab, $5be0cd19); +{$ifdef StrictLong} + {$warnings on} + {$ifdef RangeChecks_on} + {$R+} + {$endif} +{$endif} +begin + {Clear context, buffer=0!!} + fillchar(Context,sizeof(Context),0); + move(SIV,Context.Hash,sizeof(SIV)); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256UpdateXL(var Context: TTgHashContext; Msg: pointer; Len: longint); + {-update context with Msg data} +var + i: integer; +begin + {Update message bit length} + if Len<=$1FFFFFFF then UpdateLen(Context.MLen[1], Context.MLen[0], Len shl 3) + else begin + for i:=1 to 8 do UpdateLen(Context.MLen[1], Context.MLen[0], Len) + end; + while Len > 0 do begin + {fill block with msg data} + Context.Buffer[Context.Index]:= pByte(Msg)^; + inc(Ptr2Inc(Msg)); + inc(Context.Index); + dec(Len); + if Context.Index=SHA256_BlockLen then begin + {If 512 bit transferred, compress a block} + Context.Index:= 0; + SHA256Compress(Context); + while Len>=SHA256_BlockLen do begin + move(Msg^,Context.Buffer,SHA256_BlockLen); + SHA256Compress(Context); + inc(Ptr2Inc(Msg),SHA256_BlockLen); + dec(Len,SHA256_BlockLen); + end; + end; + end; +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Update(var Context: TTgHashContext; Msg: pointer; Len: longint {word}); // word 형식을 longint으로 변경 18_0621 14:02:57 sunk + {-update context with Msg data} +begin + SHA256UpdateXL(Context, Msg, Len); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalBitsEx(var Context: TTgHashContext; var Digest: THashDigest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} +var + i: integer; +begin + {Message padding} + {append bits from BData and a single '1' bit} + if (bitlen>0) and (bitlen<=7) then begin + Context.Buffer[Context.Index]:= (BData and BitAPI_Mask[bitlen]) or BitAPI_PBit[bitlen]; + UpdateLen(Context.MLen[1], Context.MLen[0], bitlen); + end + else Context.Buffer[Context.Index]:= $80; + for i:=Context.Index+1 to 63 do Context.Buffer[i] := 0; + {2. Compress if more than 448 bits, (no room for 64 bit length} + if Context.Index>= 56 then begin + SHA256Compress(Context); + fillchar(Context.Buffer,56,0); + end; + {Write 64 bit msg length into the last bits of the last block} + {(in big endian format) and do a final compress} + THashBuf32(Context.Buffer)[14]:= RB(Context.MLen[1]); + THashBuf32(Context.Buffer)[15]:= RB(Context.MLen[0]); + SHA256Compress(Context); + {Hash -> Digest to little endian format} + for i:=0 to 7 do THashDig32(Digest)[i]:= RB(Context.Hash[i]); + {Clear context} + fillchar(Context,sizeof(Context),0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalBits(var Context: TTgHashContext; var Digest: TSHA256Digest; BData: byte; bitlen: integer); + {-finalize SHA256 calculation with bitlen bits from BData (big-endian), clear context} +var + tmp: THashDigest; +begin + SHA256FinalBitsEx(Context, tmp, BData, bitlen); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FinalEx(var Context: TTgHashContext; var Digest: THashDigest); + {-finalize SHA256 calculation, clear context} +begin + SHA256FinalBitsEx(Context,Digest,0,0); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Final(var Context: TTgHashContext; var Digest: TSHA256Digest); + {-finalize SHA256 calculation, clear context} +var + tmp: THashDigest; +begin + SHA256FinalBitsEx(Context, tmp, 0, 0); + move(tmp, Digest, sizeof(Digest)); +end; + + +{---------------------------------------------------------------------------} +function SHA256SelfTest: boolean; + {-self test for string from SHA256 document} +const + s1: string[ 3] = 'abc'; + s2: string[56] = 'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'; + D1: TSHA256Digest = ($ba,$78,$16,$bf,$8f,$01,$cf,$ea,$41,$41,$40,$de,$5d,$ae,$22,$23, + $b0,$03,$61,$a3,$96,$17,$7a,$9c,$b4,$10,$ff,$61,$f2,$00,$15,$ad); + D2: TSHA256Digest = ($24,$8d,$6a,$61,$d2,$06,$38,$b8,$e5,$c0,$26,$93,$0c,$3e,$60,$39, + $a3,$3c,$e4,$59,$64,$ff,$21,$67,$f6,$ec,$ed,$d4,$19,$db,$06,$c1); + D3: TSHA256Digest = ($bd,$4f,$9e,$98,$be,$b6,$8c,$6e,$ad,$32,$43,$b1,$b4,$c7,$fe,$d7, + $5f,$a4,$fe,$aa,$b1,$f8,$47,$95,$cb,$d8,$a9,$86,$76,$a2,$a3,$75); + D4: TSHA256Digest = ($f1,$54,$1d,$eb,$68,$d1,$34,$eb,$a9,$9f,$82,$cf,$d8,$7e,$2a,$b3, + $1d,$33,$af,$4b,$6d,$e0,$08,$6a,$9b,$ed,$15,$c2,$ec,$69,$cc,$cb); +var + Context: TTgHashContext; + Digest : TSHA256Digest; + + function SingleTest(s: Str127; TDig: TSHA256Digest): boolean; + {-do a single test, const not allowed for VER<7} + { Two sub tests: 1. whole string, 2. one update per char} + var + i: integer; + begin + SingleTest := false; + {1. Hash complete string} + SHA256Full(Digest, @s[1],length(s)); + {Compare with known value} + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + {2. one update call for all chars} + SHA256Init(Context); + for i:=1 to length(s) do SHA256Update(Context,@s[i],1); + SHA256Final(Context,Digest); + {Compare with known value} + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@TDig)) then exit; + SingleTest := true; + end; + +begin + SHA256SelfTest := false; + {1 Zero bit from NESSIE test vectors} + SHA256Init(Context); + SHA256FinalBits(Context,Digest,0,1); + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@D3)) then exit; + {4 hightest bits of $50, D4 calculated with program shatest from RFC 4634} + SHA256Init(Context); + SHA256FinalBits(Context,Digest,$50,4); + if not HashSameDigest(@SHA256_Desc, PHashDigest(@Digest), PHashDigest(@D4)) then exit; + {strings from SHA256 document} + SHA256SelfTest := SingleTest(s1, D1) and SingleTest(s2, D2) +end; + + +{---------------------------------------------------------------------------} +procedure SHA256FullXL(var Digest: TSHA256Digest; Msg: pointer; Len: longint); + {-SHA256 of Msg with init/update/final} +var + Context: TTgHashContext; +begin + SHA256Init(Context); + SHA256UpdateXL(Context, Msg, Len); + SHA256Final(Context, Digest); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256Full(var Digest: TSHA256Digest; Msg: pointer; Len: word); + {-SHA256 of Msg with init/update/final} +begin + SHA256FullXL(Digest, Msg, Len); +end; + + +{---------------------------------------------------------------------------} +procedure SHA256File({$ifdef CONST} const {$endif} fname: string; + var Digest: TSHA256Digest; var buf; bsize: word; var Err: word); + {-SHA256 of file, buf: buffer with at least bsize bytes} +var + tmp: THashDigest; +begin + HashFile(fname, @SHA256_Desc, tmp, buf, bsize, Err); + move(tmp,Digest,sizeof(Digest)); +end; + + +begin + {$ifdef VER5X} + fillchar(SHA256_Desc, sizeof(SHA256_Desc), 0); + with SHA256_Desc do begin + HSig := C_HashSig; + HDSize := sizeof(THashDesc); + HDVersion := C_HashVers; + HBlockLen := SHA256_BlockLen; + HDigestlen:= sizeof(TSHA256Digest); + HInit := SHA256Init; + HFinal := SHA256FinalEx; + HUpdateXL := SHA256UpdateXL; + HAlgNum := longint(_SHA256); + HName := 'SHA256'; + HPtrOID := @SHA256_OID; + HLenOID := 9; + HFinalBit := SHA256FinalBitsEx; + end; + {$endif} + RegisterHash(_SHA256, @SHA256_Desc); +end. diff --git a/Tocsg.Lib/VCL/EncLib/std.inc b/Tocsg.Lib/VCL/EncLib/std.inc new file mode 100644 index 00000000..0a4a7f0d --- /dev/null +++ b/Tocsg.Lib/VCL/EncLib/std.inc @@ -0,0 +1,631 @@ +(************************************************************************* + + DESCRIPTION : Standard definitions and options + + REQUIREMENTS : TP5-7, D1-D7/D9-D12/D14-D25, FPC, VP, (TPW1.0/1.5,BCB3/4) + + Version Date Author Modification + ------- -------- ------- ------------------------------------------ + 1.00 05.10.03 W.Ehrhardt Initial version + 1.01 05.10.03 we X_OPT, removed TP4 + 1.02 30.10.03 we WINCRT + 1.03 09.12.03 we {$R+,S+} {$ifdef debug} + 1.04 26.12.03 we VP: {&Optimise+,SmartLink+,Speed+} ifndef debug + 1.05 28.12.03 we DELPHI = Delphi32 (no Delphi 1!) + 1.06 12.04.04 we Delphi 7 + 1.07 26.09.04 we Record starting values of important options + 1.08 10.10.04 we RESULT for Result pseudo variable + 1.09 02.01.05 we BIT16: default $F- + 1.10 26.02.05 we StrictLong + 1.11 05.05.05 we D9 aka Delphi 2005 + 1.12 22.05.05 we StrictLong for FPC 2.0 + 1.13 27.05.05 we {$goto on} for FPC + 1.14 27.05.05 we moved {$goto on} to default settings + 1.15 29.05.05 we HAS_INT64, HAS_MSG, _STD_INC_ + 1.16 06.08.05 we J_OPT, N_OPT, HAS_INLINE + 1.17 17.08.05 we HAS_ASSERT + 1.18 08.11.05 we APPCONS, partial TMT,TPW15 support + 1.19 20.11.05 we Default option {$B-} + 1.20 08.01.06 we ABSTRACT/DEFAULT + 1.21 08.02.06 we Fix Scanhelp quirk + 1.22 11.02.06 we VER5X + 1.23 15.04.06 we HAS_XTYPES + 1.24 08.05.06 we D10 aka Delphi 2006 + 1.25 25.05.06 we Define RESULT if FPC_OBJFPC is defined + 1.26 08.09.06 we Define RESULT/DEFAULT if FPC_DELPHI is defined + 1.27 14.11.06 we HAS_ASSERT for FPC VER1 and VER2 + 1.28 28.11.06 we HAS_UNSAFE, $warn SYMBOL_../UNSAFE_.. OFF + 1.29 25.05.07 we D11 aka Delphi 2007, FPC2.1.4 + 1.30 23.06.07 we FPC_ProcVar: Helper for procedure variables + 1.31 18.09.07 we HAS_INLINE for FPC VER2 + 1.32 04.10.07 we FPC Intel ASMmode only if CPUI386 is defined + 1.33 22.11.07 we Record value of $X option, undef RESULT if $X- + 1.34 19.05.08 we HAS_UINT64 + 1.35 21.06.08 we V7PLUS, HAS_UINT64 for FPC VER2_2 + 1.36 07.09.08 we HAS_CARD32 + 1.37 21.11.08 we D12 aka D2009 + 1.38 19.02.09 we TPW 1.0 adjustments + 1.39 05.07.09 we D12Plus + 1.40 17.10.09 we BASM (BASM16 or Bit32) + 1.41 21.10.09 we HAS_OVERLOAD + 1.42 07.04.10 we HAS_DENORM_LIT (Denormalised extended literals, e.g. -1.23e-4942) + 1.43 20.06.10 we D14 (VER210) + 1.45 16.10.10 we WIN16 + 1.46 05.11.10 we FPC VER2_4 + 1.47 12.11.11 we FPC VER2_6 + 1.48 01.01.12 we HAS_UINT64 for FPC VER2_6 + 1.49 12.01.12 we BIT64, WIN32or64, Bit32or64 + 1.50 13.01.12 we EXT64 (64 bit extended = double) + 1.51 19.01.12 we Define EXT64 if SIMULATE_EXT64 + 1.52 05.09.12 we Basic support for D14, D15(XE), D16(XE2), D17(XE3) + 1.53 01.12.12 we Simplified FPC 2.X.Y definitions + 1.54 17.12.12 we UNIT_SCOPE (D16/D17) + 1.55 25.12.12 we J_OPT for BIT64 + 1.56 25.04.13 we D18/XE4 (VER250) + 1.57 28.09.13 we Basic support for D19/XE5 (VER260) + 1.58 17.04.14 we Basic support for D20/XE6 (VER270) + 1.59 06.05.14 we FPC/CPUARM: $define EXT64, i.e. no FP 80-bit extended + 1.60 13.09.14 we Basic support for D21/XE7 (VER280) + 1.61 22.10.14 we HAS_OUT + 1.62 13.01.15 we FPC VER3 (FPC3.0.1/3.1.1), FPC2Plus, FPC271or3 + 1.63 22.04.15 we Basic support for D22/XE8 (VER290) + 1.64 25.04.15 we HAS_INTXX, HAS_PINTXX + 1.65 01.09.15 we Basic support for D23 (VER300) 'Seattle' + 1.66 26.04.16 we Basic support for D24 (VER310) 'Berlin' + 1.67 17.03.17 we Define PurePascal for FPC/CPUARM + 1.68 11.04.17 we Basic support for D25 (VER320) 'Tokyo' +**************************************************************************) + + +(*------------------------------------------------------------------------- + (C) Copyright 2002-2017 Wolfgang Ehrhardt + + This software is provided 'as-is', without any express or implied warranty. + In no event will the authors be held liable for any damages arising from + the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software in + a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source distribution. +----------------------------------------------------------------------------*) + +{$ifndef _STD_INC_} + +{$define _STD_INC_} {include STD.INC only once} + +{.$undef BIT16} {16 Bit code, Pascal / D1} +{.$undef BIT32} {32 Bit code} +{.$undef BIT64} {64 Bit code} +{.$undef DELPHI} {Delphi2+ and BCB++} +{.$undef G_OPT} {G+ option support} +{.$undef D4PLUS} {Delphi 4 or higher} +{.$undef BASM16} {16 Bit BASM} +{.$undef LoadArgs} {Register params} +{.$undef WINCRT} {Use WinCRT for console} +{.$undef WIN16} {Compiler for 16-bit windows} +{.$undef WIN32or64} {Compiler for 32/64-bit windows} +{.$undef RESULT} {Result pseudo variable} +{.$undef StrictLong} {Warning for longint const with MS bit} +{.$undef HAS_INT64} { int64 integer type available} +{.$undef HAS_UINT64} {uint64 integer type available} +{.$undef HAS_CARD32} {Has 32 bit cardinal} +{.$undef HAS_MSG} {Has message directive} +{.$undef HAS_INLINE} {Has inline procs/funcs (D9)} +{.$undef HAS_OUT} {Has OUT parameters: D3+, FPC2+ Delphi/ObjFPC} +{.$undef ABSTRACT} {Has abstract methods} +{.$undef DEFAULT} {Support default parameters} +{.$undef VER5X} {TP5 or TP55} +{.$undef HAS_XTYPES} {Xtra types in system: pByte, pLongint etc} +{.$undef HAS_UNSAFE} {UNSAFE warnings} +{.$undef APPCONS} {Needs "Apptype console" for console application} +{.$undef FPC_ProcVar} {FPC handling of @ and proc variables} +{.$undef FPC2Plus} {FPC 2 or newer} +{.$undef FPC271or3} {FPC 271 or 3 (less accurate for 64 bit or SSE2)} +{.$undef D12PLUS} {Delphi 12 or higher} +{.$undef HAS_OVERLOAD} {Overloading of procedures and functions} +{.$undef HAS_DENORM_LIT} {Denormalised (extended) literals, e.g. -1.23e-4942} +{.$undef EXT64} {64 bit extended = double} +{.$undef UNIT_SCOPE} {Unit scope name, D16+} +{.$undef HAS_INTXX} {Int8 .. Int32, UInt8 .. UInt32} +{.$undef HAS_PINTXX} {pInt8 .. pInt32, pUInt8 .. pUInt32} + + +{$define CONST} {const in proc declaration} +{$define Q_OPT} {Q- option support} +{$define X_OPT} {X+ option support} +{$define N_OPT} {N+ option support} +{$define BASM} {BASM16 or BIT32} +{$define V7PLUS} {TP7 or higher} + + +{$ifdef VER10} {TPW 1.0} + {$define BIT16} + {$define BASM16} + {$define WINCRT} + {$define G_OPT} + {$undef CONST} + {$undef Q_OPT} + {$undef V7PLUS} +{$endif} + +{$ifdef VER15} {TPW 1.5} + {$define BIT16} + {$define BASM16} + {$define WINCRT} + {$define G_OPT} + {$undef CONST} + {$undef Q_OPT} + {$undef V7PLUS} +{$endif} + +{$ifdef VER50 } + {$define BIT16} + {$define VER5X} + {$undef BASM} + {$undef CONST} + {$undef Q_OPT} + {$undef X_OPT} + {$undef V7PLUS} +{$endif} + +{$ifdef VER55 } + {$define BIT16} + {$define VER5X} + {$undef BASM} + {$undef CONST} + {$undef Q_OPT} + {$undef X_OPT} + {$undef V7PLUS} +{$endif} + +{$ifdef VER60 } + {$define BIT16} + {$undef CONST} + {$undef Q_OPT} + {$define G_OPT} + {$define BASM16} + {$undef V7PLUS} +{$endif} + +{$ifdef VER70 } + {$define BIT16} + {$define G_OPT} + {$define BASM16} +{$endif} + +{$ifdef VER80} + {.$define DELPHI} {D1} {*we V1.05} + {$define BIT16 } + {$define G_OPT } + {$define BASM16} + {$define WINCRT} + {$define RESULT} +{$endif} + +{$ifdef VER90 } + {$define DELPHI} {D2} +{$endif} + +{$ifdef VER93 } + {$define DELPHI} {BCB++1} +{$endif} + +{$ifdef VER100} + {$define DELPHI} {D3} + {$define HAS_ASSERT} + {$define HAS_OUT} +{$endif} + +{$ifdef VER110} + {$define DELPHI} {BCB3} + {$define HAS_OUT} +{$endif} + +{$ifdef VER120} + {$define DELPHI} {D4} + {$define D4PLUS} +{$endif} + +{$ifdef VER125} + {$define DELPHI} {BCB4} + {$define D4PLUS} +{$endif} + +{$ifdef VER130} + {$define DELPHI} {D5} + {$define D4PLUS} +{$endif} + +{$ifdef VER140} + {$define DELPHI} {D6} + {$define D4PLUS} +{$endif} + +{$ifdef VER150} + {$define DELPHI} {D7} + {$define D4PLUS} + {$define HAS_UNSAFE} + {$define HAS_UINT64} +{$endif} + +{$ifdef VER170} + {$define DELPHI} {D9} + {$define D4PLUS} + {$define HAS_INLINE} + {$define HAS_UNSAFE} + {$define HAS_UINT64} +{$endif} + +{$ifdef VER180} + {$define DELPHI} {D10, D11 ifdef VER185} + {$define D4PLUS} + {$define HAS_INLINE} + {$define HAS_UNSAFE} + {$define HAS_UINT64} +{$endif} + +{$ifdef VER200} + {$define DELPHI} {D12} + {$define D12PLUS} +{$endif} + +{$ifdef VER210} + {$define DELPHI} {D14} + {$define D12PLUS} +{$endif} + +{$ifdef VER220} + {$define DELPHI} {D15 - XE} + {$define D12PLUS} +{$endif} + +{$ifdef VER230} + {$define DELPHI} {D16 - XE2} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER240} + {$define DELPHI} {D17 - XE3} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER250} + {$define DELPHI} {D18 - XE4} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER260} + {$define DELPHI} {D19 - XE5} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER270} + {$define DELPHI} {D20 - XE6} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER280} + {$define DELPHI} {D21 - XE7} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER290} + {$define DELPHI} {D22 - XE8} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER300} + {$define DELPHI} {D23} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER310} + {$define DELPHI} {D24} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + +{$ifdef VER320} + {$define DELPHI} {D25} + {$define D12PLUS} + {$define UNIT_SCOPE} +{$endif} + + +{$ifdef CONDITIONALEXPRESSIONS} {D6+} + {$ifndef D4PLUS} + {$define D4PLUS} + {$endif} + {$define HAS_MSG} + {$define HAS_XTYPES} + {$ifdef CPUX64} + {$define BIT64} + {$endif} +{$endif} + +{$ifdef VER70} + {$ifdef windows} + {$define WINCRT} + {$endif} +{$endif} + +{$ifdef VirtualPascal} + {$define G_OPT} + {$define RESULT} + {$define LoadArgs} +{$endif} + +{$ifdef WIN32} + {$define J_OPT} +{$endif} + +{$ifdef BIT64} + {$define J_OPT} +{$endif} + +{$ifdef FPC} + {$define FPC_ProcVar} + {$define ABSTRACT} + {$define HAS_XTYPES} + {$define HAS_OVERLOAD} + {$undef N_OPT} + {$ifdef VER1} + {$undef J_OPT} + {$define HAS_INT64} + {$define HAS_CARD32} + {$define HAS_MSG} + {$define HAS_ASSERT} + {$ifndef VER1_0} + {FPC 1.9.x} + {$define StrictLong} + {$else} + {$define LoadArgs} + {$endif} + {$endif} + {$ifdef VER2} + {$define FPC2Plus} + {$define HAS_ASSERT} + {$define HAS_INT64} + {$define HAS_CARD32} + {$define HAS_MSG} + {$define HAS_INLINE} {Remember to use -Si} + {$define StrictLong} + {$ifdef FPC_OBJFPC} + {$define DEFAULT} + {$endif} + {$ifdef FPC_DELPHI} + {$define DEFAULT} + {$endif} + {$ifndef VER2_0} + {$ifndef VER2_1} + {$define HAS_UINT64} {2.2+} + {$endif} + {$define HAS_DENORM_LIT} {2.1+} + {$endif} + {$ifdef VER2_7_1} + {$define FPC271or3} + {$endif} + {$ifdef VER2_6_2} + {$define HAS_INTXX} + {$endif} + {$ifdef VER2_6_4} + {$define HAS_INTXX} + {$define HAS_PINTXX} + {$endif} + {$endif} + {$ifdef VER3} + {$define FPC2Plus} + {$define FPC271or3} + {$define HAS_ASSERT} + {$define HAS_INT64} + {$define HAS_CARD32} + {$define HAS_MSG} + {$define HAS_INLINE} + {$define HAS_UINT64} + {$define HAS_DENORM_LIT} + {$define StrictLong} + {$define HAS_INTXX} + {$define HAS_PINTXX} + {$ifdef FPC_OBJFPC} + {$define DEFAULT} + {$endif} + {$ifdef FPC_DELPHI} + {$define DEFAULT} + {$endif} + {$endif} + + {Note: Mode detection does not work for -Sxxx and version < 2.0.2} + {$ifdef FPC_OBJFPC} + {$define RESULT} + {$define HAS_OUT} + {$endif} + {$ifdef FPC_DELPHI} + {$define RESULT} + {$define HAS_OUT} + {$undef FPC_ProcVar} + {$endif} + {$ifdef FPC_TP} + {$undef FPC_ProcVar} + {$endif} + {$ifdef FPC_GPC} + {$undef FPC_ProcVar} + {$endif} + {$ifdef CPU64} + {$define BIT64} + {$endif} + {$ifdef CPUARM} + {$define EXT64} {No extended for ARM} + {$define PurePascal} + {$endif} +{$endif} + +{$ifdef __TMT__} + {$undef N_OPT} + {$define RESULT} + {$define HAS_INT64} + {$define LoadArgs} + {$ifdef __WIN32__} + {$define WIN32} + {$endif} +{$endif} + +{$ifndef BIT16} + {$define Bit32or64} + {$ifndef BIT64} + {$define BIT32} + {$endif} +{$endif} + +{$ifdef BIT16} + {$ifdef WINDOWS} + {$define WIN16} + {$endif} +{$endif} + +{$ifdef Delphi} + {$define RESULT} + {$define ABSTRACT} + {$define HAS_DENORM_LIT} +{$endif} + +{$ifdef D12Plus} + {$ifndef D4PLUS} + {$define D4PLUS} + {$endif} + {$define HAS_INLINE} + {$define HAS_UNSAFE} + {$define HAS_UINT64} + {$define HAS_INTXX} +{$endif} + +{$ifdef D4Plus} + {$define HAS_OUT} + {$define HAS_INT64} + {$define HAS_CARD32} + {$define StrictLong} + {$define HAS_ASSERT} + {$define DEFAULT} + {$define HAS_OVERLOAD} +{$endif} + +{$ifdef WIN32} + {$define WIN32or64} + {$ifndef VirtualPascal} + {$define APPCONS} + {$endif} +{$endif} + +{$ifdef WIN64} + {$define BIT64} + {$define WIN32or64} + {$define EXT64} + {$define APPCONS} +{$endif} + +{$ifdef BIT64} + {$undef BASM} +{$endif} + + +{-- Default options --} + +{$ifndef FPC} + {$B-} {short-circuit boolean expression evaluation, FPC has always B-!} +{$endif} + +{$ifdef FPC} + {$ifdef CPUI386} + {$ASMmode intel} + {$endif} + {$goto on} +{$endif} + +{$ifdef VirtualPascal} + {$ifndef debug} + {&Optimise+,SmartLink+,Speed+} + {$endif} +{$endif} + +{$ifdef G_OPT} + {$G+} +{$endif} + +{$ifdef Q_OPT} + {Most Crypto and CRC/Hash units need Q-, define Q+ locally if needed} + {$Q-} +{$endif} + +{$ifdef debug} + {$R+,S+} {Note: D9+ needs $R- for StrictLong setting!} +{$else} + {$R-,S-} +{$endif} + +{$ifdef SIMULATE_EXT64} + {$define EXT64} +{$endif} + +{$ifdef BIT16} + {$F-} +{$endif} + +{-- Record the starting values of important local options --} +{$ifopt A+} {$define Align_on} {$endif} +{$ifopt B+} {$define BoolEval_on} {$endif} +{$ifopt D+} {$define DebugInfo_on} {$endif} +{$ifopt I+} {$define IOChecks_on} {$endif} +{$ifopt R+} {$define RangeChecks_on} {$endif} +{$ifopt V+} {$define VarStringChecks_on} {$endif} + + +{$ifdef Q_OPT} +{$ifopt P+} {$define OpenStrings_on} {$endif} +{$ifopt Q+} {$define OverflowChecks_on} {$endif} +{$endif} + +{-- Note that X option is GLOBAL --} +{$ifdef X_OPT} +{$ifopt X+} {$define ExtendedSyntax_on} {$endif} +{$ifopt X-} {$undef RESULT} {$endif} +{$endif} + +{$ifdef CONDITIONALEXPRESSIONS} + {$warn SYMBOL_PLATFORM OFF} + {$warn SYMBOL_DEPRECATED OFF} + {$warn SYMBOL_LIBRARY OFF} + {$warn UNIT_DEPRECATED OFF} + {$warn UNIT_LIBRARY OFF} + {$warn UNIT_PLATFORM OFF} + {$ifdef HAS_UNSAFE} + {$warn UNSAFE_TYPE OFF} + {$warn UNSAFE_CODE OFF} + {$warn UNSAFE_CAST OFF} + {$endif} +{$endif} + +{$else} + + {$ifdef HAS_MSG} + {$message 'std.inc included more than once'} + {$endif} + +{$endif} + diff --git a/Tocsg.Lib/VCL/Other/EM.DelphiZXIngQRCode.pas b/Tocsg.Lib/VCL/Other/EM.DelphiZXIngQRCode.pas new file mode 100644 index 00000000..7140e9ef --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.DelphiZXIngQRCode.pas @@ -0,0 +1,3573 @@ +unit EM.DelphiZXingQRCode; + +// ZXing QRCode port to Delphi, by Debenu Pty Ltd (www.debenu.com) + +// Original copyright notice +(* + * Copyright 2008 ZXing authors + * + * Licensed under the Apache License, Version 2.0 (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.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + *) + +interface + +type + TQRCodeEncoding = (qrAuto, qrNumeric, qrAlphanumeric, qrISO88591, qrUTF8NoBOM, qrUTF8BOM); + T2DBooleanArray = array of array of Boolean; + + TDelphiZXingQRCode = class + protected + FData: WideString; + FRows: Integer; + FColumns: Integer; + FEncoding: TQRCodeEncoding; + FQuietZone: Integer; + FElements: T2DBooleanArray; + procedure SetEncoding(NewEncoding: TQRCodeEncoding); + procedure SetData(const NewData: WideString); + procedure SetQuietZone(NewQuietZone: Integer); + function GetIsBlack(Row, Column: Integer): Boolean; + procedure Update; + public + constructor Create; + property Data: WideString read FData write SetData; + property Encoding: TQRCodeEncoding read FEncoding write SetEncoding; + property QuietZone: Integer read FQuietZone write SetQuietZone; + property Rows: Integer read FRows; + property Columns: Integer read FColumns; + property IsBlack[Row, Column: Integer]: Boolean read GetIsBlack; + end; + +implementation + +uses + contnrs, Math, Classes; + +type + TByteArray = array of Byte; + T2DByteArray = array of array of Byte; + TIntegerArray = array of Integer; + +const + NUM_MASK_PATTERNS = 8; + + QUIET_ZONE_SIZE = 4; + + ALPHANUMERIC_TABLE: array[0..95] of Integer = ( + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, // 0x00-0x0f + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, // 0x10-0x1f + 36, -1, -1, -1, 37, 38, -1, -1, -1, -1, 39, 40, -1, 41, 42, 43, // 0x20-0x2f + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 44, -1, -1, -1, -1, -1, // 0x30-0x3f + -1, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, // 0x40-0x4f + 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, -1, -1, -1, -1, -1 // 0x50-0x5f + ); + + DEFAULT_BYTE_MODE_ENCODING = 'ISO-8859-1'; + + POSITION_DETECTION_PATTERN: array[0..6, 0..6] of Integer = ( + (1, 1, 1, 1, 1, 1, 1), + (1, 0, 0, 0, 0, 0, 1), + (1, 0, 1, 1, 1, 0, 1), + (1, 0, 1, 1, 1, 0, 1), + (1, 0, 1, 1, 1, 0, 1), + (1, 0, 0, 0, 0, 0, 1), + (1, 1, 1, 1, 1, 1, 1)); + + HORIZONTAL_SEPARATION_PATTERN: array[0..0, 0..7] of Integer = ( + (0, 0, 0, 0, 0, 0, 0, 0)); + + VERTICAL_SEPARATION_PATTERN: array[0..6, 0..0] of Integer = ( + (0), (0), (0), (0), (0), (0), (0)); + + POSITION_ADJUSTMENT_PATTERN: array[0..4, 0..4] of Integer = ( + (1, 1, 1, 1, 1), + (1, 0, 0, 0, 1), + (1, 0, 1, 0, 1), + (1, 0, 0, 0, 1), + (1, 1, 1, 1, 1)); + + // From Appendix E. Table 1, JIS0510X:2004 (p 71). The table was double-checked by komatsu. + POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE: array[0..39, 0..6] of Integer = ( + (-1, -1, -1, -1, -1, -1, -1), // Version 1 + ( 6, 18, -1, -1, -1, -1, -1), // Version 2 + ( 6, 22, -1, -1, -1, -1, -1), // Version 3 + ( 6, 26, -1, -1, -1, -1, -1), // Version 4 + ( 6, 30, -1, -1, -1, -1, -1), // Version 5 + ( 6, 34, -1, -1, -1, -1, -1), // Version 6 + ( 6, 22, 38, -1, -1, -1, -1), // Version 7 + ( 6, 24, 42, -1, -1, -1, -1), // Version 8 + ( 6, 26, 46, -1, -1, -1, -1), // Version 9 + ( 6, 28, 50, -1, -1, -1, -1), // Version 10 + ( 6, 30, 54, -1, -1, -1, -1), // Version 11 + ( 6, 32, 58, -1, -1, -1, -1), // Version 12 + ( 6, 34, 62, -1, -1, -1, -1), // Version 13 + ( 6, 26, 46, 66, -1, -1, -1), // Version 14 + ( 6, 26, 48, 70, -1, -1, -1), // Version 15 + ( 6, 26, 50, 74, -1, -1, -1), // Version 16 + ( 6, 30, 54, 78, -1, -1, -1), // Version 17 + ( 6, 30, 56, 82, -1, -1, -1), // Version 18 + ( 6, 30, 58, 86, -1, -1, -1), // Version 19 + ( 6, 34, 62, 90, -1, -1, -1), // Version 20 + ( 6, 28, 50, 72, 94, -1, -1), // Version 21 + ( 6, 26, 50, 74, 98, -1, -1), // Version 22 + ( 6, 30, 54, 78, 102, -1, -1), // Version 23 + ( 6, 28, 54, 80, 106, -1, -1), // Version 24 + ( 6, 32, 58, 84, 110, -1, -1), // Version 25 + ( 6, 30, 58, 86, 114, -1, -1), // Version 26 + ( 6, 34, 62, 90, 118, -1, -1), // Version 27 + ( 6, 26, 50, 74, 98, 122, -1), // Version 28 + ( 6, 30, 54, 78, 102, 126, -1), // Version 29 + ( 6, 26, 52, 78, 104, 130, -1), // Version 30 + ( 6, 30, 56, 82, 108, 134, -1), // Version 31 + ( 6, 34, 60, 86, 112, 138, -1), // Version 32 + ( 6, 30, 58, 86, 114, 142, -1), // Version 33 + ( 6, 34, 62, 90, 118, 146, -1), // Version 34 + ( 6, 30, 54, 78, 102, 126, 150), // Version 35 + ( 6, 24, 50, 76, 102, 128, 154), // Version 36 + ( 6, 28, 54, 80, 106, 132, 158), // Version 37 + ( 6, 32, 58, 84, 110, 136, 162), // Version 38 + ( 6, 26, 54, 82, 110, 138, 166), // Version 39 + ( 6, 30, 58, 86, 114, 142, 170) // Version 40 + ); + + // Type info cells at the left top corner. + TYPE_INFO_COORDINATES: array[0..14, 0..1] of Integer = ( + (8, 0), + (8, 1), + (8, 2), + (8, 3), + (8, 4), + (8, 5), + (8, 7), + (8, 8), + (7, 8), + (5, 8), + (4, 8), + (3, 8), + (2, 8), + (1, 8), + (0, 8) + ); + + // From Appendix D in JISX0510:2004 (p. 67) + VERSION_INFO_POLY = $1f25; // 1 1111 0010 0101 + + // From Appendix C in JISX0510:2004 (p.65). + TYPE_INFO_POLY = $537; + TYPE_INFO_MASK_PATTERN = $5412; + + + VERSION_DECODE_INFO: array[0..33] of Integer = ( + + $07C94, $085BC, $09A99, $0A4D3, $0BBF6, + $0C762, $0D847, $0E60D, $0F928, $10B78, + $1145D, $12A17, $13532, $149A6, $15683, + $168C9, $177EC, $18EC4, $191E1, $1AFAB, + $1B08E, $1CC1A, $1D33F, $1ED75, $1F250, + $209D5, $216F0, $228BA, $2379F, $24B0B, + $2542E, $26A64, $27541, $28C69); + +type + TMode = (qmTerminator, qmNumeric, qmAlphanumeric, qmStructuredAppend, + qmByte, qmECI, qmKanji, qmFNC1FirstPosition, qmFNC1SecondPosition, + qmHanzi); + +const + ModeCharacterCountBits: array[TMode] of array[0..2] of Integer = ( + (0, 0, 0), (10, 12, 14), (9, 11, 13), (0, 0, 0), (8, 16, 16), + (0, 0, 0), (8, 10, 12), (0, 0, 0), (0, 0, 0), (8, 10, 12)); + + ModeBits: array[TMode] of Integer = (0, 1, 2, 3, 4, 7, 8, 5, 9, 13); + +type + TErrorCorrectionLevel = class + private + FBits: Integer; + public + procedure Assign(Source: TErrorCorrectionLevel); + function Ordinal: Integer; + property Bits: Integer read FBits; + end; + + TECB = class + private + Count: Integer; + DataCodewords: Integer; + public + constructor Create(Count, DataCodewords: Integer); + function GetCount: Integer; + function GetDataCodewords: Integer; + end; + + TECBArray = array of TECB; + + TECBlocks = class + private + ECCodewordsPerBlock: Integer; + ECBlocks: TECBArray; + public + constructor Create(ECCodewordsPerBlock: Integer; ECBlocks: TECB); overload; + constructor Create(ECCodewordsPerBlock: Integer; ECBlocks1, ECBlocks2: TECB); overload; + destructor Destroy; override; + function GetTotalECCodewords: Integer; + function GetNumBlocks: Integer; + function GetECCodewordsPerBlock: Integer; + function GetECBlocks: TECBArray; + end; + + TByteMatrix = class + protected + Bytes: T2DByteArray; + FWidth: Integer; + FHeight: Integer; + public + constructor Create(Width, Height: Integer); + function Get(X, Y: Integer): Integer; + procedure SetBoolean(X, Y: Integer; Value: Boolean); + procedure SetInteger(X, Y: Integer; Value: Integer); + function GetArray: T2DByteArray; + procedure Assign(Source: TByteMatrix); + procedure Clear(Value: Byte); + function Hash: AnsiString; + property Width: Integer read FWidth; + property Height: Integer read FHeight; + end; + + TBitArray = class + private + Bits: array of Integer; + Size: Integer; + procedure EnsureCapacity(Size: Integer); + public + constructor Create; overload; + constructor Create(Size: Integer); overload; + function GetSizeInBytes: Integer; + function GetSize: Integer; + function Get(I: Integer): Boolean; + procedure SetBit(Index: Integer); + procedure AppendBit(Bit: Boolean); + procedure AppendBits(Value, NumBits: Integer); + procedure AppendBitArray(NewBitArray: TBitArray); + procedure ToBytes(BitOffset: Integer; Source: TByteArray; Offset, + NumBytes: Integer); + procedure XorOperation(Other: TBitArray); + end; + + TCharacterSetECI = class + + end; + + TVersion = class + private + VersionNumber: Integer; + AlignmentPatternCenters: array of Integer; + ECBlocks: array of TECBlocks; + TotalCodewords: Integer; + ECCodewords: Integer; + public + constructor Create(VersionNumber: Integer; AlignmentPatternCenters: array of Integer; ECBlocks1, ECBlocks2, ECBlocks3, ECBlocks4: TECBlocks); + destructor Destroy; override; + class function GetVersionForNumber(VersionNum: Integer): TVersion; + class function ChooseVersion(NumInputBits: Integer; ecLevel: TErrorCorrectionLevel): TVersion; + function GetTotalCodewords: Integer; + function GetECBlocksForLevel(ECLevel: TErrorCorrectionLevel): TECBlocks; + function GetDimensionForVersion: Integer; + end; + + TMaskUtil = class + public + function GetDataMaskBit(MaskPattern, X, Y: Integer): Boolean; + end; + + TQRCode = class + private + FMode: TMode; + FECLevel: TErrorCorrectionLevel; + FVersion: Integer; + FMatrixWidth: Integer; + FMaskPattern: Integer; + FNumTotalBytes: Integer; + FNumDataBytes: Integer; + FNumECBytes: Integer; + FNumRSBlocks: Integer; + FMatrix: TByteMatrix; + FQRCodeError: Boolean; + public + constructor Create; + destructor Destroy; override; + function At(X, Y: Integer): Integer; + function IsValid: Boolean; + function IsValidMaskPattern(MaskPattern: Integer): Boolean; + procedure SetMatrix(NewMatrix: TByteMatrix); + procedure SetECLevel(NewECLevel: TErrorCorrectionLevel); + procedure SetAll(VersionNum, NumBytes, NumDataBytes, NumRSBlocks, NumECBytes, MatrixWidth: Integer); + property QRCodeError: Boolean read FQRCodeError; + property Mode: TMode read FMode write FMode; + property Version: Integer read FVersion write FVersion; + property NumDataBytes: Integer read FNumDataBytes; + property NumTotalBytes: Integer read FNumTotalBytes; + property NumRSBlocks: Integer read FNumRSBlocks; + property MatrixWidth: Integer read FMatrixWidth; + property MaskPattern: Integer read FMaskPattern write FMaskPattern; + property ECLevel: TErrorCorrectionLevel read FECLevel; + end; + + TMatrixUtil = class + + private + FMatrixUtilError: Boolean; + procedure ClearMatrix(Matrix: TByteMatrix); + + procedure EmbedBasicPatterns(Version: Integer; Matrix: TByteMatrix); + procedure EmbedTypeInfo(ECLevel: TErrorCorrectionLevel; MaskPattern: Integer; Matrix: TByteMatrix); + procedure MaybeEmbedVersionInfo(Version: Integer; Matrix: TByteMatrix); + procedure EmbedDataBits(DataBits: TBitArray; MaskPattern: Integer; Matrix: TByteMatrix); + function FindMSBSet(Value: Integer): Integer; + function CalculateBCHCode(Value, Poly: Integer): Integer; + procedure MakeTypeInfoBits(ECLevel: TErrorCorrectionLevel; MaskPattern: Integer; Bits: TBitArray); + procedure MakeVersionInfoBits(Version: Integer; Bits: TBitArray); + function IsEmpty(Value: Integer): Boolean; + procedure EmbedTimingPatterns(Matrix: TByteMatrix); + procedure EmbedDarkDotAtLeftBottomCorner(Matrix: TByteMatrix); + procedure EmbedHorizontalSeparationPattern(XStart, YStart: Integer; Matrix: TByteMatrix); + procedure EmbedVerticalSeparationPattern(XStart, YStart: Integer; Matrix: TByteMatrix); + procedure EmbedPositionAdjustmentPattern(XStart, YStart: Integer; Matrix: TByteMatrix); + procedure EmbedPositionDetectionPattern(XStart, YStart: Integer; Matrix: TByteMatrix); + procedure EmbedPositionDetectionPatternsAndSeparators(Matrix: TByteMatrix); + procedure MaybeEmbedPositionAdjustmentPatterns(Version: Integer; Matrix: TByteMatrix); + public + constructor Create; + property MatrixUtilError: Boolean read FMatrixUtilError; + procedure BuildMatrix(DataBits: TBitArray; ECLevel: TErrorCorrectionLevel; Version, MaskPattern: Integer; Matrix: TByteMatrix); + end; + +function GetModeBits(Mode: TMode): Integer; +begin + Result := ModeBits[Mode]; +end; + +function GetModeCharacterCountBits(Mode: TMode; Version: TVersion): Integer; +var + Number: Integer; + Offset: Integer; +begin + Number := Version.VersionNumber; + + if (Number <= 9) then + begin + Offset := 0; + end else + if (number <= 26) then + begin + Offset := 1; + end else + begin + Offset := 2; + end; + Result := ModeCharacterCountBits[Mode][Offset]; +end; + +type + TBlockPair = class + private + FDataBytes: TByteArray; + FErrorCorrectionBytes: TByteArray; + public + constructor Create(BA1, BA2: TByteArray); + function GetDataBytes: TByteArray; + function GetErrorCorrectionBytes: TByteArray; + end; + + TGenericGFPoly = class; + + TGenericGF = class + private + FExpTable: TIntegerArray; + FLogTable: TIntegerArray; + FZero: TGenericGFPoly; + FOne: TGenericGFPoly; + FSize: Integer; + FPrimitive: Integer; + FGeneratorBase: Integer; + FInitialized: Boolean; + FPolyList: array of TGenericGFPoly; + + procedure CheckInit; + procedure Initialize; + public + class function CreateQRCodeField256: TGenericGF; + class function AddOrSubtract(A, B: Integer): Integer; + constructor Create(Primitive, Size, B: Integer); + destructor Destroy; override; + function GetZero: TGenericGFPoly; + function Exp(A: Integer): Integer; + function GetGeneratorBase: Integer; + function Inverse(A: Integer): Integer; + function Multiply(A, B: Integer): Integer; + function BuildMonomial(Degree, Coefficient: Integer): TGenericGFPoly; + end; + + TGenericGFPolyArray = array of TGenericGFPoly; + TGenericGFPoly = class + private + FField: TGenericGF; + FCoefficients: TIntegerArray; + public + constructor Create(AField: TGenericGF; ACoefficients: TIntegerArray); + destructor Destroy; override; + function Coefficients: TIntegerArray; + function Multiply(Other: TGenericGFPoly): TGenericGFPoly; + function MultiplyByMonomial(Degree, Coefficient: Integer): TGenericGFPoly; + function Divide(Other: TGenericGFPoly): TGenericGFPolyArray; + function GetCoefficients: TIntegerArray; + function IsZero: Boolean; + function GetCoefficient(Degree: Integer): Integer; + function GetDegree: Integer; + function AddOrSubtract(Other: TGenericGFPoly): TGenericGFPoly; + end; + + TReedSolomonEncoder = class + private + FField: TGenericGF; + FCachedGenerators: TObjectList; + public + constructor Create(AField: TGenericGF); + destructor Destroy; override; + procedure Encode(ToEncode: TIntegerArray; ECBytes: Integer); + function BuildGenerator(Degree: Integer): TGenericGFPoly; + end; + + TEncoder = class + private + FEncoderError: Boolean; + + function ApplyMaskPenaltyRule1Internal(Matrix: TByteMatrix; + IsHorizontal: Boolean): Integer; + function ChooseMode(const Content: WideString; var EncodeOptions: Integer): TMode; overload; + function FilterContent(const Content: WideString; Mode: TMode; EncodeOptions: Integer): WideString; + procedure Append8BitBytes(const Content: WideString; Bits: TBitArray; EncodeOptions: Integer); + + procedure AppendAlphanumericBytes(const Content: WideString; + Bits: TBitArray); + procedure AppendBytes(const Content: WideString; Mode: TMode; + Bits: TBitArray; EncodeOptions: Integer); + procedure AppendKanjiBytes(const Content: WideString; Bits: TBitArray); + procedure AppendLengthInfo(NumLetters, VersionNum: Integer; Mode: TMode; + Bits: TBitArray); + procedure AppendModeInfo(Mode: TMode; Bits: TBitArray); + procedure AppendNumericBytes(const Content: WideString; Bits: TBitArray); + function ChooseMaskPattern(Bits: TBitArray; ECLevel: TErrorCorrectionLevel; + Version: Integer; Matrix: TByteMatrix): Integer; + function GenerateECBytes(DataBytes: TByteArray; + + NumECBytesInBlock: Integer): TByteArray; + function GetAlphanumericCode(Code: Integer): Integer; + procedure GetNumDataBytesAndNumECBytesForBlockID(NumTotalBytes, + NumDataBytes, NumRSBlocks, BlockID: Integer; var NumDataBytesInBlock: TIntegerArray; + var NumECBytesInBlock: TIntegerArray); + procedure InterleaveWithECBytes(Bits: TBitArray; NumTotalBytes, + NumDataBytes, NumRSBlocks: Integer; var Result: TBitArray); + //function IsOnlyDoubleByteKanji(const Content: WideString): Boolean; + procedure TerminateBits(NumDataBytes: Integer; var Bits: TBitArray); + function CalculateMaskPenalty(Matrix: TByteMatrix): Integer; + function ApplyMaskPenaltyRule1(Matrix: TByteMatrix): Integer; + function ApplyMaskPenaltyRule2(Matrix: TByteMatrix): Integer; + function ApplyMaskPenaltyRule3(Matrix: TByteMatrix): Integer; + function ApplyMaskPenaltyRule4(Matrix: TByteMatrix): Integer; + //procedure Encode(const Content: WideString; ECLevel: TErrorCorrectionLevel; QRCode: TQRCode); overload; + procedure Encode(const Content: WideString; EncodeOptions: Integer; ECLevel: TErrorCorrectionLevel; QRCode: TQRCode); + public + constructor Create; + property EncoderError: Boolean read FEncoderError; + end; + +function TEncoder.ApplyMaskPenaltyRule1(Matrix: TByteMatrix): Integer; +begin + Result := ApplyMaskPenaltyRule1Internal(Matrix, True) + + ApplyMaskPenaltyRule1Internal(Matrix, False); +end; + +// Apply mask penalty rule 2 and return the penalty. Find 2x2 blocks with the same color and give +// penalty to them. +function TEncoder.ApplyMaskPenaltyRule2(Matrix: TByteMatrix): Integer; +var + Penalty: Integer; + TheArray: T2DByteArray; + Width: Integer; + Height: Integer; + X: Integer; + Y: Integer; + Value: Integer; +begin + Penalty := 0; + TheArray := Matrix.GetArray; + Width := Matrix.Width; + Height := Matrix.Height; + for Y := 0 to Height - 2 do + begin + for X := 0 to Width - 2 do + begin + Value := TheArray[Y][X]; + if ((Value = TheArray[Y][X + 1]) and (Value = TheArray[Y + 1][X]) and + (Value = TheArray[Y + 1][X + 1])) then + begin + Inc(Penalty, 3); + end; + end; + end; + Result := Penalty; +end; + +// Apply mask penalty rule 3 and return the penalty. Find consecutive cells of 00001011101 or +// 10111010000, and give penalty to them. If we find patterns like 000010111010000, we give +// penalties twice (i.e. 40 * 2). +function TEncoder.ApplyMaskPenaltyRule3(Matrix: TByteMatrix): Integer; +var + Penalty: Integer; + TheArray: T2DByteArray; + Width: Integer; + Height: Integer; + X: Integer; + Y: Integer; +begin + Penalty := 0; + TheArray := Matrix.GetArray; + Width := Matrix.Width; + Height := Matrix.Height; + for Y := 0 to Height - 1 do + begin + for X := 0 to Width - 1 do + begin + if ((X + 6 < Width) and + (TheArray[Y][X] = 1) and + (TheArray[Y][X + 1] = 0) and + (TheArray[Y][X + 2] = 1) and + (TheArray[Y][X + 3] = 1) and + (TheArray[Y][X + 4] = 1) and + (TheArray[Y][X + 5] = 0) and + (TheArray[Y][X + 6] = 1) and + (((X + 10 < Width) and + (TheArray[Y][X + 7] = 0) and + (TheArray[Y][X + 8] = 0) and + (TheArray[Y][X + 9] = 0) and + (TheArray[Y][X + 10] = 0)) or + ((x - 4 >= 0) and + (TheArray[Y][X - 1] = 0) and + (TheArray[Y][X - 2] = 0) and + (TheArray[Y][X - 3] = 0) and + (TheArray[Y][X - 4] = 0)))) then + begin + Inc(Penalty, 40); + end; + if ((Y + 6 < Height) and + (TheArray[Y][X] = 1) and + (TheArray[Y + 1][X] = 0) and + (TheArray[Y + 2][X] = 1) and + (TheArray[Y + 3][X] = 1) and + (TheArray[Y + 4][X] = 1) and + (TheArray[Y + 5][X] = 0) and + (TheArray[Y + 6][X] = 1) and + (((Y + 10 < Height) and + (TheArray[Y + 7][X] = 0) and + (TheArray[Y + 8][X] = 0) and + (TheArray[Y + 9][X] = 0) and + (TheArray[Y + 10][X] = 0)) or + ((Y - 4 >= 0) and + (TheArray[Y - 1][X] = 0) and + (TheArray[Y - 2][X] = 0) and + (TheArray[Y - 3][X] = 0) and + (TheArray[Y - 4][X] = 0)))) then + begin + Inc(Penalty, 40); + end; + end; + end; + Result := Penalty; +end; + +// Apply mask penalty rule 4 and return the penalty. Calculate the ratio of dark cells and give +// penalty if the ratio is far from 50%. It gives 10 penalty for 5% distance. Examples: +// - 0% => 100 +// - 40% => 20 +// - 45% => 10 +// - 50% => 0 +// - 55% => 10 +// - 55% => 20 +// - 100% => 100 +function TEncoder.ApplyMaskPenaltyRule4(Matrix: TByteMatrix): Integer; +var + NumDarkCells: Integer; + TheArray: T2DByteArray; + Width: Integer; + Height: Integer; + NumTotalCells: Integer; + DarkRatio: Double; + X: Integer; + Y: Integer; +begin + NumDarkCells := 0; + TheArray := Matrix.GetArray; + Width := Matrix.Width; + Height := matrix.Height; + for Y := 0 to Height - 1 do + begin + for X := 0 to Width - 1 do + begin + if (TheArray[Y][X] = 1) then + begin + Inc(NumDarkCells); + end; + end; + end; + numTotalCells := matrix.Height * Matrix.Width; + DarkRatio := NumDarkCells / NumTotalCells; + Result := Round(Abs((DarkRatio * 100 - 50)) / 50); +end; + +// Helper function for applyMaskPenaltyRule1. We need this for doing this calculation in both +// vertical and horizontal orders respectively. +function TEncoder.ApplyMaskPenaltyRule1Internal(Matrix: TByteMatrix; IsHorizontal: Boolean): Integer; +var + Penalty: Integer; + NumSameBitCells: Integer; + PrevBit: Integer; + TheArray: T2DByteArray; + I: Integer; + J: Integer; + Bit: Integer; + ILimit: Integer; + JLimit: Integer; +begin + Penalty := 0; + NumSameBitCells := 0; + PrevBit := -1; + // Horizontal mode: + // for (int i = 0; i < matrix.height(); ++i) { + // for (int j = 0; j < matrix.width(); ++j) { + // int bit = matrix.get(i, j); + // Vertical mode: + // for (int i = 0; i < matrix.width(); ++i) { + // for (int j = 0; j < matrix.height(); ++j) { + // int bit = matrix.get(j, i); + if (IsHorizontal) then + begin + ILimit := Matrix.Height; + JLimit := Matrix.Width; + end else + begin + ILimit := Matrix.Width; + JLimit := Matrix.Height; + end; + TheArray := Matrix.GetArray; + + for I := 0 to ILimit - 1 do + begin + for J := 0 to JLimit - 1 do + begin + if (IsHorizontal) then + begin + Bit := TheArray[I][J]; + end else + begin + Bit := TheArray[J][I]; + end; + if (Bit = PrevBit) then + begin + Inc(NumSameBitCells); + // Found five repetitive cells with the same color (bit). + // We'll give penalty of 3. + if (NumSameBitCells = 5) then + begin + Inc(Penalty, 3); + end else if (NumSameBitCells > 5) then + begin + // After five repetitive cells, we'll add the penalty one + // by one. + Inc(Penalty, 1);; + end; + end else + begin + NumSameBitCells := 1; // Include the cell itself. + PrevBit := bit; + end; + end; + NumSameBitCells := 0; // Clear at each row/column. + end; + Result := Penalty; +end; + +{ TQRCode } + +constructor TQRCode.Create; +begin + FMode := qmTerminator; + FQRCodeError := False; + FECLevel := nil; + FVersion := -1; + FMatrixWidth := -1; + FMaskPattern := -1; + FNumTotalBytes := -1; + FNumDataBytes := -1; + FNumECBytes := -1; + FNumRSBlocks := -1; + FMatrix := nil; +end; + +destructor TQRCode.Destroy; +begin + if (Assigned(FECLevel)) then + begin + FECLevel.Free; + end; + if (Assigned(FMatrix)) then + begin + FMatrix.Free; + end; + inherited; +end; + +function TQRCode.At(X, Y: Integer): Integer; +var + Value: Integer; +begin + // The value must be zero or one. + Value := FMatrix.Get(X, Y); + if (not ((Value = 0) or (Value = 1))) then + begin + FQRCodeError := True; + end; + Result := Value; +end; + +function TQRCode.IsValid: Boolean; +begin + Result := + // First check if all version are not uninitialized. + ((FECLevel <> nil) and + (FVersion <> -1) and + (FMatrixWidth <> -1) and + (FMaskPattern <> -1) and + (FNumTotalBytes <> -1) and + (FNumDataBytes <> -1) and + (FNumECBytes <> -1) and + (FNumRSBlocks <> -1) and + // Then check them in other ways.. + IsValidMaskPattern(FMaskPattern) and + (FNumTotalBytes = FNumDataBytes + FNumECBytes) and + // ByteMatrix stuff. + (Assigned(FMatrix)) and + (FMatrixWidth = FMatrix.Width) and + // See 7.3.1 of JISX0510:2004 (Fp.5). + (FMatrix.Width = FMatrix.Height)); // Must be square. +end; + +function TQRCode.IsValidMaskPattern(MaskPattern: Integer): Boolean; +begin + Result := (MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS); +end; + +procedure TQRCode.SetMatrix(NewMatrix: TByteMatrix); +begin + if (Assigned(FMatrix)) then + begin + FMatrix.Free; + FMatrix := nil; + end; + FMatrix := NewMatrix; +end; + +procedure TQRCode.SetAll(VersionNum, NumBytes, NumDataBytes, NumRSBlocks, + NumECBytes, MatrixWidth: Integer); +begin + FVersion := VersionNum; + FNumTotalBytes := NumBytes; + FNumDataBytes := NumDataBytes; + FNumRSBlocks := NumRSBlocks; + FNumECBytes := NumECBytes; + FMatrixWidth := MatrixWidth; +end; + +procedure TQRCode.SetECLevel(NewECLevel: TErrorCorrectionLevel); +begin + if (Assigned(FECLevel)) then + begin + FECLevel.Free; + end; + FECLevel := TErrorCorrectionLevel.Create; + FECLevel.Assign(NewECLevel); +end; + +{ TByteMatrix } + +procedure TByteMatrix.Clear(Value: Byte); +var + X, Y: Integer; +begin + for Y := 0 to FHeight - 1 do + begin + for X := 0 to FWidth - 1 do + begin + Bytes[Y][X] := Value; + end; + end; +end; + +constructor TByteMatrix.Create(Width, Height: Integer); +var + Y: Integer; + X: Integer; +begin + FWidth := Width; + FHeight := Height; + SetLength(Bytes, Height); + for Y := 0 to Height - 1 do + begin + SetLength(Bytes[Y], Width); + for X := 0 to Width - 1 do + begin + Bytes[Y][X] := 0; + end; + end; +end; + +function TByteMatrix.Get(X, Y: Integer): Integer; +begin + if (Bytes[Y][X] = 255) then Result := -1 else Result := Bytes[Y][X]; +end; + +function TByteMatrix.GetArray: T2DByteArray; +begin + Result := Bytes; +end; + +function TByteMatrix.Hash: AnsiString; +var + X, Y: Integer; + Counter: Integer; + CC: Integer; +begin + Result := ''; + for Y := 0 to FHeight - 1 do + begin + Counter := 0; + for X := 0 to FWidth - 1 do + begin + CC := Get(X, Y); + if (CC = -1) then CC := 255; + Counter := Counter + CC; + end; + Result := Result + AnsiChar((Counter mod 26) + 65); + end; +end; + +procedure TByteMatrix.SetBoolean(X, Y: Integer; Value: Boolean); +begin + Bytes[Y][X] := Byte(Value) and $FF; +end; + +procedure TByteMatrix.SetInteger(X, Y, Value: Integer); +begin + Bytes[Y][X] := Value and $FF; +end; + +procedure TByteMatrix.Assign(Source: TByteMatrix); +var + SourceLength: Integer; +begin + SourceLength := Length(Source.Bytes); + SetLength(Bytes, SourceLength); + if (SourceLength > 0) then + begin + Move(Source.Bytes[0], Bytes[0], SourceLength); + end; + FWidth := Source.Width; + FHeight := Source.Height; +end; + +{ TEncoder } + +function TEncoder.CalculateMaskPenalty(Matrix: TByteMatrix): Integer; +var + Penalty: Integer; +begin + Penalty := 0; + Inc(Penalty, ApplyMaskPenaltyRule1(Matrix)); + Inc(Penalty, ApplyMaskPenaltyRule2(Matrix)); + Inc(Penalty, ApplyMaskPenaltyRule3(Matrix)); + Inc(Penalty, ApplyMaskPenaltyRule4(Matrix)); + Result := Penalty; +end; + +{procedure TEncoder.Encode(const Content: WideString; ECLevel: TErrorCorrectionLevel; QRCode: TQRCode); +begin + Encode(Content, ECLevel, nil, QRCode); +end;} + +procedure TEncoder.Encode(const Content: WideString; EncodeOptions: Integer; ECLevel: TErrorCorrectionLevel; QRCode: TQRCode); +var + Mode: TMode; + DataBits: TBitArray; + FinalBits: TBitArray; + HeaderBits: TBitArray; + HeaderAndDataBits: TBitArray; + Matrix: TByteMatrix; + NumLetters: Integer; + MatrixUtil: TMatrixUtil; + BitsNeeded: Integer; + ProvisionalBitsNeeded: Integer; + ProvisionalVersion: TVersion; + Version: TVersion; + ECBlocks: TECBlocks; + NumDataBytes: Integer; + Dimension: Integer; + FilteredContent: WideString; +begin + DataBits := TBitArray.Create; + HeaderBits := TBitArray.Create; + + // Pick an encoding mode appropriate for the content. Note that this will not attempt to use + // multiple modes / segments even if that were more efficient. Twould be nice. + // Collect data within the main segment, separately, to count its size if needed. Don't add it to + // main payload yet. + + Mode := ChooseMode(Content, EncodeOptions); + FilteredContent := FilterContent(Content, Mode, EncodeOptions); + AppendBytes(FilteredContent, Mode, DataBits, EncodeOptions); + + // (With ECI in place,) Write the mode marker + AppendModeInfo(Mode, HeaderBits); + + // Hard part: need to know version to know how many bits length takes. But need to know how many + // bits it takes to know version. First we take a guess at version by assuming version will be + // the minimum, 1: + ProvisionalVersion := TVersion.GetVersionForNumber(1); + try + ProvisionalBitsNeeded := HeaderBits.GetSize + + GetModeCharacterCountBits(Mode, ProvisionalVersion) + + DataBits.GetSize; + finally + ProvisionalVersion.Free; + end; + + ProvisionalVersion := TVersion.ChooseVersion(ProvisionalBitsNeeded, ECLevel); + try + // Use that guess to calculate the right version. I am still not sure this works in 100% of cases. + BitsNeeded := HeaderBits.GetSize + + GetModeCharacterCountBits(Mode, ProvisionalVersion) + + DataBits.GetSize; + Version := TVersion.ChooseVersion(BitsNeeded, ECLevel); + finally + ProvisionalVersion.Free; + end; + + HeaderAndDataBits := TBitArray.Create; + FinalBits := TBitArray.Create; + try + HeaderAndDataBits.AppendBitArray(HeaderBits); + + // Find "length" of main segment and write it + if (Mode = qmByte) then + begin + NumLetters := DataBits.GetSizeInBytes; + end else + begin + NumLetters := Length(FilteredContent); + end; + AppendLengthInfo(NumLetters, Version.VersionNumber, Mode, HeaderAndDataBits); + // Put data together into the overall payload + HeaderAndDataBits.AppendBitArray(DataBits); + + ECBlocks := Version.GetECBlocksForLevel(ECLevel); + NumDataBytes := Version.GetTotalCodewords - ECBlocks.GetTotalECCodewords; + + // Terminate the bits properly. + TerminateBits(NumDataBytes, HeaderAndDataBits); + + // Interleave data bits with error correction code. + InterleaveWithECBytes(HeaderAndDataBits, Version.GetTotalCodewords, + NumDataBytes, ECBlocks.GetNumBlocks, FinalBits); + + // QRCode qrCode = new QRCode(); // This is passed in + + + QRCode.SetECLevel(ECLevel); + QRCode.Mode := Mode; + QRCode.Version := Version.VersionNumber; + + // Choose the mask pattern and set to "qrCode". + Dimension := Version.GetDimensionForVersion; + Matrix := TByteMatrix.Create(Dimension, Dimension); + + QRCode.MaskPattern := ChooseMaskPattern(FinalBits, ECLevel, Version.VersionNumber, Matrix); + + Matrix.Free; + Matrix := TByteMatrix.Create(Dimension, Dimension); + + // Build the matrix and set it to "qrCode". + MatrixUtil := TMatrixUtil.Create; + try + MatrixUtil.BuildMatrix(FinalBits, QRCode.ECLevel, QRCode.Version, + QRCode.MaskPattern, Matrix); + finally + MatrixUtil.Free; + end; + + QRCode.SetMatrix(Matrix); // QRCode will free the matrix + finally + DataBits.Free; + HeaderAndDataBits.Free; + FinalBits.Free; + HeaderBits.Free; + Version.Free; + end; +end; + +function TEncoder.FilterContent(const Content: WideString; Mode: TMode; + EncodeOptions: Integer): WideString; +var + X: Integer; + CanAdd: Boolean; +begin + Result := ''; + for X := 1 to Length(Content) do + begin + CanAdd := False; + if (Mode = qmNumeric) then + begin + CanAdd := (Content[X] >= '0') and (Content[X] <= '9'); + end else + if (Mode = qmAlphanumeric) then + begin + CanAdd := GetAlphanumericCode(Ord(Content[X])) > 0; + end else + if (Mode = qmByte) then + begin + if (EncodeOptions = 3) then + begin + CanAdd := Ord(Content[X]) <= $FF; + end else + if ((EncodeOptions = 4) or (EncodeOptions = 5)) then + begin + CanAdd := True; + end; + end; + if (CanAdd) then + begin + Result := Result + Content[X]; + end; + end; +end; + +// Return the code point of the table used in alphanumeric mode or +// -1 if there is no corresponding code in the table. +function TEncoder.GetAlphanumericCode(Code: Integer): Integer; +begin + if (Code < Length(ALPHANUMERIC_TABLE)) then + begin + Result := ALPHANUMERIC_TABLE[Code]; + end else + begin + Result := -1; + end; +end; + +// Choose the mode based on the content +function TEncoder.ChooseMode(const Content: WideString; var EncodeOptions: Integer): TMode; +var + AllNumeric: Boolean; + AllAlphanumeric: Boolean; + AllISO: Boolean; + I: Integer; + C: WideChar; +begin + if (EncodeOptions = 0) then + begin + AllNumeric := Length(Content) > 0; + I := 1; + while (I <= Length(Content)) and (AllNumeric) do + begin + C := Content[I]; + if ((C < '0') or (C > '9')) then + begin + AllNumeric := False; + end else + begin + Inc(I); + end; + end; + + if (not AllNumeric) then + begin + AllAlphanumeric := Length(Content) > 0; + I := 1; + while (I <= Length(Content)) and (AllAlphanumeric) do + begin + C := Content[I]; + if (GetAlphanumericCode(Ord(C)) < 0) then + begin + AllAlphanumeric := False; + end else + begin + Inc(I); + end; + end; + end else + begin + AllAlphanumeric := False; + end; + + if (not AllAlphanumeric) then + begin + AllISO := Length(Content) > 0; + I := 1; + while (I <= Length(Content)) and (AllISO) do + begin + C := Content[I]; + if (Ord(C) > $FF) then + begin + AllISO := False; + end else + begin + Inc(I); + end; + end; + end else + begin + AllISO := False; + end; + + if (AllNumeric) then + begin + Result := qmNumeric; + end else + if (AllAlphanumeric) then + begin + Result := qmAlphanumeric; + end else + if (AllISO) then + begin + Result := qmByte; + EncodeOptions := 3; + end else + begin + Result := qmByte; + EncodeOptions := 4; + end; + end else + if (EncodeOptions = 1) then + begin + Result := qmNumeric; + end else + if (EncodeOptions = 2) then + begin + Result := qmAlphanumeric; + end else + begin + Result := qmByte; + end; +end; + +constructor TEncoder.Create; +begin + FEncoderError := False; +end; + +{function TEncoder.IsOnlyDoubleByteKanji(const Content: WideString): Boolean; +var + I: Integer; + Char1: Integer; +begin + Result := True; + I := 0; + while ((I < Length(Content)) and Result) do + begin + Char1 := Ord(Content[I + 1]); + if (((Char1 < $81) or (Char1 > $9F)) and ((Char1 < $E0) or (Char1 > $EB))) then + begin + Result := False; + end; + end; +end;} + +function TEncoder.ChooseMaskPattern(Bits: TBitArray; ECLevel: TErrorCorrectionLevel; Version: Integer; Matrix: TByteMatrix): Integer; +var + MinPenalty: Integer; + BestMaskPattern: Integer; + MaskPattern: Integer; + MatrixUtil: TMatrixUtil; + Penalty: Integer; +begin + MinPenalty := MaxInt; + BestMaskPattern := -1; + + // We try all mask patterns to choose the best one. + for MaskPattern := 0 to NUM_MASK_PATTERNS - 1 do + begin + MatrixUtil := TMatrixUtil.Create; + try + MatrixUtil.BuildMatrix(Bits, ECLevel, Version, MaskPattern, Matrix); + finally + MatrixUtil.Free; + end; + Penalty := CalculateMaskPenalty(Matrix); + if (Penalty < MinPenalty) then + begin + MinPenalty := Penalty; + BestMaskPattern := MaskPattern; + end; + end; + + Result := BestMaskPattern; +end; + +// Terminate bits as described in 8.4.8 and 8.4.9 of JISX0510:2004 (p.24). +procedure TEncoder.TerminateBits(NumDataBytes: Integer; var Bits: TBitArray); +var + Capacity: Integer; + I: Integer; + NumBitsInLastByte: Integer; + NumPaddingBytes: Integer; +begin + Capacity := NumDataBytes shl 3; + if (Bits.GetSize > Capacity) then + begin + FEncoderError := True; + Exit; + end; + I := 0; + while ((I < 4) and (Bits.GetSize < capacity)) do + begin + Bits.AppendBit(False); + Inc(I); + end; + + // Append termination bits. See 8.4.8 of JISX0510:2004 (p.24) for details. + // If the last byte isn't 8-bit aligned, we'll add padding bits. + NumBitsInLastByte := Bits.GetSize and $07; + if (NumBitsInLastByte > 0) then + begin + for I := numBitsInLastByte to 7 do + begin + Bits.AppendBit(False); + end; + end; + + // If we have more space, we'll fill the space with padding patterns defined in 8.4.9 (p.24). + NumPaddingBytes := NumDataBytes - Bits.GetSizeInBytes; + for I := 0 to NumPaddingBytes - 1 do + begin + if ((I and $01) = 0) then + begin + Bits.AppendBits($EC, 8); + end else + begin + Bits.AppendBits($11, 8); + end; + end; + if (Bits.GetSize <> Capacity) then + begin + FEncoderError := True; + end; +end; + +// Get number of data bytes and number of error correction bytes for block id "blockID". Store +// the result in "numDataBytesInBlock", and "numECBytesInBlock". See table 12 in 8.5.1 of +// JISX0510:2004 (p.30) +procedure TEncoder.GetNumDataBytesAndNumECBytesForBlockID(NumTotalBytes, NumDataBytes, + NumRSBlocks, BlockID: Integer; var NumDataBytesInBlock: TIntegerArray; + var NumECBytesInBlock: TIntegerArray); +var + NumRSBlocksInGroup1: Integer; + NumRSBlocksInGroup2: Integer; + NumTotalBytesInGroup1: Integer; + NumTotalBytesInGroup2: Integer; + NumDataBytesInGroup1: Integer; + NumDataBytesInGroup2: Integer; + NumECBytesInGroup1: Integer; + NumECBytesInGroup2: Integer; +begin + if (BlockID >= NumRSBlocks) then + begin + FEncoderError := True; + Exit; + end; + // numRsBlocksInGroup2 = 196 % 5 = 1 + NumRSBlocksInGroup2 := NumTotalBytes mod NumRSBlocks; + // numRsBlocksInGroup1 = 5 - 1 = 4 + NumRSBlocksInGroup1 := NumRSBlocks - NumRSBlocksInGroup2; + // numTotalBytesInGroup1 = 196 / 5 = 39 + NumTotalBytesInGroup1 := NumTotalBytes div NumRSBlocks; + // numTotalBytesInGroup2 = 39 + 1 = 40 + NumTotalBytesInGroup2 := NumTotalBytesInGroup1 + 1; + // numDataBytesInGroup1 = 66 / 5 = 13 + NumDataBytesInGroup1 := NumDataBytes div NumRSBlocks; + // numDataBytesInGroup2 = 13 + 1 = 14 + NumDataBytesInGroup2 := NumDataBytesInGroup1 + 1; + // numEcBytesInGroup1 = 39 - 13 = 26 + NumECBytesInGroup1 := NumTotalBytesInGroup1 - NumDataBytesInGroup1; + // numEcBytesInGroup2 = 40 - 14 = 26 + NumECBytesInGroup2 := NumTotalBytesInGroup2 - NumDataBytesInGroup2; + // Sanity checks. + // 26 = 26 + if (NumECBytesInGroup1 <> NumECBytesInGroup2) then + begin + FEncoderError := True; + Exit; + end; + // 5 = 4 + 1. + if (NumRSBlocks <> (NumRSBlocksInGroup1 + NumRSBlocksInGroup2)) then + begin + FEncoderError := True; + Exit; + end; + // 196 = (13 + 26) * 4 + (14 + 26) * 1 + if (NumTotalBytes <> + ((NumDataBytesInGroup1 + NumECBytesInGroup1) * NumRsBlocksInGroup1) + + ((NumDataBytesInGroup2 + NumECBytesInGroup2) * NumRsBlocksInGroup2)) then + begin + FEncoderError := True; + Exit; + end; + + if (BlockID < NumRSBlocksInGroup1) then + begin + NumDataBytesInBlock[0] := NumDataBytesInGroup1; + NumECBytesInBlock[0] := numECBytesInGroup1; + end else + begin + NumDataBytesInBlock[0] := NumDataBytesInGroup2; + NumECBytesInBlock[0] := numEcBytesInGroup2; + end; +end; + +// Interleave "bits" with corresponding error correction bytes. On success, store the result in +// "result". The interleave rule is complicated. See 8.6 of JISX0510:2004 (p.37) for details. +procedure TEncoder.InterleaveWithECBytes(Bits: TBitArray; NumTotalBytes, + NumDataBytes, NumRSBlocks: Integer; var Result: TBitArray); +var + DataBytesOffset: Integer; + MaxNumDataBytes: Integer; + MaxNumECBytes: Integer; + Blocks: TObjectList; + NumDataBytesInBlock: TIntegerArray; + NumECBytesInBlock: TIntegerArray; + Size: Integer; + DataBytes: TByteArray; + ECBytes: TByteArray; + I, J: Integer; + BlockPair: TBlockPair; +begin + SetLength(ECBytes, 0); + + // "bits" must have "getNumDataBytes" bytes of data. + if (Bits.GetSizeInBytes <> NumDataBytes) then + begin + FEncoderError := True; + Exit; + end; + + // Step 1. Divide data bytes into blocks and generate error correction bytes for them. We'll + // store the divided data bytes blocks and error correction bytes blocks into "blocks". + DataBytesOffset := 0; + MaxNumDataBytes := 0; + MaxNumEcBytes := 0; + + // Since, we know the number of reedsolmon blocks, we can initialize the vector with the number. + Blocks := TObjectList.Create(True); + try + Blocks.Capacity := NumRSBlocks; + + for I := 0 to NumRSBlocks - 1 do + begin + SetLength(NumDataBytesInBlock, 1); + SetLength(NumECBytesInBlock, 1); + GetNumDataBytesAndNumECBytesForBlockID( + NumTotalBytes, NumDataBytes, NumRSBlocks, I, + NumDataBytesInBlock, NumEcBytesInBlock); + + Size := NumDataBytesInBlock[0]; + SetLength(DataBytes, Size); + Bits.ToBytes(8 * DataBytesOffset, DataBytes, 0, Size); + ECBytes := GenerateECBytes(DataBytes, NumEcBytesInBlock[0]); + BlockPair := TBlockPair.Create(DataBytes, ECBytes); + Blocks.Add(BlockPair); + + MaxNumDataBytes := Max(MaxNumDataBytes, Size); + MaxNumECBytes := Max(MaxNumECBytes, Length(ECBytes)); + Inc(DataBytesOffset, NumDataBytesInBlock[0]); + end; + if (NumDataBytes <> DataBytesOffset) then + begin + FEncoderError := True; + Exit; + end; + + // First, place data blocks. + for I := 0 to MaxNumDataBytes - 1 do + begin + for J := 0 to Blocks.Count - 1 do + begin + DataBytes := TBlockPair(Blocks.Items[J]).GetDataBytes; + if (I < Length(DataBytes)) then + begin + Result.AppendBits(DataBytes[I], 8); + end; + end; + end; + // Then, place error correction blocks. + for I := 0 to MaxNumECBytes - 1 do + begin + for J := 0 to Blocks.Count - 1 do + begin + ECBytes := TBlockPair(Blocks.Items[J]).GetErrorCorrectionBytes; + if (I < Length(ECBytes)) then + begin + Result.AppendBits(ECBytes[I], 8); + end; + end; + end; + finally + Blocks.Free; + end; + if (numTotalBytes <> Result.GetSizeInBytes) then // Should be same. + begin + FEncoderError := True; + Exit; + end; +end; + +function TEncoder.GenerateECBytes(DataBytes: TByteArray; NumECBytesInBlock: Integer): TByteArray; +var + NumDataBytes: Integer; + ToEncode: TIntegerArray; + ReedSolomonEncoder: TReedSolomonEncoder; + I: Integer; + ECBytes: TByteArray; + GenericGF: TGenericGF; +begin + NumDataBytes := Length(DataBytes); + SetLength(ToEncode, NumDataBytes + NumECBytesInBlock); + + for I := 0 to NumDataBytes - 1 do + begin + ToEncode[I] := DataBytes[I] and $FF; + end; + + GenericGF := TGenericGF.CreateQRCodeField256; + try + ReedSolomonEncoder := TReedSolomonEncoder.Create(GenericGF); + try + ReedSolomonEncoder.Encode(ToEncode, NumECBytesInBlock); + finally + ReedSolomonEncoder.Free; + end; + finally + GenericGF.Free; + end; + + SetLength(ECBytes, NumECBytesInBlock); + for I := 0 to NumECBytesInBlock - 1 do + begin + ECBytes[I] := ToEncode[NumDataBytes + I]; + end; + + Result := ECBytes; +end; + +// Append mode info. On success, store the result in "bits". +procedure TEncoder.AppendModeInfo(Mode: TMode; Bits: TBitArray); +begin + Bits.AppendBits(GetModeBits(Mode), 4); +end; + +// Append length info. On success, store the result in "bits". +procedure TEncoder.AppendLengthInfo(NumLetters, VersionNum: Integer; Mode: TMode; Bits: TBitArray); +var + NumBits: Integer; + Version: TVersion; +begin + Version := TVersion.GetVersionForNumber(VersionNum); + try + NumBits := GetModeCharacterCountBits(Mode, Version); + finally + Version.Free; + end; + + if (NumLetters > ((1 shl NumBits) - 1)) then + begin + FEncoderError := True; + Exit; + end; + + Bits.AppendBits(NumLetters, NumBits); +end; + +// Append "bytes" in "mode" mode (encoding) into "bits". On success, store the result in "bits". +procedure TEncoder.AppendBytes(const Content: WideString; Mode: TMode; Bits: TBitArray; EncodeOptions: Integer); +begin + if (Mode = qmNumeric) then + begin + AppendNumericBytes(Content, Bits); + end else + if (Mode = qmAlphanumeric) then + begin + AppendAlphanumericBytes(Content, Bits); + end else + if (Mode = qmByte) then + begin + Append8BitBytes(Content, Bits, EncodeOptions); + end else + if (Mode = qmKanji) then + begin + AppendKanjiBytes(Content, Bits); + end else + begin + FEncoderError := True; + Exit; + end; +end; + +procedure TEncoder.AppendNumericBytes(const Content: WideString; Bits: TBitArray); +var + ContentLength: Integer; + I: Integer; + Num1: Integer; + Num2: Integer; + Num3: Integer; +begin + ContentLength := Length(Content); + I := 0; + while (I < ContentLength) do + begin + Num1 := Ord(Content[I + 0 + 1]) - Ord('0'); + if (I + 2 < ContentLength) then + begin + // Encode three numeric letters in ten bits. + Num2 := Ord(Content[I + 1 + 1]) - Ord('0'); + Num3 := Ord(Content[I + 2 + 1]) - Ord('0'); + Bits.AppendBits(Num1 * 100 + Num2 * 10 + Num3, 10); + Inc(I, 3); + end else + if (I + 1 < ContentLength) then + begin + // Encode two numeric letters in seven bits. + Num2 := Ord(Content[I + 1 + 1]) - Ord('0'); + Bits.AppendBits(Num1 * 10 + Num2, 7); + Inc(I, 2); + end else + begin + // Encode one numeric letter in four bits. + Bits.AppendBits(Num1, 4); + Inc(I); + end; + end; +end; + +procedure TEncoder.AppendAlphanumericBytes(const Content: WideString; Bits: TBitArray); +var + ContentLength: Integer; + I: Integer; + Code1: Integer; + Code2: Integer; +begin + ContentLength := Length(Content); + I := 0; + while (I < ContentLength) do + begin + Code1 := GetAlphanumericCode(Ord(Content[I + 0 + 1])); + if (Code1 = -1) then + begin + FEncoderError := True; + Exit; + end; + if (I + 1 < ContentLength) then + begin + Code2 := GetAlphanumericCode(Ord(Content[I + 1 + 1])); + if (Code2 = -1) then + begin + FEncoderError := True; + Exit; + end; + // Encode two alphanumeric letters in 11 bits. + Bits.AppendBits(Code1 * 45 + Code2, 11); + Inc(I, 2); + end else + begin + // Encode one alphanumeric letter in six bits. + Bits.AppendBits(Code1, 6); + Inc(I); + end; + end; +end; + +procedure TEncoder.Append8BitBytes(const Content: WideString; Bits: TBitArray; EncodeOptions: Integer); +var + Bytes: TByteArray; + I: Integer; + UTF8Version: AnsiString; +begin + SetLength(Bytes, 0); + if (EncodeOptions = 3) then + begin + SetLength(Bytes, Length(Content)); + for I := 1 to Length(Content) do + begin + Bytes[I - 1] := Ord(Content[I]) and $FF; + end; + end else + if (EncodeOptions = 4) then + begin + // Add the UTF-8 BOM + UTF8Version := #$EF#$BB#$BF + UTF8Encode(Content); + SetLength(Bytes, Length(UTF8Version)); + if (Length(UTF8Version) > 0) then + begin + Move(UTF8Version[1], Bytes[0], Length(UTF8Version)); + end; + end else + if (EncodeOptions = 5) then + begin + // No BOM + UTF8Version := UTF8Encode(Content); + SetLength(Bytes, Length(UTF8Version)); + if (Length(UTF8Version) > 0) then + begin + Move(UTF8Version[1], Bytes[0], Length(UTF8Version)); + end; + end; + for I := 0 to Length(Bytes) - 1 do + begin + Bits.AppendBits(Bytes[I], 8); + end; +end; + +procedure TEncoder.AppendKanjiBytes(const Content: WideString; Bits: TBitArray); +var + Bytes: TByteArray; + ByteLength: Integer; + I: Integer; + Byte1: Integer; + Byte2: Integer; + Code: Integer; + Subtracted: Integer; + Encoded: Integer; +begin + SetLength(Bytes, 0); + try + + except + FEncoderError := True; + Exit; + end; + + ByteLength := Length(Bytes); + I := 0; + while (I < ByteLength) do + begin + Byte1 := Bytes[I] and $FF; + Byte2 := Bytes[I + 1] and $FF; + Code := (Byte1 shl 8) or Byte2; + Subtracted := -1; + if ((Code >= $8140) and (Code <= $9ffc)) then + begin + Subtracted := Code - $8140; + end else + if ((Code >= $e040) and (Code <= $ebbf)) then + begin + Subtracted := Code - $c140; + end; + if (Subtracted = -1) then + begin + FEncoderError := True; + Exit; + end; + Encoded := ((Subtracted shr 8) * $c0) + (Subtracted and $ff); + Bits.AppendBits(Encoded, 13); + Inc(I, 2); + end; +end; + +procedure TMatrixUtil.ClearMatrix(Matrix: TByteMatrix); +begin + Matrix.Clear(Byte(-1)); +end; + +constructor TMatrixUtil.Create; +begin + FMatrixUtilError := False; +end; + +// Build 2D matrix of QR Code from "dataBits" with "ecLevel", "version" and "getMaskPattern". On +// success, store the result in "matrix" and return true. +procedure TMatrixUtil.BuildMatrix(DataBits: TBitArray; ECLevel: TErrorCorrectionLevel; + Version, MaskPattern: Integer; Matrix: TByteMatrix); +begin + ClearMatrix(Matrix); + EmbedBasicPatterns(Version, Matrix); + + // Type information appear with any version. + EmbedTypeInfo(ECLevel, MaskPattern, Matrix); + + // Version info appear if version >= 7. + MaybeEmbedVersionInfo(Version, Matrix); + + // Data should be embedded at end. + EmbedDataBits(DataBits, MaskPattern, Matrix); +end; + +// Embed basic patterns. On success, modify the matrix and return true. +// The basic patterns are: +// - Position detection patterns +// - Timing patterns +// - Dark dot at the left bottom corner +// - Position adjustment patterns, if need be +procedure TMatrixUtil.EmbedBasicPatterns(Version: Integer; Matrix: TByteMatrix); +begin + // Let's get started with embedding big squares at corners. + EmbedPositionDetectionPatternsAndSeparators(Matrix); + + // Then, embed the dark dot at the left bottom corner. + EmbedDarkDotAtLeftBottomCorner(Matrix); + + // Position adjustment patterns appear if version >= 2. + MaybeEmbedPositionAdjustmentPatterns(Version, Matrix); + + // Timing patterns should be embedded after position adj. patterns. + EmbedTimingPatterns(Matrix); +end; + +// Embed type information. On success, modify the matrix. +procedure TMatrixUtil.EmbedTypeInfo(ECLevel: TErrorCorrectionLevel; MaskPattern: Integer; Matrix: TByteMatrix); +var + TypeInfoBits: TBitArray; + I: Integer; + Bit: Boolean; + X1, Y1: Integer; + X2, Y2: Integer; +begin + TypeInfoBits := TBitArray.Create; + try + MakeTypeInfoBits(ECLevel, MaskPattern, TypeInfoBits); + + for I := 0 to TypeInfoBits.GetSize - 1 do + begin + // Place bits in LSB to MSB order. LSB (least significant bit) is the last value in + // "typeInfoBits". + Bit := TypeInfoBits.Get(TypeInfoBits.GetSize - 1 - I); + + // Type info bits at the left top corner. See 8.9 of JISX0510:2004 (p.46). + X1 := TYPE_INFO_COORDINATES[I][0]; + Y1 := TYPE_INFO_COORDINATES[I][1]; + Matrix.SetBoolean(X1, Y1, Bit); + + if (I < 8) then + begin + // Right top corner. + X2 := Matrix.Width - I - 1; + Y2 := 8; + Matrix.SetBoolean(X2, Y2, Bit); + end else + begin + // Left bottom corner. + X2 := 8; + Y2 := Matrix.Height - 7 + (I - 8); + Matrix.SetBoolean(X2, Y2, Bit); + end; + end; + finally + TypeInfoBits.Free; + end; +end; + +// Embed version information if need be. On success, modify the matrix and return true. +// See 8.10 of JISX0510:2004 (p.47) for how to embed version information. +procedure TMatrixUtil.MaybeEmbedVersionInfo(Version: Integer; Matrix: TByteMatrix); +var + VersionInfoBits: TBitArray; + I, J: Integer; + BitIndex: Integer; + Bit: Boolean; +begin + if (Version < 7) then + begin + Exit; // Don't need version info. + end; + + VersionInfoBits := TBitArray.Create; + try + MakeVersionInfoBits(Version, VersionInfoBits); + + BitIndex := 6 * 3 - 1; // It will decrease from 17 to 0. + for I := 0 to 5 do + begin + for J := 0 to 2 do + begin + // Place bits in LSB (least significant bit) to MSB order. + Bit := VersionInfoBits.Get(BitIndex); + Dec(BitIndex); + // Left bottom corner. + Matrix.SetBoolean(I, Matrix.Height - 11 + J, Bit); + // Right bottom corner. + Matrix.SetBoolean(Matrix.Height - 11 + J, I, bit); + end; + end; + finally + VersionInfoBits.Free; + end; +end; + +// Embed "dataBits" using "getMaskPattern". On success, modify the matrix and return true. +// For debugging purposes, it skips masking process if "getMaskPattern" is -1. +// See 8.7 of JISX0510:2004 (p.38) for how to embed data bits. +procedure TMatrixUtil.EmbedDataBits(DataBits: TBitArray; MaskPattern: Integer; Matrix: TByteMatrix); +var + BitIndex: Integer; + Direction: Integer; + X, Y, I, XX: Integer; + Bit: Boolean; + MaskUtil: TMaskUtil; +begin + MaskUtil := TMaskUtil.Create; + try + bitIndex := 0; + direction := -1; + // Start from the right bottom cell. + X := Matrix.Width - 1; + Y := Matrix.Height - 1; + while (X > 0) do + begin + // Skip the vertical timing pattern. + if (X = 6) then + begin + Dec(X, 1); + end; + while ((Y >= 0) and (y < Matrix.Height)) do + begin + for I := 0 to 1 do + begin + XX := X - I; + // Skip the cell if it's not empty. + if (not IsEmpty(Matrix.Get(XX, Y))) then + begin + Continue; + end; + + if (BitIndex < DataBits.GetSize) then + begin + Bit := DataBits.Get(BitIndex); + Inc(BitIndex); + end else + begin + // Padding bit. If there is no bit left, we'll fill the left cells with 0, as described + // in 8.4.9 of JISX0510:2004 (p. 24). + Bit := False; + end; + + // Skip masking if mask_pattern is -1. + if (MaskPattern <> -1) then + begin + if (MaskUtil.GetDataMaskBit(MaskPattern, XX, Y)) then + begin + Bit := not Bit; + end; + end; + Matrix.SetBoolean(XX, Y, Bit); + end; + Inc(Y, Direction); + end; + Direction := -Direction; // Reverse the direction. + Inc(Y, Direction); + Dec(X, 2); // Move to the left. + end; + finally + MaskUtil.Free; + end; + + // All bits should be consumed. + if (BitIndex <> DataBits.GetSize()) then + begin + FMatrixUtilError := True; + Exit; + end; +end; + +// Return the position of the most significant bit set (to one) in the "value". The most +// significant bit is position 32. If there is no bit set, return 0. Examples: +// - findMSBSet(0) => 0 +// - findMSBSet(1) => 1 +// - findMSBSet(255) => 8 +function TMatrixUtil.FindMSBSet(Value: Integer): Integer; +var + NumDigits: Integer; +begin + NumDigits := 0; + while (Value <> 0) do + begin + Value := Value shr 1; + Inc(NumDigits); + end; + Result := NumDigits; +end; + +// Calculate BCH (Bose-Chaudhuri-Hocquenghem) code for "value" using polynomial "poly". The BCH +// code is used for encoding type information and version information. +// Example: Calculation of version information of 7. +// f(x) is created from 7. +// - 7 = 000111 in 6 bits +// - f(x) = x^2 + x^1 + x^0 +// g(x) is given by the standard (p. 67) +// - g(x) = x^12 + x^11 + x^10 + x^9 + x^8 + x^5 + x^2 + 1 +// Multiply f(x) by x^(18 - 6) +// - f'(x) = f(x) * x^(18 - 6) +// - f'(x) = x^14 + x^13 + x^12 +// Calculate the remainder of f'(x) / g(x) +// x^2 +// __________________________________________________ +// g(x) )x^14 + x^13 + x^12 +// x^14 + x^13 + x^12 + x^11 + x^10 + x^7 + x^4 + x^2 +// -------------------------------------------------- +// x^11 + x^10 + x^7 + x^4 + x^2 +// +// The remainder is x^11 + x^10 + x^7 + x^4 + x^2 +// Encode it in binary: 110010010100 +// The return value is 0xc94 (1100 1001 0100) +// +// Since all coefficients in the polynomials are 1 or 0, we can do the calculation by bit +// operations. We don't care if cofficients are positive or negative. +function TMatrixUtil.CalculateBCHCode(Value, Poly: Integer): Integer; +var + MSBSetInPoly: Integer; +begin + // If poly is "1 1111 0010 0101" (version info poly), msbSetInPoly is 13. We'll subtract 1 + // from 13 to make it 12. + MSBSetInPoly := FindMSBSet(Poly); + Value := Value shl (MSBSetInPoly - 1); + // Do the division business using exclusive-or operations. + while (FindMSBSet(Value) >= MSBSetInPoly) do + begin + Value := Value xor (Poly shl (FindMSBSet(Value) - MSBSetInPoly)); + end; + // Now the "value" is the remainder (i.e. the BCH code) + Result := Value; +end; + +// Make bit vector of type information. On success, store the result in "bits" and return true. +// Encode error correction level and mask pattern. See 8.9 of +// JISX0510:2004 (p.45) for details. +procedure TMatrixUtil.MakeTypeInfoBits(ECLevel: TErrorCorrectionLevel; MaskPattern: Integer; Bits: TBitArray); +var + TypeInfo: Integer; + BCHCode: Integer; + MaskBits: TBitArray; +begin + if ((MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS)) then + begin + TypeInfo := (ECLevel.Bits shl 3) or MaskPattern; + Bits.AppendBits(TypeInfo, 5); + + BCHCode := CalculateBCHCode(TypeInfo, TYPE_INFO_POLY); + Bits.AppendBits(BCHCode, 10); + + MaskBits := TBitArray.Create; + try + MaskBits.AppendBits(TYPE_INFO_MASK_PATTERN, 15); + Bits.XorOperation(MaskBits); + finally + MaskBits.Free; + end; + + if (Bits.GetSize <> 15) then // Just in case. + begin + FMatrixUtilError := True; + Exit; + end; + end; +end; + +// Make bit vector of version information. On success, store the result in "bits" and return true. +// See 8.10 of JISX0510:2004 (p.45) for details. +procedure TMatrixUtil.MakeVersionInfoBits(Version: Integer; Bits: TBitArray); +var + BCHCode: Integer; +begin + Bits.AppendBits(Version, 6); + BCHCode := CalculateBCHCode(Version, VERSION_INFO_POLY); + Bits.AppendBits(BCHCode, 12); + + if (Bits.GetSize() <> 18) then + begin + FMatrixUtilError := True; + Exit; + end; +end; + +// Check if "value" is empty. +function TMatrixUtil.IsEmpty(Value: Integer): Boolean; +begin + Result := (Value = -1); +end; + +procedure TMatrixUtil.EmbedTimingPatterns(Matrix: TByteMatrix); +var + I: Integer; + Bit: Integer; +begin + // -8 is for skipping position detection patterns (size 7), and two horizontal/vertical + // separation patterns (size 1). Thus, 8 = 7 + 1. + for I := 8 to Matrix.Width - 9 do + begin + Bit := (I + 1) mod 2; + // Horizontal line. + if (IsEmpty(Matrix.Get(I, 6))) then + begin + Matrix.SetInteger(I, 6, Bit); + end; + // Vertical line. + if (IsEmpty(Matrix.Get(6, I))) then + begin + Matrix.SetInteger(6, I, Bit); + end; + end; +end; + +// Embed the lonely dark dot at left bottom corner. JISX0510:2004 (p.46) +procedure TMatrixUtil.EmbedDarkDotAtLeftBottomCorner(Matrix: TByteMatrix); +begin + if (Matrix.Get(8, Matrix.Height - 8) = 0) then + begin + FMatrixUtilError := True; + Exit; + end; + Matrix.SetInteger(8, Matrix.Height - 8, 1); +end; + +procedure TMatrixUtil.EmbedHorizontalSeparationPattern(XStart, YStart: Integer; Matrix: TByteMatrix); +var + X: Integer; +begin + // We know the width and height. + for X := 0 to 7 do + begin + if (not IsEmpty(Matrix.Get(XStart + X, YStart))) then + begin + FMatrixUtilError := True; + Exit; + end; + Matrix.SetInteger(XStart + X, YStart, HORIZONTAL_SEPARATION_PATTERN[0][X]); + end; +end; + +procedure TMatrixUtil.EmbedVerticalSeparationPattern(XStart, YStart: Integer; Matrix: TByteMatrix); +var + Y: Integer; +begin + // We know the width and height. + for Y := 0 to 6 do + begin + if (not IsEmpty(Matrix.Get(XStart, YStart + Y))) then + begin + FMatrixUtilError := True; + Exit; + end; + Matrix.SetInteger(XStart, YStart + Y, VERTICAL_SEPARATION_PATTERN[Y][0]); + end; +end; + +// Note that we cannot unify the function with embedPositionDetectionPattern() despite they are +// almost identical, since we cannot write a function that takes 2D arrays in different sizes in +// C/C++. We should live with the fact. +procedure TMatrixUtil.EmbedPositionAdjustmentPattern(XStart, YStart: Integer; Matrix: TByteMatrix); +var + X, Y: Integer; +begin + // We know the width and height. + for Y := 0 to 4 do + begin + for X := 0 to 4 do + begin + if (not IsEmpty(Matrix.Get(XStart + X, YStart + Y))) then + begin + FMatrixUtilError := True; + Exit; + end; + Matrix.SetInteger(XStart + X, YStart + Y, POSITION_ADJUSTMENT_PATTERN[Y][X]); + end; + end; +end; + +procedure TMatrixUtil.EmbedPositionDetectionPattern(XStart, YStart: Integer; Matrix: TByteMatrix); +var + X, Y: Integer; +begin + // We know the width and height. + for Y := 0 to 6 do + begin + for X := 0 to 6 do + begin + if (not IsEmpty(Matrix.Get(XStart + X, YStart + Y))) then + begin + FMatrixUtilError := True; + Exit; + end; + Matrix.SetInteger(XStart + X, YStart + Y, POSITION_DETECTION_PATTERN[Y][X]); + end; + end; +end; + +// Embed position detection patterns and surrounding vertical/horizontal separators. +procedure TMatrixUtil.EmbedPositionDetectionPatternsAndSeparators(Matrix: TByteMatrix); +var + PDPWidth: Integer; + HSPWidth: Integer; + VSPSize: Integer; +begin + // Embed three big squares at corners. + PDPWidth := Length(POSITION_DETECTION_PATTERN[0]); + // Left top corner. + EmbedPositionDetectionPattern(0, 0, Matrix); + // Right top corner. + EmbedPositionDetectionPattern(Matrix.Width - PDPWidth, 0, Matrix); + // Left bottom corner. + EmbedPositionDetectionPattern(0, Matrix.Width- PDPWidth, Matrix); + + // Embed horizontal separation patterns around the squares. + HSPWidth := Length(HORIZONTAL_SEPARATION_PATTERN[0]); + // Left top corner. + EmbedHorizontalSeparationPattern(0, HSPWidth - 1, Matrix); + // Right top corner. + EmbedHorizontalSeparationPattern(Matrix.Width - HSPWidth, + HSPWidth - 1, Matrix); + // Left bottom corner. + EmbedHorizontalSeparationPattern(0, Matrix.Width - HSPWidth, Matrix); + + // Embed vertical separation patterns around the squares. + VSPSize := Length(VERTICAL_SEPARATION_PATTERN); + // Left top corner. + EmbedVerticalSeparationPattern(VSPSize, 0, Matrix); + // Right top corner. + EmbedVerticalSeparationPattern(Matrix.Height - VSPSize - 1, 0, Matrix); + // Left bottom corner. + EmbedVerticalSeparationPattern(VSPSize, Matrix.Height - VSPSize, Matrix); +end; + +// Embed position adjustment patterns if need be. +procedure TMatrixUtil.MaybeEmbedPositionAdjustmentPatterns(Version: Integer; Matrix: TByteMatrix); +var + Index: Integer; + Coordinates: array of Integer; + NumCoordinates: Integer; + X, Y, I, J: Integer; +begin + if (Version >= 2) then + begin + Index := Version - 1; + NumCoordinates := Length(POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE[Index]); + SetLength(Coordinates, NumCoordinates); + Move(POSITION_ADJUSTMENT_PATTERN_COORDINATE_TABLE[Index][0], Coordinates[0], NumCoordinates * SizeOf(Integer)); + for I := 0 to NumCoordinates - 1 do + begin + for J := 0 to NumCoordinates - 1 do + begin + Y := Coordinates[I]; + X := Coordinates[J]; + if ((X = -1) or (Y = -1)) then + begin + Continue; + end; + // If the cell is unset, we embed the position adjustment pattern here. + if (IsEmpty(Matrix.Get(X, Y))) then + begin + // -2 is necessary since the x/y coordinates point to the center of the pattern, not the + // left top corner. + EmbedPositionAdjustmentPattern(X - 2, Y - 2, Matrix); + end; + end; + end; + end; +end; + + +{ TBitArray } + + +procedure TBitArray.AppendBits(Value, NumBits: Integer); +var + NumBitsLeft: Integer; +begin + if ((NumBits < 0) or (NumBits > 32)) then + begin + + end; + EnsureCapacity(Size + NumBits); + for NumBitsLeft := NumBits downto 1 do + begin + AppendBit(((Value shr (NumBitsLeft - 1)) and $01) = 1); + end; +end; + +constructor TBitArray.Create(Size: Integer); + +begin + Size := Size; + SetLength(Bits, (Size + 31) shr 5); +end; + +constructor TBitArray.Create; +begin + Size := 0; + SetLength(Bits, 1); +end; + +function TBitArray.Get(I: Integer): Boolean; +begin + Result := (Bits[I shr 5] and (1 shl (I and $1F))) <> 0; +end; + +function TBitArray.GetSize: Integer; +begin + Result := Size; +end; + +function TBitArray.GetSizeInBytes: Integer; +begin + Result := (Size + 7) shr 3; +end; + +procedure TBitArray.SetBit(Index: Integer); +begin + Bits[Index shr 5] := Bits[Index shr 5] or (1 shl (Index and $1F)); +end; + +procedure TBitArray.AppendBit(Bit: Boolean); +begin + EnsureCapacity(Size + 1); + if (Bit) then + begin + Bits[Size shr 5] := Bits[Size shr 5] or (1 shl (Size and $1F)); + end; + Inc(Size); +end; + +procedure TBitArray.ToBytes(BitOffset: Integer; Source: TByteArray; Offset, + NumBytes: Integer); +var + I: Integer; + J: Integer; + TheByte: Integer; +begin + for I := 0 to NumBytes - 1 do + begin + TheByte := 0; + for J := 0 to 7 do + begin + if (Get(BitOffset)) then + begin + TheByte := TheByte or (1 shl (7 - J)); + end; + Inc(BitOffset); + end; + Source[Offset + I] := TheByte; + end; +end; + +procedure TBitArray.XorOperation(Other: TBitArray); +var + I: Integer; +begin + if (Length(Bits) = Length(Other.Bits)) then + begin + for I := 0 to Length(Bits) - 1 do + begin + // The last byte could be incomplete (i.e. not have 8 bits in + // it) but there is no problem since 0 XOR 0 == 0. + Bits[I] := Bits[I] xor Other.Bits[I]; + end; + end; +end; + +procedure TBitArray.AppendBitArray(NewBitArray: TBitArray); +var + OtherSize: Integer; + I: Integer; +begin + OtherSize := NewBitArray.GetSize; + EnsureCapacity(Size + OtherSize); + for I := 0 to OtherSize - 1 do + begin + AppendBit(NewBitArray.Get(I)); + end; +end; + +procedure TBitArray.EnsureCapacity(Size: Integer); +begin + if (Size > (Length(Bits) shl 5)) then + begin + SetLength(Bits, Size); + end; +end; + +{ TErrorCorrectionLevel } + +procedure TErrorCorrectionLevel.Assign(Source: TErrorCorrectionLevel); +begin + Self.FBits := Source.FBits; +end; + +function TErrorCorrectionLevel.Ordinal: Integer; +begin + Result := 0; +end; + +{ TVersion } + +class function TVersion.ChooseVersion(NumInputBits: Integer; + ECLevel: TErrorCorrectionLevel): TVersion; +var + VersionNum: Integer; + Version: TVersion; + NumBytes: Integer; + ECBlocks: TECBlocks; + NumECBytes: Integer; + NumDataBytes: Integer; + TotalInputBytes: Integer; +begin + Result := nil; + // In the following comments, we use numbers of Version 7-H. + for VersionNum := 1 to 40 do + begin + Version := TVersion.GetVersionForNumber(VersionNum); + + // numBytes = 196 + NumBytes := Version.GetTotalCodewords; + // getNumECBytes = 130 + ECBlocks := Version.GetECBlocksForLevel(ECLevel); + NumECBytes := ECBlocks.GetTotalECCodewords; + // getNumDataBytes = 196 - 130 = 66 + NumDataBytes := NumBytes - NumECBytes; + TotalInputBytes := (NumInputBits + 7) div 8; + + if (numDataBytes >= totalInputBytes) then + begin + Result := Version; + Exit; + end else + begin + Version.Free; + end; + end; +end; + +constructor TVersion.Create(VersionNumber: Integer; + AlignmentPatternCenters: array of Integer; ECBlocks1, ECBlocks2, ECBlocks3, + ECBlocks4: TECBlocks); +var + Total: Integer; + ECBlock: TECB; + ECBArray: TECBArray; + I: Integer; +begin + Self.VersionNumber := VersionNumber; + SetLength(Self.AlignmentPatternCenters, Length(AlignmentPatternCenters)); + if (Length(AlignmentPatternCenters) > 0) then + begin + Move(AlignmentPatternCenters[0], Self.AlignmentPatternCenters[0], + Length(AlignmentPatternCenters) * SizeOf(Integer)); + end; + SetLength(ECBlocks, 4); + ECBlocks[0] := ECBlocks1; + ECBlocks[1] := ECBlocks2; + ECBlocks[2] := ECBlocks3; + ECBlocks[3] := ECBlocks4; + Total := 0; + ECCodewords := ECBlocks1.GetECCodewordsPerBlock; + ECBArray := ECBlocks1.GetECBlocks; + for I := 0 to Length(ECBArray) - 1 do + begin + ECBlock := ECBArray[I]; + Inc(Total, ECBlock.GetCount * (ECBlock.GetDataCodewords + ECCodewords)); + end; + TotalCodewords := Total; +end; + +destructor TVersion.Destroy; +var + X: Integer; +begin + for X := 0 to Length(ECBlocks) - 1 do + begin + ECBlocks[X].Free; + end; + inherited; +end; + +function TVersion.GetDimensionForVersion: Integer; +begin + Result := 17 + 4 * VersionNumber; +end; + +function TVersion.GetECBlocksForLevel(ECLevel: TErrorCorrectionLevel): TECBlocks; +begin + Result := ECBlocks[ECLevel.Ordinal]; +end; + +function TVersion.GetTotalCodewords: Integer; +begin + Result := TotalCodewords; +end; + +class function TVersion.GetVersionForNumber(VersionNum: Integer): TVersion; +begin + if (VersionNum = 1) then + begin + Result := TVersion.Create(1, [], + TECBlocks.Create(7, TECB.Create(1, 19)), + TECBlocks.Create(10, TECB.Create(1, 16)), + TECBlocks.Create(13, TECB.Create(1, 13)), + TECBlocks.Create(17, TECB.Create(1, 9))); + end else + if (VersionNum = 2) then + begin + Result := TVersion.Create(2, [6, 18], + TECBlocks.Create(10, TECB.Create(1, 34)), + TECBlocks.Create(16, TECB.Create(1, 28)), + TECBlocks.Create(22, TECB.Create(1, 22)), + TECBlocks.Create(28, TECB.Create(1, 16))); + end else + if (VersionNum = 3) then + begin + Result := TVersion.Create(3, [6, 22], + TECBlocks.Create(15, TECB.Create(1, 55)), + TECBlocks.Create(26, TECB.Create(1, 44)), + TECBlocks.Create(18, TECB.Create(2, 17)), + TECBlocks.Create(22, TECB.Create(2, 13))); + end else + if (VersionNum = 4) then + begin + Result := TVersion.Create(4, [6, 26], + TECBlocks.Create(20, TECB.Create(1, 80)), + TECBlocks.Create(18, TECB.Create(2, 32)), + TECBlocks.Create(26, TECB.Create(2, 24)), + TECBlocks.Create(16, TECB.Create(4, 9))); + end else + if (VersionNum = 5) then + begin + Result := TVersion.Create(5, [6, 30], + TECBlocks.Create(26, TECB.Create(1, 108)), + TECBlocks.Create(24, TECB.Create(2, 43)), + TECBlocks.Create(18, TECB.Create(2, 15), + TECB.Create(2, 16)), + TECBlocks.Create(22, TECB.Create(2, 11), + TECB.Create(2, 12))); + end else + if (VersionNum = 6) then + begin + Result := TVersion.Create(6, [6, 34], + TECBlocks.Create(18, TECB.Create(2, 68)), + TECBlocks.Create(16, TECB.Create(4, 27)), + TECBlocks.Create(24, TECB.Create(4, 19)), + TECBlocks.Create(28, TECB.Create(4, 15))); + end else + if (VersionNum = 7) then + begin + Result := TVersion.Create(7, [6, 22, 38], + TECBlocks.Create(20, TECB.Create(2, 78)), + TECBlocks.Create(18, TECB.Create(4, 31)), + TECBlocks.Create(18, TECB.Create(2, 14), + TECB.Create(4, 15)), + TECBlocks.Create(26, TECB.Create(4, 13), + TECB.Create(1, 14))); + end else + if (VersionNum = 8) then + begin + Result := TVersion.Create(8, [6, 24, 42], + TECBlocks.Create(24, TECB.Create(2, 97)), + TECBlocks.Create(22, TECB.Create(2, 38), + TECB.Create(2, 39)), + TECBlocks.Create(22, TECB.Create(4, 18), + TECB.Create(2, 19)), + TECBlocks.Create(26, TECB.Create(4, 14), + TECB.Create(2, 15))); + end else + if (VersionNum = 9) then + begin + Result := TVersion.Create(9, [6, 26, 46], + TECBlocks.Create(30, TECB.Create(2, 116)), + TECBlocks.Create(22, TECB.Create(3, 36), + TECB.Create(2, 37)), + TECBlocks.Create(20, TECB.Create(4, 16), + TECB.Create(4, 17)), + TECBlocks.Create(24, TECB.Create(4, 12), + TECB.Create(4, 13))); + end else + if (VersionNum = 10) then + begin + Result := TVersion.Create(10, [6, 28, 50], + TECBlocks.Create(18, TECB.Create(2, 68), + TECB.Create(2, 69)), + TECBlocks.Create(26, TECB.Create(4, 43), + TECB.Create(1, 44)), + TECBlocks.Create(24, TECB.Create(6, 19), + TECB.Create(2, 20)), + TECBlocks.Create(28, TECB.Create(6, 15), + TECB.Create(2, 16))); + end else + if (VersionNum = 11) then + begin + Result := TVersion.Create(11, [6, 30, 54], + TECBlocks.Create(20, TECB.Create(4, 81)), + TECBlocks.Create(30, TECB.Create(1, 50), + TECB.Create(4, 51)), + TECBlocks.Create(28, TECB.Create(4, 22), + TECB.Create(4, 23)), + TECBlocks.Create(24, TECB.Create(3, 12), + TECB.Create(8, 13))); + end else + if (VersionNum = 12) then + begin + Result := TVersion.Create(12, [6, 32, 58], + TECBlocks.Create(24, TECB.Create(2, 92), + TECB.Create(2, 93)), + TECBlocks.Create(22, TECB.Create(6, 36), + TECB.Create(2, 37)), + TECBlocks.Create(26, TECB.Create(4, 20), + TECB.Create(6, 21)), + TECBlocks.Create(28, TECB.Create(7, 14), + TECB.Create(4, 15))); + end else + if (VersionNum = 13) then + begin + Result := TVersion.Create(13, [6, 34, 62], + TECBlocks.Create(26, TECB.Create(4, 107)), + TECBlocks.Create(22, TECB.Create(8, 37), + TECB.Create(1, 38)), + TECBlocks.Create(24, TECB.Create(8, 20), + TECB.Create(4, 21)), + TECBlocks.Create(22, TECB.Create(12, 11), + TECB.Create(4, 12))); + end else + if (VersionNum = 14) then + begin + Result := TVersion.Create(14, [6, 26, 46, 66], + TECBlocks.Create(30, TECB.Create(3, 115), + TECB.Create(1, 116)), + TECBlocks.Create(24, TECB.Create(4, 40), + TECB.Create(5, 41)), + TECBlocks.Create(20, TECB.Create(11, 16), + TECB.Create(5, 17)), + TECBlocks.Create(24, TECB.Create(11, 12), + TECB.Create(5, 13))); + end else + if (VersionNum = 15) then + begin + Result := TVersion.Create(15, [6, 26, 48, 70], + TECBlocks.Create(22, TECB.Create(5, 87), + TECB.Create(1, 88)), + TECBlocks.Create(24, TECB.Create(5, 41), + TECB.Create(5, 42)), + TECBlocks.Create(30, TECB.Create(5, 24), + TECB.Create(7, 25)), + TECBlocks.Create(24, TECB.Create(11, 12), + TECB.Create(7, 13))); + end else + if (VersionNum = 16) then + begin + Result := TVersion.Create(16, [6, 26, 50, 74], + TECBlocks.Create(24, TECB.Create(5, 98), + TECB.Create(1, 99)), + TECBlocks.Create(28, TECB.Create(7, 45), + TECB.Create(3, 46)), + TECBlocks.Create(24, TECB.Create(15, 19), + TECB.Create(2, 20)), + TECBlocks.Create(30, TECB.Create(3, 15), + TECB.Create(13, 16))); + end else + if (VersionNum = 17) then + begin + Result := TVersion.Create(17, [6, 30, 54, 78], + TECBlocks.Create(28, TECB.Create(1, 107), + TECB.Create(5, 108)), + TECBlocks.Create(28, TECB.Create(10, 46), + TECB.Create(1, 47)), + TECBlocks.Create(28, TECB.Create(1, 22), + TECB.Create(15, 23)), + TECBlocks.Create(28, TECB.Create(2, 14), + TECB.Create(17, 15))); + end else + if (VersionNum = 18) then + begin + Result := TVersion.Create(18, [6, 30, 56, 82], + TECBlocks.Create(30, TECB.Create(5, 120), + TECB.Create(1, 121)), + TECBlocks.Create(26, TECB.Create(9, 43), + TECB.Create(4, 44)), + TECBlocks.Create(28, TECB.Create(17, 22), + TECB.Create(1, 23)), + TECBlocks.Create(28, TECB.Create(2, 14), + TECB.Create(19, 15))); + end else + if (VersionNum = 19) then + begin + Result := TVersion.Create(19, [6, 30, 58, 86], + TECBlocks.Create(28, TECB.Create(3, 113), + TECB.Create(4, 114)), + TECBlocks.Create(26, TECB.Create(3, 44), + TECB.Create(11, 45)), + TECBlocks.Create(26, TECB.Create(17, 21), + TECB.Create(4, 22)), + TECBlocks.Create(26, TECB.Create(9, 13), + TECB.Create(16, 14))); + end else + if (VersionNum = 20) then + begin + Result := TVersion.Create(20, [6, 34, 62, 90], + TECBlocks.Create(28, TECB.Create(3, 107), + TECB.Create(5, 108)), + TECBlocks.Create(26, TECB.Create(3, 41), + TECB.Create(13, 42)), + TECBlocks.Create(30, TECB.Create(15, 24), + TECB.Create(5, 25)), + TECBlocks.Create(28, TECB.Create(15, 15), + TECB.Create(10, 16))); + end else + if (VersionNum = 21) then + begin + Result := TVersion.Create(21, [6, 28, 50, 72, 94], + TECBlocks.Create(28, TECB.Create(4, 116), + TECB.Create(4, 117)), + TECBlocks.Create(26, TECB.Create(17, 42)), + TECBlocks.Create(28, TECB.Create(17, 22), + TECB.Create(6, 23)), + TECBlocks.Create(30, TECB.Create(19, 16), + TECB.Create(6, 17))); + end else + if (VersionNum = 22) then + begin + Result := TVersion.Create(22, [6, 26, 50, 74, 98], + TECBlocks.Create(28, TECB.Create(2, 111), + TECB.Create(7, 112)), + TECBlocks.Create(28, TECB.Create(17, 46)), + TECBlocks.Create(30, TECB.Create(7, 24), + TECB.Create(16, 25)), + TECBlocks.Create(24, TECB.Create(34, 13))); + end else + if (VersionNum = 23) then + begin + Result := TVersion.Create(23, [6, 30, 54, 78, 102], + TECBlocks.Create(30, TECB.Create(4, 121), + TECB.Create(5, 122)), + TECBlocks.Create(28, TECB.Create(4, 47), + TECB.Create(14, 48)), + TECBlocks.Create(30, TECB.Create(11, 24), + TECB.Create(14, 25)), + TECBlocks.Create(30, TECB.Create(16, 15), + TECB.Create(14, 16))); + end else + if (VersionNum = 24) then + begin + Result := TVersion.Create(24, [6, 28, 54, 80, 106], + TECBlocks.Create(30, TECB.Create(6, 117), + TECB.Create(4, 118)), + TECBlocks.Create(28, TECB.Create(6, 45), + TECB.Create(14, 46)), + TECBlocks.Create(30, TECB.Create(11, 24), + TECB.Create(16, 25)), + TECBlocks.Create(30, TECB.Create(30, 16), + TECB.Create(2, 17))); + end else + if (VersionNum = 25) then + begin + Result := TVersion.Create(25, [6, 32, 58, 84, 110], + TECBlocks.Create(26, TECB.Create(8, 106), + TECB.Create(4, 107)), + TECBlocks.Create(28, TECB.Create(8, 47), + TECB.Create(13, 48)), + TECBlocks.Create(30, TECB.Create(7, 24), + TECB.Create(22, 25)), + TECBlocks.Create(30, TECB.Create(22, 15), + TECB.Create(13, 16))); + end else + if (VersionNum = 26) then + begin + Result := TVersion.Create(26, [6, 30, 58, 86, 114], + TECBlocks.Create(28, TECB.Create(10, 114), + TECB.Create(2, 115)), + TECBlocks.Create(28, TECB.Create(19, 46), + TECB.Create(4, 47)), + TECBlocks.Create(28, TECB.Create(28, 22), + TECB.Create(6, 23)), + TECBlocks.Create(30, TECB.Create(33, 16), + TECB.Create(4, 17))); + end else + if (VersionNum = 27) then + begin + Result := TVersion.Create(27, [6, 34, 62, 90, 118], + TECBlocks.Create(30, TECB.Create(8, 122), + TECB.Create(4, 123)), + TECBlocks.Create(28, TECB.Create(22, 45), + TECB.Create(3, 46)), + TECBlocks.Create(30, TECB.Create(8, 23), + TECB.Create(26, 24)), + TECBlocks.Create(30, TECB.Create(12, 15), + TECB.Create(28, 16))); + end else + if (VersionNum = 28) then + begin + Result := TVersion.Create(28, [6, 26, 50, 74, 98, 122], + TECBlocks.Create(30, TECB.Create(3, 117), + TECB.Create(10, 118)), + TECBlocks.Create(28, TECB.Create(3, 45), + TECB.Create(23, 46)), + TECBlocks.Create(30, TECB.Create(4, 24), + TECB.Create(31, 25)), + TECBlocks.Create(30, TECB.Create(11, 15), + TECB.Create(31, 16))); + end else + if (VersionNum = 29) then + begin + Result := TVersion.Create(29, [6, 30, 54, 78, 102, 126], + TECBlocks.Create(30, TECB.Create(7, 116), + TECB.Create(7, 117)), + TECBlocks.Create(28, TECB.Create(21, 45), + TECB.Create(7, 46)), + TECBlocks.Create(30, TECB.Create(1, 23), + TECB.Create(37, 24)), + TECBlocks.Create(30, TECB.Create(19, 15), + TECB.Create(26, 16))); + end else + if (VersionNum = 30) then + begin + Result := TVersion.Create(30, [6, 26, 52, 78, 104, 130], + TECBlocks.Create(30, TECB.Create(5, 115), + TECB.Create(10, 116)), + TECBlocks.Create(28, TECB.Create(19, 47), + TECB.Create(10, 48)), + TECBlocks.Create(30, TECB.Create(15, 24), + TECB.Create(25, 25)), + TECBlocks.Create(30, TECB.Create(23, 15), + TECB.Create(25, 16))); + end else + if (VersionNum = 31) then + begin + Result := TVersion.Create(31, [6, 30, 56, 82, 108, 134], + TECBlocks.Create(30, TECB.Create(13, 115), + TECB.Create(3, 116)), + TECBlocks.Create(28, TECB.Create(2, 46), + TECB.Create(29, 47)), + TECBlocks.Create(30, TECB.Create(42, 24), + TECB.Create(1, 25)), + TECBlocks.Create(30, TECB.Create(23, 15), + TECB.Create(28, 16))); + end else + if (VersionNum = 32) then + begin + Result := TVersion.Create(32, [6, 34, 60, 86, 112, 138], + TECBlocks.Create(30, TECB.Create(17, 115)), + TECBlocks.Create(28, TECB.Create(10, 46), + TECB.Create(23, 47)), + TECBlocks.Create(30, TECB.Create(10, 24), + TECB.Create(35, 25)), + TECBlocks.Create(30, TECB.Create(19, 15), + TECB.Create(35, 16))); + end else + if (VersionNum = 33) then + begin + Result := TVersion.Create(33, [6, 30, 58, 86, 114, 142], + TECBlocks.Create(30, TECB.Create(17, 115), + TECB.Create(1, 116)), + TECBlocks.Create(28, TECB.Create(14, 46), + TECB.Create(21, 47)), + TECBlocks.Create(30, TECB.Create(29, 24), + TECB.Create(19, 25)), + TECBlocks.Create(30, TECB.Create(11, 15), + TECB.Create(46, 16))); + end else + if (VersionNum = 34) then + begin + Result := TVersion.Create(34, [6, 34, 62, 90, 118, 146], + TECBlocks.Create(30, TECB.Create(13, 115), + TECB.Create(6, 116)), + TECBlocks.Create(28, TECB.Create(14, 46), + TECB.Create(23, 47)), + TECBlocks.Create(30, TECB.Create(44, 24), + TECB.Create(7, 25)), + TECBlocks.Create(30, TECB.Create(59, 16), + TECB.Create(1, 17))); + end else + if (VersionNum = 35) then + begin + Result := TVersion.Create(35, [6, 30, 54, 78, 102, 126, 150], + TECBlocks.Create(30, TECB.Create(12, 121), + TECB.Create(7, 122)), + TECBlocks.Create(28, TECB.Create(12, 47), + TECB.Create(26, 48)), + TECBlocks.Create(30, TECB.Create(39, 24), + TECB.Create(14, 25)), + TECBlocks.Create(30, TECB.Create(22, 15), + TECB.Create(41, 16))); + end else + if (VersionNum = 36) then + begin + Result := TVersion.Create(36, [6, 24, 50, 76, 102, 128, 154], + TECBlocks.Create(30, TECB.Create(6, 121), + TECB.Create(14, 122)), + TECBlocks.Create(28, TECB.Create(6, 47), + TECB.Create(34, 48)), + TECBlocks.Create(30, TECB.Create(46, 24), + TECB.Create(10, 25)), + TECBlocks.Create(30, TECB.Create(2, 15), + TECB.Create(64, 16))); + end else + if (VersionNum = 37) then + begin + Result := TVersion.Create(37, [6, 28, 54, 80, 106, 132, 158], + TECBlocks.Create(30, TECB.Create(17, 122), + TECB.Create(4, 123)), + TECBlocks.Create(28, TECB.Create(29, 46), + TECB.Create(14, 47)), + TECBlocks.Create(30, TECB.Create(49, 24), + TECB.Create(10, 25)), + TECBlocks.Create(30, TECB.Create(24, 15), + TECB.Create(46, 16))); + end else + if (VersionNum = 38) then + begin + Result := TVersion.Create(38, [6, 32, 58, 84, 110, 136, 162], + TECBlocks.Create(30, TECB.Create(4, 122), + TECB.Create(18, 123)), + TECBlocks.Create(28, TECB.Create(13, 46), + TECB.Create(32, 47)), + TECBlocks.Create(30, TECB.Create(48, 24), + TECB.Create(14, 25)), + TECBlocks.Create(30, TECB.Create(42, 15), + TECB.Create(32, 16))); + end else + if (VersionNum = 39) then + begin + Result := TVersion.Create(39, [6, 26, 54, 82, 110, 138, 166], + TECBlocks.Create(30, TECB.Create(20, 117), + TECB.Create(4, 118)), + TECBlocks.Create(28, TECB.Create(40, 47), + TECB.Create(7, 48)), + TECBlocks.Create(30, TECB.Create(43, 24), + TECB.Create(22, 25)), + TECBlocks.Create(30, TECB.Create(10, 15), + TECB.Create(67, 16))); + end else + if (VersionNum = 40) then + begin + Result := TVersion.Create(40, [6, 30, 58, 86, 114, 142, 170], + TECBlocks.Create(30, TECB.Create(19, 118), + TECB.Create(6, 119)), + TECBlocks.Create(28, TECB.Create(18, 47), + TECB.Create(31, 48)), + TECBlocks.Create(30, TECB.Create(34, 24), + TECB.Create(34, 25)), + TECBlocks.Create(30, TECB.Create(20, 15), + TECB.Create(61, 16))); + end else + begin + Result := nil; + end; +end; + +{ TMaskUtil } + +// Return the mask bit for "getMaskPattern" at "x" and "y". See 8.8 of JISX0510:2004 for mask +// pattern conditions. +function TMaskUtil.GetDataMaskBit(MaskPattern, X, Y: Integer): Boolean; +var + Intermediate: Integer; + Temp: Integer; +begin + Intermediate := 0; + if ((MaskPattern >= 0) and (MaskPattern < NUM_MASK_PATTERNS)) then + begin + case (maskPattern) of + 0: Intermediate := (Y + X) and 1; + 1: Intermediate := Y and 1; + 2: Intermediate := X mod 3; + 3: Intermediate := (Y + X) mod 3; + 4: Intermediate := ((y shr 1) + (X div 3)) and 1; + 5: + begin + Temp := Y * X; + Intermediate := (Temp and 1) + (Temp mod 3); + end; + 6: + begin + Temp := Y * X; + Intermediate := ((Temp and 1) + (Temp mod 3)) and 1; + end; + 7: + begin + Temp := Y * X; + Intermediate := ((temp mod 3) + ((Y + X) and 1)) and 1; + end; + end; + end; + Result := Intermediate = 0; +end; + +{ TECBlocks } + +constructor TECBlocks.Create(ECCodewordsPerBlock: Integer; ECBlocks: TECB); +begin + Self.ECCodewordsPerBlock := ECCodewordsPerBlock; + SetLength(Self.ECBlocks, 1); + Self.ECBlocks[0] := ECBlocks; +end; + +constructor TECBlocks.Create(ECCodewordsPerBlock: Integer; ECBlocks1, + ECBlocks2: TECB); +begin + Self.ECCodewordsPerBlock := ECCodewordsPerBlock; + SetLength(Self.ECBlocks, 2); + ECBlocks[0] := ECBlocks1; + ECBlocks[1] := ECBlocks2; +end; + +destructor TECBlocks.Destroy; +var + X: Integer; +begin + for X := 0 to Length(ECBlocks) - 1 do + begin + ECBlocks[X].Free; + end; + inherited; +end; + +function TECBlocks.GetECBlocks: TECBArray; +begin + Result := ECBlocks; +end; + +function TECBlocks.GetECCodewordsPerBlock: Integer; +begin + Result := ECCodewordsPerBlock; +end; + +function TECBlocks.GetNumBlocks: Integer; +var + Total: Integer; + I: Integer; +begin + Total := 0; + for I := 0 to Length(ECBlocks) - 1 do + begin + Inc(Total, ECBlocks[I].GetCount); + end; + Result := Total; +end; + +function TECBlocks.GetTotalECCodewords: Integer; +begin + Result := ECCodewordsPerBlock * GetNumBlocks; +end; + +{ TBlockPair } + +constructor TBlockPair.Create(BA1, BA2: TByteArray); +begin + FDataBytes := BA1; + FErrorCorrectionBytes := BA2; +end; + +function TBlockPair.GetDataBytes: TByteArray; +begin + Result := FDataBytes; +end; + +function TBlockPair.GetErrorCorrectionBytes: TByteArray; +begin + Result := FErrorCorrectionBytes; +end; + +{ TReedSolomonEncoder } + +function TReedSolomonEncoder.BuildGenerator(Degree: Integer): TGenericGFPoly; +var + LastGenerator: TGenericGFPoly; + NextGenerator: TGenericGFPoly; + Poly: TGenericGFPoly; + D: Integer; + CA: TIntegerArray; +begin + if (Degree >= FCachedGenerators.Count) then + begin + LastGenerator := TGenericGFPoly(FCachedGenerators[FCachedGenerators.Count - 1]); + + for D := FCachedGenerators.Count to Degree do + begin + SetLength(CA, 2); + CA[0] := 1; + CA[1] := FField.Exp(D - 1 + FField.GetGeneratorBase); + Poly := TGenericGFPoly.Create(FField, CA); + NextGenerator := LastGenerator.Multiply(Poly); + FCachedGenerators.Add(NextGenerator); + LastGenerator := NextGenerator; + end; + end; + Result := TGenericGFPoly(FCachedGenerators[Degree]); +end; + +constructor TReedSolomonEncoder.Create(AField: TGenericGF); +var + GenericGFPoly: TGenericGFPoly; + IntArray: TIntegerArray; +begin + FField := AField; + + // Contents of FCachedGenerators will be freed by FGenericGF.Destroy + FCachedGenerators := TObjectList.Create(False); + + SetLength(IntArray, 1); + IntArray[0] := 1; + GenericGFPoly := TGenericGFPoly.Create(AField, IntArray); + FCachedGenerators.Add(GenericGFPoly); +end; + +destructor TReedSolomonEncoder.Destroy; +begin + FCachedGenerators.Free; + inherited; +end; + +procedure TReedSolomonEncoder.Encode(ToEncode: TIntegerArray; ECBytes: Integer); +var + DataBytes: Integer; + Generator: TGenericGFPoly; + InfoCoefficients: TIntegerArray; + Info: TGenericGFPoly; + Remainder: TGenericGFPoly; + Coefficients: TIntegerArray; + NumZeroCoefficients: Integer; + I: Integer; +begin + SetLength(Coefficients, 0); + if (ECBytes > 0) then + begin + DataBytes := Length(ToEncode) - ECBytes; + if (DataBytes > 0) then + begin + Generator := BuildGenerator(ECBytes); + SetLength(InfoCoefficients, DataBytes); + InfoCoefficients := Copy(ToEncode, 0, DataBytes); + Info := TGenericGFPoly.Create(FField, InfoCoefficients); + Info := Info.MultiplyByMonomial(ECBytes, 1); + Remainder := Info.Divide(Generator)[1]; + Coefficients := Remainder.GetCoefficients; + NumZeroCoefficients := ECBytes - Length(Coefficients); + for I := 0 to NumZeroCoefficients - 1 do + begin + ToEncode[DataBytes + I] := 0; + end; + Move(Coefficients[0], ToEncode[DataBytes + NumZeroCoefficients], Length(Coefficients) * SizeOf(Integer)); + end; + end; +end; + +{ TECB } + +constructor TECB.Create(Count, DataCodewords: Integer); +begin + Self.Count := Count; + Self.DataCodewords := DataCodewords; +end; + +function TECB.GetCount: Integer; +begin + Result := Count; +end; + +function TECB.GetDataCodewords: Integer; +begin + Result := DataCodewords; +end; + +{ TGenericGFPoly } + +function TGenericGFPoly.AddOrSubtract(Other: TGenericGFPoly): TGenericGFPoly; +var + SmallerCoefficients: TIntegerArray; + LargerCoefficients: TIntegerArray; + Temp: TIntegerArray; + SumDiff: TIntegerArray; + LengthDiff: Integer; + I: Integer; +begin + SetLength(SmallerCoefficients, 0); + SetLength(LargerCoefficients, 0); + SetLength(Temp, 0); + SetLength(SumDiff, 0); + + Result := nil; + if (Assigned(Other)) then + begin + if (FField = Other.FField) then + begin + if (IsZero) then + begin + Result := Other; + Exit; + end; + + if (Other.IsZero) then + begin + Result := Self; + Exit; + end; + + SmallerCoefficients := FCoefficients; + LargerCoefficients := Other.Coefficients; + if (Length(SmallerCoefficients) > Length(LargerCoefficients)) then + begin + Temp := smallerCoefficients; + SmallerCoefficients := LargerCoefficients; + LargerCoefficients := temp; + end; + SetLength(SumDiff, Length(LargerCoefficients)); + LengthDiff := Length(LargerCoefficients) - Length(SmallerCoefficients); + + // Copy high-order terms only found in higher-degree polynomial's coefficients + if (LengthDiff > 0) then + begin + //SumDiff := Copy(LargerCoefficients, 0, LengthDiff); + Move(LargerCoefficients[0], SumDiff[0], LengthDiff * SizeOf(Integer)); + end; + + for I := LengthDiff to Length(LargerCoefficients) - 1 do + begin + SumDiff[I] := TGenericGF.AddOrSubtract(SmallerCoefficients[I - LengthDiff], LargerCoefficients[I]); + end; + + Result := TGenericGFPoly.Create(FField, SumDiff); + end; + end; +end; + +function TGenericGFPoly.Coefficients: TIntegerArray; +begin + Result := FCoefficients; +end; + +constructor TGenericGFPoly.Create(AField: TGenericGF; + ACoefficients: TIntegerArray); +var + CoefficientsLength: Integer; + FirstNonZero: Integer; +begin + FField := AField; + SetLength(FField.FPolyList, Length(FField.FPolyList) + 1); + FField.FPolyList[Length(FField.FPolyList) - 1] := Self; + CoefficientsLength := Length(ACoefficients); + if ((CoefficientsLength > 1) and (ACoefficients[0] = 0)) then + begin + // Leading term must be non-zero for anything except the constant polynomial "0" + FirstNonZero := 1; + while ((FirstNonZero < CoefficientsLength) and (ACoefficients[FirstNonZero] = 0)) do + begin + Inc(FirstNonZero); + end; + + if (FirstNonZero = CoefficientsLength) then + begin + FCoefficients := AField.GetZero.Coefficients; + end else + begin + SetLength(FCoefficients, CoefficientsLength - FirstNonZero); + FCoefficients := Copy(ACoefficients, FirstNonZero, Length(FCoefficients)); + end; + end else + begin + FCoefficients := ACoefficients; + end; +end; + +destructor TGenericGFPoly.Destroy; +begin + Self.FField := FField; + inherited; +end; + +function TGenericGFPoly.Divide(Other: TGenericGFPoly): TGenericGFPolyArray; +var + Quotient: TGenericGFPoly; + Remainder: TGenericGFPoly; + DenominatorLeadingTerm: Integer; + InverseDenominatorLeadingTerm: integer; + DegreeDifference: Integer; + Scale: Integer; + Term: TGenericGFPoly; + IterationQuotient: TGenericGFPoly; +begin + SetLength(Result, 0); + if ((FField = Other.FField) and (not Other.IsZero)) then + begin + + Quotient := FField.GetZero; + Remainder := Self; + + DenominatorLeadingTerm := Other.GetCoefficient(Other.GetDegree); + InverseDenominatorLeadingTerm := FField.Inverse(DenominatorLeadingTerm); + + while ((Remainder.GetDegree >= Other.GetDegree) and (not Remainder.IsZero)) do + begin + DegreeDifference := Remainder.GetDegree - Other.GetDegree; + Scale := FField.Multiply(Remainder.GetCoefficient(Remainder.GetDegree), InverseDenominatorLeadingTerm); + Term := Other.MultiplyByMonomial(DegreeDifference, Scale); + IterationQuotient := FField.BuildMonomial(degreeDifference, scale); + Quotient := Quotient.AddOrSubtract(IterationQuotient); + Remainder := Remainder.AddOrSubtract(Term); + end; + + SetLength(Result, 2); + Result[0] := Quotient; + Result[1] := Remainder; + end; +end; + +function TGenericGFPoly.GetCoefficient(Degree: Integer): Integer; +begin + Result := FCoefficients[Length(FCoefficients) - 1 - Degree]; +end; + +function TGenericGFPoly.GetCoefficients: TIntegerArray; +begin + Result := FCoefficients; +end; + +function TGenericGFPoly.GetDegree: Integer; +begin + Result := Length(FCoefficients) - 1; +end; + +function TGenericGFPoly.IsZero: Boolean; +begin + Result := FCoefficients[0] = 0; +end; + +function TGenericGFPoly.Multiply(Other: TGenericGFPoly): TGenericGFPoly; +var + ACoefficients: TIntegerArray; + BCoefficients: TIntegerArray; + Product: TIntegerArray; + ALength: Integer; + BLength: Integer; + I: Integer; + J: Integer; + ACoeff: Integer; +begin + SetLength(ACoefficients, 0); + SetLength(BCoefficients, 0); + Result := nil; + + if (FField = Other.FField) then + begin + if (IsZero or Other.IsZero) then + begin + Result := FField.GetZero; + Exit; + end; + + ACoefficients := FCoefficients; + ALength := Length(ACoefficients); + BCoefficients := Other.Coefficients; + BLength := Length(BCoefficients); + SetLength(Product, aLength + bLength - 1); + for I := 0 to ALength - 1 do + begin + ACoeff := ACoefficients[I]; + for J := 0 to BLength - 1 do + begin + Product[I + J] := TGenericGF.AddOrSubtract(Product[I + J], + FField.Multiply(ACoeff, BCoefficients[J])); + end; + end; + Result := TGenericGFPoly.Create(FField, Product); + end; +end; + +function TGenericGFPoly.MultiplyByMonomial(Degree, + Coefficient: Integer): TGenericGFPoly; +var + I: Integer; + Size: Integer; + Product: TIntegerArray; +begin + Result := nil; + if (Degree >= 0) then + begin + if (Coefficient = 0) then + begin + Result := FField.GetZero; + Exit; + end; + Size := Length(Coefficients); + SetLength(Product, Size + Degree); + for I := 0 to Size - 1 do + begin + Product[I] := FField.Multiply(FCoefficients[I], Coefficient); + end; + Result := TGenericGFPoly.Create(FField, Product); + end; +end; + +{ TGenericGF } + +class function TGenericGF.AddOrSubtract(A, B: Integer): Integer; +begin + Result := A xor B; +end; + +function TGenericGF.BuildMonomial(Degree, Coefficient: Integer): TGenericGFPoly; +var + Coefficients: TIntegerArray; +begin + CheckInit(); + + if (Degree >= 0) then + begin + if (Coefficient = 0) then + begin + Result := FZero; + Exit; + end; + SetLength(Coefficients, Degree + 1); + Coefficients[0] := Coefficient; + Result := TGenericGFPoly.Create(Self, Coefficients); + end else + begin + Result := nil; + end; +end; + +procedure TGenericGF.CheckInit; +begin + if (not FInitialized) then + begin + Initialize; + end; +end; + +constructor TGenericGF.Create(Primitive, Size, B: Integer); +begin + FInitialized := False; + FPrimitive := Primitive; + FSize := Size; + FGeneratorBase := B; + if (FSize < 0) then + begin + Initialize; + end; +end; + +class function TGenericGF.CreateQRCodeField256: TGenericGF; +begin + Result := TGenericGF.Create($011D, 256, 0); +end; + +destructor TGenericGF.Destroy; +var + X: Integer; + Y: Integer; +begin + for X := 0 to Length(FPolyList) - 1 do + begin + if (Assigned(FPolyList[X])) then + begin + for Y := X + 1 to Length(FPolyList) - 1 do + begin + if (FPolyList[Y] = FPolyList[X]) then + begin + FPolyList[Y] := nil; + end; + end; + FPolyList[X].Free; + end; + end; + inherited; +end; + +function TGenericGF.Exp(A: Integer): Integer; +begin + CheckInit; + Result := FExpTable[A]; +end; + +function TGenericGF.GetGeneratorBase: Integer; +begin + Result := FGeneratorBase; +end; + +function TGenericGF.GetZero: TGenericGFPoly; +begin + CheckInit; + Result := FZero; +end; + +procedure TGenericGF.Initialize; +var + X: Integer; + I: Integer; + CA: TIntegerArray; +begin + SetLength(FExpTable, FSize); + SetLength(FLogTable, FSize); + X := 1; + for I := 0 to FSize - 1 do + begin + FExpTable[I] := x; + X := X shl 1; // x = x * 2; we're assuming the generator alpha is 2 + if (X >= FSize) then + begin + X := X xor FPrimitive; + X := X and (FSize - 1); + end; + end; + + for I := 0 to FSize - 2 do + begin + FLogTable[FExpTable[I]] := I; + end; + + // logTable[0] == 0 but this should never be used + + SetLength(CA, 1); + CA[0] := 0; + FZero := TGenericGFPoly.Create(Self, CA); + + SetLength(CA, 1); + CA[0] := 1; + FOne := TGenericGFPoly.Create(Self, CA); + + FInitialized := True; +end; + +function TGenericGF.Inverse(A: Integer): Integer; +begin + CheckInit; + + if (a <> 0) then + begin + Result := FExpTable[FSize - FLogTable[A] - 1]; + end else + begin + Result := 0; + end; +end; + +function TGenericGF.Multiply(A, B: Integer): Integer; +begin + CheckInit; + if ((A <> 0) and (B <> 0)) then + begin + Result := FExpTable[(FLogTable[A] + FLogTable[B]) mod (FSize - 1)]; + end else + begin + Result := 0; + end; +end; + +function GenerateQRCode(const Input: WideString; EncodeOptions: Integer): T2DBooleanArray; +var + Encoder: TEncoder; + Level: TErrorCorrectionLevel; + QRCode: TQRCode; + X: Integer; + Y: Integer; +begin + Level := TErrorCorrectionLevel.Create; + Level.FBits := 1; + Encoder := TEncoder.Create; + QRCode := TQRCode.Create; + try + Encoder.Encode(Input, EncodeOptions, Level, QRCode); + if (Assigned(QRCode.FMatrix)) then + begin + SetLength(Result, QRCode.FMatrix.FHeight); + for Y := 0 to QRCode.FMatrix.FHeight - 1 do + begin + SetLength(Result[Y], QRCode.FMatrix.FWidth); + for X := 0 to QRCode.FMatrix.FWidth - 1 do + begin + Result[Y][X] := QRCode.FMatrix.Get(Y, X) = 1; + end; + end; + end; + finally + QRCode.Free; + Encoder.Free; + Level.Free; + end; +end; + +{ TDelphiZXingQRCode } + +constructor TDelphiZXingQRCode.Create; +begin + FData := ''; + FEncoding := qrAuto; + FQuietZone := 4; + FRows := 0; + FColumns := 0; +end; + +function TDelphiZXingQRCode.GetIsBlack(Row, Column: Integer): Boolean; +begin + Dec(Row, FQuietZone); + Dec(Column, FQuietZone); + if ((Row >= 0) and (Column >= 0) and (Row < (FRows - FQuietZone * 2)) and (Column < (FColumns - FQuietZone * 2))) then + begin + Result := FElements[Column, Row]; + end else + begin + Result := False; + end; +end; + +procedure TDelphiZXingQRCode.SetData(const NewData: WideString); +begin + if (FData <> NewData) then + begin + FData := NewData; + Update; + end; +end; + +procedure TDelphiZXingQRCode.SetEncoding(NewEncoding: TQRCodeEncoding); +begin + if (FEncoding <> NewEncoding) then + begin + FEncoding := NewEncoding; + Update; + end; +end; + +procedure TDelphiZXingQRCode.SetQuietZone(NewQuietZone: Integer); +begin + if ((FQuietZone <> NewQuietZone) and (NewQuietZone >= 0) and (NewQuietZone <= 100)) then + begin + FQuietZone := NewQuietZone; + Update; + end; +end; + +procedure TDelphiZXingQRCode.Update; +begin + FElements := GenerateQRCode(FData, Ord(FEncoding)); + FRows := Length(FElements) + FQuietZone * 2; + FColumns := FRows; +end; + +end. \ No newline at end of file diff --git a/Tocsg.Lib/VCL/Other/EM.Dnsapi.pas b/Tocsg.Lib/VCL/Other/EM.Dnsapi.pas new file mode 100644 index 00000000..43b66573 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.Dnsapi.pas @@ -0,0 +1,526 @@ +unit EM.Dnsapi; + +interface + +uses windows,sysutils,winsock; + +const + DNS_UPDATE_SECURITY_USE_DEFAULT = 0; + DNS_UPDATE_SECURITY_OFF =$10; + DNS_UPDATE_SECURITY_ON =$20; + DNS_UPDATE_SECURITY_ONLY=$100; +//autres + DNS_ATMA_MAX_ADDR_LENGTH = 20; + DNS_ATMA_AESA_ADDR_LENGTH = 20; + + /// Various DNS record types + DNS_TYPE_A = $0001; // 1 + DNS_TYPE_NS = $0002; // 2 + DNS_TYPE_MD = $0003; // 3 + DNS_TYPE_MF = $0004; // 4 + DNS_TYPE_CNAME = $0005; // 5 + DNS_TYPE_SOA = $0006; // 6 + DNS_TYPE_MB = $0007; // 7 + DNS_TYPE_MG = $0008; // 8 + DNS_TYPE_MR = $0009; // 9 + DNS_TYPE_NULL = $000a; // 10 + DNS_TYPE_WKS = $000b; // 11 + DNS_TYPE_PTR = $000c; // 12 + DNS_TYPE_HINFO = $000d; // 13 + DNS_TYPE_MINFO = $000e; // 14 + DNS_TYPE_MX = $000f; // 15 + DNS_TYPE_TEXT = $0010; // 16 + DNS_TYPE_RP = $0011; + DNS_TYPE_AFSDB = $0012; + DNS_TYPE_X25 = $0013 ; + DNS_TYPE_ISDN = $0014 ; + DNS_TYPE_RT = $0015 ; + DNS_TYPE_NSAP = $0016 ; + DNS_TYPE_NSAPPTR = $0017 ; + DNS_TYPE_SIG = $0018 ; + DNS_TYPE_KEY = $0019 ; + DNS_TYPE_PX = $001a ; + DNS_TYPE_GPOS = $001b ; + DNS_TYPE_AAAA = $001c ; + DNS_TYPE_LOC = $001d ; + DNS_TYPE_NXT = $001e ; + DNS_TYPE_EID = $001f ; + DNS_TYPE_NIMLOC = $0020 ; + DNS_TYPE_SRV = $0021 ; + DNS_TYPE_ATMA = $0022 ; + DNS_TYPE_NAPTR = $0023 ; + DNS_TYPE_KX = $0024 ; + DNS_TYPE_CERT = $0025 ; + DNS_TYPE_A6 = $0026 ; + DNS_TYPE_DNAME = $0027 ; + DNS_TYPE_SINK = $0028 ; + DNS_TYPE_OPT = $0029 ; + DNS_TYPE_DS = $002B ; + DNS_TYPE_RRSIG = $002E ; + DNS_TYPE_NSEC = $002F ; + DNS_TYPE_DNSKEY = $0030 ; + DNS_TYPE_DHCID = $0031 ; + DNS_TYPE_UINFO = $0064 ; + DNS_TYPE_UID = $0065 ; + DNS_TYPE_GID = $0066 ; + DNS_TYPE_UNSPEC = $0067 ; + DNS_TYPE_ADDRS = $00f8 ; + DNS_TYPE_TKEY = $00f9 ; + DNS_TYPE_TSIG = $00fa ; + DNS_TYPE_IXFR = $00fb ; + DNS_TYPE_AXFR = $00fc ; + DNS_TYPE_MAILB = $00fd ; + DNS_TYPE_MAILA = $00fe ; + DNS_TYPE_ALL = $00ff ; + DNS_TYPE_ANY = $00ff ; + DNS_TYPE_WINS = $ff01 ; + DNS_TYPE_WINSR = $ff02 ; + DNS_TYPE_NBSTAT= DNS_TYPE_WINSR; + +type + IP6_ADDRESS = array[0..3] of dword; + IP4_ADDRESS = DWORD; + DNS_A_DATA = IP4_ADDRESS; + DNS_PTR_DATA = PChar; + DNS_PTR_DATAA = DNS_PTR_DATA; + DNS_PTR_DATAW = DNS_PTR_DATA; + DNS_AAAA_DATA = IP6_ADDRESS; + DNS_STATUS = LongInt; + +{ + PDNS_A_DATA = ^DNS_A_DATA; + DNS_A_DATA = record + IpAddress: IP4_ADDRESS; + end; +} + + PIP4_ARRAY = ^IP4_ARRAY; + IP4_ARRAY=record + AddrCount:dword; + AddrArray:array [0..10] of IP4_ADDRESS; + end; + + PDNS_LOC_DATA = ^DNS_LOC_DATA; + DNS_LOC_DATA=record + wVersion:WORD; + wSize:WORD; + wHorPrec:WORD; + wVerPrec:WORD; + dwLatitude:DWORD; + dwLongitude:DWORD; + dwAltitude:DWORD; + end; + + DNS_SRV_DATA = record + pNameTarget: PChar; + wPriority: Word; + wWeighty: Word; + wPorty: Word; + Pady: Word; // keep ptrs DWORD aligned + end; + + DNS_TSIG_DATA = record + pNameAlgorithm: PChar; + pAlgorithmPacket: ^Byte; + pSignature: ^Byte; + pOtherData: ^Byte; + i64CreateTime: longlong; + wFudgeTime: Word; + wOriginalXid: Word; + wError: Word; + wSigLength: Word; + wOtherLength: Word; + cAlgNameLength: UCHAR; + bPacketPointers: Boolean; + end; + + DNS_NXT_DATA = record + pNameNext: PChar; + wNumTypes: Word; + wTypes: array[0..1] of Word; + end; + + DNS_WINSR_DATA = record + dwMappingFlag: DWORD; + dwLookupTimeout: DWORD; + dwCacheTimeout: DWORD; + pNameResultDomain: PWideChar; + end; + + DNS_WINSR_DATAA = record + dwMappingFlag: DWORD; + dwLookupTimeout: DWORD; + dwCacheTimeout: DWORD; + pNameResultDomain: PChar; + end; + + DNS_TXT_DATA = record + dwStringCount: DWORD; + pStringArray: array[0..10] of PChar; + end; + + DNS_NULL_DATA = record + dwByteCount: DWORD; + Data: array[0..10] of Byte; + end; + + DNS_KEY_DATA = record + wFlags: Word; + chProtocol: Byte; + chAlgorithm: Byte; + Key: array[0..0] of Byte; + end; + + DNS_SIG_DATA = record + pNameSigner: PChar; + wTypeCovered: Word; + chAlgorithm: Byte; + chLabelCount: Byte; + dwOriginalTtl: DWORD; + dwExpiration: DWORD; + dwTimeSigned: DWORD; + wKeyTag: Word; + Pad: Word; // keep Byte field aligned + Signature: array[0..0] of Byte; + end; + + DNS_ATMA_DATA = record + AddressType: Byte; + Address: array[0..(DNS_ATMA_MAX_ADDR_LENGTH - 1)] of Byte; + end; + + DNS_WKS_DATA = record + IpAddress: IP4_ADDRESS; + chProtocol: UCHAR; + BitMask: array[0..0] of Byte; // BitMask[1]; + end; + + DNS_MX_DATA = record + pNameExchange: PChar; + wPreference: Word; + Pad: Word; + end; + + DNS_MINFO_DATA = record + pNameMailbox: PChar; + pNameErrorsMailbox: PChar; + end; + + DNS_WINS_DATA = record + dwMappingFlag: DWORD; + dwLookupTimeout: DWORD; + dwCacheTimeout: DWORD; + cWinsServerCount: DWORD; + WinsServers: array[0..0] of IP4_ADDRESS; + end; + + DNS_TKEY_DATA = record + pNameAlgorithm: PChar; + pAlgorithmPacket: ^Byte; + pKey: ^Byte; + pOtherData: ^Byte; + dwCreateTime: DWORD; + dwExpireTime: DWORD; + wMode: Word; + wError: Word; + wKeyLength: Word; + wOtherLength: Word; + cAlgNameLength: UCHAR; + bPacketPointers: Boolean; + end; + + DNS_SOA_DATA = record + pNamePrimaryServer: PChar; + pNameAdministrator: PChar; + dwSerialNo: DWORD; + dwRefresh: DWORD; + dwRetry: DWORD; + dwExpire: DWORD; + dwDefaultTtl: DWORD; + end; + +DNS_RECORD_FLAGS = record + Section: DWORD; //DWORD Section : 2; + Delete: DWORD; //DWORD Delete : 1; + CharSet: DWORD; //DWORD CharSet : 2; + Unused: DWORD; //DWORD Unused : 3; + Reserved: DWORD; //DWORD Reserved : 24; + end; + + pdns_record = ^dns_record; + dns_record = packed record //28 bytes + 36 bytes data=64 + pnext:pdword; //4 + pname:lptstr ; //4 LPTSTR + wType:word; //2 + wDataLength:word; //2 + dw_flags:dword; //4 + dwTtl:dword; //4 + dwReserved:dword; //4 + prt:dword; //4 + data:array[0..8] of dword; + end; + + { + PPDNS_RECORD = ^PDNS_RECORD; + pdns_record = ^dns_record; + Dns_Record = record + pNext: PDNS_RECORD; + pName: LPTSTR; + wType: WORD; + wDataLength: WORD; // Not referenced for DNS record types defined above. + Flags: record + case Integer of + 0: (DW: DWORD); // flags as DWORD + 1: (S: DNS_RECORD_FLAGS); // flags as structure + end; + dwTtl: DWORD; + dwReserved: DWORD; + + // Record Data + + Data: record + case Integer of + 0: (A: DNS_A_DATA); + 1: (SOA, Soa_: DNS_SOA_DATA); + 2: (PTR, Ptr_, + NS, Ns_, + CNAME, Cname_, + MB, Mb_, + MD, Md_, + MF, Mf_, + MG, Mg_, + MR, Mr_: DNS_PTR_DATA); + 3: (MINFO, Minfo_, + RP, Rp_: DNS_MINFO_DATA); + 4: (MX, Mx_, + AFSDB, Afsdb_, + RT, Rt_: DNS_MX_DATA); + 5: (HINFO, Hinfo_, + ISDN, Isdn_, + TXT, Txt_, + X25: DNS_TXT_DATA); + 6: (Null: DNS_NULL_DATA); + 7: (WKS, Wks_: DNS_WKS_DATA); + 8: (AAAA: DNS_AAAA_DATA); + 9: (KEY, Key_: DNS_KEY_DATA); + 10: (SIG, Sig_: DNS_SIG_DATA); + 11: (ATMA, Atma_: DNS_ATMA_DATA); + 12: (NXT, Nxt_: DNS_NXT_DATA); + 13: (SRV, Srv_: DNS_SRV_DATA); + 14: (TKEY, Tkey_: DNS_TKEY_DATA); + 15: (TSIG, Tsig_: DNS_TSIG_DATA); + 16: (WINS, Wins_: DNS_WINS_DATA); + 17: (WINSR, WinsR_, NBSTAT, Nbstat_: DNS_WINSR_DATA); + end; + end; + } + + + pDnsCacheEntry=^DnsCacheEntry; + DnsCacheEntry=packed record + pNext:pdword; // Pointer to next entry + pszName:LPWSTR; //PWSTR DNS Record Name + wType:word; //unsigned short DNS Record Type + wDataLength:word; //unsigned short Not referenced + dwFlags:ulong; //unsigned long DNS Record Flags + end; + +//validation d'un nom DNS + DNS_NAME_FORMAT = (DnsNameDomain, + DnsNameDomainLabel, + DnsNameHostnameFull, + DnsNameHostnameLabel, + DnsNameWildcard, + DnsNameSrvRecord); + + //d�finie le type de lib�ration pour avec DnsFreeRecordList + DNS_FREE_TYPE = ( + DnsFreeFlat, + DnsFreeRecordList, + DnsFreeParsedMessageFields + ); + + + + //probl�me non r�solu lorsqu'on utilise les flags de type S + { + TFlags = record + case Integer of + 1: (DW: DWORD); // flags as DWORD + 2: (S: ^DNS_RECORD_FLAGS); // flags as structure ??? + end; + } + + { + TDataA = record + case Integer of + 1: (A: DNS_A_DATA); // A; + 2: (SOA: DNS_SOA_DATA); // SOA, Soa; + 3: (PTR: DNS_PTR_DATA); //PTR, Ptr, NS, Ns, CNAME, Cname, MB, Mb, MD, Md, MF, Mf, MG, Mg, MR, Mr; + 4: (MINFO: DNS_MINFO_DATA); //MINFO, Minfo, RP, Rp; + 5: (MX: DNS_MX_DATA); //MX, Mx, AFSDB, Afsdb, RT, Rt; + 6: (HINFO: DNS_TXT_DATA); //HINFO, Hinfo, ISDN, Isdn, TXT, Txt, X25; + 7: (Null: DNS_NULL_DATA); //Null; + 8: (WKS: DNS_WKS_DATA); //WKS, Wks; + 9: (AAAA: DNS_AAAA_DATA); //AAAA; + 10: (KEY: DNS_KEY_DATA); //KEY, Key; + 11: (SIG: DNS_SIG_DATA); //SIG, Sig; + 12: (ATMA: DNS_ATMA_DATA); //ATMA, Atma; + 13: (NXT: DNS_NXT_DATA); //NXT, Nxt; + 14: (SRV: DNS_SRV_DATA); //SRV, Srv; + 15: (TKEY: DNS_TKEY_DATA); //TKEY, Tkey; + 16: (TSIG: DNS_TSIG_DATA); //TSIG, Tsig; + 17: (DWINS: DNS_WINS_DATA); //WINS, Wins; + 18: (WINSR: DNS_WINSR_DATA); //WINSR, WinsR, NBSTAT, Nbstat; + end; + } + +type + PVOID = Pointer; + +const +/// Various DNS query types + + DNS_QUERY_STANDARD = $00000000; + DNS_QUERY_ACCEPT_TRUNCATED_RESPONSE = $00000001; + DNS_QUERY_USE_TCP_ONLY = $00000002; + DNS_QUERY_NO_RECURSION = $00000004; + DNS_QUERY_BYPASS_CACHE = $00000008; + DNS_QUERY_CACHE_ONLY = $00000010; + DNS_QUERY_NO_LOCAL_NAME =$00000020; + DNS_QUERY_NO_HOSTS_FILE =$00000040; + DNS_QUERY_NO_NETBT =$00000080; + DNS_QUERY_WIRE_ONLY =$00000100; + DNS_QUERY_SOCKET_KEEPALIVE = $00000100; + DNS_QUERY_RETURN_MESSAGE =$00000200; + DNS_QUERY_TREAT_AS_FQDN = $00001000; + DNS_QUERY_ALLOW_EMPTY_AUTH_RESP = $00010000; + DNS_QUERY_DONT_RESET_TTL_VALUES = $00100000; + DNS_QUERY_RESERVED = $ff000000; + DNS_QUERY_NO_WIRE_QUERY = $00000010; + + function CreateDnsRecOrd(Hostname: string; IP: string; var newDnsreord: DNS_RECORD): LongInt; + procedure FreeDnsRecOrd(var newDnsreord: DNS_RECORD); + +type + PDnsQueryRequest = ^TDnsQueryRequest; + TDnsQueryRequest = record + nVersion: Integer; + sQueryName: LPWSTR; + wQueryType: WORD; + llQueryOptions: LONGLONG; + // 이하 넣지 않음... +// PDNS_ADDR_ARRAY pDnsServerList; +// ULONG InterfaceIndex; +// PDNS_QUERY_COMPLETION_ROUTINE pQueryCompletionCallback; +// PVOID pQueryContext; + end; + +var + DnsQuery_A: function(lpstrName: LPSTR; + wType: WORD; + fOptions: DWORD; + aipServers: PDWORD; + var ppQueryResultsSet: PDWORD; + pReserved:pdword): DWORD; stdcall; + + DnsQuery_UTF8: function(lpstrName: LPSTR; + wType: WORD; + fOptions: DWORD; + aipServers: PDWORD; + var ppQueryResultsSet: PDWORD; + pReserved:pdword): DWORD; stdcall; + + DnsQuery_W: function(lpstrName: LPWSTR; + wType: WORD; + fOptions: DWORD; + aipServers: PDWORD; + var ppQueryResultsSet: PDWORD; + pReserved:pdword): DWORD; stdcall; + + DnsQueryEx: function(pQueryRequest: PDnsQueryRequest; pQueryResults, pCancelHandle: Pointer): DWORD; stdcall; + + DnsFlushResolverCache: Function: boolean; stdcall; + + DnsGetCacheDataTable: function (var pEntry:pdword) : boolean; stdcall; + +//ajouter, modifier et supprimer un enregistrement + DnsModifyRecordsInSet_A: function(pAddRecords: PDNS_RECORD; + pDeleteRecords: PDNS_RECORD; + Options: DWORD; + hContext: Hwnd; + pServerList: PIP4_ARRAY; + pReserved: Pointer + ): DNS_STATUS; stdcall; + + //DnsRecordListFree: procedure(pRecordList: PDNS_RECORD; FreeType: DNS_FREE_TYPE); stdcall; + DnsRecordListFree: procedure(pRecordList: pointer; FreeType: DNS_FREE_TYPE); stdcall; + DnsFree: procedure(pData: PVOID; FreeType: DNS_FREE_TYPE); stdcall; + +implementation + +const + apilib = 'dnsapi.dll'; + + var + Api: THandle = 0; + +function InitDnsAPI: Boolean; +begin + Result := False; + if api = 0 then Api := LoadLibrary(apilib); + if Api > HINSTANCE_ERROR then + begin + @DnsQuery_A := GetProcAddress(Api, 'DnsQuery_A'); + @DnsQuery_UTF8 := GetProcAddress(Api, 'DnsQuery_UTF8'); + @DnsQuery_W := GetProcAddress(Api, 'DnsQuery_W'); + @DnsQueryEx := GetProcAddress(Api, 'DnsQueryEx'); + @DnsFlushResolverCache := GetProcAddress(Api, 'DnsFlushResolverCache'); + @DnsGetCacheDataTable := GetProcAddress(Api, 'DnsGetCacheDataTable'); + @DnsModifyRecordsInSet_A := GetProcAddress(Api, 'DnsModifyRecordsInSet_A'); + @DnsRecordListFree := GetProcAddress(Api, 'DnsRecordListFree'); + @DnsFree := GetProcAddress(Api, 'DnsFree'); + end; +end; + +procedure FreeDnsAPI; +begin + if Api <> 0 then FreeLibrary(Api); + Api := 0; +end; + +procedure FreeDnsRecOrd(var newDnsreord: DNS_RECORD); +begin + FreeMem(newDnsreord.pName); +end; +//--- + +function CreateDnsRecOrd(Hostname: string; IP: string; var newDnsreord: DNS_RECORD): LongInt; +begin + try + //GetMem(newDnsreord.pName, Length(Hostname) + 1); + fillchar(newDnsreord,sizeof(newDnsreord ),0); + newDnsreord.pName:=allocmem(Length(Hostname) + 1); //allocmem=getmem+Initialize + newDnsreord.pnext := nil; + StrPCopy(newDnsreord.pName, Hostname); + newDnsreord.wType := DNS_TYPE_A; + newDnsreord.wDataLength := SizeOf(DNS_A_DATA); + //newDnsreord.flags := 32; //??? + newDnsreord.dwTtl := 0; //dur�e de vie dans le cache + newDnsreord.prt := inet_Addr(PansiChar(ansistring(ip))); //string2IP(IP); + //newDnsreord.Data.A :=inet_Addr(PansiChar(ansistring(ip))); //string2IP(IP); + + //verification si IP valide + if newDnsreord.prt <> 0 then CreateDnsRecord := 0 else CreateDnsRecord := 1; + except + CreateDnsRecord := 1; + end; +end; + + +initialization + InitDnsAPI; +finalization + FreeDnsAPI; + +end. \ No newline at end of file diff --git a/Tocsg.Lib/VCL/Other/EM.DomParser.pas b/Tocsg.Lib/VCL/Other/EM.DomParser.pas new file mode 100644 index 00000000..370f1747 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.DomParser.pas @@ -0,0 +1,912 @@ +{==============================================================================| +| Project : Delphi HTML/XHTML parser module | 1.1.2 | +|==============================================================================| +| Content: | +|==============================================================================| +| The contents of this file are subject to the Mozilla Public License Ver. 1.0 | +| (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. | +|==============================================================================| +| Initial Developers of the Original Code are: | +| Sandbil (Russia) sandbil@ya.ru | +| All Rights Reserved. | +| Last Modified: | +| 25.10.2014, Sandbil | +|==============================================================================| +| History: see README | +|==============================================================================|} + + +unit EM.DomParser; + +interface + +uses + System.Classes, System.RegularExpressionsCore, System.Generics.Collections, + System.Contnrs, System.StrUtils, System.SysUtils; + + + +type + TNodeList = class; + TChildList=class; + TDomTreeNode = class; + + + + TDomTree = class + private + FCount: Integer; + fParseErr: TStringList; + fRootNode: TDomTreeNode; + public + constructor Create; + destructor destroy; override; + property Count: Integer read fCount; + property RootNode: TDomTreeNode read fRootNode; + property ParseErr: TStringList read fParseErr; + end; + + TDomTreeNode = class(TObject) + private + fTag: string; + fAttributesTxt: string; + fAttributes: TDictionary; + fText: string; + fTypeTag: string; + fChild: TChildList; + fParent: Pointer; + fOwner: TDomTree; + public + property Tag: string read fTag; + property AttributesTxt: string read fAttributesTxt; + property Attributes: TDictionary read fAttributes; + property Text: string read fText; + property TypeTag: string read fTypeTag; + property Child: TChildList read fChild; + property Parent: Pointer read fParent; + property Owner: TDomTree read fOwner; + + constructor create(hOwner: TDomTree; hParent: Pointer; hTag, hAttrTxt: string; hAttr: + TDictionary; hTypeTag, hText: string); + destructor destroy; override; + function FindNode(hNameTag: string; hIndex:integer; hAttrTxt: String; + hAnyLevel: Boolean; dListNode: TNodeList): Boolean; + function FindTagOfIndex(hNameTag: String; hIndex:integer; hAnyLevel: + Boolean; dListNode: TNodeList): Boolean; + function FindXPath(hXPathTxt: String; dListNode: TNodeList; + dListValue:TStringList): Boolean; + function GetAttrValue(hAttrName:string): string; + function GetComment(hIndex: Integer): string; + function GetTagName: string; + function GetTextValue(hIndex:Integer): string; + function GetXPath(hRelative:boolean): string; + function RunParse(HtmlTxt: String): Boolean; + end; + + TChildList = class(TList) + private + function Get(Index: Integer): TDomTreeNode; + public + destructor Destroy; override; + property Items[Index: Integer]: TDomTreeNode read Get; default; + end; + + TNodeList = class(TList) + private + function Get(Index: Integer): TDomTreeNode; + public + property Items[Index: Integer]: TDomTreeNode read Get; default; + end; + + + PPrmRec=^TPrmRec; + TPrmRec = record + TagName: string; + ind: Integer; + Attr: string; + AnyLevel: Boolean; + end; + + TPrmRecList = class(TList) + private + function Get(Index: Integer): PPrmRec; + public + destructor Destroy; override; + property Items[Index: Integer]: PPrmRec read Get; default; + end; + + + + + +implementation + +{ TDomTree } + +{ +*********************************** TDomTree *********************************** +} +constructor TDomTree.Create; +begin + fParseErr:= TStringList.Create; + fRootnode:= TDomTreeNode.Create(self,self,'Root','',nil,'',''); + FCount:=0; + +end; + +destructor TDomTree.destroy; +begin + FreeAndNil(fParseErr); + FreeAndNil(fRootNode); + inherited; +end; + + +{ TChildList } + +{ +********************************** TChildList ********************************** +} +destructor TChildList.Destroy; +var + i: Integer; +begin + for i := 0 to Count - 1 do + self[i].Free; + inherited; +end; + + +function TChildList.Get(Index: Integer): TDomTreeNode; +begin + Result := TDomTreeNode(inherited Get(Index)); +end; + +{ TNodeList } + +function TNodeList.Get(Index: Integer): TDomTreeNode; +begin + Result := TDomTreeNode(inherited Get(Index)); +end; + + +{ TPrmRecList } + +{ +********************************* TPrmRecList ********************************** +} +destructor TPrmRecList.Destroy; +var + i: Integer; +begin + for i := 0 to Count - 1 do + FreeMem(Items[i]); + inherited; +end; + + + +function TPrmRecList.Get(Index: Integer): PPrmRec; +begin + Result := PPrmRec(inherited Get(Index)); +end; + +{ TDomTreeNode } + +{ +********************************* TDomTreeNode ********************************* +} +constructor TDomTreeNode.create(hOwner: TDomTree; hParent: Pointer; hTag, hAttrTxt: string; + hAttr: TDictionary; hTypeTag, hText: string); +begin + fChild := TChildList.create; + fParent := hParent; + fTag := hTag; + fAttributesTxt := hAttrTxt; + fAttributes := hAttr; + fTypeTag:= hTypeTag; + fText := hText; + fOwner:=hOwner; + inc(hOwner.FCount); +end; + +destructor TDomTreeNode.destroy; +begin +FreeAndNil(fAttributes); +FreeAndNil(fChild); + inherited; +end; + +//***********FindAttr************* +// hNameTag - name Tag +// hIndex - number of a tag one after another (0 - all tag, 1 - each first ..) +// hAttrTxt - attribute. ex. alt=1 +// hAnyLevel - true - all levels after start node; false - only one child level after start node +// dListNode - return TNodeList of TDomTreeNode + +function TDomTreeNode.FindNode(hNameTag: string; hIndex:integer; hAttrTxt: + String; hAnyLevel: Boolean; dListNode: TNodeList): Boolean; +var +RegEx: TPerlRegEx; +i,a: integer; +TagNodeList:TNodeList; +tValue: string; + + Function FindAttrChildNode(aNode:TDomTreeNode;AttrName,AttrValue: String):TNodeList; + var + aValue: String; + j: integer; + begin + for j := 0 to aNode.Child.Count - 1 do + begin + if aNode.Child[j].Attributes <> nil then + if aNode.Child[j].Attributes.ContainsKey(AttrName) then + if aNode.Child[j].Attributes.TryGetValue(AttrName, aValue) then + if AttrValue = aValue then dListNode.Add(aNode.Child[j]); + if hAnyLevel then + FindAttrChildNode(aNode.Child[j], AttrName, AttrValue); + end; + result:=dListNode; + end; + +begin + RegEx:=nil; + try + result:=false; + RegEx := TPerlRegEx.create; + RegEx.Subject := hAttrTxt; + RegEx.RegEx :='([^\s]*?[^\S]*)=([^\S]*".*?"[^\S]*)|'+ + '([^\s]*?[^\S]*)=([^\S]*#39.*?#39[^\S]*)|'+ + '([^\s]*?[^\S]*)=([^\S]*[^\s]+[^\S]*)|'+ + '(autofocus[^\S]*)()|'+ + '(disabled[^\S]*)()|'+ + '(selected[^\S]*)()'; + + if (not (hAttrTxt = '')) and (RegEx.Match) then + begin + for i := 1 to RegEx.GroupCount do + if trim(RegEx.Groups[i]) <> '' then break; + if hNameTag = '' then + begin + if FindAttrChildNode(self,RegEx.Groups[i],RegEx.Groups[i+1]).Count>0 + then result:=true; + end + else + begin + TagNodeList:=TNodeList.Create; + if FindTagOfIndex(hNameTag,hIndex,hAnyLevel,TagNodeList) then + for a := 0 to TagNodeList.Count - 1 do + if TagNodeList[a].Attributes <> nil then + if TagNodeList[a].Attributes.ContainsKey(RegEx.Groups[i]) then + if TagNodeList[a].Attributes.TryGetValue(RegEx.Groups[i], tValue) then + //There was a strong compareson of values of attribute + // if RegEx.Groups = tValue) + if Pos(RegEx.Groups[i+1], tValue)>0 + then + begin + dListNode.Add(TagNodeList[a]); + result:=true; + end; + TagNodeList.Free; + end; + end + else + if hAttrTxt = '' then + begin + TagNodeList:=TNodeList.Create; + if FindTagOfIndex(hNameTag,hIndex,hAnyLevel,TagNodeList) then + for a := 0 to TagNodeList.Count - 1 do + begin + dListNode.Add(TagNodeList[a]); + result:=true; + end; + TagNodeList.Free; + end + else raise Exception.create('Attribute not found: '+ hAttrTxt ); + + finally + RegEx.free + end; +end; + +//***********FindTagOfIndex************* +// hNameTag - name Tag (* - any tag, except text tag) +// hIndex - number of a tag one after another (0 - all tag, 1 - each first ..) +// hAnyLevel - true - all level after start node; false - only one child level after start node +// dListNode - return TNodeList of TDomTreeNode + +function TDomTreeNode.FindTagOfIndex(hNameTag: String; hIndex:integer; + hAnyLevel: Boolean; dListNode: TNodeList): Boolean; + + function SubStringOccurences(const subString, sourceString : string; caseSensitive : boolean) : integer; +var + pEx: integer; + sub, source : string; +begin + if caseSensitive then + begin + sub := subString; + source := sourceString; + end + else + begin + sub := LowerCase(subString); + source := LowerCase(sourceString); + end; + + result := 0; + pEx := PosEx(sub, source, 1); + while pEx <> 0 do + begin + Inc(result); + pEx := PosEx(sub, source, pEx + Length(sub)); + end; +end; + + Function FindChildTagOfIndex(aNode:TDomTreeNode):TNodeList; + var + countNode,j: integer; + enumTags:string; + begin + countNode:=0; + for j := 0 to aNode.Child.Count - 1 do + begin + if hNameTag <> '*' then + begin + if ((AnsiUpperCase(aNode.Child[j].Tag) = AnsiUpperCase(hNameTag)) and (aNode.Child[j].TypeTag <> '')) + or ((AnsiUpperCase(aNode.Child[j].Tag) = '') and (AnsiUpperCase(hNameTag)='TEXT()') and (aNode.Child[j].Text <> '')) + or ((LeftStr(AnsiUpperCase(aNode.Child[j].Tag),4) = '[^<]*) - comment + // ([^<]*) - script + // (<[^>]+>[^<]*) - all remaining tags + // [^<]* - text + RegExException :='(

.*?</PLAINTEXT>[^<]*)|'+ + '(<title>.*?</title>[^<]*)|'+ + '(<xmp>.*?</xmp>[^<]*)|'+ + '(<script.*?</script>[^<]*)|'+ + '(<textarea.*?</textarea>[^<]*)|'+ +// '(<pre.*?</pre>[^<]*)|'+ + '(<!--.+?-->[^<]*)|'; + RegEx := RegExException + '(<[^>]+>[^<]*)'; // all teg and text + Subject := HtmlUtf8; + if Match then + begin + MatchTag(RegExHTML.MatchedText); + prev := MatchedOffset + MatchedLength; + while MatchAgain do + begin + MatchTag(RegExHTML.MatchedText); + // *****Start Check Parsing HTML Error************ + if MatchedOffset - prev > 0 then + begin + Owner.fParseErr.Add(IntToStr(ErrParseHTML) + '- Check error found after HTML parsing'); + inc(ErrParseHTML) + end; + prev := MatchedOffset + MatchedLength; + // *****End Check Parsing HTML Error************ + end; + // ***********End RegExp match cycle************ + end + else + raise Exception.create('Input text not contain HTML tags'); + // *************End RegExp match ************ + end; + + Finally + RegExHTML.Free; + RegExTag.Free; + if Owner.FCount>0 then + result := True + else result := False ; + end; + +end; + +end. diff --git a/Tocsg.Lib/VCL/Other/EM.GDIPAPI.pas b/Tocsg.Lib/VCL/Other/EM.GDIPAPI.pas new file mode 100644 index 00000000..88e42442 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.GDIPAPI.pas @@ -0,0 +1,7055 @@ + {******************************************************************} + { GDI+ API } + { } + { home page : http://www.progdigy.com } + { email : hgourvest@progdigy.com } + { } + { date : 15-02-2002 } + { } + { 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 EM.GDIPAPI; + +{$ALIGN ON} +{$MINENUMSIZE 4} + +interface + +(**************************************************************************\ +* +* GDI+ public header file +* +\**************************************************************************) + +uses + Windows, + ActiveX, + DirectDraw, + Math; + +type + INT16 = type Smallint; + UINT16 = type Word; + PUINT16 = ^UINT16; + UINT32 = type Cardinal; + TSingleDynArray = array of Single; + +(**************************************************************************\ +* +* GDI+ Private Memory Management APIs +* +\**************************************************************************) + +const WINGDIPDLL = 'gdiplus.dll'; + +function GetEncoderClsid(sFormat: String; var aClsid: TGuid): Boolean; + +//---------------------------------------------------------------------------- +// Memory Allocation APIs +//---------------------------------------------------------------------------- + +{$EXTERNALSYM GdipAlloc} +function GdipAlloc(size: ULONG): pointer; stdcall; +{$EXTERNALSYM GdipFree} +procedure GdipFree(ptr: pointer); stdcall; + +(**************************************************************************\ +* +* GDI+ base memory allocation class +* +\**************************************************************************) + +type + TGdiplusBase = class + public + class function NewInstance: TObject; override; + procedure FreeInstance; override; + end; + +(**************************************************************************\ +* +* GDI+ Enumeration Types +* +\**************************************************************************) + +//-------------------------------------------------------------------------- +// Default bezier flattening tolerance in device pixels. +//-------------------------------------------------------------------------- + +const + {$EXTERNALSYM FlatnessDefault} + FlatnessDefault = 0.25; + +//-------------------------------------------------------------------------- +// Graphics and Container State cookies +//-------------------------------------------------------------------------- +type + {$EXTERNALSYM GraphicsState} + GraphicsState = UINT; + {$EXTERNALSYM GraphicsContainer} + GraphicsContainer = UINT; + +//-------------------------------------------------------------------------- +// Fill mode constants +//-------------------------------------------------------------------------- + + {$EXTERNALSYM FillMode} + FillMode = ( + FillModeAlternate, // 0 + FillModeWinding // 1 + ); + TFillMode = FillMode; + +//-------------------------------------------------------------------------- +// Quality mode constants +//-------------------------------------------------------------------------- + +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM QualityMode} + QualityMode = ( + QualityModeInvalid = -1, + QualityModeDefault = 0, + QualityModeLow = 1, // Best performance + QualityModeHigh = 2 // Best rendering quality + ); + TQualityMode = QualityMode; +{$ELSE} + {$EXTERNALSYM QualityMode} + QualityMode = Integer; + const + QualityModeInvalid = -1; + QualityModeDefault = 0; + QualityModeLow = 1; // Best performance + QualityModeHigh = 2; // Best rendering quality +{$ENDIF} + +//-------------------------------------------------------------------------- +// Alpha Compositing mode constants +//-------------------------------------------------------------------------- +type + {$EXTERNALSYM CompositingMode} + CompositingMode = ( + CompositingModeSourceOver, // 0 + CompositingModeSourceCopy // 1 + ); + TCompositingMode = CompositingMode; + +//-------------------------------------------------------------------------- +// Alpha Compositing quality constants +//-------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM CompositingQuality} + CompositingQuality = ( + CompositingQualityInvalid = ord(QualityModeInvalid), + CompositingQualityDefault = ord(QualityModeDefault), + CompositingQualityHighSpeed = ord(QualityModeLow), + CompositingQualityHighQuality = ord(QualityModeHigh), + CompositingQualityGammaCorrected, + CompositingQualityAssumeLinear + ); + TCompositingQuality = CompositingQuality; +{$ELSE} + {$EXTERNALSYM CompositingQuality} + CompositingQuality = Integer; + const + CompositingQualityInvalid = QualityModeInvalid; + CompositingQualityDefault = QualityModeDefault; + CompositingQualityHighSpeed = QualityModeLow; + CompositingQualityHighQuality = QualityModeHigh; + CompositingQualityGammaCorrected = 3; + CompositingQualityAssumeLinear = 4; + +type + TCompositingQuality = CompositingQuality; +{$ENDIF} + +//-------------------------------------------------------------------------- +// Unit constants +//-------------------------------------------------------------------------- + + // {$EXTERNALSYM Unit} + Unit_ = ( + UnitWorld, // 0 -- World coordinate (non-physical unit) + UnitDisplay, // 1 -- Variable -- for PageTransform only + UnitPixel, // 2 -- Each unit is one device pixel. + UnitPoint, // 3 -- Each unit is a printer's point, or 1/72 inch. + UnitInch, // 4 -- Each unit is 1 inch. + UnitDocument, // 5 -- Each unit is 1/300 inch. + UnitMillimeter // 6 -- Each unit is 1 millimeter. + ); + TUnit = Unit_; + +//-------------------------------------------------------------------------- +// MetafileFrameUnit +// +// The frameRect for creating a metafile can be specified in any of these +// units. There is an extra frame unit value (MetafileFrameUnitGdi) so +// that units can be supplied in the same units that GDI expects for +// frame rects -- these units are in .01 (1/100ths) millimeter units +// as defined by GDI. +//-------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM MetafileFrameUnit} + MetafileFrameUnit = ( + MetafileFrameUnitPixel = ord(UnitPixel), + MetafileFrameUnitPoint = ord(UnitPoint), + MetafileFrameUnitInch = ord(UnitInch), + MetafileFrameUnitDocument = ord(UnitDocument), + MetafileFrameUnitMillimeter = ord(UnitMillimeter), + MetafileFrameUnitGdi // GDI compatible .01 MM units + ); + TMetafileFrameUnit = MetafileFrameUnit; +{$ELSE} + {$EXTERNALSYM MetafileFrameUnit} + MetafileFrameUnit = Integer; + const + MetafileFrameUnitPixel = 2; + MetafileFrameUnitPoint = 3; + MetafileFrameUnitInch = 4; + MetafileFrameUnitDocument = 5; + MetafileFrameUnitMillimeter = 6; + MetafileFrameUnitGdi = 7; // GDI compatible .01 MM units + +type + TMetafileFrameUnit = MetafileFrameUnit; +{$ENDIF} +//-------------------------------------------------------------------------- +// Coordinate space identifiers +//-------------------------------------------------------------------------- + + {$EXTERNALSYM CoordinateSpace} + CoordinateSpace = ( + CoordinateSpaceWorld, // 0 + CoordinateSpacePage, // 1 + CoordinateSpaceDevice // 2 + ); + TCoordinateSpace = CoordinateSpace; + +//-------------------------------------------------------------------------- +// Various wrap modes for brushes +//-------------------------------------------------------------------------- + + {$EXTERNALSYM WrapMode} + WrapMode = ( + WrapModeTile, // 0 + WrapModeTileFlipX, // 1 + WrapModeTileFlipY, // 2 + WrapModeTileFlipXY, // 3 + WrapModeClamp // 4 + ); + TWrapMode = WrapMode; + +//-------------------------------------------------------------------------- +// Various hatch styles +//-------------------------------------------------------------------------- + + {$EXTERNALSYM HatchStyle} + HatchStyle = ( + HatchStyleHorizontal, // = 0, + HatchStyleVertical, // = 1, + HatchStyleForwardDiagonal, // = 2, + HatchStyleBackwardDiagonal, // = 3, + HatchStyleCross, // = 4, + HatchStyleDiagonalCross, // = 5, + HatchStyle05Percent, // = 6, + HatchStyle10Percent, // = 7, + HatchStyle20Percent, // = 8, + HatchStyle25Percent, // = 9, + HatchStyle30Percent, // = 10, + HatchStyle40Percent, // = 11, + HatchStyle50Percent, // = 12, + HatchStyle60Percent, // = 13, + HatchStyle70Percent, // = 14, + HatchStyle75Percent, // = 15, + HatchStyle80Percent, // = 16, + HatchStyle90Percent, // = 17, + HatchStyleLightDownwardDiagonal, // = 18, + HatchStyleLightUpwardDiagonal, // = 19, + HatchStyleDarkDownwardDiagonal, // = 20, + HatchStyleDarkUpwardDiagonal, // = 21, + HatchStyleWideDownwardDiagonal, // = 22, + HatchStyleWideUpwardDiagonal, // = 23, + HatchStyleLightVertical, // = 24, + HatchStyleLightHorizontal, // = 25, + HatchStyleNarrowVertical, // = 26, + HatchStyleNarrowHorizontal, // = 27, + HatchStyleDarkVertical, // = 28, + HatchStyleDarkHorizontal, // = 29, + HatchStyleDashedDownwardDiagonal, // = 30, + HatchStyleDashedUpwardDiagonal, // = 31, + HatchStyleDashedHorizontal, // = 32, + HatchStyleDashedVertical, // = 33, + HatchStyleSmallConfetti, // = 34, + HatchStyleLargeConfetti, // = 35, + HatchStyleZigZag, // = 36, + HatchStyleWave, // = 37, + HatchStyleDiagonalBrick, // = 38, + HatchStyleHorizontalBrick, // = 39, + HatchStyleWeave, // = 40, + HatchStylePlaid, // = 41, + HatchStyleDivot, // = 42, + HatchStyleDottedGrid, // = 43, + HatchStyleDottedDiamond, // = 44, + HatchStyleShingle, // = 45, + HatchStyleTrellis, // = 46, + HatchStyleSphere, // = 47, + HatchStyleSmallGrid, // = 48, + HatchStyleSmallCheckerBoard, // = 49, + HatchStyleLargeCheckerBoard, // = 50, + HatchStyleOutlinedDiamond, // = 51, + HatchStyleSolidDiamond, // = 52, + + HatchStyleTotal // = 53, + ); + + const + HatchStyleLargeGrid = HatchStyleCross; // 4 + HatchStyleMin = HatchStyleHorizontal; + HatchStyleMax = HatchStyleSolidDiamond; + +type + THatchStyle = HatchStyle; + +//-------------------------------------------------------------------------- +// Dash style constants +//-------------------------------------------------------------------------- + + {$EXTERNALSYM DashStyle} + DashStyle = ( + DashStyleSolid, // 0 + DashStyleDash, // 1 + DashStyleDot, // 2 + DashStyleDashDot, // 3 + DashStyleDashDotDot, // 4 + DashStyleCustom // 5 + ); + TDashStyle = DashStyle; + +//-------------------------------------------------------------------------- +// Dash cap constants +//-------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM DashCap} + DashCap = ( + DashCapFlat = 0, + DashCapRound = 2, + DashCapTriangle = 3 + ); + TDashCap = DashCap; +{$ELSE} + {$EXTERNALSYM DashCap} + DashCap = Integer; + const + DashCapFlat = 0; + DashCapRound = 2; + DashCapTriangle = 3; + +type + TDashCap = DashCap; +{$ENDIF} + +//-------------------------------------------------------------------------- +// Line cap constants (only the lowest 8 bits are used). +//-------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM LineCap} + LineCap = ( + LineCapFlat = 0, + LineCapSquare = 1, + LineCapRound = 2, + LineCapTriangle = 3, + + LineCapNoAnchor = $10, // corresponds to flat cap + LineCapSquareAnchor = $11, // corresponds to square cap + LineCapRoundAnchor = $12, // corresponds to round cap + LineCapDiamondAnchor = $13, // corresponds to triangle cap + LineCapArrowAnchor = $14, // no correspondence + + LineCapCustom = $ff, // custom cap + + LineCapAnchorMask = $f0 // mask to check for anchor or not. + ); + TLineCap = LineCap; +{$ELSE} + {$EXTERNALSYM LineCap} + LineCap = Integer; + const + LineCapFlat = 0; + LineCapSquare = 1; + LineCapRound = 2; + LineCapTriangle = 3; + + LineCapNoAnchor = $10; // corresponds to flat cap + LineCapSquareAnchor = $11; // corresponds to square cap + LineCapRoundAnchor = $12; // corresponds to round cap + LineCapDiamondAnchor = $13; // corresponds to triangle cap + LineCapArrowAnchor = $14; // no correspondence + + LineCapCustom = $ff; // custom cap + + LineCapAnchorMask = $f0; // mask to check for anchor or not. + +type + TLineCap = LineCap; +{$ENDIF} + +//-------------------------------------------------------------------------- +// Custom Line cap type constants +//-------------------------------------------------------------------------- + + {$EXTERNALSYM CustomLineCapType} + CustomLineCapType = ( + CustomLineCapTypeDefault, + CustomLineCapTypeAdjustableArrow + ); + TCustomLineCapType = CustomLineCapType; + +//-------------------------------------------------------------------------- +// Line join constants +//-------------------------------------------------------------------------- + + {$EXTERNALSYM LineJoin} + LineJoin = ( + LineJoinMiter, + LineJoinBevel, + LineJoinRound, + LineJoinMiterClipped + ); + TLineJoin = LineJoin; + +//-------------------------------------------------------------------------- +// Path point types (only the lowest 8 bits are used.) +// The lowest 3 bits are interpreted as point type +// The higher 5 bits are reserved for flags. +//-------------------------------------------------------------------------- + +{$IFDEF DELPHI6_UP} + {$Z1} + {$EXTERNALSYM PathPointType} + PathPointType = ( + PathPointTypeStart = $00, // move + PathPointTypeLine = $01, // line + PathPointTypeBezier = $03, // default Bezier (= cubic Bezier) + PathPointTypePathTypeMask = $07, // type mask (lowest 3 bits). + PathPointTypeDashMode = $10, // currently in dash mode. + PathPointTypePathMarker = $20, // a marker for the path. + PathPointTypeCloseSubpath = $80, // closed flag + + // Path types used for advanced path. + PathPointTypeBezier3 = $03 // cubic Bezier + ); + TPathPointType = PathPointType; + {$Z4} +{$ELSE} + {$EXTERNALSYM PathPointType} + PathPointType = Byte; + const + PathPointTypeStart : Byte = $00; // move + PathPointTypeLine : Byte = $01; // line + PathPointTypeBezier : Byte = $03; // default Bezier (= cubic Bezier) + PathPointTypePathTypeMask : Byte = $07; // type mask (lowest 3 bits). + PathPointTypeDashMode : Byte = $10; // currently in dash mode. + PathPointTypePathMarker : Byte = $20; // a marker for the path. + PathPointTypeCloseSubpath : Byte = $80; // closed flag + + // Path types used for advanced path. + PathPointTypeBezier3 : Byte = $03; // cubic Bezier + +type + TPathPointType = PathPointType; +{$ENDIF} + +//-------------------------------------------------------------------------- +// WarpMode constants +//-------------------------------------------------------------------------- + + {$EXTERNALSYM WarpMode} + WarpMode = ( + WarpModePerspective, // 0 + WarpModeBilinear // 1 + ); + TWarpMode = WarpMode; + +//-------------------------------------------------------------------------- +// LineGradient Mode +//-------------------------------------------------------------------------- + + {$EXTERNALSYM LinearGradientMode} + LinearGradientMode = ( + LinearGradientModeHorizontal, // 0 + LinearGradientModeVertical, // 1 + LinearGradientModeForwardDiagonal, // 2 + LinearGradientModeBackwardDiagonal // 3 + ); + TLinearGradientMode = LinearGradientMode; + +//-------------------------------------------------------------------------- +// Region Comine Modes +//-------------------------------------------------------------------------- + + {$EXTERNALSYM CombineMode} + CombineMode = ( + CombineModeReplace, // 0 + CombineModeIntersect, // 1 + CombineModeUnion, // 2 + CombineModeXor, // 3 + CombineModeExclude, // 4 + CombineModeComplement // 5 (Exclude From) + ); + TCombineMode = CombineMode; + +//-------------------------------------------------------------------------- + // Image types +//-------------------------------------------------------------------------- + + {$EXTERNALSYM ImageType} + ImageType = ( + ImageTypeUnknown, // 0 + ImageTypeBitmap, // 1 + ImageTypeMetafile // 2 + ); + TImageType = ImageType; + +//-------------------------------------------------------------------------- +// Interpolation modes +//-------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM InterpolationMode} + InterpolationMode = ( + InterpolationModeInvalid = ord(QualityModeInvalid), + InterpolationModeDefault = ord(QualityModeDefault), + InterpolationModeLowQuality = ord(QualityModeLow), + InterpolationModeHighQuality = ord(QualityModeHigh), + InterpolationModeBilinear, + InterpolationModeBicubic, + InterpolationModeNearestNeighbor, + InterpolationModeHighQualityBilinear, + InterpolationModeHighQualityBicubic + ); + TInterpolationMode = InterpolationMode; +{$ELSE} + {$EXTERNALSYM InterpolationMode} + InterpolationMode = Integer; + const + InterpolationModeInvalid = QualityModeInvalid; + InterpolationModeDefault = QualityModeDefault; + InterpolationModeLowQuality = QualityModeLow; + InterpolationModeHighQuality = QualityModeHigh; + InterpolationModeBilinear = 3; + InterpolationModeBicubic = 4; + InterpolationModeNearestNeighbor = 5; + InterpolationModeHighQualityBilinear = 6; + InterpolationModeHighQualityBicubic = 7; + +type + TInterpolationMode = InterpolationMode; +{$ENDIF} + +//-------------------------------------------------------------------------- +// Pen types +//-------------------------------------------------------------------------- + + {$EXTERNALSYM PenAlignment} + PenAlignment = ( + PenAlignmentCenter, + PenAlignmentInset + ); + TPenAlignment = PenAlignment; + +//-------------------------------------------------------------------------- +// Brush types +//-------------------------------------------------------------------------- + + {$EXTERNALSYM BrushType} + BrushType = ( + BrushTypeSolidColor, + BrushTypeHatchFill, + BrushTypeTextureFill, + BrushTypePathGradient, + BrushTypeLinearGradient + ); + TBrushType = BrushType; + +//-------------------------------------------------------------------------- +// Pen's Fill types +//-------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM PenType} + PenType = ( + PenTypeSolidColor = ord(BrushTypeSolidColor), + PenTypeHatchFill = ord(BrushTypeHatchFill), + PenTypeTextureFill = ord(BrushTypeTextureFill), + PenTypePathGradient = ord(BrushTypePathGradient), + PenTypeLinearGradient = ord(BrushTypeLinearGradient), + PenTypeUnknown = -1 + ); + TPenType = PenType; +{$ELSE} + {$EXTERNALSYM PenType} + PenType = Integer; + const + PenTypeSolidColor = 0; + PenTypeHatchFill = 1; + PenTypeTextureFill = 2; + PenTypePathGradient = 3; + PenTypeLinearGradient = 4; + PenTypeUnknown = -1; + +type + TPenType = PenType; +{$ENDIF} + +//-------------------------------------------------------------------------- +// Matrix Order +//-------------------------------------------------------------------------- + + {$EXTERNALSYM MatrixOrder} + MatrixOrder = ( + MatrixOrderPrepend, + MatrixOrderAppend + ); + TMatrixOrder = MatrixOrder; + +//-------------------------------------------------------------------------- +// Generic font families +//-------------------------------------------------------------------------- + + {$EXTERNALSYM GenericFontFamily} + GenericFontFamily = ( + GenericFontFamilySerif, + GenericFontFamilySansSerif, + GenericFontFamilyMonospace + ); + TGenericFontFamily = GenericFontFamily; + +//-------------------------------------------------------------------------- +// FontStyle: face types and common styles +//-------------------------------------------------------------------------- +type + {$EXTERNALSYM FontStyle} + FontStyle = Integer; + const + FontStyleRegular = Integer(0); + FontStyleBold = Integer(1); + FontStyleItalic = Integer(2); + FontStyleBoldItalic = Integer(3); + FontStyleUnderline = Integer(4); + FontStyleStrikeout = Integer(8); + Type + TFontStyle = FontStyle; + +//--------------------------------------------------------------------------- +// Smoothing Mode +//--------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM SmoothingMode} + SmoothingMode = ( + SmoothingModeInvalid = ord(QualityModeInvalid), + SmoothingModeDefault = ord(QualityModeDefault), + SmoothingModeHighSpeed = ord(QualityModeLow), + SmoothingModeHighQuality = ord(QualityModeHigh), + SmoothingModeNone, + SmoothingModeAntiAlias + ); + TSmoothingMode = SmoothingMode; +{$ELSE} + {$EXTERNALSYM SmoothingMode} + SmoothingMode = Integer; + const + SmoothingModeInvalid = QualityModeInvalid; + SmoothingModeDefault = QualityModeDefault; + SmoothingModeHighSpeed = QualityModeLow; + SmoothingModeHighQuality = QualityModeHigh; + SmoothingModeNone = 3; + SmoothingModeAntiAlias = 4; + +type + TSmoothingMode = SmoothingMode; +{$ENDIF} + +//--------------------------------------------------------------------------- +// Pixel Format Mode +//--------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM PixelOffsetMode} + PixelOffsetMode = ( + PixelOffsetModeInvalid = Ord(QualityModeInvalid), + PixelOffsetModeDefault = Ord(QualityModeDefault), + PixelOffsetModeHighSpeed = Ord(QualityModeLow), + PixelOffsetModeHighQuality = Ord(QualityModeHigh), + PixelOffsetModeNone, // No pixel offset + PixelOffsetModeHalf // Offset by -0.5, -0.5 for fast anti-alias perf + ); + TPixelOffsetMode = PixelOffsetMode; +{$ELSE} + {$EXTERNALSYM PixelOffsetMode} + PixelOffsetMode = Integer; + const + PixelOffsetModeInvalid = QualityModeInvalid; + PixelOffsetModeDefault = QualityModeDefault; + PixelOffsetModeHighSpeed = QualityModeLow; + PixelOffsetModeHighQuality = QualityModeHigh; + PixelOffsetModeNone = 3; // No pixel offset + PixelOffsetModeHalf = 4; // Offset by -0.5, -0.5 for fast anti-alias perf + +type + TPixelOffsetMode = PixelOffsetMode; +{$ENDIF} + +//--------------------------------------------------------------------------- +// Text Rendering Hint +//--------------------------------------------------------------------------- + + {$EXTERNALSYM TextRenderingHint} + TextRenderingHint = ( + TextRenderingHintSystemDefault, // Glyph with system default rendering hint + TextRenderingHintSingleBitPerPixelGridFit, // Glyph bitmap with hinting + TextRenderingHintSingleBitPerPixel, // Glyph bitmap without hinting + TextRenderingHintAntiAliasGridFit, // Glyph anti-alias bitmap with hinting + TextRenderingHintAntiAlias, // Glyph anti-alias bitmap without hinting + TextRenderingHintClearTypeGridFit // Glyph CT bitmap with hinting + ); + TTextRenderingHint = TextRenderingHint; + +//--------------------------------------------------------------------------- +// Metafile Types +//--------------------------------------------------------------------------- + + {$EXTERNALSYM MetafileType} + MetafileType = ( + MetafileTypeInvalid, // Invalid metafile + MetafileTypeWmf, // Standard WMF + MetafileTypeWmfPlaceable, // Placeable WMF + MetafileTypeEmf, // EMF (not EMF+) + MetafileTypeEmfPlusOnly, // EMF+ without dual, down-level records + MetafileTypeEmfPlusDual // EMF+ with dual, down-level records + ); + TMetafileType = MetafileType; + +//--------------------------------------------------------------------------- +// Specifies the type of EMF to record +//--------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM EmfType} + EmfType = ( + EmfTypeEmfOnly = Ord(MetafileTypeEmf), // no EMF+, only EMF + EmfTypeEmfPlusOnly = Ord(MetafileTypeEmfPlusOnly), // no EMF, only EMF+ + EmfTypeEmfPlusDual = Ord(MetafileTypeEmfPlusDual) // both EMF+ and EMF + ); + TEmfType = EmfType; +{$ELSE} + {$EXTERNALSYM EmfType} + EmfType = Integer; + const + EmfTypeEmfOnly = Ord(MetafileTypeEmf); // no EMF+, only EMF + EmfTypeEmfPlusOnly = Ord(MetafileTypeEmfPlusOnly); // no EMF, only EMF+ + EmfTypeEmfPlusDual = Ord(MetafileTypeEmfPlusDual); // both EMF+ and EMF + +type + TEmfType = EmfType; +{$ENDIF} + +//--------------------------------------------------------------------------- +// EMF+ Persistent object types +//--------------------------------------------------------------------------- + + {$EXTERNALSYM ObjectType} + ObjectType = ( + ObjectTypeInvalid, + ObjectTypeBrush, + ObjectTypePen, + ObjectTypePath, + ObjectTypeRegion, + ObjectTypeImage, + ObjectTypeFont, + ObjectTypeStringFormat, + ObjectTypeImageAttributes, + ObjectTypeCustomLineCap + ); + TObjectType = ObjectType; + +const + ObjectTypeMax = ObjectTypeCustomLineCap; + ObjectTypeMin = ObjectTypeBrush; + +function ObjectTypeIsValid(type_: ObjectType): BOOL; + +//--------------------------------------------------------------------------- +// EMF+ Records +//--------------------------------------------------------------------------- + + // We have to change the WMF record numbers so that they don't conflict with + // the EMF and EMF+ record numbers. + +const + GDIP_EMFPLUS_RECORD_BASE = $00004000; + {$EXTERNALSYM GDIP_EMFPLUS_RECORD_BASE} + GDIP_WMF_RECORD_BASE = $00010000; + {$EXTERNALSYM GDIP_WMF_RECORD_BASE} + +// macros +function GDIP_WMF_RECORD_TO_EMFPLUS(n: integer): Integer; +function GDIP_EMFPLUS_RECORD_TO_WMF(n: integer): Integer; +function GDIP_IS_WMF_RECORDTYPE(n: integer): BOOL; + + +{$IFDEF DELPHI6_UP} +type + {$EXTERNALSYM EmfPlusRecordType} + EmfPlusRecordType = ( + // Since we have to enumerate GDI records right along with GDI+ records, + // We list all the GDI records here so that they can be part of the + // same enumeration type which is used in the enumeration callback. + + WmfRecordTypeSetBkColor = (META_SETBKCOLOR or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetBkMode = (META_SETBKMODE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetMapMode = (META_SETMAPMODE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetROP2 = (META_SETROP2 or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetRelAbs = (META_SETRELABS or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetPolyFillMode = (META_SETPOLYFILLMODE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetStretchBltMode = (META_SETSTRETCHBLTMODE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetTextCharExtra = (META_SETTEXTCHAREXTRA or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetTextColor = (META_SETTEXTCOLOR or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetTextJustification = (META_SETTEXTJUSTIFICATION or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetWindowOrg = (META_SETWINDOWORG or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetWindowExt = (META_SETWINDOWEXT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetViewportOrg = (META_SETVIEWPORTORG or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetViewportExt = (META_SETVIEWPORTEXT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeOffsetWindowOrg = (META_OFFSETWINDOWORG or GDIP_WMF_RECORD_BASE), + WmfRecordTypeScaleWindowExt = (META_SCALEWINDOWEXT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeOffsetViewportOrg = (META_OFFSETVIEWPORTORG or GDIP_WMF_RECORD_BASE), + WmfRecordTypeScaleViewportExt = (META_SCALEVIEWPORTEXT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeLineTo = (META_LINETO or GDIP_WMF_RECORD_BASE), + WmfRecordTypeMoveTo = (META_MOVETO or GDIP_WMF_RECORD_BASE), + WmfRecordTypeExcludeClipRect = (META_EXCLUDECLIPRECT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeIntersectClipRect = (META_INTERSECTCLIPRECT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeArc = (META_ARC or GDIP_WMF_RECORD_BASE), + WmfRecordTypeEllipse = (META_ELLIPSE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeFloodFill = (META_FLOODFILL or GDIP_WMF_RECORD_BASE), + WmfRecordTypePie = (META_PIE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeRectangle = (META_RECTANGLE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeRoundRect = (META_ROUNDRECT or GDIP_WMF_RECORD_BASE), + WmfRecordTypePatBlt = (META_PATBLT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSaveDC = (META_SAVEDC or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetPixel = (META_SETPIXEL or GDIP_WMF_RECORD_BASE), + WmfRecordTypeOffsetClipRgn = (META_OFFSETCLIPRGN or GDIP_WMF_RECORD_BASE), + WmfRecordTypeTextOut = (META_TEXTOUT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeBitBlt = (META_BITBLT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeStretchBlt = (META_STRETCHBLT or GDIP_WMF_RECORD_BASE), + WmfRecordTypePolygon = (META_POLYGON or GDIP_WMF_RECORD_BASE), + WmfRecordTypePolyline = (META_POLYLINE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeEscape = (META_ESCAPE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeRestoreDC = (META_RESTOREDC or GDIP_WMF_RECORD_BASE), + WmfRecordTypeFillRegion = (META_FILLREGION or GDIP_WMF_RECORD_BASE), + WmfRecordTypeFrameRegion = (META_FRAMEREGION or GDIP_WMF_RECORD_BASE), + WmfRecordTypeInvertRegion = (META_INVERTREGION or GDIP_WMF_RECORD_BASE), + WmfRecordTypePaintRegion = (META_PAINTREGION or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSelectClipRegion = (META_SELECTCLIPREGION or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSelectObject = (META_SELECTOBJECT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetTextAlign = (META_SETTEXTALIGN or GDIP_WMF_RECORD_BASE), + WmfRecordTypeDrawText = ($062F or GDIP_WMF_RECORD_BASE), // META_DRAWTEXT + WmfRecordTypeChord = (META_CHORD or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetMapperFlags = (META_SETMAPPERFLAGS or GDIP_WMF_RECORD_BASE), + WmfRecordTypeExtTextOut = (META_EXTTEXTOUT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetDIBToDev = (META_SETDIBTODEV or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSelectPalette = (META_SELECTPALETTE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeRealizePalette = (META_REALIZEPALETTE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeAnimatePalette = (META_ANIMATEPALETTE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetPalEntries = (META_SETPALENTRIES or GDIP_WMF_RECORD_BASE), + WmfRecordTypePolyPolygon = (META_POLYPOLYGON or GDIP_WMF_RECORD_BASE), + WmfRecordTypeResizePalette = (META_RESIZEPALETTE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeDIBBitBlt = (META_DIBBITBLT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeDIBStretchBlt = (META_DIBSTRETCHBLT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeDIBCreatePatternBrush = (META_DIBCREATEPATTERNBRUSH or GDIP_WMF_RECORD_BASE), + WmfRecordTypeStretchDIB = (META_STRETCHDIB or GDIP_WMF_RECORD_BASE), + WmfRecordTypeExtFloodFill = (META_EXTFLOODFILL or GDIP_WMF_RECORD_BASE), + WmfRecordTypeSetLayout = ($0149 or GDIP_WMF_RECORD_BASE), // META_SETLAYOUT + WmfRecordTypeResetDC = ($014C or GDIP_WMF_RECORD_BASE), // META_RESETDC + WmfRecordTypeStartDoc = ($014D or GDIP_WMF_RECORD_BASE), // META_STARTDOC + WmfRecordTypeStartPage = ($004F or GDIP_WMF_RECORD_BASE), // META_STARTPAGE + WmfRecordTypeEndPage = ($0050 or GDIP_WMF_RECORD_BASE), // META_ENDPAGE + WmfRecordTypeAbortDoc = ($0052 or GDIP_WMF_RECORD_BASE), // META_ABORTDOC + WmfRecordTypeEndDoc = ($005E or GDIP_WMF_RECORD_BASE), // META_ENDDOC + WmfRecordTypeDeleteObject = (META_DELETEOBJECT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeCreatePalette = (META_CREATEPALETTE or GDIP_WMF_RECORD_BASE), + WmfRecordTypeCreateBrush = ($00F8 or GDIP_WMF_RECORD_BASE), // META_CREATEBRUSH + WmfRecordTypeCreatePatternBrush = (META_CREATEPATTERNBRUSH or GDIP_WMF_RECORD_BASE), + WmfRecordTypeCreatePenIndirect = (META_CREATEPENINDIRECT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeCreateFontIndirect = (META_CREATEFONTINDIRECT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeCreateBrushIndirect = (META_CREATEBRUSHINDIRECT or GDIP_WMF_RECORD_BASE), + WmfRecordTypeCreateBitmapIndirect = ($02FD or GDIP_WMF_RECORD_BASE), // META_CREATEBITMAPINDIRECT + WmfRecordTypeCreateBitmap = ($06FE or GDIP_WMF_RECORD_BASE), // META_CREATEBITMAP + WmfRecordTypeCreateRegion = (META_CREATEREGION or GDIP_WMF_RECORD_BASE), + + EmfRecordTypeHeader = EMR_HEADER, + EmfRecordTypePolyBezier = EMR_POLYBEZIER, + EmfRecordTypePolygon = EMR_POLYGON, + EmfRecordTypePolyline = EMR_POLYLINE, + EmfRecordTypePolyBezierTo = EMR_POLYBEZIERTO, + EmfRecordTypePolyLineTo = EMR_POLYLINETO, + EmfRecordTypePolyPolyline = EMR_POLYPOLYLINE, + EmfRecordTypePolyPolygon = EMR_POLYPOLYGON, + EmfRecordTypeSetWindowExtEx = EMR_SETWINDOWEXTEX, + EmfRecordTypeSetWindowOrgEx = EMR_SETWINDOWORGEX, + EmfRecordTypeSetViewportExtEx = EMR_SETVIEWPORTEXTEX, + EmfRecordTypeSetViewportOrgEx = EMR_SETVIEWPORTORGEX, + EmfRecordTypeSetBrushOrgEx = EMR_SETBRUSHORGEX, + EmfRecordTypeEOF = EMR_EOF, + EmfRecordTypeSetPixelV = EMR_SETPIXELV, + EmfRecordTypeSetMapperFlags = EMR_SETMAPPERFLAGS, + EmfRecordTypeSetMapMode = EMR_SETMAPMODE, + EmfRecordTypeSetBkMode = EMR_SETBKMODE, + EmfRecordTypeSetPolyFillMode = EMR_SETPOLYFILLMODE, + EmfRecordTypeSetROP2 = EMR_SETROP2, + EmfRecordTypeSetStretchBltMode = EMR_SETSTRETCHBLTMODE, + EmfRecordTypeSetTextAlign = EMR_SETTEXTALIGN, + EmfRecordTypeSetColorAdjustment = EMR_SETCOLORADJUSTMENT, + EmfRecordTypeSetTextColor = EMR_SETTEXTCOLOR, + EmfRecordTypeSetBkColor = EMR_SETBKCOLOR, + EmfRecordTypeOffsetClipRgn = EMR_OFFSETCLIPRGN, + EmfRecordTypeMoveToEx = EMR_MOVETOEX, + EmfRecordTypeSetMetaRgn = EMR_SETMETARGN, + EmfRecordTypeExcludeClipRect = EMR_EXCLUDECLIPRECT, + EmfRecordTypeIntersectClipRect = EMR_INTERSECTCLIPRECT, + EmfRecordTypeScaleViewportExtEx = EMR_SCALEVIEWPORTEXTEX, + EmfRecordTypeScaleWindowExtEx = EMR_SCALEWINDOWEXTEX, + EmfRecordTypeSaveDC = EMR_SAVEDC, + EmfRecordTypeRestoreDC = EMR_RESTOREDC, + EmfRecordTypeSetWorldTransform = EMR_SETWORLDTRANSFORM, + EmfRecordTypeModifyWorldTransform = EMR_MODIFYWORLDTRANSFORM, + EmfRecordTypeSelectObject = EMR_SELECTOBJECT, + EmfRecordTypeCreatePen = EMR_CREATEPEN, + EmfRecordTypeCreateBrushIndirect = EMR_CREATEBRUSHINDIRECT, + EmfRecordTypeDeleteObject = EMR_DELETEOBJECT, + EmfRecordTypeAngleArc = EMR_ANGLEARC, + EmfRecordTypeEllipse = EMR_ELLIPSE, + EmfRecordTypeRectangle = EMR_RECTANGLE, + EmfRecordTypeRoundRect = EMR_ROUNDRECT, + EmfRecordTypeArc = EMR_ARC, + EmfRecordTypeChord = EMR_CHORD, + EmfRecordTypePie = EMR_PIE, + EmfRecordTypeSelectPalette = EMR_SELECTPALETTE, + EmfRecordTypeCreatePalette = EMR_CREATEPALETTE, + EmfRecordTypeSetPaletteEntries = EMR_SETPALETTEENTRIES, + EmfRecordTypeResizePalette = EMR_RESIZEPALETTE, + EmfRecordTypeRealizePalette = EMR_REALIZEPALETTE, + EmfRecordTypeExtFloodFill = EMR_EXTFLOODFILL, + EmfRecordTypeLineTo = EMR_LINETO, + EmfRecordTypeArcTo = EMR_ARCTO, + EmfRecordTypePolyDraw = EMR_POLYDRAW, + EmfRecordTypeSetArcDirection = EMR_SETARCDIRECTION, + EmfRecordTypeSetMiterLimit = EMR_SETMITERLIMIT, + EmfRecordTypeBeginPath = EMR_BEGINPATH, + EmfRecordTypeEndPath = EMR_ENDPATH, + EmfRecordTypeCloseFigure = EMR_CLOSEFIGURE, + EmfRecordTypeFillPath = EMR_FILLPATH, + EmfRecordTypeStrokeAndFillPath = EMR_STROKEANDFILLPATH, + EmfRecordTypeStrokePath = EMR_STROKEPATH, + EmfRecordTypeFlattenPath = EMR_FLATTENPATH, + EmfRecordTypeWidenPath = EMR_WIDENPATH, + EmfRecordTypeSelectClipPath = EMR_SELECTCLIPPATH, + EmfRecordTypeAbortPath = EMR_ABORTPATH, + EmfRecordTypeReserved_069 = 69, // Not Used + EmfRecordTypeGdiComment = EMR_GDICOMMENT, + EmfRecordTypeFillRgn = EMR_FILLRGN, + EmfRecordTypeFrameRgn = EMR_FRAMERGN, + EmfRecordTypeInvertRgn = EMR_INVERTRGN, + EmfRecordTypePaintRgn = EMR_PAINTRGN, + EmfRecordTypeExtSelectClipRgn = EMR_EXTSELECTCLIPRGN, + EmfRecordTypeBitBlt = EMR_BITBLT, + EmfRecordTypeStretchBlt = EMR_STRETCHBLT, + EmfRecordTypeMaskBlt = EMR_MASKBLT, + EmfRecordTypePlgBlt = EMR_PLGBLT, + EmfRecordTypeSetDIBitsToDevice = EMR_SETDIBITSTODEVICE, + EmfRecordTypeStretchDIBits = EMR_STRETCHDIBITS, + EmfRecordTypeExtCreateFontIndirect = EMR_EXTCREATEFONTINDIRECTW, + EmfRecordTypeExtTextOutA = EMR_EXTTEXTOUTA, + EmfRecordTypeExtTextOutW = EMR_EXTTEXTOUTW, + EmfRecordTypePolyBezier16 = EMR_POLYBEZIER16, + EmfRecordTypePolygon16 = EMR_POLYGON16, + EmfRecordTypePolyline16 = EMR_POLYLINE16, + EmfRecordTypePolyBezierTo16 = EMR_POLYBEZIERTO16, + EmfRecordTypePolylineTo16 = EMR_POLYLINETO16, + EmfRecordTypePolyPolyline16 = EMR_POLYPOLYLINE16, + EmfRecordTypePolyPolygon16 = EMR_POLYPOLYGON16, + EmfRecordTypePolyDraw16 = EMR_POLYDRAW16, + EmfRecordTypeCreateMonoBrush = EMR_CREATEMONOBRUSH, + EmfRecordTypeCreateDIBPatternBrushPt = EMR_CREATEDIBPATTERNBRUSHPT, + EmfRecordTypeExtCreatePen = EMR_EXTCREATEPEN, + EmfRecordTypePolyTextOutA = EMR_POLYTEXTOUTA, + EmfRecordTypePolyTextOutW = EMR_POLYTEXTOUTW, + EmfRecordTypeSetICMMode = 98, // EMR_SETICMMODE, + EmfRecordTypeCreateColorSpace = 99, // EMR_CREATECOLORSPACE, + EmfRecordTypeSetColorSpace = 100, // EMR_SETCOLORSPACE, + EmfRecordTypeDeleteColorSpace = 101, // EMR_DELETECOLORSPACE, + EmfRecordTypeGLSRecord = 102, // EMR_GLSRECORD, + EmfRecordTypeGLSBoundedRecord = 103, // EMR_GLSBOUNDEDRECORD, + EmfRecordTypePixelFormat = 104, // EMR_PIXELFORMAT, + EmfRecordTypeDrawEscape = 105, // EMR_RESERVED_105, + EmfRecordTypeExtEscape = 106, // EMR_RESERVED_106, + EmfRecordTypeStartDoc = 107, // EMR_RESERVED_107, + EmfRecordTypeSmallTextOut = 108, // EMR_RESERVED_108, + EmfRecordTypeForceUFIMapping = 109, // EMR_RESERVED_109, + EmfRecordTypeNamedEscape = 110, // EMR_RESERVED_110, + EmfRecordTypeColorCorrectPalette = 111, // EMR_COLORCORRECTPALETTE, + EmfRecordTypeSetICMProfileA = 112, // EMR_SETICMPROFILEA, + EmfRecordTypeSetICMProfileW = 113, // EMR_SETICMPROFILEW, + EmfRecordTypeAlphaBlend = 114, // EMR_ALPHABLEND, + EmfRecordTypeSetLayout = 115, // EMR_SETLAYOUT, + EmfRecordTypeTransparentBlt = 116, // EMR_TRANSPARENTBLT, + EmfRecordTypeReserved_117 = 117, // Not Used + EmfRecordTypeGradientFill = 118, // EMR_GRADIENTFILL, + EmfRecordTypeSetLinkedUFIs = 119, // EMR_RESERVED_119, + EmfRecordTypeSetTextJustification = 120, // EMR_RESERVED_120, + EmfRecordTypeColorMatchToTargetW = 121, // EMR_COLORMATCHTOTARGETW, + EmfRecordTypeCreateColorSpaceW = 122, // EMR_CREATECOLORSPACEW, + EmfRecordTypeMax = 122, + EmfRecordTypeMin = 1, + + // That is the END of the GDI EMF records. + + // Now we start the list of EMF+ records. We leave quite + // a bit of room here for the addition of any new GDI + // records that may be added later. + + EmfPlusRecordTypeInvalid = GDIP_EMFPLUS_RECORD_BASE, + EmfPlusRecordTypeHeader, + EmfPlusRecordTypeEndOfFile, + + EmfPlusRecordTypeComment, + + EmfPlusRecordTypeGetDC, + + EmfPlusRecordTypeMultiFormatStart, + EmfPlusRecordTypeMultiFormatSection, + EmfPlusRecordTypeMultiFormatEnd, + + // For all persistent objects + + EmfPlusRecordTypeObject, + + // Drawing Records + + EmfPlusRecordTypeClear, + EmfPlusRecordTypeFillRects, + EmfPlusRecordTypeDrawRects, + EmfPlusRecordTypeFillPolygon, + EmfPlusRecordTypeDrawLines, + EmfPlusRecordTypeFillEllipse, + EmfPlusRecordTypeDrawEllipse, + EmfPlusRecordTypeFillPie, + EmfPlusRecordTypeDrawPie, + EmfPlusRecordTypeDrawArc, + EmfPlusRecordTypeFillRegion, + EmfPlusRecordTypeFillPath, + EmfPlusRecordTypeDrawPath, + EmfPlusRecordTypeFillClosedCurve, + EmfPlusRecordTypeDrawClosedCurve, + EmfPlusRecordTypeDrawCurve, + EmfPlusRecordTypeDrawBeziers, + EmfPlusRecordTypeDrawImage, + EmfPlusRecordTypeDrawImagePoints, + EmfPlusRecordTypeDrawString, + + // Graphics State Records + + EmfPlusRecordTypeSetRenderingOrigin, + EmfPlusRecordTypeSetAntiAliasMode, + EmfPlusRecordTypeSetTextRenderingHint, + EmfPlusRecordTypeSetTextContrast, + EmfPlusRecordTypeSetInterpolationMode, + EmfPlusRecordTypeSetPixelOffsetMode, + EmfPlusRecordTypeSetCompositingMode, + EmfPlusRecordTypeSetCompositingQuality, + EmfPlusRecordTypeSave, + EmfPlusRecordTypeRestore, + EmfPlusRecordTypeBeginContainer, + EmfPlusRecordTypeBeginContainerNoParams, + EmfPlusRecordTypeEndContainer, + EmfPlusRecordTypeSetWorldTransform, + EmfPlusRecordTypeResetWorldTransform, + EmfPlusRecordTypeMultiplyWorldTransform, + EmfPlusRecordTypeTranslateWorldTransform, + EmfPlusRecordTypeScaleWorldTransform, + EmfPlusRecordTypeRotateWorldTransform, + EmfPlusRecordTypeSetPageTransform, + EmfPlusRecordTypeResetClip, + EmfPlusRecordTypeSetClipRect, + EmfPlusRecordTypeSetClipPath, + EmfPlusRecordTypeSetClipRegion, + EmfPlusRecordTypeOffsetClip, + + EmfPlusRecordTypeDrawDriverString, + + EmfPlusRecordTotal, + + EmfPlusRecordTypeMax = EmfPlusRecordTotal-1, + EmfPlusRecordTypeMin = EmfPlusRecordTypeHeader + ); + TEmfPlusRecordType = EmfPlusRecordType; +{$ELSE} +type + {$EXTERNALSYM EmfPlusRecordType} + EmfPlusRecordType = Integer; + // Since we have to enumerate GDI records right along with GDI+ records, + // We list all the GDI records here so that they can be part of the + // same enumeration type which is used in the enumeration callback. + const + WmfRecordTypeSetBkColor = (META_SETBKCOLOR or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetBkMode = (META_SETBKMODE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetMapMode = (META_SETMAPMODE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetROP2 = (META_SETROP2 or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetRelAbs = (META_SETRELABS or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetPolyFillMode = (META_SETPOLYFILLMODE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetStretchBltMode = (META_SETSTRETCHBLTMODE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetTextCharExtra = (META_SETTEXTCHAREXTRA or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetTextColor = (META_SETTEXTCOLOR or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetTextJustification = (META_SETTEXTJUSTIFICATION or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetWindowOrg = (META_SETWINDOWORG or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetWindowExt = (META_SETWINDOWEXT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetViewportOrg = (META_SETVIEWPORTORG or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetViewportExt = (META_SETVIEWPORTEXT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeOffsetWindowOrg = (META_OFFSETWINDOWORG or GDIP_WMF_RECORD_BASE); + WmfRecordTypeScaleWindowExt = (META_SCALEWINDOWEXT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeOffsetViewportOrg = (META_OFFSETVIEWPORTORG or GDIP_WMF_RECORD_BASE); + WmfRecordTypeScaleViewportExt = (META_SCALEVIEWPORTEXT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeLineTo = (META_LINETO or GDIP_WMF_RECORD_BASE); + WmfRecordTypeMoveTo = (META_MOVETO or GDIP_WMF_RECORD_BASE); + WmfRecordTypeExcludeClipRect = (META_EXCLUDECLIPRECT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeIntersectClipRect = (META_INTERSECTCLIPRECT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeArc = (META_ARC or GDIP_WMF_RECORD_BASE); + WmfRecordTypeEllipse = (META_ELLIPSE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeFloodFill = (META_FLOODFILL or GDIP_WMF_RECORD_BASE); + WmfRecordTypePie = (META_PIE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeRectangle = (META_RECTANGLE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeRoundRect = (META_ROUNDRECT or GDIP_WMF_RECORD_BASE); + WmfRecordTypePatBlt = (META_PATBLT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSaveDC = (META_SAVEDC or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetPixel = (META_SETPIXEL or GDIP_WMF_RECORD_BASE); + WmfRecordTypeOffsetClipRgn = (META_OFFSETCLIPRGN or GDIP_WMF_RECORD_BASE); + WmfRecordTypeTextOut = (META_TEXTOUT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeBitBlt = (META_BITBLT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeStretchBlt = (META_STRETCHBLT or GDIP_WMF_RECORD_BASE); + WmfRecordTypePolygon = (META_POLYGON or GDIP_WMF_RECORD_BASE); + WmfRecordTypePolyline = (META_POLYLINE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeEscape = (META_ESCAPE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeRestoreDC = (META_RESTOREDC or GDIP_WMF_RECORD_BASE); + WmfRecordTypeFillRegion = (META_FILLREGION or GDIP_WMF_RECORD_BASE); + WmfRecordTypeFrameRegion = (META_FRAMEREGION or GDIP_WMF_RECORD_BASE); + WmfRecordTypeInvertRegion = (META_INVERTREGION or GDIP_WMF_RECORD_BASE); + WmfRecordTypePaintRegion = (META_PAINTREGION or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSelectClipRegion = (META_SELECTCLIPREGION or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSelectObject = (META_SELECTOBJECT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetTextAlign = (META_SETTEXTALIGN or GDIP_WMF_RECORD_BASE); + WmfRecordTypeDrawText = ($062F or GDIP_WMF_RECORD_BASE); // META_DRAWTEXT + WmfRecordTypeChord = (META_CHORD or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetMapperFlags = (META_SETMAPPERFLAGS or GDIP_WMF_RECORD_BASE); + WmfRecordTypeExtTextOut = (META_EXTTEXTOUT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetDIBToDev = (META_SETDIBTODEV or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSelectPalette = (META_SELECTPALETTE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeRealizePalette = (META_REALIZEPALETTE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeAnimatePalette = (META_ANIMATEPALETTE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetPalEntries = (META_SETPALENTRIES or GDIP_WMF_RECORD_BASE); + WmfRecordTypePolyPolygon = (META_POLYPOLYGON or GDIP_WMF_RECORD_BASE); + WmfRecordTypeResizePalette = (META_RESIZEPALETTE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeDIBBitBlt = (META_DIBBITBLT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeDIBStretchBlt = (META_DIBSTRETCHBLT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeDIBCreatePatternBrush = (META_DIBCREATEPATTERNBRUSH or GDIP_WMF_RECORD_BASE); + WmfRecordTypeStretchDIB = (META_STRETCHDIB or GDIP_WMF_RECORD_BASE); + WmfRecordTypeExtFloodFill = (META_EXTFLOODFILL or GDIP_WMF_RECORD_BASE); + WmfRecordTypeSetLayout = ($0149 or GDIP_WMF_RECORD_BASE); // META_SETLAYOUT + WmfRecordTypeResetDC = ($014C or GDIP_WMF_RECORD_BASE); // META_RESETDC + WmfRecordTypeStartDoc = ($014D or GDIP_WMF_RECORD_BASE); // META_STARTDOC + WmfRecordTypeStartPage = ($004F or GDIP_WMF_RECORD_BASE); // META_STARTPAGE + WmfRecordTypeEndPage = ($0050 or GDIP_WMF_RECORD_BASE); // META_ENDPAGE + WmfRecordTypeAbortDoc = ($0052 or GDIP_WMF_RECORD_BASE); // META_ABORTDOC + WmfRecordTypeEndDoc = ($005E or GDIP_WMF_RECORD_BASE); // META_ENDDOC + WmfRecordTypeDeleteObject = (META_DELETEOBJECT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeCreatePalette = (META_CREATEPALETTE or GDIP_WMF_RECORD_BASE); + WmfRecordTypeCreateBrush = ($00F8 or GDIP_WMF_RECORD_BASE); // META_CREATEBRUSH + WmfRecordTypeCreatePatternBrush = (META_CREATEPATTERNBRUSH or GDIP_WMF_RECORD_BASE); + WmfRecordTypeCreatePenIndirect = (META_CREATEPENINDIRECT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeCreateFontIndirect = (META_CREATEFONTINDIRECT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeCreateBrushIndirect = (META_CREATEBRUSHINDIRECT or GDIP_WMF_RECORD_BASE); + WmfRecordTypeCreateBitmapIndirect = ($02FD or GDIP_WMF_RECORD_BASE); // META_CREATEBITMAPINDIRECT + WmfRecordTypeCreateBitmap = ($06FE or GDIP_WMF_RECORD_BASE); // META_CREATEBITMAP + WmfRecordTypeCreateRegion = (META_CREATEREGION or GDIP_WMF_RECORD_BASE); + + EmfRecordTypeHeader = EMR_HEADER; + EmfRecordTypePolyBezier = EMR_POLYBEZIER; + EmfRecordTypePolygon = EMR_POLYGON; + EmfRecordTypePolyline = EMR_POLYLINE; + EmfRecordTypePolyBezierTo = EMR_POLYBEZIERTO; + EmfRecordTypePolyLineTo = EMR_POLYLINETO; + EmfRecordTypePolyPolyline = EMR_POLYPOLYLINE; + EmfRecordTypePolyPolygon = EMR_POLYPOLYGON; + EmfRecordTypeSetWindowExtEx = EMR_SETWINDOWEXTEX; + EmfRecordTypeSetWindowOrgEx = EMR_SETWINDOWORGEX; + EmfRecordTypeSetViewportExtEx = EMR_SETVIEWPORTEXTEX; + EmfRecordTypeSetViewportOrgEx = EMR_SETVIEWPORTORGEX; + EmfRecordTypeSetBrushOrgEx = EMR_SETBRUSHORGEX; + EmfRecordTypeEOF = EMR_EOF; + EmfRecordTypeSetPixelV = EMR_SETPIXELV; + EmfRecordTypeSetMapperFlags = EMR_SETMAPPERFLAGS; + EmfRecordTypeSetMapMode = EMR_SETMAPMODE; + EmfRecordTypeSetBkMode = EMR_SETBKMODE; + EmfRecordTypeSetPolyFillMode = EMR_SETPOLYFILLMODE; + EmfRecordTypeSetROP2 = EMR_SETROP2; + EmfRecordTypeSetStretchBltMode = EMR_SETSTRETCHBLTMODE; + EmfRecordTypeSetTextAlign = EMR_SETTEXTALIGN; + EmfRecordTypeSetColorAdjustment = EMR_SETCOLORADJUSTMENT; + EmfRecordTypeSetTextColor = EMR_SETTEXTCOLOR; + EmfRecordTypeSetBkColor = EMR_SETBKCOLOR; + EmfRecordTypeOffsetClipRgn = EMR_OFFSETCLIPRGN; + EmfRecordTypeMoveToEx = EMR_MOVETOEX; + EmfRecordTypeSetMetaRgn = EMR_SETMETARGN; + EmfRecordTypeExcludeClipRect = EMR_EXCLUDECLIPRECT; + EmfRecordTypeIntersectClipRect = EMR_INTERSECTCLIPRECT; + EmfRecordTypeScaleViewportExtEx = EMR_SCALEVIEWPORTEXTEX; + EmfRecordTypeScaleWindowExtEx = EMR_SCALEWINDOWEXTEX; + EmfRecordTypeSaveDC = EMR_SAVEDC; + EmfRecordTypeRestoreDC = EMR_RESTOREDC; + EmfRecordTypeSetWorldTransform = EMR_SETWORLDTRANSFORM; + EmfRecordTypeModifyWorldTransform = EMR_MODIFYWORLDTRANSFORM; + EmfRecordTypeSelectObject = EMR_SELECTOBJECT; + EmfRecordTypeCreatePen = EMR_CREATEPEN; + EmfRecordTypeCreateBrushIndirect = EMR_CREATEBRUSHINDIRECT; + EmfRecordTypeDeleteObject = EMR_DELETEOBJECT; + EmfRecordTypeAngleArc = EMR_ANGLEARC; + EmfRecordTypeEllipse = EMR_ELLIPSE; + EmfRecordTypeRectangle = EMR_RECTANGLE; + EmfRecordTypeRoundRect = EMR_ROUNDRECT; + EmfRecordTypeArc = EMR_ARC; + EmfRecordTypeChord = EMR_CHORD; + EmfRecordTypePie = EMR_PIE; + EmfRecordTypeSelectPalette = EMR_SELECTPALETTE; + EmfRecordTypeCreatePalette = EMR_CREATEPALETTE; + EmfRecordTypeSetPaletteEntries = EMR_SETPALETTEENTRIES; + EmfRecordTypeResizePalette = EMR_RESIZEPALETTE; + EmfRecordTypeRealizePalette = EMR_REALIZEPALETTE; + EmfRecordTypeExtFloodFill = EMR_EXTFLOODFILL; + EmfRecordTypeLineTo = EMR_LINETO; + EmfRecordTypeArcTo = EMR_ARCTO; + EmfRecordTypePolyDraw = EMR_POLYDRAW; + EmfRecordTypeSetArcDirection = EMR_SETARCDIRECTION; + EmfRecordTypeSetMiterLimit = EMR_SETMITERLIMIT; + EmfRecordTypeBeginPath = EMR_BEGINPATH; + EmfRecordTypeEndPath = EMR_ENDPATH; + EmfRecordTypeCloseFigure = EMR_CLOSEFIGURE; + EmfRecordTypeFillPath = EMR_FILLPATH; + EmfRecordTypeStrokeAndFillPath = EMR_STROKEANDFILLPATH; + EmfRecordTypeStrokePath = EMR_STROKEPATH; + EmfRecordTypeFlattenPath = EMR_FLATTENPATH; + EmfRecordTypeWidenPath = EMR_WIDENPATH; + EmfRecordTypeSelectClipPath = EMR_SELECTCLIPPATH; + EmfRecordTypeAbortPath = EMR_ABORTPATH; + EmfRecordTypeReserved_069 = 69; // Not Used + EmfRecordTypeGdiComment = EMR_GDICOMMENT; + EmfRecordTypeFillRgn = EMR_FILLRGN; + EmfRecordTypeFrameRgn = EMR_FRAMERGN; + EmfRecordTypeInvertRgn = EMR_INVERTRGN; + EmfRecordTypePaintRgn = EMR_PAINTRGN; + EmfRecordTypeExtSelectClipRgn = EMR_EXTSELECTCLIPRGN; + EmfRecordTypeBitBlt = EMR_BITBLT; + EmfRecordTypeStretchBlt = EMR_STRETCHBLT; + EmfRecordTypeMaskBlt = EMR_MASKBLT; + EmfRecordTypePlgBlt = EMR_PLGBLT; + EmfRecordTypeSetDIBitsToDevice = EMR_SETDIBITSTODEVICE; + EmfRecordTypeStretchDIBits = EMR_STRETCHDIBITS; + EmfRecordTypeExtCreateFontIndirect = EMR_EXTCREATEFONTINDIRECTW; + EmfRecordTypeExtTextOutA = EMR_EXTTEXTOUTA; + EmfRecordTypeExtTextOutW = EMR_EXTTEXTOUTW; + EmfRecordTypePolyBezier16 = EMR_POLYBEZIER16; + EmfRecordTypePolygon16 = EMR_POLYGON16; + EmfRecordTypePolyline16 = EMR_POLYLINE16; + EmfRecordTypePolyBezierTo16 = EMR_POLYBEZIERTO16; + EmfRecordTypePolylineTo16 = EMR_POLYLINETO16; + EmfRecordTypePolyPolyline16 = EMR_POLYPOLYLINE16; + EmfRecordTypePolyPolygon16 = EMR_POLYPOLYGON16; + EmfRecordTypePolyDraw16 = EMR_POLYDRAW16; + EmfRecordTypeCreateMonoBrush = EMR_CREATEMONOBRUSH; + EmfRecordTypeCreateDIBPatternBrushPt = EMR_CREATEDIBPATTERNBRUSHPT; + EmfRecordTypeExtCreatePen = EMR_EXTCREATEPEN; + EmfRecordTypePolyTextOutA = EMR_POLYTEXTOUTA; + EmfRecordTypePolyTextOutW = EMR_POLYTEXTOUTW; + EmfRecordTypeSetICMMode = 98; // EMR_SETICMMODE, + EmfRecordTypeCreateColorSpace = 99; // EMR_CREATECOLORSPACE, + EmfRecordTypeSetColorSpace = 100; // EMR_SETCOLORSPACE, + EmfRecordTypeDeleteColorSpace = 101; // EMR_DELETECOLORSPACE, + EmfRecordTypeGLSRecord = 102; // EMR_GLSRECORD, + EmfRecordTypeGLSBoundedRecord = 103; // EMR_GLSBOUNDEDRECORD, + EmfRecordTypePixelFormat = 104; // EMR_PIXELFORMAT, + EmfRecordTypeDrawEscape = 105; // EMR_RESERVED_105, + EmfRecordTypeExtEscape = 106; // EMR_RESERVED_106, + EmfRecordTypeStartDoc = 107; // EMR_RESERVED_107, + EmfRecordTypeSmallTextOut = 108; // EMR_RESERVED_108, + EmfRecordTypeForceUFIMapping = 109; // EMR_RESERVED_109, + EmfRecordTypeNamedEscape = 110; // EMR_RESERVED_110, + EmfRecordTypeColorCorrectPalette = 111; // EMR_COLORCORRECTPALETTE, + EmfRecordTypeSetICMProfileA = 112; // EMR_SETICMPROFILEA, + EmfRecordTypeSetICMProfileW = 113; // EMR_SETICMPROFILEW, + EmfRecordTypeAlphaBlend = 114; // EMR_ALPHABLEND, + EmfRecordTypeSetLayout = 115; // EMR_SETLAYOUT, + EmfRecordTypeTransparentBlt = 116; // EMR_TRANSPARENTBLT, + EmfRecordTypeReserved_117 = 117; // Not Used + EmfRecordTypeGradientFill = 118; // EMR_GRADIENTFILL, + EmfRecordTypeSetLinkedUFIs = 119; // EMR_RESERVED_119, + EmfRecordTypeSetTextJustification = 120; // EMR_RESERVED_120, + EmfRecordTypeColorMatchToTargetW = 121; // EMR_COLORMATCHTOTARGETW, + EmfRecordTypeCreateColorSpaceW = 122; // EMR_CREATECOLORSPACEW, + EmfRecordTypeMax = 122; + EmfRecordTypeMin = 1; + + // That is the END of the GDI EMF records. + + // Now we start the list of EMF+ records. We leave quite + // a bit of room here for the addition of any new GDI + // records that may be added later. + + EmfPlusRecordTypeInvalid = GDIP_EMFPLUS_RECORD_BASE; + EmfPlusRecordTypeHeader = GDIP_EMFPLUS_RECORD_BASE + 1; + EmfPlusRecordTypeEndOfFile = GDIP_EMFPLUS_RECORD_BASE + 2; + + EmfPlusRecordTypeComment = GDIP_EMFPLUS_RECORD_BASE + 3; + + EmfPlusRecordTypeGetDC = GDIP_EMFPLUS_RECORD_BASE + 4; + + EmfPlusRecordTypeMultiFormatStart = GDIP_EMFPLUS_RECORD_BASE + 5; + EmfPlusRecordTypeMultiFormatSection = GDIP_EMFPLUS_RECORD_BASE + 6; + EmfPlusRecordTypeMultiFormatEnd = GDIP_EMFPLUS_RECORD_BASE + 7; + + // For all persistent objects + + EmfPlusRecordTypeObject = GDIP_EMFPLUS_RECORD_BASE + 8; + + // Drawing Records + + EmfPlusRecordTypeClear = GDIP_EMFPLUS_RECORD_BASE + 9; + EmfPlusRecordTypeFillRects = GDIP_EMFPLUS_RECORD_BASE + 10; + EmfPlusRecordTypeDrawRects = GDIP_EMFPLUS_RECORD_BASE + 11; + EmfPlusRecordTypeFillPolygon = GDIP_EMFPLUS_RECORD_BASE + 12; + EmfPlusRecordTypeDrawLines = GDIP_EMFPLUS_RECORD_BASE + 13; + EmfPlusRecordTypeFillEllipse = GDIP_EMFPLUS_RECORD_BASE + 14; + EmfPlusRecordTypeDrawEllipse = GDIP_EMFPLUS_RECORD_BASE + 15; + EmfPlusRecordTypeFillPie = GDIP_EMFPLUS_RECORD_BASE + 16; + EmfPlusRecordTypeDrawPie = GDIP_EMFPLUS_RECORD_BASE + 17; + EmfPlusRecordTypeDrawArc = GDIP_EMFPLUS_RECORD_BASE + 18; + EmfPlusRecordTypeFillRegion = GDIP_EMFPLUS_RECORD_BASE + 19; + EmfPlusRecordTypeFillPath = GDIP_EMFPLUS_RECORD_BASE + 20; + EmfPlusRecordTypeDrawPath = GDIP_EMFPLUS_RECORD_BASE + 21; + EmfPlusRecordTypeFillClosedCurve = GDIP_EMFPLUS_RECORD_BASE + 22; + EmfPlusRecordTypeDrawClosedCurve = GDIP_EMFPLUS_RECORD_BASE + 23; + EmfPlusRecordTypeDrawCurve = GDIP_EMFPLUS_RECORD_BASE + 24; + EmfPlusRecordTypeDrawBeziers = GDIP_EMFPLUS_RECORD_BASE + 25; + EmfPlusRecordTypeDrawImage = GDIP_EMFPLUS_RECORD_BASE + 26; + EmfPlusRecordTypeDrawImagePoints = GDIP_EMFPLUS_RECORD_BASE + 27; + EmfPlusRecordTypeDrawString = GDIP_EMFPLUS_RECORD_BASE + 28; + + // Graphics State Records + + EmfPlusRecordTypeSetRenderingOrigin = GDIP_EMFPLUS_RECORD_BASE + 29; + EmfPlusRecordTypeSetAntiAliasMode = GDIP_EMFPLUS_RECORD_BASE + 30; + EmfPlusRecordTypeSetTextRenderingHint = GDIP_EMFPLUS_RECORD_BASE + 31; + EmfPlusRecordTypeSetTextContrast = GDIP_EMFPLUS_RECORD_BASE + 32; + EmfPlusRecordTypeSetInterpolationMode = GDIP_EMFPLUS_RECORD_BASE + 33; + EmfPlusRecordTypeSetPixelOffsetMode = GDIP_EMFPLUS_RECORD_BASE + 34; + EmfPlusRecordTypeSetCompositingMode = GDIP_EMFPLUS_RECORD_BASE + 35; + EmfPlusRecordTypeSetCompositingQuality = GDIP_EMFPLUS_RECORD_BASE + 36; + EmfPlusRecordTypeSave = GDIP_EMFPLUS_RECORD_BASE + 37; + EmfPlusRecordTypeRestore = GDIP_EMFPLUS_RECORD_BASE + 38; + EmfPlusRecordTypeBeginContainer = GDIP_EMFPLUS_RECORD_BASE + 39; + EmfPlusRecordTypeBeginContainerNoParams = GDIP_EMFPLUS_RECORD_BASE + 40; + EmfPlusRecordTypeEndContainer = GDIP_EMFPLUS_RECORD_BASE + 41; + EmfPlusRecordTypeSetWorldTransform = GDIP_EMFPLUS_RECORD_BASE + 42; + EmfPlusRecordTypeResetWorldTransform = GDIP_EMFPLUS_RECORD_BASE + 43; + EmfPlusRecordTypeMultiplyWorldTransform = GDIP_EMFPLUS_RECORD_BASE + 44; + EmfPlusRecordTypeTranslateWorldTransform = GDIP_EMFPLUS_RECORD_BASE + 45; + EmfPlusRecordTypeScaleWorldTransform = GDIP_EMFPLUS_RECORD_BASE + 46; + EmfPlusRecordTypeRotateWorldTransform = GDIP_EMFPLUS_RECORD_BASE + 47; + EmfPlusRecordTypeSetPageTransform = GDIP_EMFPLUS_RECORD_BASE + 48; + EmfPlusRecordTypeResetClip = GDIP_EMFPLUS_RECORD_BASE + 49; + EmfPlusRecordTypeSetClipRect = GDIP_EMFPLUS_RECORD_BASE + 50; + EmfPlusRecordTypeSetClipPath = GDIP_EMFPLUS_RECORD_BASE + 51; + EmfPlusRecordTypeSetClipRegion = GDIP_EMFPLUS_RECORD_BASE + 52; + EmfPlusRecordTypeOffsetClip = GDIP_EMFPLUS_RECORD_BASE + 53; + + EmfPlusRecordTypeDrawDriverString = GDIP_EMFPLUS_RECORD_BASE + 54; + + EmfPlusRecordTotal = GDIP_EMFPLUS_RECORD_BASE + 55; + + EmfPlusRecordTypeMax = EmfPlusRecordTotal-1; + EmfPlusRecordTypeMin = EmfPlusRecordTypeHeader; + +type + TEmfPlusRecordType = EmfPlusRecordType; +{$ENDIF} +//--------------------------------------------------------------------------- +// StringFormatFlags +//--------------------------------------------------------------------------- + +//--------------------------------------------------------------------------- +// String format flags +// +// DirectionRightToLeft - For horizontal text, the reading order is +// right to left. This value is called +// the base embedding level by the Unicode +// bidirectional engine. +// For vertical text, columns are read from +// right to left. +// By default, horizontal or vertical text is +// read from left to right. +// +// DirectionVertical - Individual lines of text are vertical. In +// each line, characters progress from top to +// bottom. +// By default, lines of text are horizontal, +// each new line below the previous line. +// +// NoFitBlackBox - Allows parts of glyphs to overhang the +// bounding rectangle. +// By default glyphs are first aligned +// inside the margines, then any glyphs which +// still overhang the bounding box are +// repositioned to avoid any overhang. +// For example when an italic +// lower case letter f in a font such as +// Garamond is aligned at the far left of a +// rectangle, the lower part of the f will +// reach slightly further left than the left +// edge of the rectangle. Setting this flag +// will ensure the character aligns visually +// with the lines above and below, but may +// cause some pixels outside the formatting +// rectangle to be clipped or painted. +// +// DisplayFormatControl - Causes control characters such as the +// left-to-right mark to be shown in the +// output with a representative glyph. +// +// NoFontFallback - Disables fallback to alternate fonts for +// characters not supported in the requested +// font. Any missing characters will be +// be displayed with the fonts missing glyph, +// usually an open square. +// +// NoWrap - Disables wrapping of text between lines +// when formatting within a rectangle. +// NoWrap is implied when a point is passed +// instead of a rectangle, or when the +// specified rectangle has a zero line length. +// +// NoClip - By default text is clipped to the +// formatting rectangle. Setting NoClip +// allows overhanging pixels to affect the +// device outside the formatting rectangle. +// Pixels at the end of the line may be +// affected if the glyphs overhang their +// cells, and either the NoFitBlackBox flag +// has been set, or the glyph extends to far +// to be fitted. +// Pixels above/before the first line or +// below/after the last line may be affected +// if the glyphs extend beyond their cell +// ascent / descent. This can occur rarely +// with unusual diacritic mark combinations. + +//--------------------------------------------------------------------------- + + {$EXTERNALSYM StringFormatFlags} + StringFormatFlags = Integer; + const + StringFormatFlagsDirectionRightToLeft = $00000001; + StringFormatFlagsDirectionVertical = $00000002; + StringFormatFlagsNoFitBlackBox = $00000004; + StringFormatFlagsDisplayFormatControl = $00000020; + StringFormatFlagsNoFontFallback = $00000400; + StringFormatFlagsMeasureTrailingSpaces = $00000800; + StringFormatFlagsNoWrap = $00001000; + StringFormatFlagsLineLimit = $00002000; + + StringFormatFlagsNoClip = $00004000; + +Type + TStringFormatFlags = StringFormatFlags; + +//--------------------------------------------------------------------------- +// StringTrimming +//--------------------------------------------------------------------------- + + {$EXTERNALSYM StringTrimming} + StringTrimming = ( + StringTrimmingNone, + StringTrimmingCharacter, + StringTrimmingWord, + StringTrimmingEllipsisCharacter, + StringTrimmingEllipsisWord, + StringTrimmingEllipsisPath + ); + TStringTrimming = StringTrimming; + +//--------------------------------------------------------------------------- +// National language digit substitution +//--------------------------------------------------------------------------- + + {$EXTERNALSYM StringDigitSubstitute} + StringDigitSubstitute = ( + StringDigitSubstituteUser, // As NLS setting + StringDigitSubstituteNone, + StringDigitSubstituteNational, + StringDigitSubstituteTraditional + ); + TStringDigitSubstitute = StringDigitSubstitute; + PStringDigitSubstitute = ^TStringDigitSubstitute; + +//--------------------------------------------------------------------------- +// Hotkey prefix interpretation +//--------------------------------------------------------------------------- + + {$EXTERNALSYM HotkeyPrefix} + HotkeyPrefix = ( + HotkeyPrefixNone, + HotkeyPrefixShow, + HotkeyPrefixHide + ); + THotkeyPrefix = HotkeyPrefix; + +//--------------------------------------------------------------------------- +// String alignment flags +//--------------------------------------------------------------------------- + + {$EXTERNALSYM StringAlignment} + StringAlignment = ( + // Left edge for left-to-right text, + // right for right-to-left text, + // and top for vertical + StringAlignmentNear, + StringAlignmentCenter, + StringAlignmentFar + ); + TStringAlignment = StringAlignment; + +//--------------------------------------------------------------------------- +// DriverStringOptions +//--------------------------------------------------------------------------- + + {$EXTERNALSYM DriverStringOptions} + DriverStringOptions = Integer; + const + DriverStringOptionsCmapLookup = 1; + DriverStringOptionsVertical = 2; + DriverStringOptionsRealizedAdvance = 4; + DriverStringOptionsLimitSubpixel = 8; + +type + TDriverStringOptions = DriverStringOptions; + +//--------------------------------------------------------------------------- +// Flush Intention flags +//--------------------------------------------------------------------------- + + {$EXTERNALSYM FlushIntention} + FlushIntention = ( + FlushIntentionFlush, // Flush all batched rendering operations + FlushIntentionSync // Flush all batched rendering operations + // and wait for them to complete + ); + TFlushIntention = FlushIntention; + +//--------------------------------------------------------------------------- +// Image encoder parameter related types +//--------------------------------------------------------------------------- + + {$EXTERNALSYM EncoderParameterValueType} + EncoderParameterValueType = Integer; + const + EncoderParameterValueTypeByte : Integer = 1; // 8-bit unsigned int + EncoderParameterValueTypeASCII : Integer = 2; // 8-bit byte containing one 7-bit ASCII + // code. NULL terminated. + EncoderParameterValueTypeShort : Integer = 3; // 16-bit unsigned int + EncoderParameterValueTypeLong : Integer = 4; // 32-bit unsigned int + EncoderParameterValueTypeRational : Integer = 5; // Two Longs. The first Long is the + // numerator, the second Long expresses the + // denomintor. + EncoderParameterValueTypeLongRange : Integer = 6; // Two longs which specify a range of + // integer values. The first Long specifies + // the lower end and the second one + // specifies the higher end. All values + // are inclusive at both ends + EncoderParameterValueTypeUndefined : Integer = 7; // 8-bit byte that can take any value + // depending on field definition + EncoderParameterValueTypeRationalRange : Integer = 8; // Two Rationals. The first Rational + // specifies the lower end and the second + // specifies the higher end. All values + // are inclusive at both ends +type + TEncoderParameterValueType = EncoderParameterValueType; + +//--------------------------------------------------------------------------- +// Image encoder value types +//--------------------------------------------------------------------------- + + {$EXTERNALSYM EncoderValue} + EncoderValue = ( + EncoderValueColorTypeCMYK, + EncoderValueColorTypeYCCK, + EncoderValueCompressionLZW, + EncoderValueCompressionCCITT3, + EncoderValueCompressionCCITT4, + EncoderValueCompressionRle, + EncoderValueCompressionNone, + EncoderValueScanMethodInterlaced, + EncoderValueScanMethodNonInterlaced, + EncoderValueVersionGif87, + EncoderValueVersionGif89, + EncoderValueRenderProgressive, + EncoderValueRenderNonProgressive, + EncoderValueTransformRotate90, + EncoderValueTransformRotate180, + EncoderValueTransformRotate270, + EncoderValueTransformFlipHorizontal, + EncoderValueTransformFlipVertical, + EncoderValueMultiFrame, + EncoderValueLastFrame, + EncoderValueFlush, + EncoderValueFrameDimensionTime, + EncoderValueFrameDimensionResolution, + EncoderValueFrameDimensionPage + ); + TEncoderValue = EncoderValue; + +//--------------------------------------------------------------------------- +// Conversion of Emf To WMF Bits flags +//--------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM EmfToWmfBitsFlags} + EmfToWmfBitsFlags = ( + EmfToWmfBitsFlagsDefault = $00000000, + EmfToWmfBitsFlagsEmbedEmf = $00000001, + EmfToWmfBitsFlagsIncludePlaceable = $00000002, + EmfToWmfBitsFlagsNoXORClip = $00000004 + ); + TEmfToWmfBitsFlags = EmfToWmfBitsFlags; +{$ELSE} + {$EXTERNALSYM EmfToWmfBitsFlags} + EmfToWmfBitsFlags = Integer; + const + EmfToWmfBitsFlagsDefault = $00000000; + EmfToWmfBitsFlagsEmbedEmf = $00000001; + EmfToWmfBitsFlagsIncludePlaceable = $00000002; + EmfToWmfBitsFlagsNoXORClip = $00000004; + +type + TEmfToWmfBitsFlags = EmfToWmfBitsFlags; +{$ENDIF} +(**************************************************************************\ +* +* GDI+ Types +* +\**************************************************************************) + +//-------------------------------------------------------------------------- +// Callback functions +//-------------------------------------------------------------------------- + + {$EXTERNALSYM ImageAbort} + ImageAbort = function: BOOL; stdcall; + {$EXTERNALSYM DrawImageAbort} + DrawImageAbort = ImageAbort; + {$EXTERNALSYM GetThumbnailImageAbort} + GetThumbnailImageAbort = ImageAbort; + + + // Callback for EnumerateMetafile methods. The parameters are: + + // recordType WMF, EMF, or EMF+ record type + // flags (always 0 for WMF/EMF records) + // dataSize size of the record data (in bytes), or 0 if no data + // data pointer to the record data, or NULL if no data + // callbackData pointer to callbackData, if any + + // This method can then call Metafile::PlayRecord to play the + // record that was just enumerated. If this method returns + // FALSE, the enumeration process is aborted. Otherwise, it continues. + + {$EXTERNALSYM EnumerateMetafileProc} + EnumerateMetafileProc = function(recordType: EmfPlusRecordType; flags: UINT; + dataSize: UINT; data: PBYTE; callbackData: pointer): BOOL; stdcall; + +//-------------------------------------------------------------------------- +// Primitive data types +// +// NOTE: +// Types already defined in standard header files: +// INT8 +// UINT8 +// INT16 +// UINT16 +// INT32 +// UINT32 +// INT64 +// UINT64 +// +// Avoid using the following types: +// LONG - use INT +// ULONG - use UINT +// DWORD - use UINT32 +//-------------------------------------------------------------------------- + +const + { from float.h } + FLT_MAX = 3.402823466e+38; // max value + FLT_MIN = 1.175494351e-38; // min positive value + + REAL_MAX = FLT_MAX; + {$EXTERNALSYM REAL_MAX} + REAL_MIN = FLT_MIN; + {$EXTERNALSYM REAL_MIN} + REAL_TOLERANCE = (FLT_MIN * 100); + {$EXTERNALSYM REAL_TOLERANCE} + REAL_EPSILON = 1.192092896e-07; // FLT_EPSILON + {$EXTERNALSYM REAL_EPSILON} + +//-------------------------------------------------------------------------- +// Status return values from GDI+ methods +//-------------------------------------------------------------------------- +type + {$EXTERNALSYM Status} + Status = ( + Ok, + GenericError, + InvalidParameter, + OutOfMemory, + ObjectBusy, + InsufficientBuffer, + NotImplemented, + Win32Error, + WrongState, + Aborted, + FileNotFound, + ValueOverflow, + AccessDenied, + UnknownImageFormat, + FontFamilyNotFound, + FontStyleNotFound, + NotTrueTypeFont, + UnsupportedGdiplusVersion, + GdiplusNotInitialized, + PropertyNotFound, + PropertyNotSupported + ); + TStatus = Status; + +//-------------------------------------------------------------------------- +// Represents a dimension in a 2D coordinate system (floating-point coordinates) +//-------------------------------------------------------------------------- + +type + PGPSizeF = ^TGPSizeF; + TGPSizeF = packed record + Width : Single; + Height : Single; + end; + + function MakeSize(Width, Height: Single): TGPSizeF; overload; + +//-------------------------------------------------------------------------- +// Represents a dimension in a 2D coordinate system (integer coordinates) +//-------------------------------------------------------------------------- + +type + PGPSize = ^TGPSize; + TGPSize = packed record + Width : Integer; + Height : Integer; + end; + + function MakeSize(Width, Height: Integer): TGPSize; overload; + +//-------------------------------------------------------------------------- +// Represents a location in a 2D coordinate system (floating-point coordinates) +//-------------------------------------------------------------------------- + +type + PGPPointF = ^TGPPointF; + TGPPointF = packed record + X : Single; + Y : Single; + end; + TPointFDynArray = array of TGPPointF; + + function MakePoint(X, Y: Single): TGPPointF; overload; + +//-------------------------------------------------------------------------- +// Represents a location in a 2D coordinate system (integer coordinates) +//-------------------------------------------------------------------------- + +type + PGPPoint = ^TGPPoint; + TGPPoint = packed record + X : Integer; + Y : Integer; + end; + TPointDynArray = array of TGPPoint; + + function MakePoint(X, Y: Integer): TGPPoint; overload; + +//-------------------------------------------------------------------------- +// Represents a rectangle in a 2D coordinate system (floating-point coordinates) +//-------------------------------------------------------------------------- + +type + PGPRectF = ^TGPRectF; + TGPRectF = packed record + X : Single; + Y : Single; + Width : Single; + Height: Single; + end; + TRectFDynArray = array of TGPRectF; + + function MakeRect(x, y, width, height: Single): TGPRectF; overload; + function MakeRect(location: TGPPointF; size: TGPSizeF): TGPRectF; overload; + +type + PGPRect = ^TGPRect; + TGPRect = packed record + X : Integer; + Y : Integer; + Width : Integer; + Height: Integer; + end; + TRectDynArray = array of TGPRect; + + function MakeRect(x, y, width, height: Integer): TGPRect; overload; + function MakeRect(location: TGPPoint; size: TGPSize): TGPRect; overload; + function MakeRect(const Rect: TRect): TGPRect; overload; + +type + TPathData = packed class + public + Count : Integer; + Points : PGPPointF; + Types : PBYTE; + constructor Create; + destructor destroy; override; + end; + + PCharacterRange = ^TCharacterRange; + TCharacterRange = packed record + First : Integer; + Length : Integer; + end; + + function MakeCharacterRange(First, Length: Integer): TCharacterRange; + +(************************************************************************** +* +* GDI+ Startup and Shutdown APIs +* +**************************************************************************) +type + {$EXTERNALSYM DebugEventLevel} + DebugEventLevel = ( + DebugEventLevelFatal, + DebugEventLevelWarning + ); + TDebugEventLevel = DebugEventLevel; + + // Callback function that GDI+ can call, on debug builds, for assertions + // and warnings. + + {$EXTERNALSYM DebugEventProc} + DebugEventProc = procedure(level: DebugEventLevel; message: PChar); stdcall; + + // Notification functions which the user must call appropriately if + // "SuppressBackgroundThread" (below) is set. + + {$EXTERNALSYM NotificationHookProc} + NotificationHookProc = function(out token: ULONG): Status; stdcall; + {$EXTERNALSYM NotificationUnhookProc} + NotificationUnhookProc = procedure(token: ULONG); stdcall; + + // Input structure for GdiplusStartup + + {$EXTERNALSYM GdiplusStartupInput} + GdiplusStartupInput = packed record + GdiplusVersion : Cardinal; // Must be 1 + DebugEventCallback : DebugEventProc; // Ignored on free builds + SuppressBackgroundThread: BOOL; // FALSE unless you're prepared to call + // the hook/unhook functions properly + SuppressExternalCodecs : BOOL; // FALSE unless you want GDI+ only to use + end; // its internal image codecs. + TGdiplusStartupInput = GdiplusStartupInput; + PGdiplusStartupInput = ^TGdiplusStartupInput; + + // Output structure for GdiplusStartup() + + {$EXTERNALSYM GdiplusStartupOutput} + GdiplusStartupOutput = packed record + // The following 2 fields are NULL if SuppressBackgroundThread is FALSE. + // Otherwise, they are functions which must be called appropriately to + // replace the background thread. + // + // These should be called on the application's main message loop - i.e. + // a message loop which is active for the lifetime of GDI+. + // "NotificationHook" should be called before starting the loop, + // and "NotificationUnhook" should be called after the loop ends. + + NotificationHook : NotificationHookProc; + NotificationUnhook: NotificationUnhookProc; + end; + TGdiplusStartupOutput = GdiplusStartupOutput; + PGdiplusStartupOutput = ^TGdiplusStartupOutput; + + // GDI+ initialization. Must not be called from DllMain - can cause deadlock. + // + // Must be called before GDI+ API's or constructors are used. + // + // token - may not be NULL - accepts a token to be passed in the corresponding + // GdiplusShutdown call. + // input - may not be NULL + // output - may be NULL only if input->SuppressBackgroundThread is FALSE. + + {$EXTERNALSYM GdiplusStartup} + function GdiplusStartup(out token: ULONG; input: PGdiplusStartupInput; + output: PGdiplusStartupOutput): Status; stdcall; + + // GDI+ termination. Must be called before GDI+ is unloaded. + // Must not be called from DllMain - can cause deadlock. + // + // GDI+ API's may not be called after GdiplusShutdown. Pay careful attention + // to GDI+ object destructors. + + {$EXTERNALSYM GdiplusShutdown} + procedure GdiplusShutdown(token: ULONG); stdcall; + + +(**************************************************************************\ +* +* Copyright (c) 1998-2001, Microsoft Corp. All Rights Reserved. +* Module Name: +* Gdiplus Pixel Formats +* Abstract: +* GDI+ Pixel Formats +* +\**************************************************************************) + +type + PARGB = ^ARGB; + ARGB = DWORD; + {$EXTERNALSYM ARGB} + ARGB64 = Int64; + {$EXTERNALSYM ARGB64} + +const + ALPHA_SHIFT = 24; + {$EXTERNALSYM ALPHA_SHIFT} + RED_SHIFT = 16; + {$EXTERNALSYM RED_SHIFT} + GREEN_SHIFT = 8; + {$EXTERNALSYM GREEN_SHIFT} + BLUE_SHIFT = 0; + {$EXTERNALSYM BLUE_SHIFT} + ALPHA_MASK = (ARGB($ff) shl ALPHA_SHIFT); + {$EXTERNALSYM ALPHA_MASK} + + // In-memory pixel data formats: + // bits 0-7 = format index + // bits 8-15 = pixel size (in bits) + // bits 16-23 = flags + // bits 24-31 = reserved + +type + PixelFormat = Integer; + {$EXTERNALSYM PixelFormat} + TPixelFormat = PixelFormat; + +const + PixelFormatIndexed = $00010000; // Indexes into a palette + {$EXTERNALSYM PixelFormatIndexed} + PixelFormatGDI = $00020000; // Is a GDI-supported format + {$EXTERNALSYM PixelFormatGDI} + PixelFormatAlpha = $00040000; // Has an alpha component + {$EXTERNALSYM PixelFormatAlpha} + PixelFormatPAlpha = $00080000; // Pre-multiplied alpha + {$EXTERNALSYM PixelFormatPAlpha} + PixelFormatExtended = $00100000; // Extended color 16 bits/channel + {$EXTERNALSYM PixelFormatExtended} + PixelFormatCanonical = $00200000; + {$EXTERNALSYM PixelFormatCanonical} + + PixelFormatUndefined = 0; + {$EXTERNALSYM PixelFormatUndefined} + PixelFormatDontCare = 0; + {$EXTERNALSYM PixelFormatDontCare} + + PixelFormat1bppIndexed = (1 or ( 1 shl 8) or PixelFormatIndexed or PixelFormatGDI); + {$EXTERNALSYM PixelFormat1bppIndexed} + PixelFormat4bppIndexed = (2 or ( 4 shl 8) or PixelFormatIndexed or PixelFormatGDI); + {$EXTERNALSYM PixelFormat4bppIndexed} + PixelFormat8bppIndexed = (3 or ( 8 shl 8) or PixelFormatIndexed or PixelFormatGDI); + {$EXTERNALSYM PixelFormat8bppIndexed} + PixelFormat16bppGrayScale = (4 or (16 shl 8) or PixelFormatExtended); + {$EXTERNALSYM PixelFormat16bppGrayScale} + PixelFormat16bppRGB555 = (5 or (16 shl 8) or PixelFormatGDI); + {$EXTERNALSYM PixelFormat16bppRGB555} + PixelFormat16bppRGB565 = (6 or (16 shl 8) or PixelFormatGDI); + {$EXTERNALSYM PixelFormat16bppRGB565} + PixelFormat16bppARGB1555 = (7 or (16 shl 8) or PixelFormatAlpha or PixelFormatGDI); + {$EXTERNALSYM PixelFormat16bppARGB1555} + PixelFormat24bppRGB = (8 or (24 shl 8) or PixelFormatGDI); + {$EXTERNALSYM PixelFormat24bppRGB} + PixelFormat32bppRGB = (9 or (32 shl 8) or PixelFormatGDI); + {$EXTERNALSYM PixelFormat32bppRGB} + PixelFormat32bppARGB = (10 or (32 shl 8) or PixelFormatAlpha or PixelFormatGDI or PixelFormatCanonical); + {$EXTERNALSYM PixelFormat32bppARGB} + PixelFormat32bppPARGB = (11 or (32 shl 8) or PixelFormatAlpha or PixelFormatPAlpha or PixelFormatGDI); + {$EXTERNALSYM PixelFormat32bppPARGB} + PixelFormat48bppRGB = (12 or (48 shl 8) or PixelFormatExtended); + {$EXTERNALSYM PixelFormat48bppRGB} + PixelFormat64bppARGB = (13 or (64 shl 8) or PixelFormatAlpha or PixelFormatCanonical or PixelFormatExtended); + {$EXTERNALSYM PixelFormat64bppARGB} + PixelFormat64bppPARGB = (14 or (64 shl 8) or PixelFormatAlpha or PixelFormatPAlpha or PixelFormatExtended); + {$EXTERNALSYM PixelFormat64bppPARGB} + PixelFormatMax = 15; + {$EXTERNALSYM PixelFormatMax} + +{$EXTERNALSYM GetPixelFormatSize} +function GetPixelFormatSize(pixfmt: PixelFormat): UINT; +{$EXTERNALSYM IsIndexedPixelFormat} +function IsIndexedPixelFormat(pixfmt: PixelFormat): BOOL; +{$EXTERNALSYM IsAlphaPixelFormat} +function IsAlphaPixelFormat(pixfmt: PixelFormat): BOOL; +{$EXTERNALSYM IsExtendedPixelFormat} +function IsExtendedPixelFormat(pixfmt: PixelFormat): BOOL; + +//-------------------------------------------------------------------------- +// Determine if the Pixel Format is Canonical format: +// PixelFormat32bppARGB +// PixelFormat32bppPARGB +// PixelFormat64bppARGB +// PixelFormat64bppPARGB +//-------------------------------------------------------------------------- + +{$EXTERNALSYM IsCanonicalPixelFormat} +function IsCanonicalPixelFormat(pixfmt: PixelFormat): BOOL; + +{$IFDEF DELPHI6_UP} +type + {$EXTERNALSYM PaletteFlags} + PaletteFlags = ( + PaletteFlagsHasAlpha = $0001, + PaletteFlagsGrayScale = $0002, + PaletteFlagsHalftone = $0004 + ); + TPaletteFlags = PaletteFlags; +{$ELSE} +type + {$EXTERNALSYM PaletteFlags} + PaletteFlags = Integer; + const + PaletteFlagsHasAlpha = $0001; + PaletteFlagsGrayScale = $0002; + PaletteFlagsHalftone = $0004; + +type + TPaletteFlags = PaletteFlags; +{$ENDIF} + + {$EXTERNALSYM ColorPalette} + ColorPalette = packed record + Flags : UINT ; // Palette flags + Count : UINT ; // Number of color entries + Entries: array [0..0] of ARGB ; // Palette color entries + end; + + TColorPalette = ColorPalette; + PColorPalette = ^TColorPalette; + +(**************************************************************************\ +* +* GDI+ Color Object +* +\**************************************************************************) + +//---------------------------------------------------------------------------- +// Color mode +//---------------------------------------------------------------------------- + + {$EXTERNALSYM ColorMode} + ColorMode = ( + ColorModeARGB32, + ColorModeARGB64 + ); + TColorMode = ColorMode; + +//---------------------------------------------------------------------------- +// Color Channel flags +//---------------------------------------------------------------------------- + + {$EXTERNALSYM ColorChannelFlags} + ColorChannelFlags = ( + ColorChannelFlagsC, + ColorChannelFlagsM, + ColorChannelFlagsY, + ColorChannelFlagsK, + ColorChannelFlagsLast + ); + TColorChannelFlags = ColorChannelFlags; + +//---------------------------------------------------------------------------- +// Color +//---------------------------------------------------------------------------- + + // Common color constants +const + aclAliceBlue = $FFF0F8FF; + aclAntiqueWhite = $FFFAEBD7; + aclAqua = $FF00FFFF; + aclAquamarine = $FF7FFFD4; + aclAzure = $FFF0FFFF; + aclBeige = $FFF5F5DC; + aclBisque = $FFFFE4C4; + aclBlack = $FF000000; + aclBlanchedAlmond = $FFFFEBCD; + aclBlue = $FF0000FF; + aclBlueViolet = $FF8A2BE2; + aclBrown = $FFA52A2A; + aclBurlyWood = $FFDEB887; + aclCadetBlue = $FF5F9EA0; + aclChartreuse = $FF7FFF00; + aclChocolate = $FFD2691E; + aclCoral = $FFFF7F50; + aclCornflowerBlue = $FF6495ED; + aclCornsilk = $FFFFF8DC; + aclCrimson = $FFDC143C; + aclCyan = $FF00FFFF; + aclDarkBlue = $FF00008B; + aclDarkCyan = $FF008B8B; + aclDarkGoldenrod = $FFB8860B; + aclDarkGray = $FFA9A9A9; + aclDarkGreen = $FF006400; + aclDarkKhaki = $FFBDB76B; + aclDarkMagenta = $FF8B008B; + aclDarkOliveGreen = $FF556B2F; + aclDarkOrange = $FFFF8C00; + aclDarkOrchid = $FF9932CC; + aclDarkRed = $FF8B0000; + aclDarkSalmon = $FFE9967A; + aclDarkSeaGreen = $FF8FBC8B; + aclDarkSlateBlue = $FF483D8B; + aclDarkSlateGray = $FF2F4F4F; + aclDarkTurquoise = $FF00CED1; + aclDarkViolet = $FF9400D3; + aclDeepPink = $FFFF1493; + aclDeepSkyBlue = $FF00BFFF; + aclDimGray = $FF696969; + aclDodgerBlue = $FF1E90FF; + aclFirebrick = $FFB22222; + aclFloralWhite = $FFFFFAF0; + aclForestGreen = $FF228B22; + aclFuchsia = $FFFF00FF; + aclGainsboro = $FFDCDCDC; + aclGhostWhite = $FFF8F8FF; + aclGold = $FFFFD700; + aclGoldenrod = $FFDAA520; + aclGray = $FF808080; + aclGreen = $FF008000; + aclGreenYellow = $FFADFF2F; + aclHoneydew = $FFF0FFF0; + aclHotPink = $FFFF69B4; + aclIndianRed = $FFCD5C5C; + aclIndigo = $FF4B0082; + aclIvory = $FFFFFFF0; + aclKhaki = $FFF0E68C; + aclLavender = $FFE6E6FA; + aclLavenderBlush = $FFFFF0F5; + aclLawnGreen = $FF7CFC00; + aclLemonChiffon = $FFFFFACD; + aclLightBlue = $FFADD8E6; + aclLightCoral = $FFF08080; + aclLightCyan = $FFE0FFFF; + aclLightGoldenrodYellow = $FFFAFAD2; + aclLightGray = $FFD3D3D3; + aclLightGreen = $FF90EE90; + aclLightPink = $FFFFB6C1; + aclLightSalmon = $FFFFA07A; + aclLightSeaGreen = $FF20B2AA; + aclLightSkyBlue = $FF87CEFA; + aclLightSlateGray = $FF778899; + aclLightSteelBlue = $FFB0C4DE; + aclLightYellow = $FFFFFFE0; + aclLime = $FF00FF00; + aclLimeGreen = $FF32CD32; + aclLinen = $FFFAF0E6; + aclMagenta = $FFFF00FF; + aclMaroon = $FF800000; + aclMediumAquamarine = $FF66CDAA; + aclMediumBlue = $FF0000CD; + aclMediumOrchid = $FFBA55D3; + aclMediumPurple = $FF9370DB; + aclMediumSeaGreen = $FF3CB371; + aclMediumSlateBlue = $FF7B68EE; + aclMediumSpringGreen = $FF00FA9A; + aclMediumTurquoise = $FF48D1CC; + aclMediumVioletRed = $FFC71585; + aclMidnightBlue = $FF191970; + aclMintCream = $FFF5FFFA; + aclMistyRose = $FFFFE4E1; + aclMoccasin = $FFFFE4B5; + aclNavajoWhite = $FFFFDEAD; + aclNavy = $FF000080; + aclOldLace = $FFFDF5E6; + aclOlive = $FF808000; + aclOliveDrab = $FF6B8E23; + aclOrange = $FFFFA500; + aclOrangeRed = $FFFF4500; + aclOrchid = $FFDA70D6; + aclPaleGoldenrod = $FFEEE8AA; + aclPaleGreen = $FF98FB98; + aclPaleTurquoise = $FFAFEEEE; + aclPaleVioletRed = $FFDB7093; + aclPapayaWhip = $FFFFEFD5; + aclPeachPuff = $FFFFDAB9; + aclPeru = $FFCD853F; + aclPink = $FFFFC0CB; + aclPlum = $FFDDA0DD; + aclPowderBlue = $FFB0E0E6; + aclPurple = $FF800080; + aclRed = $FFFF0000; + aclRosyBrown = $FFBC8F8F; + aclRoyalBlue = $FF4169E1; + aclSaddleBrown = $FF8B4513; + aclSalmon = $FFFA8072; + aclSandyBrown = $FFF4A460; + aclSeaGreen = $FF2E8B57; + aclSeaShell = $FFFFF5EE; + aclSienna = $FFA0522D; + aclSilver = $FFC0C0C0; + aclSkyBlue = $FF87CEEB; + aclSlateBlue = $FF6A5ACD; + aclSlateGray = $FF708090; + aclSnow = $FFFFFAFA; + aclSpringGreen = $FF00FF7F; + aclSteelBlue = $FF4682B4; + aclTan = $FFD2B48C; + aclTeal = $FF008080; + aclThistle = $FFD8BFD8; + aclTomato = $FFFF6347; + aclTransparent = $00FFFFFF; + aclTurquoise = $FF40E0D0; + aclViolet = $FFEE82EE; + aclWheat = $FFF5DEB3; + aclWhite = $FFFFFFFF; + aclWhiteSmoke = $FFF5F5F5; + aclYellow = $FFFFFF00; + aclYellowGreen = $FF9ACD32; + + // Shift count and bit mask for A, R, G, B components + AlphaShift = 24; + {$EXTERNALSYM AlphaShift} + RedShift = 16; + {$EXTERNALSYM RedShift} + GreenShift = 8; + {$EXTERNALSYM GreenShift} + BlueShift = 0; + {$EXTERNALSYM BlueShift} + + AlphaMask = $ff000000; + {$EXTERNALSYM AlphaMask} + RedMask = $00ff0000; + {$EXTERNALSYM RedMask} + GreenMask = $0000ff00; + {$EXTERNALSYM GreenMask} + BlueMask = $000000ff; + {$EXTERNALSYM BlueMask} + + +type +{ TGPColor = class + protected + Argb: ARGB; + public + constructor Create; overload; + constructor Create(r, g, b: Byte); overload; + constructor Create(a, r, g, b: Byte); overload; + constructor Create(Value: ARGB); overload; + function GetAlpha: BYTE; + function GetA: BYTE; + function GetRed: BYTE; + function GetR: BYTE; + function GetGreen: Byte; + function GetG: Byte; + function GetBlue: Byte; + function GetB: Byte; + function GetValue: ARGB; + procedure SetValue(Value: ARGB); + procedure SetFromCOLORREF(rgb: COLORREF); + function ToCOLORREF: COLORREF; + function MakeARGB(a, r, g, b: Byte): ARGB; + end; } + + PGPColor = ^TGPColor; + TGPColor = ARGB; + TColorDynArray = array of TGPColor; + + function MakeColor(r, g, b: Byte): ARGB; overload; + function MakeColor(a, r, g, b: Byte): ARGB; overload; + function GetAlpha(color: ARGB): BYTE; + function GetRed(color: ARGB): BYTE; + function GetGreen(color: ARGB): BYTE; + function GetBlue(color: ARGB): BYTE; + function ColorRefToARGB(rgb: COLORREF): ARGB; + function ARGBToColorRef(Color: ARGB): COLORREF; + + +(**************************************************************************\ +* +* GDI+ Metafile Related Structures +* +\**************************************************************************) + +type + { from Windef.h } + RECTL = Windows.TRect; + SIZEL = Windows.TSize; + + {$EXTERNALSYM ENHMETAHEADER3} + ENHMETAHEADER3 = packed record + iType : DWORD; // Record type EMR_HEADER + nSize : DWORD; // Record size in bytes. This may be greater + // than the sizeof(ENHMETAHEADER). + rclBounds : RECTL; // Inclusive-inclusive bounds in device units + rclFrame : RECTL; // Inclusive-inclusive Picture Frame .01mm unit + dSignature : DWORD; // Signature. Must be ENHMETA_SIGNATURE. + nVersion : DWORD; // Version number + nBytes : DWORD; // Size of the metafile in bytes + nRecords : DWORD; // Number of records in the metafile + nHandles : WORD; // Number of handles in the handle table + // Handle index zero is reserved. + sReserved : WORD; // Reserved. Must be zero. + nDescription : DWORD; // Number of chars in the unicode desc string + // This is 0 if there is no description string + offDescription : DWORD; // Offset to the metafile description record. + // This is 0 if there is no description string + nPalEntries : DWORD; // Number of entries in the metafile palette. + szlDevice : SIZEL; // Size of the reference device in pels + szlMillimeters : SIZEL; // Size of the reference device in millimeters + end; + TENHMETAHEADER3 = ENHMETAHEADER3; + PENHMETAHEADER3 = ^TENHMETAHEADER3; + + // Placeable WMFs + + // Placeable Metafiles were created as a non-standard way of specifying how + // a metafile is mapped and scaled on an output device. + // Placeable metafiles are quite wide-spread, but not directly supported by + // the Windows API. To playback a placeable metafile using the Windows API, + // you will first need to strip the placeable metafile header from the file. + // This is typically performed by copying the metafile to a temporary file + // starting at file offset 22 (0x16). The contents of the temporary file may + // then be used as input to the Windows GetMetaFile(), PlayMetaFile(), + // CopyMetaFile(), etc. GDI functions. + + // Each placeable metafile begins with a 22-byte header, + // followed by a standard metafile: + + {$EXTERNALSYM PWMFRect16} + PWMFRect16 = packed record + Left : INT16; + Top : INT16; + Right : INT16; + Bottom : INT16; + end; + TPWMFRect16 = PWMFRect16; + PPWMFRect16 = ^TPWMFRect16; + + {$EXTERNALSYM WmfPlaceableFileHeader} + WmfPlaceableFileHeader = packed record + Key : UINT32; // GDIP_WMF_PLACEABLEKEY + Hmf : INT16; // Metafile HANDLE number (always 0) + BoundingBox : PWMFRect16; // Coordinates in metafile units + Inch : INT16; // Number of metafile units per inch + Reserved : UINT32; // Reserved (always 0) + Checksum : INT16; // Checksum value for previous 10 WORDs + end; + TWmfPlaceableFileHeader = WmfPlaceableFileHeader; + PWmfPlaceableFileHeader = ^TWmfPlaceableFileHeader; + + // Key contains a special identification value that indicates the presence + // of a placeable metafile header and is always 0x9AC6CDD7. + + // Handle is used to stored the handle of the metafile in memory. When written + // to disk, this field is not used and will always contains the value 0. + + // Left, Top, Right, and Bottom contain the coordinates of the upper-left + // and lower-right corners of the image on the output device. These are + // measured in twips. + + // A twip (meaning "twentieth of a point") is the logical unit of measurement + // used in Windows Metafiles. A twip is equal to 1/1440 of an inch. Thus 720 + // twips equal 1/2 inch, while 32,768 twips is 22.75 inches. + + // Inch contains the number of twips per inch used to represent the image. + // Normally, there are 1440 twips per inch; however, this number may be + // changed to scale the image. A value of 720 indicates that the image is + // double its normal size, or scaled to a factor of 2:1. A value of 360 + // indicates a scale of 4:1, while a value of 2880 indicates that the image + // is scaled down in size by a factor of two. A value of 1440 indicates + // a 1:1 scale ratio. + + // Reserved is not used and is always set to 0. + + // Checksum contains a checksum value for the previous 10 WORDs in the header. + // This value can be used in an attempt to detect if the metafile has become + // corrupted. The checksum is calculated by XORing each WORD value to an + // initial value of 0. + + // If the metafile was recorded with a reference Hdc that was a display. + +const + GDIP_EMFPLUSFLAGS_DISPLAY = $00000001; + {$EXTERNALSYM GDIP_EMFPLUSFLAGS_DISPLAY} + +type + TMetafileHeader = packed class + public + Type_ : TMetafileType; + Size : UINT; // Size of the metafile (in bytes) + Version : UINT; // EMF+, EMF, or WMF version + EmfPlusFlags : UINT; + DpiX : Single; + DpiY : Single; + X : Integer; // Bounds in device units + Y : Integer; + Width : Integer; + Height : Integer; + Header : record + case integer of + 0: (WmfHeader: TMETAHEADER;); + 1: (EmfHeader: TENHMETAHEADER3); + end; + EmfPlusHeaderSize : Integer; // size of the EMF+ header in file + LogicalDpiX : Integer; // Logical Dpi of reference Hdc + LogicalDpiY : Integer; // usually valid only for EMF+ + public + property GetType: TMetafileType read Type_; + property GetMetafileSize: UINT read Size; + // If IsEmfPlus, this is the EMF+ version; else it is the WMF or EMF ver + property GetVersion: UINT read Version; + // Get the EMF+ flags associated with the metafile + property GetEmfPlusFlags: UINT read EmfPlusFlags; + property GetDpiX: Single read DpiX; + property GetDpiY: Single read DpiY; + procedure GetBounds(out Rect: TGPRect); + // Is it any type of WMF (standard or Placeable Metafile)? + function IsWmf: BOOL; + // Is this an Placeable Metafile? + function IsWmfPlaceable: BOOL; + // Is this an EMF (not an EMF+)? + function IsEmf: BOOL; + // Is this an EMF or EMF+ file? + function IsEmfOrEmfPlus: BOOL; + // Is this an EMF+ file? + function IsEmfPlus: BOOL; + // Is this an EMF+ dual (has dual, down-level records) file? + function IsEmfPlusDual: BOOL; + // Is this an EMF+ only (no dual records) file? + function IsEmfPlusOnly: BOOL; + // If it's an EMF+ file, was it recorded against a display Hdc? + function IsDisplay: BOOL; + // Get the WMF header of the metafile (if it is a WMF) + function GetWmfHeader: PMetaHeader; + // Get the EMF header of the metafile (if it is an EMF) + function GetEmfHeader: PENHMETAHEADER3; + end; + +(**************************************************************************\ +* +* GDI+ Imaging GUIDs +* +\**************************************************************************) + +//--------------------------------------------------------------------------- +// Image file format identifiers +//--------------------------------------------------------------------------- + +const + ImageFormatUndefined : TGUID = '{b96b3ca9-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatUndefined} + ImageFormatMemoryBMP : TGUID = '{b96b3caa-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatMemoryBMP} + ImageFormatBMP : TGUID = '{b96b3cab-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatBMP} + ImageFormatEMF : TGUID = '{b96b3cac-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatEMF} + ImageFormatWMF : TGUID = '{b96b3cad-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatWMF} + ImageFormatJPEG : TGUID = '{b96b3cae-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatJPEG} + ImageFormatPNG : TGUID = '{b96b3caf-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatPNG} + ImageFormatGIF : TGUID = '{b96b3cb0-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatGIF} + ImageFormatTIFF : TGUID = '{b96b3cb1-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatTIFF} + ImageFormatEXIF : TGUID = '{b96b3cb2-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatEXIF} + ImageFormatIcon : TGUID = '{b96b3cb5-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatIcon} + +//--------------------------------------------------------------------------- +// Predefined multi-frame dimension IDs +//--------------------------------------------------------------------------- + + FrameDimensionTime : TGUID = '{6aedbd6d-3fb5-418a-83a6-7f45229dc872}'; + {$EXTERNALSYM FrameDimensionTime} + FrameDimensionResolution : TGUID = '{84236f7b-3bd3-428f-8dab-4ea1439ca315}'; + {$EXTERNALSYM FrameDimensionResolution} + FrameDimensionPage : TGUID = '{7462dc86-6180-4c7e-8e3f-ee7333a7a483}'; + {$EXTERNALSYM FrameDimensionPage} + +//--------------------------------------------------------------------------- +// Property sets +//--------------------------------------------------------------------------- + + FormatIDImageInformation : TGUID = '{e5836cbe-5eef-4f1d-acde-ae4c43b608ce}'; + {$EXTERNALSYM FormatIDImageInformation} + FormatIDJpegAppHeaders : TGUID = '{1c4afdcd-6177-43cf-abc7-5f51af39ee85}'; + {$EXTERNALSYM FormatIDJpegAppHeaders} + +//--------------------------------------------------------------------------- +// Encoder parameter sets +//--------------------------------------------------------------------------- + + EncoderCompression : TGUID = '{e09d739d-ccd4-44ee-8eba-3fbf8be4fc58}'; + {$EXTERNALSYM EncoderCompression} + EncoderColorDepth : TGUID = '{66087055-ad66-4c7c-9a18-38a2310b8337}'; + {$EXTERNALSYM EncoderColorDepth} + EncoderScanMethod : TGUID = '{3a4e2661-3109-4e56-8536-42c156e7dcfa}'; + {$EXTERNALSYM EncoderScanMethod} + EncoderVersion : TGUID = '{24d18c76-814a-41a4-bf53-1c219cccf797}'; + {$EXTERNALSYM EncoderVersion} + EncoderRenderMethod : TGUID = '{6d42c53a-229a-4825-8bb7-5c99e2b9a8b8}'; + {$EXTERNALSYM EncoderRenderMethod} + EncoderQuality : TGUID = '{1d5be4b5-fa4a-452d-9cdd-5db35105e7eb}'; + {$EXTERNALSYM EncoderQuality} + EncoderTransformation : TGUID = '{8d0eb2d1-a58e-4ea8-aa14-108074b7b6f9}'; + {$EXTERNALSYM EncoderTransformation} + EncoderLuminanceTable : TGUID = '{edb33bce-0266-4a77-b904-27216099e717}'; + {$EXTERNALSYM EncoderLuminanceTable} + EncoderChrominanceTable : TGUID = '{f2e455dc-09b3-4316-8260-676ada32481c}'; + {$EXTERNALSYM EncoderChrominanceTable} + EncoderSaveFlag : TGUID = '{292266fc-ac40-47bf-8cfc-a85b89a655de}'; + {$EXTERNALSYM EncoderSaveFlag} + + CodecIImageBytes : TGUID = '{025d1823-6c7d-447b-bbdb-a3cbc3dfa2fc}'; + {$EXTERNALSYM CodecIImageBytes} + +type + {$EXTERNALSYM IImageBytes} + IImageBytes = Interface(IUnknown) + ['{025D1823-6C7D-447B-BBDB-A3CBC3DFA2FC}'] + // Return total number of bytes in the IStream + function CountBytes(out pcb: UINT): HRESULT; stdcall; + // Locks "cb" bytes, starting from "ulOffset" in the stream, and returns the + // pointer to the beginning of the locked memory chunk in "ppvBytes" + function LockBytes(cb: UINT; ulOffset: ULONG; out ppvBytes: pointer): HRESULT; stdcall; + // Unlocks "cb" bytes, pointed by "pvBytes", starting from "ulOffset" in the + // stream + function UnlockBytes(pvBytes: pointer; cb: UINT; ulOffset: ULONG): HRESULT; stdcall; + end; + +//-------------------------------------------------------------------------- +// ImageCodecInfo structure +//-------------------------------------------------------------------------- + + {$EXTERNALSYM ImageCodecInfo} + ImageCodecInfo = packed record + Clsid : TGUID; + FormatID : TGUID; + CodecName : PWCHAR; + DllName : PWCHAR; + FormatDescription : PWCHAR; + FilenameExtension : PWCHAR; + MimeType : PWCHAR; + Flags : DWORD; + Version : DWORD; + SigCount : DWORD; + SigSize : DWORD; + SigPattern : PBYTE; + SigMask : PBYTE; + end; + TImageCodecInfo = ImageCodecInfo; + PImageCodecInfo = ^TImageCodecInfo; + +//-------------------------------------------------------------------------- +// Information flags about image codecs +//-------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM ImageCodecFlags} + ImageCodecFlags = ( + ImageCodecFlagsEncoder = $00000001, + ImageCodecFlagsDecoder = $00000002, + ImageCodecFlagsSupportBitmap = $00000004, + ImageCodecFlagsSupportVector = $00000008, + ImageCodecFlagsSeekableEncode = $00000010, + ImageCodecFlagsBlockingDecode = $00000020, + + ImageCodecFlagsBuiltin = $00010000, + ImageCodecFlagsSystem = $00020000, + ImageCodecFlagsUser = $00040000 + ); + TImageCodecFlags = ImageCodecFlags; +{$ELSE} + {$EXTERNALSYM ImageCodecFlags} + ImageCodecFlags = Integer; + const + ImageCodecFlagsEncoder = $00000001; + ImageCodecFlagsDecoder = $00000002; + ImageCodecFlagsSupportBitmap = $00000004; + ImageCodecFlagsSupportVector = $00000008; + ImageCodecFlagsSeekableEncode = $00000010; + ImageCodecFlagsBlockingDecode = $00000020; + + ImageCodecFlagsBuiltin = $00010000; + ImageCodecFlagsSystem = $00020000; + ImageCodecFlagsUser = $00040000; + +type + TImageCodecFlags = ImageCodecFlags; +{$ENDIF} +//--------------------------------------------------------------------------- +// Access modes used when calling Image::LockBits +//--------------------------------------------------------------------------- + + {$EXTERNALSYM ImageLockMode} + ImageLockMode = Integer; + const + ImageLockModeRead = $0001; + ImageLockModeWrite = $0002; + ImageLockModeUserInputBuf = $0004; +type + TImageLockMode = ImageLockMode; + +//--------------------------------------------------------------------------- +// Information about image pixel data +//--------------------------------------------------------------------------- + + {$EXTERNALSYM BitmapData} + BitmapData = packed record + Width : UINT; + Height : UINT; + Stride : Integer; + PixelFormat : PixelFormat; + Scan0 : Pointer; + Reserved : UINT; + end; + TBitmapData = BitmapData; + PBitmapData = ^TBitmapData; + +//--------------------------------------------------------------------------- +// Image flags +//--------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM ImageFlags} + ImageFlags = ( + ImageFlagsNone = 0, + + // Low-word: shared with SINKFLAG_x + + ImageFlagsScalable = $0001, + ImageFlagsHasAlpha = $0002, + ImageFlagsHasTranslucent = $0004, + ImageFlagsPartiallyScalable = $0008, + + // Low-word: color space definition + + ImageFlagsColorSpaceRGB = $0010, + ImageFlagsColorSpaceCMYK = $0020, + ImageFlagsColorSpaceGRAY = $0040, + ImageFlagsColorSpaceYCBCR = $0080, + ImageFlagsColorSpaceYCCK = $0100, + + // Low-word: image size info + + ImageFlagsHasRealDPI = $1000, + ImageFlagsHasRealPixelSize = $2000, + + // High-word + + ImageFlagsReadOnly = $00010000, + ImageFlagsCaching = $00020000 + ); + TImageFlags = ImageFlags; +{$ELSE} + {$EXTERNALSYM ImageFlags} + ImageFlags = Integer; + const + ImageFlagsNone = 0; + + // Low-word: shared with SINKFLAG_x + + ImageFlagsScalable = $0001; + ImageFlagsHasAlpha = $0002; + ImageFlagsHasTranslucent = $0004; + ImageFlagsPartiallyScalable = $0008; + + // Low-word: color space definition + + ImageFlagsColorSpaceRGB = $0010; + ImageFlagsColorSpaceCMYK = $0020; + ImageFlagsColorSpaceGRAY = $0040; + ImageFlagsColorSpaceYCBCR = $0080; + ImageFlagsColorSpaceYCCK = $0100; + + // Low-word: image size info + + ImageFlagsHasRealDPI = $1000; + ImageFlagsHasRealPixelSize = $2000; + + // High-word + + ImageFlagsReadOnly = $00010000; + ImageFlagsCaching = $00020000; + +type + TImageFlags = ImageFlags; +{$ENDIF} + + +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM RotateFlipType} + RotateFlipType = ( + RotateNoneFlipNone = 0, + Rotate90FlipNone = 1, + Rotate180FlipNone = 2, + Rotate270FlipNone = 3, + + RotateNoneFlipX = 4, + Rotate90FlipX = 5, + Rotate180FlipX = 6, + Rotate270FlipX = 7, + + RotateNoneFlipY = Rotate180FlipX, + Rotate90FlipY = Rotate270FlipX, + Rotate180FlipY = RotateNoneFlipX, + Rotate270FlipY = Rotate90FlipX, + + RotateNoneFlipXY = Rotate180FlipNone, + Rotate90FlipXY = Rotate270FlipNone, + Rotate180FlipXY = RotateNoneFlipNone, + Rotate270FlipXY = Rotate90FlipNone + ); + TRotateFlipType = RotateFlipType; +{$ELSE} + {$EXTERNALSYM RotateFlipType} + RotateFlipType = ( + RotateNoneFlipNone, // = 0, + Rotate90FlipNone, // = 1, + Rotate180FlipNone, // = 2, + Rotate270FlipNone, // = 3, + + RotateNoneFlipX, // = 4, + Rotate90FlipX, // = 5, + Rotate180FlipX, // = 6, + Rotate270FlipX // = 7, + ); + const + RotateNoneFlipY = Rotate180FlipX; + Rotate90FlipY = Rotate270FlipX; + Rotate180FlipY = RotateNoneFlipX; + Rotate270FlipY = Rotate90FlipX; + + RotateNoneFlipXY = Rotate180FlipNone; + Rotate90FlipXY = Rotate270FlipNone; + Rotate180FlipXY = RotateNoneFlipNone; + Rotate270FlipXY = Rotate90FlipNone; + +type + TRotateFlipType = RotateFlipType; +{$ENDIF} + +//--------------------------------------------------------------------------- +// Encoder Parameter structure +//--------------------------------------------------------------------------- + + {$EXTERNALSYM EncoderParameter} + EncoderParameter = packed record + Guid : TGUID; // GUID of the parameter + NumberOfValues : ULONG; // Number of the parameter values + Type_ : ULONG; // Value type, like ValueTypeLONG etc. + Value : Pointer; // A pointer to the parameter values + end; + TEncoderParameter = EncoderParameter; + PEncoderParameter = ^TEncoderParameter; + +//--------------------------------------------------------------------------- +// Encoder Parameters structure +//--------------------------------------------------------------------------- + + {$EXTERNALSYM EncoderParameters} + EncoderParameters = packed record + Count : UINT; // Number of parameters in this structure + Parameter : array[0..0] of TEncoderParameter; // Parameter values + end; + TEncoderParameters = EncoderParameters; + PEncoderParameters = ^TEncoderParameters; + +//--------------------------------------------------------------------------- +// Property Item +//--------------------------------------------------------------------------- + + {$EXTERNALSYM PropertyItem} + PropertyItem = record // NOT PACKED !! + id : PROPID; // ID of this property + length : ULONG; // Length of the property value, in bytes + type_ : WORD; // Type of the value, as one of TAG_TYPE_XXX + value : Pointer; // property value + end; + TPropertyItem = PropertyItem; + PPropertyItem = ^TPropertyItem; + +//--------------------------------------------------------------------------- +// Image property types +//--------------------------------------------------------------------------- + +const + PropertyTagTypeByte : Integer = 1; + {$EXTERNALSYM PropertyTagTypeByte} + PropertyTagTypeASCII : Integer = 2; + {$EXTERNALSYM PropertyTagTypeASCII} + PropertyTagTypeShort : Integer = 3; + {$EXTERNALSYM PropertyTagTypeShort} + PropertyTagTypeLong : Integer = 4; + {$EXTERNALSYM PropertyTagTypeLong} + PropertyTagTypeRational : Integer = 5; + {$EXTERNALSYM PropertyTagTypeRational} + PropertyTagTypeUndefined : Integer = 7; + {$EXTERNALSYM PropertyTagTypeUndefined} + PropertyTagTypeSLONG : Integer = 9; + {$EXTERNALSYM PropertyTagTypeSLONG} + PropertyTagTypeSRational : Integer = 10; + {$EXTERNALSYM PropertyTagTypeSRational} + +//--------------------------------------------------------------------------- +// Image property ID tags +//--------------------------------------------------------------------------- + + PropertyTagExifIFD = $8769; + {$EXTERNALSYM PropertyTagExifIFD} + PropertyTagGpsIFD = $8825; + {$EXTERNALSYM PropertyTagGpsIFD} + + PropertyTagNewSubfileType = $00FE; + {$EXTERNALSYM PropertyTagNewSubfileType} + PropertyTagSubfileType = $00FF; + {$EXTERNALSYM PropertyTagSubfileType} + PropertyTagImageWidth = $0100; + {$EXTERNALSYM PropertyTagImageWidth} + PropertyTagImageHeight = $0101; + {$EXTERNALSYM PropertyTagImageHeight} + PropertyTagBitsPerSample = $0102; + {$EXTERNALSYM PropertyTagBitsPerSample} + PropertyTagCompression = $0103; + {$EXTERNALSYM PropertyTagCompression} + PropertyTagPhotometricInterp = $0106; + {$EXTERNALSYM PropertyTagPhotometricInterp} + PropertyTagThreshHolding = $0107; + {$EXTERNALSYM PropertyTagThreshHolding} + PropertyTagCellWidth = $0108; + {$EXTERNALSYM PropertyTagCellWidth} + PropertyTagCellHeight = $0109; + {$EXTERNALSYM PropertyTagCellHeight} + PropertyTagFillOrder = $010A; + {$EXTERNALSYM PropertyTagFillOrder} + PropertyTagDocumentName = $010D; + {$EXTERNALSYM PropertyTagDocumentName} + PropertyTagImageDescription = $010E; + {$EXTERNALSYM PropertyTagImageDescription} + PropertyTagEquipMake = $010F; + {$EXTERNALSYM PropertyTagEquipMake} + PropertyTagEquipModel = $0110; + {$EXTERNALSYM PropertyTagEquipModel} + PropertyTagStripOffsets = $0111; + {$EXTERNALSYM PropertyTagStripOffsets} + PropertyTagOrientation = $0112; + {$EXTERNALSYM PropertyTagOrientation} + PropertyTagSamplesPerPixel = $0115; + {$EXTERNALSYM PropertyTagSamplesPerPixel} + PropertyTagRowsPerStrip = $0116; + {$EXTERNALSYM PropertyTagRowsPerStrip} + PropertyTagStripBytesCount = $0117; + {$EXTERNALSYM PropertyTagStripBytesCount} + PropertyTagMinSampleValue = $0118; + {$EXTERNALSYM PropertyTagMinSampleValue} + PropertyTagMaxSampleValue = $0119; + {$EXTERNALSYM PropertyTagMaxSampleValue} + PropertyTagXResolution = $011A; // Image resolution in width direction + {$EXTERNALSYM PropertyTagXResolution} + PropertyTagYResolution = $011B; // Image resolution in height direction + {$EXTERNALSYM PropertyTagYResolution} + PropertyTagPlanarConfig = $011C; // Image data arrangement + {$EXTERNALSYM PropertyTagPlanarConfig} + PropertyTagPageName = $011D; + {$EXTERNALSYM PropertyTagPageName} + PropertyTagXPosition = $011E; + {$EXTERNALSYM PropertyTagXPosition} + PropertyTagYPosition = $011F; + {$EXTERNALSYM PropertyTagYPosition} + PropertyTagFreeOffset = $0120; + {$EXTERNALSYM PropertyTagFreeOffset} + PropertyTagFreeByteCounts = $0121; + {$EXTERNALSYM PropertyTagFreeByteCounts} + PropertyTagGrayResponseUnit = $0122; + {$EXTERNALSYM PropertyTagGrayResponseUnit} + PropertyTagGrayResponseCurve = $0123; + {$EXTERNALSYM PropertyTagGrayResponseCurve} + PropertyTagT4Option = $0124; + {$EXTERNALSYM PropertyTagT4Option} + PropertyTagT6Option = $0125; + {$EXTERNALSYM PropertyTagT6Option} + PropertyTagResolutionUnit = $0128; // Unit of X and Y resolution + {$EXTERNALSYM PropertyTagResolutionUnit} + PropertyTagPageNumber = $0129; + {$EXTERNALSYM PropertyTagPageNumber} + PropertyTagTransferFuncition = $012D; + {$EXTERNALSYM PropertyTagTransferFuncition} + PropertyTagSoftwareUsed = $0131; + {$EXTERNALSYM PropertyTagSoftwareUsed} + PropertyTagDateTime = $0132; + {$EXTERNALSYM PropertyTagDateTime} + PropertyTagArtist = $013B; + {$EXTERNALSYM PropertyTagArtist} + PropertyTagHostComputer = $013C; + {$EXTERNALSYM PropertyTagHostComputer} + PropertyTagPredictor = $013D; + {$EXTERNALSYM PropertyTagPredictor} + PropertyTagWhitePoint = $013E; + {$EXTERNALSYM PropertyTagWhitePoint} + PropertyTagPrimaryChromaticities = $013F; + {$EXTERNALSYM PropertyTagPrimaryChromaticities} + PropertyTagColorMap = $0140; + {$EXTERNALSYM PropertyTagColorMap} + PropertyTagHalftoneHints = $0141; + {$EXTERNALSYM PropertyTagHalftoneHints} + PropertyTagTileWidth = $0142; + {$EXTERNALSYM PropertyTagTileWidth} + PropertyTagTileLength = $0143; + {$EXTERNALSYM PropertyTagTileLength} + PropertyTagTileOffset = $0144; + {$EXTERNALSYM PropertyTagTileOffset} + PropertyTagTileByteCounts = $0145; + {$EXTERNALSYM PropertyTagTileByteCounts} + PropertyTagInkSet = $014C; + {$EXTERNALSYM PropertyTagInkSet} + PropertyTagInkNames = $014D; + {$EXTERNALSYM PropertyTagInkNames} + PropertyTagNumberOfInks = $014E; + {$EXTERNALSYM PropertyTagNumberOfInks} + PropertyTagDotRange = $0150; + {$EXTERNALSYM PropertyTagDotRange} + PropertyTagTargetPrinter = $0151; + {$EXTERNALSYM PropertyTagTargetPrinter} + PropertyTagExtraSamples = $0152; + {$EXTERNALSYM PropertyTagExtraSamples} + PropertyTagSampleFormat = $0153; + {$EXTERNALSYM PropertyTagSampleFormat} + PropertyTagSMinSampleValue = $0154; + {$EXTERNALSYM PropertyTagSMinSampleValue} + PropertyTagSMaxSampleValue = $0155; + {$EXTERNALSYM PropertyTagSMaxSampleValue} + PropertyTagTransferRange = $0156; + {$EXTERNALSYM PropertyTagTransferRange} + + PropertyTagJPEGProc = $0200; + {$EXTERNALSYM PropertyTagJPEGProc} + PropertyTagJPEGInterFormat = $0201; + {$EXTERNALSYM PropertyTagJPEGInterFormat} + PropertyTagJPEGInterLength = $0202; + {$EXTERNALSYM PropertyTagJPEGInterLength} + PropertyTagJPEGRestartInterval = $0203; + {$EXTERNALSYM PropertyTagJPEGRestartInterval} + PropertyTagJPEGLosslessPredictors = $0205; + {$EXTERNALSYM PropertyTagJPEGLosslessPredictors} + PropertyTagJPEGPointTransforms = $0206; + {$EXTERNALSYM PropertyTagJPEGPointTransforms} + PropertyTagJPEGQTables = $0207; + {$EXTERNALSYM PropertyTagJPEGQTables} + PropertyTagJPEGDCTables = $0208; + {$EXTERNALSYM PropertyTagJPEGDCTables} + PropertyTagJPEGACTables = $0209; + {$EXTERNALSYM PropertyTagJPEGACTables} + + PropertyTagYCbCrCoefficients = $0211; + {$EXTERNALSYM PropertyTagYCbCrCoefficients} + PropertyTagYCbCrSubsampling = $0212; + {$EXTERNALSYM PropertyTagYCbCrSubsampling} + PropertyTagYCbCrPositioning = $0213; + {$EXTERNALSYM PropertyTagYCbCrPositioning} + PropertyTagREFBlackWhite = $0214; + {$EXTERNALSYM PropertyTagREFBlackWhite} + + PropertyTagICCProfile = $8773; // This TAG is defined by ICC + {$EXTERNALSYM PropertyTagICCProfile} + // for embedded ICC in TIFF + PropertyTagGamma = $0301; + {$EXTERNALSYM PropertyTagGamma} + PropertyTagICCProfileDescriptor = $0302; + {$EXTERNALSYM PropertyTagICCProfileDescriptor} + PropertyTagSRGBRenderingIntent = $0303; + {$EXTERNALSYM PropertyTagSRGBRenderingIntent} + + PropertyTagImageTitle = $0320; + {$EXTERNALSYM PropertyTagImageTitle} + PropertyTagCopyright = $8298; + {$EXTERNALSYM PropertyTagCopyright} + +// Extra TAGs (Like Adobe Image Information tags etc.) + + PropertyTagResolutionXUnit = $5001; + {$EXTERNALSYM PropertyTagResolutionXUnit} + PropertyTagResolutionYUnit = $5002; + {$EXTERNALSYM PropertyTagResolutionYUnit} + PropertyTagResolutionXLengthUnit = $5003; + {$EXTERNALSYM PropertyTagResolutionXLengthUnit} + PropertyTagResolutionYLengthUnit = $5004; + {$EXTERNALSYM PropertyTagResolutionYLengthUnit} + PropertyTagPrintFlags = $5005; + {$EXTERNALSYM PropertyTagPrintFlags} + PropertyTagPrintFlagsVersion = $5006; + {$EXTERNALSYM PropertyTagPrintFlagsVersion} + PropertyTagPrintFlagsCrop = $5007; + {$EXTERNALSYM PropertyTagPrintFlagsCrop} + PropertyTagPrintFlagsBleedWidth = $5008; + {$EXTERNALSYM PropertyTagPrintFlagsBleedWidth} + PropertyTagPrintFlagsBleedWidthScale = $5009; + {$EXTERNALSYM PropertyTagPrintFlagsBleedWidthScale} + PropertyTagHalftoneLPI = $500A; + {$EXTERNALSYM PropertyTagHalftoneLPI} + PropertyTagHalftoneLPIUnit = $500B; + {$EXTERNALSYM PropertyTagHalftoneLPIUnit} + PropertyTagHalftoneDegree = $500C; + {$EXTERNALSYM PropertyTagHalftoneDegree} + PropertyTagHalftoneShape = $500D; + {$EXTERNALSYM PropertyTagHalftoneShape} + PropertyTagHalftoneMisc = $500E; + {$EXTERNALSYM PropertyTagHalftoneMisc} + PropertyTagHalftoneScreen = $500F; + {$EXTERNALSYM PropertyTagHalftoneScreen} + PropertyTagJPEGQuality = $5010; + {$EXTERNALSYM PropertyTagJPEGQuality} + PropertyTagGridSize = $5011; + {$EXTERNALSYM PropertyTagGridSize} + PropertyTagThumbnailFormat = $5012; // 1 = JPEG, 0 = RAW RGB + {$EXTERNALSYM PropertyTagThumbnailFormat} + PropertyTagThumbnailWidth = $5013; + {$EXTERNALSYM PropertyTagThumbnailWidth} + PropertyTagThumbnailHeight = $5014; + {$EXTERNALSYM PropertyTagThumbnailHeight} + PropertyTagThumbnailColorDepth = $5015; + {$EXTERNALSYM PropertyTagThumbnailColorDepth} + PropertyTagThumbnailPlanes = $5016; + {$EXTERNALSYM PropertyTagThumbnailPlanes} + PropertyTagThumbnailRawBytes = $5017; + {$EXTERNALSYM PropertyTagThumbnailRawBytes} + PropertyTagThumbnailSize = $5018; + {$EXTERNALSYM PropertyTagThumbnailSize} + PropertyTagThumbnailCompressedSize = $5019; + {$EXTERNALSYM PropertyTagThumbnailCompressedSize} + PropertyTagColorTransferFunction = $501A; + {$EXTERNALSYM PropertyTagColorTransferFunction} + PropertyTagThumbnailData = $501B; // RAW thumbnail bits in + {$EXTERNALSYM PropertyTagThumbnailData} + // JPEG format or RGB format + // depends on + // PropertyTagThumbnailFormat + + // Thumbnail related TAGs + + PropertyTagThumbnailImageWidth = $5020; // Thumbnail width + {$EXTERNALSYM PropertyTagThumbnailImageWidth} + PropertyTagThumbnailImageHeight = $5021; // Thumbnail height + {$EXTERNALSYM PropertyTagThumbnailImageHeight} + PropertyTagThumbnailBitsPerSample = $5022; // Number of bits per + {$EXTERNALSYM PropertyTagThumbnailBitsPerSample} + // component + PropertyTagThumbnailCompression = $5023; // Compression Scheme + {$EXTERNALSYM PropertyTagThumbnailCompression} + PropertyTagThumbnailPhotometricInterp = $5024; // Pixel composition + {$EXTERNALSYM PropertyTagThumbnailPhotometricInterp} + PropertyTagThumbnailImageDescription = $5025; // Image Tile + {$EXTERNALSYM PropertyTagThumbnailImageDescription} + PropertyTagThumbnailEquipMake = $5026; // Manufacturer of Image + {$EXTERNALSYM PropertyTagThumbnailEquipMake} + // Input equipment + PropertyTagThumbnailEquipModel = $5027; // Model of Image input + {$EXTERNALSYM PropertyTagThumbnailEquipModel} + // equipment + PropertyTagThumbnailStripOffsets = $5028; // Image data location + {$EXTERNALSYM PropertyTagThumbnailStripOffsets} + PropertyTagThumbnailOrientation = $5029; // Orientation of image + {$EXTERNALSYM PropertyTagThumbnailOrientation} + PropertyTagThumbnailSamplesPerPixel = $502A; // Number of components + {$EXTERNALSYM PropertyTagThumbnailSamplesPerPixel} + PropertyTagThumbnailRowsPerStrip = $502B; // Number of rows per strip + {$EXTERNALSYM PropertyTagThumbnailRowsPerStrip} + PropertyTagThumbnailStripBytesCount = $502C; // Bytes per compressed + {$EXTERNALSYM PropertyTagThumbnailStripBytesCount} + // strip + PropertyTagThumbnailResolutionX = $502D; // Resolution in width + {$EXTERNALSYM PropertyTagThumbnailResolutionX} + // direction + PropertyTagThumbnailResolutionY = $502E; // Resolution in height + {$EXTERNALSYM PropertyTagThumbnailResolutionY} + // direction + PropertyTagThumbnailPlanarConfig = $502F; // Image data arrangement + {$EXTERNALSYM PropertyTagThumbnailPlanarConfig} + PropertyTagThumbnailResolutionUnit = $5030; // Unit of X and Y + {$EXTERNALSYM PropertyTagThumbnailResolutionUnit} + // Resolution + PropertyTagThumbnailTransferFunction = $5031; // Transfer function + {$EXTERNALSYM PropertyTagThumbnailTransferFunction} + PropertyTagThumbnailSoftwareUsed = $5032; // Software used + {$EXTERNALSYM PropertyTagThumbnailSoftwareUsed} + PropertyTagThumbnailDateTime = $5033; // File change date and + {$EXTERNALSYM PropertyTagThumbnailDateTime} + // time + PropertyTagThumbnailArtist = $5034; // Person who created the + {$EXTERNALSYM PropertyTagThumbnailArtist} + // image + PropertyTagThumbnailWhitePoint = $5035; // White point chromaticity + {$EXTERNALSYM PropertyTagThumbnailWhitePoint} + PropertyTagThumbnailPrimaryChromaticities = $5036; + {$EXTERNALSYM PropertyTagThumbnailPrimaryChromaticities} + // Chromaticities of + // primaries + PropertyTagThumbnailYCbCrCoefficients = $5037; // Color space transforma- + {$EXTERNALSYM PropertyTagThumbnailYCbCrCoefficients} + // tion coefficients + PropertyTagThumbnailYCbCrSubsampling = $5038; // Subsampling ratio of Y + {$EXTERNALSYM PropertyTagThumbnailYCbCrSubsampling} + // to C + PropertyTagThumbnailYCbCrPositioning = $5039; // Y and C position + {$EXTERNALSYM PropertyTagThumbnailYCbCrPositioning} + PropertyTagThumbnailRefBlackWhite = $503A; // Pair of black and white + {$EXTERNALSYM PropertyTagThumbnailRefBlackWhite} + // reference values + PropertyTagThumbnailCopyRight = $503B; // CopyRight holder + {$EXTERNALSYM PropertyTagThumbnailCopyRight} + + PropertyTagLuminanceTable = $5090; + {$EXTERNALSYM PropertyTagLuminanceTable} + PropertyTagChrominanceTable = $5091; + {$EXTERNALSYM PropertyTagChrominanceTable} + + PropertyTagFrameDelay = $5100; + {$EXTERNALSYM PropertyTagFrameDelay} + PropertyTagLoopCount = $5101; + {$EXTERNALSYM PropertyTagLoopCount} + + PropertyTagPixelUnit = $5110; // Unit specifier for pixel/unit + {$EXTERNALSYM PropertyTagPixelUnit} + PropertyTagPixelPerUnitX = $5111; // Pixels per unit in X + {$EXTERNALSYM PropertyTagPixelPerUnitX} + PropertyTagPixelPerUnitY = $5112; // Pixels per unit in Y + {$EXTERNALSYM PropertyTagPixelPerUnitY} + PropertyTagPaletteHistogram = $5113; // Palette histogram + {$EXTERNALSYM PropertyTagPaletteHistogram} + + // EXIF specific tag + + PropertyTagExifExposureTime = $829A; + {$EXTERNALSYM PropertyTagExifExposureTime} + PropertyTagExifFNumber = $829D; + {$EXTERNALSYM PropertyTagExifFNumber} + + PropertyTagExifExposureProg = $8822; + {$EXTERNALSYM PropertyTagExifExposureProg} + PropertyTagExifSpectralSense = $8824; + {$EXTERNALSYM PropertyTagExifSpectralSense} + PropertyTagExifISOSpeed = $8827; + {$EXTERNALSYM PropertyTagExifISOSpeed} + PropertyTagExifOECF = $8828; + {$EXTERNALSYM PropertyTagExifOECF} + + PropertyTagExifVer = $9000; + {$EXTERNALSYM PropertyTagExifVer} + PropertyTagExifDTOrig = $9003; // Date & time of original + {$EXTERNALSYM PropertyTagExifDTOrig} + PropertyTagExifDTDigitized = $9004; // Date & time of digital data generation + {$EXTERNALSYM PropertyTagExifDTDigitized} + + PropertyTagExifCompConfig = $9101; + {$EXTERNALSYM PropertyTagExifCompConfig} + PropertyTagExifCompBPP = $9102; + {$EXTERNALSYM PropertyTagExifCompBPP} + + PropertyTagExifShutterSpeed = $9201; + {$EXTERNALSYM PropertyTagExifShutterSpeed} + PropertyTagExifAperture = $9202; + {$EXTERNALSYM PropertyTagExifAperture} + PropertyTagExifBrightness = $9203; + {$EXTERNALSYM PropertyTagExifBrightness} + PropertyTagExifExposureBias = $9204; + {$EXTERNALSYM PropertyTagExifExposureBias} + PropertyTagExifMaxAperture = $9205; + {$EXTERNALSYM PropertyTagExifMaxAperture} + PropertyTagExifSubjectDist = $9206; + {$EXTERNALSYM PropertyTagExifSubjectDist} + PropertyTagExifMeteringMode = $9207; + {$EXTERNALSYM PropertyTagExifMeteringMode} + PropertyTagExifLightSource = $9208; + {$EXTERNALSYM PropertyTagExifLightSource} + PropertyTagExifFlash = $9209; + {$EXTERNALSYM PropertyTagExifFlash} + PropertyTagExifFocalLength = $920A; + {$EXTERNALSYM PropertyTagExifFocalLength} + PropertyTagExifMakerNote = $927C; + {$EXTERNALSYM PropertyTagExifMakerNote} + PropertyTagExifUserComment = $9286; + {$EXTERNALSYM PropertyTagExifUserComment} + PropertyTagExifDTSubsec = $9290; // Date & Time subseconds + {$EXTERNALSYM PropertyTagExifDTSubsec} + PropertyTagExifDTOrigSS = $9291; // Date & Time original subseconds + {$EXTERNALSYM PropertyTagExifDTOrigSS} + PropertyTagExifDTDigSS = $9292; // Date & TIme digitized subseconds + {$EXTERNALSYM PropertyTagExifDTDigSS} + + PropertyTagExifFPXVer = $A000; + {$EXTERNALSYM PropertyTagExifFPXVer} + PropertyTagExifColorSpace = $A001; + {$EXTERNALSYM PropertyTagExifColorSpace} + PropertyTagExifPixXDim = $A002; + {$EXTERNALSYM PropertyTagExifPixXDim} + PropertyTagExifPixYDim = $A003; + {$EXTERNALSYM PropertyTagExifPixYDim} + PropertyTagExifRelatedWav = $A004; // related sound file + {$EXTERNALSYM PropertyTagExifRelatedWav} + PropertyTagExifInterop = $A005; + {$EXTERNALSYM PropertyTagExifInterop} + PropertyTagExifFlashEnergy = $A20B; + {$EXTERNALSYM PropertyTagExifFlashEnergy} + PropertyTagExifSpatialFR = $A20C; // Spatial Frequency Response + {$EXTERNALSYM PropertyTagExifSpatialFR} + PropertyTagExifFocalXRes = $A20E; // Focal Plane X Resolution + {$EXTERNALSYM PropertyTagExifFocalXRes} + PropertyTagExifFocalYRes = $A20F; // Focal Plane Y Resolution + {$EXTERNALSYM PropertyTagExifFocalYRes} + PropertyTagExifFocalResUnit = $A210; // Focal Plane Resolution Unit + {$EXTERNALSYM PropertyTagExifFocalResUnit} + PropertyTagExifSubjectLoc = $A214; + {$EXTERNALSYM PropertyTagExifSubjectLoc} + PropertyTagExifExposureIndex = $A215; + {$EXTERNALSYM PropertyTagExifExposureIndex} + PropertyTagExifSensingMethod = $A217; + {$EXTERNALSYM PropertyTagExifSensingMethod} + PropertyTagExifFileSource = $A300; + {$EXTERNALSYM PropertyTagExifFileSource} + PropertyTagExifSceneType = $A301; + {$EXTERNALSYM PropertyTagExifSceneType} + PropertyTagExifCfaPattern = $A302; + {$EXTERNALSYM PropertyTagExifCfaPattern} + + PropertyTagGpsVer = $0000; + {$EXTERNALSYM PropertyTagGpsVer} + PropertyTagGpsLatitudeRef = $0001; + {$EXTERNALSYM PropertyTagGpsLatitudeRef} + PropertyTagGpsLatitude = $0002; + {$EXTERNALSYM PropertyTagGpsLatitude} + PropertyTagGpsLongitudeRef = $0003; + {$EXTERNALSYM PropertyTagGpsLongitudeRef} + PropertyTagGpsLongitude = $0004; + {$EXTERNALSYM PropertyTagGpsLongitude} + PropertyTagGpsAltitudeRef = $0005; + {$EXTERNALSYM PropertyTagGpsAltitudeRef} + PropertyTagGpsAltitude = $0006; + {$EXTERNALSYM PropertyTagGpsAltitude} + PropertyTagGpsGpsTime = $0007; + {$EXTERNALSYM PropertyTagGpsGpsTime} + PropertyTagGpsGpsSatellites = $0008; + {$EXTERNALSYM PropertyTagGpsGpsSatellites} + PropertyTagGpsGpsStatus = $0009; + {$EXTERNALSYM PropertyTagGpsGpsStatus} + PropertyTagGpsGpsMeasureMode = $00A; + {$EXTERNALSYM PropertyTagGpsGpsMeasureMode} + PropertyTagGpsGpsDop = $000B; // Measurement precision + {$EXTERNALSYM PropertyTagGpsGpsDop} + PropertyTagGpsSpeedRef = $000C; + {$EXTERNALSYM PropertyTagGpsSpeedRef} + PropertyTagGpsSpeed = $000D; + {$EXTERNALSYM PropertyTagGpsSpeed} + PropertyTagGpsTrackRef = $000E; + {$EXTERNALSYM PropertyTagGpsTrackRef} + PropertyTagGpsTrack = $000F; + {$EXTERNALSYM PropertyTagGpsTrack} + PropertyTagGpsImgDirRef = $0010; + {$EXTERNALSYM PropertyTagGpsImgDirRef} + PropertyTagGpsImgDir = $0011; + {$EXTERNALSYM PropertyTagGpsImgDir} + PropertyTagGpsMapDatum = $0012; + {$EXTERNALSYM PropertyTagGpsMapDatum} + PropertyTagGpsDestLatRef = $0013; + {$EXTERNALSYM PropertyTagGpsDestLatRef} + PropertyTagGpsDestLat = $0014; + {$EXTERNALSYM PropertyTagGpsDestLat} + PropertyTagGpsDestLongRef = $0015; + {$EXTERNALSYM PropertyTagGpsDestLongRef} + PropertyTagGpsDestLong = $0016; + {$EXTERNALSYM PropertyTagGpsDestLong} + PropertyTagGpsDestBearRef = $0017; + {$EXTERNALSYM PropertyTagGpsDestBearRef} + PropertyTagGpsDestBear = $0018; + {$EXTERNALSYM PropertyTagGpsDestBear} + PropertyTagGpsDestDistRef = $0019; + {$EXTERNALSYM PropertyTagGpsDestDistRef} + PropertyTagGpsDestDist = $001A; + {$EXTERNALSYM PropertyTagGpsDestDist} + +(**************************************************************************\ +* +* GDI+ Color Matrix object, used with Graphics.DrawImage +* +\**************************************************************************) + +//---------------------------------------------------------------------------- +// Color matrix +//---------------------------------------------------------------------------- + +type + {$EXTERNALSYM ColorMatrix} + ColorMatrix = packed array[0..4, 0..4] of Single; + TColorMatrix = ColorMatrix; + PColorMatrix = ^TColorMatrix; + +//---------------------------------------------------------------------------- +// Color Matrix flags +//---------------------------------------------------------------------------- + + {$EXTERNALSYM ColorMatrixFlags} + ColorMatrixFlags = ( + ColorMatrixFlagsDefault, + ColorMatrixFlagsSkipGrays, + ColorMatrixFlagsAltGray + ); + TColorMatrixFlags = ColorMatrixFlags; + +//---------------------------------------------------------------------------- +// Color Adjust Type +//---------------------------------------------------------------------------- + + {$EXTERNALSYM ColorAdjustType} + ColorAdjustType = ( + ColorAdjustTypeDefault, + ColorAdjustTypeBitmap, + ColorAdjustTypeBrush, + ColorAdjustTypePen, + ColorAdjustTypeText, + ColorAdjustTypeCount, + ColorAdjustTypeAny // Reserved + ); + TColorAdjustType = ColorAdjustType; + +//---------------------------------------------------------------------------- +// Color Map +//---------------------------------------------------------------------------- + + {$EXTERNALSYM ColorMap} + ColorMap = packed record + oldColor: TGPColor; + newColor: TGPColor; + end; + TColorMap = ColorMap; + PColorMap = ^TColorMap; + +//--------------------------------------------------------------------------- +// Private GDI+ classes for internal type checking +//--------------------------------------------------------------------------- + + GpGraphics = Pointer; + + GpBrush = Pointer; + GpTexture = Pointer; + GpSolidFill = Pointer; + GpLineGradient = Pointer; + GpPathGradient = Pointer; + GpHatch = Pointer; + + GpPen = Pointer; + GpCustomLineCap = Pointer; + GpAdjustableArrowCap = Pointer; + + GpImage = Pointer; + GpBitmap = Pointer; + GpMetafile = Pointer; + GpImageAttributes = Pointer; + + GpPath = Pointer; + GpRegion = Pointer; + GpPathIterator = Pointer; + + GpFontFamily = Pointer; + GpFont = Pointer; + GpStringFormat = Pointer; + GpFontCollection = Pointer; + GpCachedBitmap = Pointer; + + GpStatus = TStatus; + GpFillMode = TFillMode; + GpWrapMode = TWrapMode; + GpUnit = TUnit; + GpCoordinateSpace = TCoordinateSpace; + GpPointF = PGPPointF; + GpPoint = PGPPoint; + GpRectF = PGPRectF; + GpRect = PGPRect; + GpSizeF = PGPSizeF; + GpHatchStyle = THatchStyle; + GpDashStyle = TDashStyle; + GpLineCap = TLineCap; + GpDashCap = TDashCap; + + GpPenAlignment = TPenAlignment; + + GpLineJoin = TLineJoin; + GpPenType = TPenType; + + GpMatrix = Pointer; + GpBrushType = TBrushType; + GpMatrixOrder = TMatrixOrder; + GpFlushIntention = TFlushIntention; + GpPathData = TPathData; + +(**************************************************************************\ +* +* Copyright (c) 1998-2001, Microsoft Corp. All Rights Reserved. +* Module Name: +* GdiplusFlat.h +* Abstract: +* Private GDI+ header file. +* +\**************************************************************************) + + function GdipCreatePath(brushMode: GPFILLMODE; + out path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePath} + + function GdipCreatePath2(v1: GPPOINTF; v2: PBYTE; v3: Integer; v4: GPFILLMODE; + out path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePath2} + + function GdipCreatePath2I(v1: GPPOINT; v2: PBYTE; v3: Integer; v4: GPFILLMODE; + out path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePath2I} + + function GdipClonePath(path: GPPATH; + out clonePath: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipClonePath} + + function GdipDeletePath(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeletePath} + + function GdipResetPath(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetPath} + + function GdipGetPointCount(path: GPPATH; + out count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPointCount} + + function GdipGetPathTypes(path: GPPATH; types: PBYTE; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathTypes} + + function GdipGetPathPoints(v1: GPPATH; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathPoints} + + function GdipGetPathPointsI(v1: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathPointsI} + + function GdipGetPathFillMode(path: GPPATH; + var fillmode: GPFILLMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathFillMode} + + function GdipSetPathFillMode(path: GPPATH; + fillmode: GPFILLMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathFillMode} + + function GdipGetPathData(path: GPPATH; + pathData: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathData} + + function GdipStartPathFigure(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipStartPathFigure} + + function GdipClosePathFigure(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipClosePathFigure} + + function GdipClosePathFigures(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipClosePathFigures} + + function GdipSetPathMarker(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathMarker} + + function GdipClearPathMarkers(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipClearPathMarkers} + + function GdipReversePath(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipReversePath} + + function GdipGetPathLastPoint(path: GPPATH; + lastPoint: GPPOINTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathLastPoint} + + function GdipAddPathLine(path: GPPATH; + x1, y1, x2, y2: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathLine} + + function GdipAddPathLine2(path: GPPATH; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathLine2} + + function GdipAddPathArc(path: GPPATH; x, y, width, height, startAngle, + sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathArc} + + function GdipAddPathBezier(path: GPPATH; + x1, y1, x2, y2, x3, y3, x4, y4: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathBezier} + + function GdipAddPathBeziers(path: GPPATH; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathBeziers} + + function GdipAddPathCurve(path: GPPATH; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurve} + + function GdipAddPathCurve2(path: GPPATH; points: GPPOINTF; count: Integer; + tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurve2} + + function GdipAddPathCurve3(path: GPPATH; points: GPPOINTF; count: Integer; + offset: Integer; numberOfSegments: Integer; + tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurve3} + + function GdipAddPathClosedCurve(path: GPPATH; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathClosedCurve} + + function GdipAddPathClosedCurve2(path: GPPATH; points: GPPOINTF; + count: Integer; tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathClosedCurve2} + + function GdipAddPathRectangle(path: GPPATH; x: Single; y: Single; + width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathRectangle} + + function GdipAddPathRectangles(path: GPPATH; rects: GPRECTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathRectangles} + + function GdipAddPathEllipse(path: GPPATH; x: Single; y: Single; + width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathEllipse} + + function GdipAddPathPie(path: GPPATH; x: Single; y: Single; width: Single; + height: Single; startAngle: Single; sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathPie} + + function GdipAddPathPolygon(path: GPPATH; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathPolygon} + + function GdipAddPathPath(path: GPPATH; addingPath: GPPATH; + connect: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathPath} + + function GdipAddPathString(path: GPPATH; string_: PWCHAR; length: Integer; + family: GPFONTFAMILY; style: Integer; emSize: Single; layoutRect: PGPRectF; + format: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathString} + + function GdipAddPathStringI(path: GPPATH; string_: PWCHAR; length: Integer; + family: GPFONTFAMILY; style: Integer; emSize: Single; layoutRect: PGPRect; + format: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathStringI} + + function GdipAddPathLineI(path: GPPATH; x1: Integer; y1: Integer; x2: Integer; + y2: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathLineI} + + function GdipAddPathLine2I(path: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathLine2I} + + function GdipAddPathArcI(path: GPPATH; x: Integer; y: Integer; width: Integer; + height: Integer; startAngle: Single; sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathArcI} + + function GdipAddPathBezierI(path: GPPATH; x1: Integer; y1: Integer; + x2: Integer; y2: Integer; x3: Integer; y3: Integer; x4: Integer; + y4: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathBezierI} + + function GdipAddPathBeziersI(path: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathBeziersI} + + function GdipAddPathCurveI(path: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurveI} + + function GdipAddPathCurve2I(path: GPPATH; points: GPPOINT; count: Integer; + tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurve2I} + + function GdipAddPathCurve3I(path: GPPATH; points: GPPOINT; count: Integer; + offset: Integer; numberOfSegments: Integer; + tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurve3I} + + function GdipAddPathClosedCurveI(path: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathClosedCurveI} + + function GdipAddPathClosedCurve2I(path: GPPATH; points: GPPOINT; + count: Integer; tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathClosedCurve2I} + + function GdipAddPathRectangleI(path: GPPATH; x: Integer; y: Integer; + width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathRectangleI} + + function GdipAddPathRectanglesI(path: GPPATH; rects: GPRECT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathRectanglesI} + + function GdipAddPathEllipseI(path: GPPATH; x: Integer; y: Integer; + width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathEllipseI} + + function GdipAddPathPieI(path: GPPATH; x: Integer; y: Integer; width: Integer; + height: Integer; startAngle: Single; sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathPieI} + + function GdipAddPathPolygonI(path: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathPolygonI} + + function GdipFlattenPath(path: GPPATH; matrix: GPMATRIX; + flatness: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFlattenPath} + + function GdipWindingModeOutline(path: GPPATH; matrix: GPMATRIX; + flatness: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipWindingModeOutline} + + function GdipWidenPath(nativePath: GPPATH; pen: GPPEN; matrix: GPMATRIX; + flatness: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipWidenPath} + + function GdipWarpPath(path: GPPATH; matrix: GPMATRIX; points: GPPOINTF; + count: Integer; srcx: Single; srcy: Single; srcwidth: Single; + srcheight: Single; warpMode: WARPMODE; flatness: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipWarpPath} + + function GdipTransformPath(path: GPPATH; matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTransformPath} + + function GdipGetPathWorldBounds(path: GPPATH; bounds: GPRECTF; + matrix: GPMATRIX; pen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathWorldBounds} + + function GdipGetPathWorldBoundsI(path: GPPATH; bounds: GPRECT; + matrix: GPMATRIX; pen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathWorldBoundsI} + + function GdipIsVisiblePathPoint(path: GPPATH; x: Single; y: Single; + graphics: GPGRAPHICS; out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisiblePathPoint} + + function GdipIsVisiblePathPointI(path: GPPATH; x: Integer; y: Integer; + graphics: GPGRAPHICS; out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisiblePathPointI} + + function GdipIsOutlineVisiblePathPoint(path: GPPATH; x: Single; y: Single; + pen: GPPEN; graphics: GPGRAPHICS; out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsOutlineVisiblePathPoint} + + function GdipIsOutlineVisiblePathPointI(path: GPPATH; x: Integer; y: Integer; + pen: GPPEN; graphics: GPGRAPHICS; out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsOutlineVisiblePathPointI} + +//---------------------------------------------------------------------------- +// PathIterator APIs +//---------------------------------------------------------------------------- + + function GdipCreatePathIter(out iterator: GPPATHITERATOR; + path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePathIter} + + function GdipDeletePathIter(iterator: GPPATHITERATOR): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeletePathIter} + + function GdipPathIterNextSubpath(iterator: GPPATHITERATOR; + var resultCount: Integer; var startIndex: Integer; var endIndex: Integer; + out isClosed: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterNextSubpath} + + function GdipPathIterNextSubpathPath(iterator: GPPATHITERATOR; + var resultCount: Integer; path: GPPATH; + out isClosed: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterNextSubpathPath} + + function GdipPathIterNextPathType(iterator: GPPATHITERATOR; + var resultCount: Integer; pathType: PBYTE; var startIndex: Integer; + var endIndex: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterNextPathType} + + function GdipPathIterNextMarker(iterator: GPPATHITERATOR; + var resultCount: Integer; var startIndex: Integer; + var endIndex: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterNextMarker} + + function GdipPathIterNextMarkerPath(iterator: GPPATHITERATOR; + var resultCount: Integer; path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterNextMarkerPath} + + function GdipPathIterGetCount(iterator: GPPATHITERATOR; + out count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterGetCount} + + function GdipPathIterGetSubpathCount(iterator: GPPATHITERATOR; + out count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterGetSubpathCount} + + function GdipPathIterIsValid(iterator: GPPATHITERATOR; + out valid: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterIsValid} + + function GdipPathIterHasCurve(iterator: GPPATHITERATOR; + out hasCurve: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterHasCurve} + + function GdipPathIterRewind(iterator: GPPATHITERATOR): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterRewind} + + function GdipPathIterEnumerate(iterator: GPPATHITERATOR; + var resultCount: Integer; points: GPPOINTF; types: PBYTE; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterEnumerate} + + function GdipPathIterCopyData(iterator: GPPATHITERATOR; + var resultCount: Integer; points: GPPOINTF; types: PBYTE; + startIndex: Integer; endIndex: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPathIterCopyData} + +//---------------------------------------------------------------------------- +// Matrix APIs +//---------------------------------------------------------------------------- + + function GdipCreateMatrix(out matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMatrix} + + function GdipCreateMatrix2(m11: Single; m12: Single; m21: Single; m22: Single; + dx: Single; dy: Single; out matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMatrix2} + + function GdipCreateMatrix3(rect: GPRECTF; dstplg: GPPOINTF; + out matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMatrix3} + + function GdipCreateMatrix3I(rect: GPRECT; dstplg: GPPOINT; + out matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMatrix3I} + + function GdipCloneMatrix(matrix: GPMATRIX; + out cloneMatrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneMatrix} + + function GdipDeleteMatrix(matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteMatrix} + + function GdipSetMatrixElements(matrix: GPMATRIX; m11: Single; m12: Single; + m21: Single; m22: Single; dx: Single; dy: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetMatrixElements} + + function GdipMultiplyMatrix(matrix: GPMATRIX; matrix2: GPMATRIX; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMultiplyMatrix} + + function GdipTranslateMatrix(matrix: GPMATRIX; offsetX: Single; + offsetY: Single; order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslateMatrix} + + function GdipScaleMatrix(matrix: GPMATRIX; scaleX: Single; scaleY: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipScaleMatrix} + + function GdipRotateMatrix(matrix: GPMATRIX; angle: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRotateMatrix} + + function GdipShearMatrix(matrix: GPMATRIX; shearX: Single; shearY: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipShearMatrix} + + function GdipInvertMatrix(matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipInvertMatrix} + + function GdipTransformMatrixPoints(matrix: GPMATRIX; pts: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTransformMatrixPoints} + + function GdipTransformMatrixPointsI(matrix: GPMATRIX; pts: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTransformMatrixPointsI} + + function GdipVectorTransformMatrixPoints(matrix: GPMATRIX; pts: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipVectorTransformMatrixPoints} + + function GdipVectorTransformMatrixPointsI(matrix: GPMATRIX; pts: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipVectorTransformMatrixPointsI} + + function GdipGetMatrixElements(matrix: GPMATRIX; + matrixOut: PSingle): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetMatrixElements} + + function GdipIsMatrixInvertible(matrix: GPMATRIX; + out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsMatrixInvertible} + + function GdipIsMatrixIdentity(matrix: GPMATRIX; + out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsMatrixIdentity} + + function GdipIsMatrixEqual(matrix: GPMATRIX; matrix2: GPMATRIX; + out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsMatrixEqual} + +//---------------------------------------------------------------------------- +// Region APIs +//---------------------------------------------------------------------------- + + function GdipCreateRegion(out region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateRegion} + + function GdipCreateRegionRect(rect: GPRECTF; + out region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateRegionRect} + + function GdipCreateRegionRectI(rect: GPRECT; + out region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateRegionRectI} + + function GdipCreateRegionPath(path: GPPATH; + out region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateRegionPath} + + function GdipCreateRegionRgnData(regionData: PBYTE; size: Integer; + out region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateRegionRgnData} + + function GdipCreateRegionHrgn(hRgn: HRGN; + out region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateRegionHrgn} + + function GdipCloneRegion(region: GPREGION; + out cloneRegion: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneRegion} + + function GdipDeleteRegion(region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteRegion} + + function GdipSetInfinite(region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetInfinite} + + function GdipSetEmpty(region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetEmpty} + + function GdipCombineRegionRect(region: GPREGION; rect: GPRECTF; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCombineRegionRect} + + function GdipCombineRegionRectI(region: GPREGION; rect: GPRECT; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCombineRegionRectI} + + function GdipCombineRegionPath(region: GPREGION; path: GPPATH; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCombineRegionPath} + + function GdipCombineRegionRegion(region: GPREGION; region2: GPREGION; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCombineRegionRegion} + + function GdipTranslateRegion(region: GPREGION; dx: Single; + dy: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslateRegion} + + function GdipTranslateRegionI(region: GPREGION; dx: Integer; + dy: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslateRegionI} + + function GdipTransformRegion(region: GPREGION; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTransformRegion} + + function GdipGetRegionBounds(region: GPREGION; graphics: GPGRAPHICS; + rect: GPRECTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRegionBounds} + + function GdipGetRegionBoundsI(region: GPREGION; graphics: GPGRAPHICS; + rect: GPRECT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRegionBoundsI} + + function GdipGetRegionHRgn(region: GPREGION; graphics: GPGRAPHICS; + out hRgn: HRGN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRegionHRgn} + + function GdipIsEmptyRegion(region: GPREGION; graphics: GPGRAPHICS; + out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsEmptyRegion} + + function GdipIsInfiniteRegion(region: GPREGION; graphics: GPGRAPHICS; + out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsInfiniteRegion} + + function GdipIsEqualRegion(region: GPREGION; region2: GPREGION; + graphics: GPGRAPHICS; out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsEqualRegion} + + function GdipGetRegionDataSize(region: GPREGION; + out bufferSize: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRegionDataSize} + + function GdipGetRegionData(region: GPREGION; buffer: PBYTE; + bufferSize: UINT; sizeFilled: PUINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRegionData} + + function GdipIsVisibleRegionPoint(region: GPREGION; x: Single; y: Single; + graphics: GPGRAPHICS; out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisibleRegionPoint} + + function GdipIsVisibleRegionPointI(region: GPREGION; x: Integer; y: Integer; + graphics: GPGRAPHICS; out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisibleRegionPointI} + + function GdipIsVisibleRegionRect(region: GPREGION; x: Single; y: Single; + width: Single; height: Single; graphics: GPGRAPHICS; + out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisibleRegionRect} + + function GdipIsVisibleRegionRectI(region: GPREGION; x: Integer; y: Integer; + width: Integer; height: Integer; graphics: GPGRAPHICS; + out result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisibleRegionRectI} + + function GdipGetRegionScansCount(region: GPREGION; out count: UINT; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRegionScansCount} + + function GdipGetRegionScans(region: GPREGION; rects: GPRECTF; + out count: Integer; matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRegionScans} + + function GdipGetRegionScansI(region: GPREGION; rects: GPRECT; + out count: Integer; matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRegionScansI} + +//---------------------------------------------------------------------------- +// Brush APIs +//---------------------------------------------------------------------------- + + function GdipCloneBrush(brush: GPBRUSH; + out cloneBrush: GPBRUSH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneBrush} + + function GdipDeleteBrush(brush: GPBRUSH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteBrush} + + function GdipGetBrushType(brush: GPBRUSH; + out type_: GPBRUSHTYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetBrushType} + +//---------------------------------------------------------------------------- +// HatchBrush APIs +//---------------------------------------------------------------------------- + + function GdipCreateHatchBrush(hatchstyle: Integer; forecol: ARGB; + backcol: ARGB; out brush: GPHATCH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateHatchBrush} + + function GdipGetHatchStyle(brush: GPHATCH; + out hatchstyle: GPHATCHSTYLE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetHatchStyle} + + function GdipGetHatchForegroundColor(brush: GPHATCH; + out forecol: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetHatchForegroundColor} + + function GdipGetHatchBackgroundColor(brush: GPHATCH; + out backcol: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetHatchBackgroundColor} + +//---------------------------------------------------------------------------- +// TextureBrush APIs +//---------------------------------------------------------------------------- + + + function GdipCreateTexture(image: GPIMAGE; wrapmode: GPWRAPMODE; + var texture: GPTEXTURE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateTexture} + + function GdipCreateTexture2(image: GPIMAGE; wrapmode: GPWRAPMODE; + x: Single; y: Single; width: Single; height: Single; + out texture: GPTEXTURE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateTexture2} + + function GdipCreateTextureIA(image: GPIMAGE; + imageAttributes: GPIMAGEATTRIBUTES; x: Single; y: Single; width: Single; + height: Single; out texture: GPTEXTURE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateTextureIA} + + function GdipCreateTexture2I(image: GPIMAGE; wrapmode: GPWRAPMODE; x: Integer; + y: Integer; width: Integer; height: Integer; + out texture: GPTEXTURE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateTexture2I} + + function GdipCreateTextureIAI(image: GPIMAGE; + imageAttributes: GPIMAGEATTRIBUTES; x: Integer; y: Integer; width: Integer; + height: Integer; out texture: GPTEXTURE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateTextureIAI} + + function GdipGetTextureTransform(brush: GPTEXTURE; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetTextureTransform} + + function GdipSetTextureTransform(brush: GPTEXTURE; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetTextureTransform} + + function GdipResetTextureTransform(brush: GPTEXTURE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetTextureTransform} + + function GdipMultiplyTextureTransform(brush: GPTEXTURE; matrix: GPMATRIX; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMultiplyTextureTransform} + + function GdipTranslateTextureTransform(brush: GPTEXTURE; dx: Single; + dy: Single; order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslateTextureTransform} + + function GdipScaleTextureTransform(brush: GPTEXTURE; sx: Single; sy: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipScaleTextureTransform} + + function GdipRotateTextureTransform(brush: GPTEXTURE; angle: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRotateTextureTransform} + + function GdipSetTextureWrapMode(brush: GPTEXTURE; + wrapmode: GPWRAPMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetTextureWrapMode} + + function GdipGetTextureWrapMode(brush: GPTEXTURE; + var wrapmode: GPWRAPMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetTextureWrapMode} + + function GdipGetTextureImage(brush: GPTEXTURE; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetTextureImage} + +//---------------------------------------------------------------------------- +// SolidBrush APIs +//---------------------------------------------------------------------------- + + function GdipCreateSolidFill(color: ARGB; + out brush: GPSOLIDFILL): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateSolidFill} + + function GdipSetSolidFillColor(brush: GPSOLIDFILL; + color: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetSolidFillColor} + + function GdipGetSolidFillColor(brush: GPSOLIDFILL; + out color: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetSolidFillColor} + +//---------------------------------------------------------------------------- +// LineBrush APIs +//---------------------------------------------------------------------------- + + function GdipCreateLineBrush(point1: GPPOINTF; point2: GPPOINTF; color1: ARGB; + color2: ARGB; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrush} + + function GdipCreateLineBrushI(point1: GPPOINT; point2: GPPOINT; color1: ARGB; + color2: ARGB; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrushI} + + function GdipCreateLineBrushFromRect(rect: GPRECTF; color1: ARGB; + color2: ARGB; mode: LINEARGRADIENTMODE; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrushFromRect} + + function GdipCreateLineBrushFromRectI(rect: GPRECT; color1: ARGB; + color2: ARGB; mode: LINEARGRADIENTMODE; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrushFromRectI} + + function GdipCreateLineBrushFromRectWithAngle(rect: GPRECTF; color1: ARGB; + color2: ARGB; angle: Single; isAngleScalable: Bool; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrushFromRectWithAngle} + + function GdipCreateLineBrushFromRectWithAngleI(rect: GPRECT; color1: ARGB; + color2: ARGB; angle: Single; isAngleScalable: Bool; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrushFromRectWithAngleI} + + function GdipSetLineColors(brush: GPLINEGRADIENT; color1: ARGB; + color2: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetLineColors} + + function GdipGetLineColors(brush: GPLINEGRADIENT; + colors: PARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineColors} + + function GdipGetLineRect(brush: GPLINEGRADIENT; + rect: GPRECTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineRect} + + function GdipGetLineRectI(brush: GPLINEGRADIENT; + rect: GPRECT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineRectI} + + function GdipSetLineGammaCorrection(brush: GPLINEGRADIENT; + useGammaCorrection: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetLineGammaCorrection} + + function GdipGetLineGammaCorrection(brush: GPLINEGRADIENT; + out useGammaCorrection: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineGammaCorrection} + + function GdipGetLineBlendCount(brush: GPLINEGRADIENT; + out count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineBlendCount} + + function GdipGetLineBlend(brush: GPLINEGRADIENT; blend: PSingle; + positions: PSingle; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineBlend} + + function GdipSetLineBlend(brush: GPLINEGRADIENT; blend: PSingle; + positions: PSingle; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetLineBlend} + + function GdipGetLinePresetBlendCount(brush: GPLINEGRADIENT; + out count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLinePresetBlendCount} + + function GdipGetLinePresetBlend(brush: GPLINEGRADIENT; blend: PARGB; + positions: PSingle; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLinePresetBlend} + + function GdipSetLinePresetBlend(brush: GPLINEGRADIENT; blend: PARGB; + positions: PSingle; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetLinePresetBlend} + + function GdipSetLineSigmaBlend(brush: GPLINEGRADIENT; focus: Single; + scale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetLineSigmaBlend} + + function GdipSetLineLinearBlend(brush: GPLINEGRADIENT; focus: Single; + scale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetLineLinearBlend} + + function GdipSetLineWrapMode(brush: GPLINEGRADIENT; + wrapmode: GPWRAPMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetLineWrapMode} + + function GdipGetLineWrapMode(brush: GPLINEGRADIENT; + out wrapmode: GPWRAPMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineWrapMode} + + function GdipGetLineTransform(brush: GPLINEGRADIENT; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineTransform} + + function GdipSetLineTransform(brush: GPLINEGRADIENT; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetLineTransform} + + function GdipResetLineTransform(brush: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetLineTransform} + + function GdipMultiplyLineTransform(brush: GPLINEGRADIENT; matrix: GPMATRIX; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMultiplyLineTransform} + + function GdipTranslateLineTransform(brush: GPLINEGRADIENT; dx: Single; + dy: Single; order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslateLineTransform} + + function GdipScaleLineTransform(brush: GPLINEGRADIENT; sx: Single; sy: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipScaleLineTransform} + + function GdipRotateLineTransform(brush: GPLINEGRADIENT; angle: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRotateLineTransform} + +//---------------------------------------------------------------------------- +// PathGradientBrush APIs +//---------------------------------------------------------------------------- + + function GdipCreatePathGradient(points: GPPOINTF; count: Integer; + wrapMode: GPWRAPMODE; out polyGradient: GPPATHGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePathGradient} + + function GdipCreatePathGradientI(points: GPPOINT; count: Integer; + wrapMode: GPWRAPMODE; out polyGradient: GPPATHGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePathGradientI} + + function GdipCreatePathGradientFromPath(path: GPPATH; + out polyGradient: GPPATHGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePathGradientFromPath} + + function GdipGetPathGradientCenterColor(brush: GPPATHGRADIENT; + out colors: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientCenterColor} + + function GdipSetPathGradientCenterColor(brush: GPPATHGRADIENT; + colors: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientCenterColor} + + function GdipGetPathGradientSurroundColorsWithCount(brush: GPPATHGRADIENT; + color: PARGB; var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientSurroundColorsWithCount} + + function GdipSetPathGradientSurroundColorsWithCount(brush: GPPATHGRADIENT; + color: PARGB; var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientSurroundColorsWithCount} + + function GdipGetPathGradientPath(brush: GPPATHGRADIENT; + path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientPath} + + function GdipSetPathGradientPath(brush: GPPATHGRADIENT; + path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientPath} + + function GdipGetPathGradientCenterPoint(brush: GPPATHGRADIENT; + points: GPPOINTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientCenterPoint} + + function GdipGetPathGradientCenterPointI(brush: GPPATHGRADIENT; + points: GPPOINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientCenterPointI} + + function GdipSetPathGradientCenterPoint(brush: GPPATHGRADIENT; + points: GPPOINTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientCenterPoint} + + function GdipSetPathGradientCenterPointI(brush: GPPATHGRADIENT; + points: GPPOINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientCenterPointI} + + function GdipGetPathGradientRect(brush: GPPATHGRADIENT; + rect: GPRECTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientRect} + + function GdipGetPathGradientRectI(brush: GPPATHGRADIENT; + rect: GPRECT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientRectI} + + function GdipGetPathGradientPointCount(brush: GPPATHGRADIENT; + var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientPointCount} + + function GdipGetPathGradientSurroundColorCount(brush: GPPATHGRADIENT; + var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientSurroundColorCount} + + function GdipSetPathGradientGammaCorrection(brush: GPPATHGRADIENT; + useGammaCorrection: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientGammaCorrection} + + function GdipGetPathGradientGammaCorrection(brush: GPPATHGRADIENT; + var useGammaCorrection: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientGammaCorrection} + + function GdipGetPathGradientBlendCount(brush: GPPATHGRADIENT; + var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientBlendCount} + + function GdipGetPathGradientBlend(brush: GPPATHGRADIENT; + blend: PSingle; positions: PSingle; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientBlend} + + function GdipSetPathGradientBlend(brush: GPPATHGRADIENT; + blend: PSingle; positions: PSingle; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientBlend} + + function GdipGetPathGradientPresetBlendCount(brush: GPPATHGRADIENT; + var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientPresetBlendCount} + + function GdipGetPathGradientPresetBlend(brush: GPPATHGRADIENT; + blend: PARGB; positions: PSingle; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientPresetBlend} + + function GdipSetPathGradientPresetBlend(brush: GPPATHGRADIENT; + blend: PARGB; positions: PSingle; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientPresetBlend} + + function GdipSetPathGradientSigmaBlend(brush: GPPATHGRADIENT; + focus: Single; scale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientSigmaBlend} + + function GdipSetPathGradientLinearBlend(brush: GPPATHGRADIENT; + focus: Single; scale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientLinearBlend} + + function GdipGetPathGradientWrapMode(brush: GPPATHGRADIENT; + var wrapmode: GPWRAPMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientWrapMode} + + function GdipSetPathGradientWrapMode(brush: GPPATHGRADIENT; + wrapmode: GPWRAPMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientWrapMode} + + function GdipGetPathGradientTransform(brush: GPPATHGRADIENT; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientTransform} + + function GdipSetPathGradientTransform(brush: GPPATHGRADIENT; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientTransform} + + function GdipResetPathGradientTransform( + brush: GPPATHGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetPathGradientTransform} + + function GdipMultiplyPathGradientTransform(brush: GPPATHGRADIENT; + matrix: GPMATRIX; order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMultiplyPathGradientTransform} + + function GdipTranslatePathGradientTransform(brush: GPPATHGRADIENT; + dx: Single; dy: Single; order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslatePathGradientTransform} + + function GdipScalePathGradientTransform(brush: GPPATHGRADIENT; + sx: Single; sy: Single; order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipScalePathGradientTransform} + + function GdipRotatePathGradientTransform(brush: GPPATHGRADIENT; + angle: Single; order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRotatePathGradientTransform} + + function GdipGetPathGradientFocusScales(brush: GPPATHGRADIENT; + var xScale: Single; var yScale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientFocusScales} + + function GdipSetPathGradientFocusScales(brush: GPPATHGRADIENT; + xScale: Single; yScale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientFocusScales} + +//---------------------------------------------------------------------------- +// Pen APIs +//---------------------------------------------------------------------------- + + function GdipCreatePen1(color: ARGB; width: Single; unit_: GPUNIT; + out pen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePen1} + + function GdipCreatePen2(brush: GPBRUSH; width: Single; unit_: GPUNIT; + out pen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePen2} + + function GdipClonePen(pen: GPPEN; out clonepen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipClonePen} + + function GdipDeletePen(pen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeletePen} + + function GdipSetPenWidth(pen: GPPEN; width: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenWidth} + + function GdipGetPenWidth(pen: GPPEN; out width: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenWidth} + + function GdipSetPenUnit(pen: GPPEN; unit_: GPUNIT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenUnit} + + function GdipGetPenUnit(pen: GPPEN; var unit_: GPUNIT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenUnit} + + function GdipSetPenLineCap197819(pen: GPPEN; startCap: GPLINECAP; + endCap: GPLINECAP; dashCap: GPDASHCAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenLineCap197819} + + function GdipSetPenStartCap(pen: GPPEN; + startCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenStartCap} + + function GdipSetPenEndCap(pen: GPPEN; endCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenEndCap} + + function GdipSetPenDashCap197819(pen: GPPEN; + dashCap: GPDASHCAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenDashCap197819} + + function GdipGetPenStartCap(pen: GPPEN; + out startCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenStartCap} + + function GdipGetPenEndCap(pen: GPPEN; + out endCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenEndCap} + + function GdipGetPenDashCap197819(pen: GPPEN; + out dashCap: GPDASHCAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenDashCap197819} + + function GdipSetPenLineJoin(pen: GPPEN; + lineJoin: GPLINEJOIN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenLineJoin} + + function GdipGetPenLineJoin(pen: GPPEN; + var lineJoin: GPLINEJOIN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenLineJoin} + + function GdipSetPenCustomStartCap(pen: GPPEN; + customCap: GPCUSTOMLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenCustomStartCap} + + function GdipGetPenCustomStartCap(pen: GPPEN; + out customCap: GPCUSTOMLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenCustomStartCap} + + function GdipSetPenCustomEndCap(pen: GPPEN; + customCap: GPCUSTOMLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenCustomEndCap} + + function GdipGetPenCustomEndCap(pen: GPPEN; + out customCap: GPCUSTOMLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenCustomEndCap} + + function GdipSetPenMiterLimit(pen: GPPEN; + miterLimit: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenMiterLimit} + + function GdipGetPenMiterLimit(pen: GPPEN; + out miterLimit: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenMiterLimit} + + function GdipSetPenMode(pen: GPPEN; + penMode: GPPENALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenMode} + + function GdipGetPenMode(pen: GPPEN; + var penMode: GPPENALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenMode} + + function GdipSetPenTransform(pen: GPPEN; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenTransform} + + function GdipGetPenTransform(pen: GPPEN; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenTransform} + + function GdipResetPenTransform(pen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetPenTransform} + + function GdipMultiplyPenTransform(pen: GPPEN; matrix: GPMATRIX; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMultiplyPenTransform} + + function GdipTranslatePenTransform(pen: GPPEN; dx: Single; dy: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslatePenTransform} + + function GdipScalePenTransform(pen: GPPEN; sx: Single; sy: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipScalePenTransform} + + function GdipRotatePenTransform(pen: GPPEN; angle: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRotatePenTransform} + + function GdipSetPenColor(pen: GPPEN; argb: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenColor} + + function GdipGetPenColor(pen: GPPEN; out argb: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenColor} + + function GdipSetPenBrushFill(pen: GPPEN; brush: GPBRUSH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenBrushFill} + + function GdipGetPenBrushFill(pen: GPPEN; + out brush: GPBRUSH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenBrushFill} + + function GdipGetPenFillType(pen: GPPEN; + out type_: GPPENTYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenFillType} + + function GdipGetPenDashStyle(pen: GPPEN; + out dashstyle: GPDASHSTYLE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenDashStyle} + + function GdipSetPenDashStyle(pen: GPPEN; + dashstyle: GPDASHSTYLE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenDashStyle} + + function GdipGetPenDashOffset(pen: GPPEN; + out offset: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenDashOffset} + + function GdipSetPenDashOffset(pen: GPPEN; offset: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenDashOffset} + + function GdipGetPenDashCount(pen: GPPEN; + var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenDashCount} + + function GdipSetPenDashArray(pen: GPPEN; dash: PSingle; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenDashArray} + + function GdipGetPenDashArray(pen: GPPEN; dash: PSingle; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenDashArray} + + function GdipGetPenCompoundCount(pen: GPPEN; + out count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenCompoundCount} + + function GdipSetPenCompoundArray(pen: GPPEN; dash: PSingle; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenCompoundArray} + + function GdipGetPenCompoundArray(pen: GPPEN; dash: PSingle; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenCompoundArray} + +//---------------------------------------------------------------------------- +// CustomLineCap APIs +//---------------------------------------------------------------------------- + + function GdipCreateCustomLineCap(fillPath: GPPATH; strokePath: GPPATH; + baseCap: GPLINECAP; baseInset: Single; + out customCap: GPCUSTOMLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateCustomLineCap} + + function GdipDeleteCustomLineCap( + customCap: GPCUSTOMLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteCustomLineCap} + + function GdipCloneCustomLineCap(customCap: GPCUSTOMLINECAP; + out clonedCap: GPCUSTOMLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneCustomLineCap} + + function GdipGetCustomLineCapType(customCap: GPCUSTOMLINECAP; + var capType: CUSTOMLINECAPTYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCustomLineCapType} + + function GdipSetCustomLineCapStrokeCaps(customCap: GPCUSTOMLINECAP; + startCap: GPLINECAP; endCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetCustomLineCapStrokeCaps} + + function GdipGetCustomLineCapStrokeCaps(customCap: GPCUSTOMLINECAP; + var startCap: GPLINECAP; var endCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCustomLineCapStrokeCaps} + + function GdipSetCustomLineCapStrokeJoin(customCap: GPCUSTOMLINECAP; + lineJoin: GPLINEJOIN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetCustomLineCapStrokeJoin} + + function GdipGetCustomLineCapStrokeJoin(customCap: GPCUSTOMLINECAP; + var lineJoin: GPLINEJOIN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCustomLineCapStrokeJoin} + + function GdipSetCustomLineCapBaseCap(customCap: GPCUSTOMLINECAP; + baseCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetCustomLineCapBaseCap} + + function GdipGetCustomLineCapBaseCap(customCap: GPCUSTOMLINECAP; + var baseCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCustomLineCapBaseCap} + + function GdipSetCustomLineCapBaseInset(customCap: GPCUSTOMLINECAP; + inset: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetCustomLineCapBaseInset} + + function GdipGetCustomLineCapBaseInset(customCap: GPCUSTOMLINECAP; + var inset: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCustomLineCapBaseInset} + + function GdipSetCustomLineCapWidthScale(customCap: GPCUSTOMLINECAP; + widthScale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetCustomLineCapWidthScale} + + function GdipGetCustomLineCapWidthScale(customCap: GPCUSTOMLINECAP; + var widthScale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCustomLineCapWidthScale} + +//---------------------------------------------------------------------------- +// AdjustableArrowCap APIs +//---------------------------------------------------------------------------- + + function GdipCreateAdjustableArrowCap(height: Single; + width: Single; + isFilled: Bool; + out cap: GPADJUSTABLEARROWCAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateAdjustableArrowCap} + + function GdipSetAdjustableArrowCapHeight(cap: GPADJUSTABLEARROWCAP; + height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetAdjustableArrowCapHeight} + + function GdipGetAdjustableArrowCapHeight(cap: GPADJUSTABLEARROWCAP; + var height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetAdjustableArrowCapHeight} + + function GdipSetAdjustableArrowCapWidth(cap: GPADJUSTABLEARROWCAP; + width: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetAdjustableArrowCapWidth} + + function GdipGetAdjustableArrowCapWidth(cap: GPADJUSTABLEARROWCAP; + var width: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetAdjustableArrowCapWidth} + + function GdipSetAdjustableArrowCapMiddleInset(cap: GPADJUSTABLEARROWCAP; + middleInset: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetAdjustableArrowCapMiddleInset} + + function GdipGetAdjustableArrowCapMiddleInset(cap: GPADJUSTABLEARROWCAP; + var middleInset: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetAdjustableArrowCapMiddleInset} + + function GdipSetAdjustableArrowCapFillState(cap: GPADJUSTABLEARROWCAP; + fillState: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetAdjustableArrowCapFillState} + + function GdipGetAdjustableArrowCapFillState(cap: GPADJUSTABLEARROWCAP; + var fillState: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetAdjustableArrowCapFillState} + +//---------------------------------------------------------------------------- +// Image APIs +//---------------------------------------------------------------------------- + + function GdipLoadImageFromStream(stream: ISTREAM; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipLoadImageFromStream} + + function GdipLoadImageFromFile(filename: PWCHAR; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipLoadImageFromFile} + + function GdipLoadImageFromStreamICM(stream: ISTREAM; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipLoadImageFromStreamICM} + + function GdipLoadImageFromFileICM(filename: PWCHAR; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipLoadImageFromFileICM} + + function GdipCloneImage(image: GPIMAGE; + out cloneImage: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneImage} + + function GdipDisposeImage(image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDisposeImage} + + function GdipSaveImageToFile(image: GPIMAGE; + filename: PWCHAR; + clsidEncoder: PGUID; + encoderParams: PENCODERPARAMETERS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSaveImageToFile} + + function GdipSaveImageToStream(image: GPIMAGE; + stream: ISTREAM; + clsidEncoder: PGUID; + encoderParams: PENCODERPARAMETERS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSaveImageToStream} + + function GdipSaveAdd(image: GPIMAGE; + encoderParams: PENCODERPARAMETERS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSaveAdd} + + function GdipSaveAddImage(image: GPIMAGE; + newImage: GPIMAGE; + encoderParams: PENCODERPARAMETERS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSaveAddImage} + + function GdipGetImageGraphicsContext(image: GPIMAGE; + out graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageGraphicsContext} + + function GdipGetImageBounds(image: GPIMAGE; + srcRect: GPRECTF; + var srcUnit: GPUNIT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageBounds} + + function GdipGetImageDimension(image: GPIMAGE; + var width: Single; + var height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageDimension} + + function GdipGetImageType(image: GPIMAGE; + var type_: IMAGETYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageType} + + function GdipGetImageWidth(image: GPIMAGE; + var width: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageWidth} + + function GdipGetImageHeight(image: GPIMAGE; + var height: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageHeight} + + function GdipGetImageHorizontalResolution(image: GPIMAGE; + var resolution: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageHorizontalResolution} + + function GdipGetImageVerticalResolution(image: GPIMAGE; + var resolution: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageVerticalResolution} + + function GdipGetImageFlags(image: GPIMAGE; + var flags: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageFlags} + + function GdipGetImageRawFormat(image: GPIMAGE; + format: PGUID): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageRawFormat} + + function GdipGetImagePixelFormat(image: GPIMAGE; + out format: TPIXELFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImagePixelFormat} + + function GdipGetImageThumbnail(image: GPIMAGE; thumbWidth: UINT; + thumbHeight: UINT; out thumbImage: GPIMAGE; + callback: GETTHUMBNAILIMAGEABORT; callbackData: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageThumbnail} + + function GdipGetEncoderParameterListSize(image: GPIMAGE; + clsidEncoder: PGUID; out size: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetEncoderParameterListSize} + + function GdipGetEncoderParameterList(image: GPIMAGE; clsidEncoder: PGUID; + size: UINT; buffer: PENCODERPARAMETERS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetEncoderParameterList} + + function GdipImageGetFrameDimensionsCount(image: GPIMAGE; + var count: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipImageGetFrameDimensionsCount} + + function GdipImageGetFrameDimensionsList(image: GPIMAGE; dimensionIDs: PGUID; + count: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipImageGetFrameDimensionsList} + + function GdipImageGetFrameCount(image: GPIMAGE; dimensionID: PGUID; + var count: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipImageGetFrameCount} + + function GdipImageSelectActiveFrame(image: GPIMAGE; dimensionID: PGUID; + frameIndex: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipImageSelectActiveFrame} + + function GdipImageRotateFlip(image: GPIMAGE; + rfType: ROTATEFLIPTYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipImageRotateFlip} + + function GdipGetImagePalette(image: GPIMAGE; palette: PCOLORPALETTE; + size: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImagePalette} + + function GdipSetImagePalette(image: GPIMAGE; + palette: PCOLORPALETTE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImagePalette} + + function GdipGetImagePaletteSize(image: GPIMAGE; + var size: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImagePaletteSize} + + function GdipGetPropertyCount(image: GPIMAGE; + var numOfProperty: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPropertyCount} + + function GdipGetPropertyIdList(image: GPIMAGE; numOfProperty: UINT; + list: PPROPID): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPropertyIdList} + + function GdipGetPropertyItemSize(image: GPIMAGE; propId: PROPID; + var size: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPropertyItemSize} + + function GdipGetPropertyItem(image: GPIMAGE; propId: PROPID; propSize: UINT; + buffer: PPROPERTYITEM): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPropertyItem} + + function GdipGetPropertySize(image: GPIMAGE; var totalBufferSize: UINT; + var numProperties: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPropertySize} + + function GdipGetAllPropertyItems(image: GPIMAGE; totalBufferSize: UINT; + numProperties: UINT; allItems: PPROPERTYITEM): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetAllPropertyItems} + + function GdipRemovePropertyItem(image: GPIMAGE; + propId: PROPID): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRemovePropertyItem} + + function GdipSetPropertyItem(image: GPIMAGE; + item: PPROPERTYITEM): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPropertyItem} + + function GdipImageForceValidation(image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipImageForceValidation} + +//---------------------------------------------------------------------------- +// Bitmap APIs +//---------------------------------------------------------------------------- + + function GdipCreateBitmapFromStream(stream: ISTREAM; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromStream} + + function GdipCreateBitmapFromFile(filename: PWCHAR; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromFile} + + function GdipCreateBitmapFromStreamICM(stream: ISTREAM; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromStreamICM} + + function GdipCreateBitmapFromFileICM(filename: PWCHAR; + var bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromFileICM} + + function GdipCreateBitmapFromScan0(width: Integer; height: Integer; + stride: Integer; format: PIXELFORMAT; scan0: PBYTE; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromScan0} + + function GdipCreateBitmapFromGraphics(width: Integer; height: Integer; + target: GPGRAPHICS; out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromGraphics} + + function GdipCreateBitmapFromDirectDrawSurface(surface: IDIRECTDRAWSURFACE7; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromDirectDrawSurface} + + function GdipCreateBitmapFromGdiDib(gdiBitmapInfo: PBitmapInfo; + gdiBitmapData: Pointer; out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromGdiDib} + + function GdipCreateBitmapFromHBITMAP(hbm: HBITMAP; hpal: HPALETTE; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromHBITMAP} + + function GdipCreateHBITMAPFromBitmap(bitmap: GPBITMAP; out hbmReturn: HBITMAP; + background: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateHBITMAPFromBitmap} + + function GdipCreateBitmapFromHICON(hicon: HICON; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromHICON} + + function GdipCreateHICONFromBitmap(bitmap: GPBITMAP; + out hbmReturn: HICON): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateHICONFromBitmap} + + function GdipCreateBitmapFromResource(hInstance: HMODULE; + lpBitmapName: PWCHAR; out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromResource} + + function GdipCloneBitmapArea(x: Single; y: Single; width: Single; + height: Single; format: PIXELFORMAT; srcBitmap: GPBITMAP; + out dstBitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneBitmapArea} + + function GdipCloneBitmapAreaI(x: Integer; y: Integer; width: Integer; + height: Integer; format: PIXELFORMAT; srcBitmap: GPBITMAP; + out dstBitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneBitmapAreaI} + + function GdipBitmapLockBits(bitmap: GPBITMAP; rect: GPRECT; flags: UINT; + format: PIXELFORMAT; lockedBitmapData: PBITMAPDATA): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBitmapLockBits} + + function GdipBitmapUnlockBits(bitmap: GPBITMAP; + lockedBitmapData: PBITMAPDATA): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBitmapUnlockBits} + + function GdipBitmapGetPixel(bitmap: GPBITMAP; x: Integer; y: Integer; + var color: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBitmapGetPixel} + + function GdipBitmapSetPixel(bitmap: GPBITMAP; x: Integer; y: Integer; + color: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBitmapSetPixel} + + function GdipBitmapSetResolution(bitmap: GPBITMAP; xdpi: Single; + ydpi: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBitmapSetResolution} + +//---------------------------------------------------------------------------- +// ImageAttributes APIs +//---------------------------------------------------------------------------- + + function GdipCreateImageAttributes( + out imageattr: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateImageAttributes} + + function GdipCloneImageAttributes(imageattr: GPIMAGEATTRIBUTES; + out cloneImageattr: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneImageAttributes} + + function GdipDisposeImageAttributes( + imageattr: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDisposeImageAttributes} + + function GdipSetImageAttributesToIdentity(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesToIdentity} + + function GdipResetImageAttributes(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetImageAttributes} + + function GdipSetImageAttributesColorMatrix(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE; enableFlag: Bool; colorMatrix: PCOLORMATRIX; + grayMatrix: PCOLORMATRIX; flags: COLORMATRIXFLAGS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesColorMatrix} + + function GdipSetImageAttributesThreshold(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE; enableFlag: Bool; + threshold: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesThreshold} + + function GdipSetImageAttributesGamma(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE; enableFlag: Bool; gamma: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesGamma} + + function GdipSetImageAttributesNoOp(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE; enableFlag: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesNoOp} + + function GdipSetImageAttributesColorKeys(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE; enableFlag: Bool; colorLow: ARGB; + colorHigh: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesColorKeys} + + function GdipSetImageAttributesOutputChannel(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE; enableFlag: Bool; + channelFlags: COLORCHANNELFLAGS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesOutputChannel} + + function GdipSetImageAttributesOutputChannelColorProfile(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE; enableFlag: Bool; + colorProfileFilename: PWCHAR): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesOutputChannelColorProfile} + + function GdipSetImageAttributesRemapTable(imageattr: GPIMAGEATTRIBUTES; + type_: COLORADJUSTTYPE; enableFlag: Bool; mapSize: UINT; + map: PCOLORMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesRemapTable} + + function GdipSetImageAttributesWrapMode(imageAttr: GPIMAGEATTRIBUTES; + wrap: WRAPMODE; argb: ARGB; clamp: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesWrapMode} + + function GdipSetImageAttributesICMMode(imageAttr: GPIMAGEATTRIBUTES; + on_: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetImageAttributesICMMode} + + function GdipGetImageAttributesAdjustedPalette(imageAttr: GPIMAGEATTRIBUTES; + colorPalette: PCOLORPALETTE; + colorAdjustType: COLORADJUSTTYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageAttributesAdjustedPalette} + +//---------------------------------------------------------------------------- +// Graphics APIs +//---------------------------------------------------------------------------- + + function GdipFlush(graphics: GPGRAPHICS; + intention: GPFLUSHINTENTION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFlush} + + function GdipCreateFromHDC(hdc: HDC; + out graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFromHDC} + + function GdipCreateFromHDC2(hdc: HDC; hDevice: THandle; + out graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFromHDC2} + + function GdipCreateFromHWND(hwnd: HWND; + out graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFromHWND} + + function GdipCreateFromHWNDICM(hwnd: HWND; + out graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFromHWNDICM} + + function GdipDeleteGraphics(graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteGraphics} + + function GdipGetDC(graphics: GPGRAPHICS; var hdc: HDC): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetDC} + + function GdipReleaseDC(graphics: GPGRAPHICS; hdc: HDC): GPSTATUS; stdcall; + {$EXTERNALSYM GdipReleaseDC} + + function GdipSetCompositingMode(graphics: GPGRAPHICS; + compositingMode: COMPOSITINGMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetCompositingMode} + + function GdipGetCompositingMode(graphics: GPGRAPHICS; + var compositingMode: COMPOSITINGMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCompositingMode} + + function GdipSetRenderingOrigin(graphics: GPGRAPHICS; x: Integer; + y: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetRenderingOrigin} + + function GdipGetRenderingOrigin(graphics: GPGRAPHICS; var x: Integer; + var y: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetRenderingOrigin} + + function GdipSetCompositingQuality(graphics: GPGRAPHICS; + compositingQuality: COMPOSITINGQUALITY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetCompositingQuality} + + function GdipGetCompositingQuality(graphics: GPGRAPHICS; + var compositingQuality: COMPOSITINGQUALITY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCompositingQuality} + + function GdipSetSmoothingMode(graphics: GPGRAPHICS; + smoothingMode: SMOOTHINGMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetSmoothingMode} + + function GdipGetSmoothingMode(graphics: GPGRAPHICS; + var smoothingMode: SMOOTHINGMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetSmoothingMode} + + function GdipSetPixelOffsetMode(graphics: GPGRAPHICS; + pixelOffsetMode: PIXELOFFSETMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPixelOffsetMode} + + function GdipGetPixelOffsetMode(graphics: GPGRAPHICS; + var pixelOffsetMode: PIXELOFFSETMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPixelOffsetMode} + + function GdipSetTextRenderingHint(graphics: GPGRAPHICS; + mode: TEXTRENDERINGHINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetTextRenderingHint} + + function GdipGetTextRenderingHint(graphics: GPGRAPHICS; + var mode: TEXTRENDERINGHINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetTextRenderingHint} + + function GdipSetTextContrast(graphics: GPGRAPHICS; + contrast: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetTextContrast} + + function GdipGetTextContrast(graphics: GPGRAPHICS; + var contrast: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetTextContrast} + + function GdipSetInterpolationMode(graphics: GPGRAPHICS; + interpolationMode: INTERPOLATIONMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetInterpolationMode} + + function GdipGetInterpolationMode(graphics: GPGRAPHICS; + var interpolationMode: INTERPOLATIONMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetInterpolationMode} + + function GdipSetWorldTransform(graphics: GPGRAPHICS; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetWorldTransform} + + function GdipResetWorldTransform(graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetWorldTransform} + + function GdipMultiplyWorldTransform(graphics: GPGRAPHICS; matrix: GPMATRIX; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMultiplyWorldTransform} + + function GdipTranslateWorldTransform(graphics: GPGRAPHICS; dx: Single; + dy: Single; order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslateWorldTransform} + + function GdipScaleWorldTransform(graphics: GPGRAPHICS; sx: Single; sy: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipScaleWorldTransform} + + function GdipRotateWorldTransform(graphics: GPGRAPHICS; angle: Single; + order: GPMATRIXORDER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRotateWorldTransform} + + function GdipGetWorldTransform(graphics: GPGRAPHICS; + matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetWorldTransform} + + function GdipResetPageTransform(graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetPageTransform} + + function GdipGetPageUnit(graphics: GPGRAPHICS; + var unit_: GPUNIT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPageUnit} + + function GdipGetPageScale(graphics: GPGRAPHICS; + var scale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPageScale} + + function GdipSetPageUnit(graphics: GPGRAPHICS; + unit_: GPUNIT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPageUnit} + + function GdipSetPageScale(graphics: GPGRAPHICS; + scale: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPageScale} + + function GdipGetDpiX(graphics: GPGRAPHICS; + var dpi: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetDpiX} + + function GdipGetDpiY(graphics: GPGRAPHICS; + var dpi: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetDpiY} + + function GdipTransformPoints(graphics: GPGRAPHICS; + destSpace: GPCOORDINATESPACE; srcSpace: GPCOORDINATESPACE; + points: GPPOINTF; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTransformPoints} + + function GdipTransformPointsI(graphics: GPGRAPHICS; + destSpace: GPCOORDINATESPACE; srcSpace: GPCOORDINATESPACE; + points: GPPOINT; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTransformPointsI} + + function GdipGetNearestColor(graphics: GPGRAPHICS; + argb: PARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetNearestColor} + +// Creates the Win9x Halftone Palette (even on NT) with correct Desktop colors + + function GdipCreateHalftonePalette: HPALETTE; stdcall; + {$EXTERNALSYM GdipCreateHalftonePalette} + + function GdipDrawLine(graphics: GPGRAPHICS; pen: GPPEN; x1: Single; + y1: Single; x2: Single; y2: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawLine} + + function GdipDrawLineI(graphics: GPGRAPHICS; pen: GPPEN; x1: Integer; + y1: Integer; x2: Integer; y2: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawLineI} + + function GdipDrawLines(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawLines} + + function GdipDrawLinesI(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawLinesI} + + function GdipDrawArc(graphics: GPGRAPHICS; pen: GPPEN; x: Single; y: Single; + width: Single; height: Single; startAngle: Single; + sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawArc} + + function GdipDrawArcI(graphics: GPGRAPHICS; pen: GPPEN; x: Integer; + y: Integer; width: Integer; height: Integer; startAngle: Single; + sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawArcI} + + function GdipDrawBezier(graphics: GPGRAPHICS; pen: GPPEN; x1: Single; + y1: Single; x2: Single; y2: Single; x3: Single; y3: Single; x4: Single; + y4: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawBezier} + + function GdipDrawBezierI(graphics: GPGRAPHICS; pen: GPPEN; x1: Integer; + y1: Integer; x2: Integer; y2: Integer; x3: Integer; y3: Integer; + x4: Integer; y4: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawBezierI} + + function GdipDrawBeziers(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawBeziers} + + function GdipDrawBeziersI(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawBeziersI} + + function GdipDrawRectangle(graphics: GPGRAPHICS; pen: GPPEN; x: Single; + y: Single; width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawRectangle} + + function GdipDrawRectangleI(graphics: GPGRAPHICS; pen: GPPEN; x: Integer; + y: Integer; width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawRectangleI} + + function GdipDrawRectangles(graphics: GPGRAPHICS; pen: GPPEN; rects: GPRECTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawRectangles} + + function GdipDrawRectanglesI(graphics: GPGRAPHICS; pen: GPPEN; rects: GPRECT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawRectanglesI} + + function GdipDrawEllipse(graphics: GPGRAPHICS; pen: GPPEN; x: Single; + y: Single; width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawEllipse} + + function GdipDrawEllipseI(graphics: GPGRAPHICS; pen: GPPEN; x: Integer; + y: Integer; width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawEllipseI} + + function GdipDrawPie(graphics: GPGRAPHICS; pen: GPPEN; x: Single; y: Single; + width: Single; height: Single; startAngle: Single; + sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawPie} + + function GdipDrawPieI(graphics: GPGRAPHICS; pen: GPPEN; x: Integer; + y: Integer; width: Integer; height: Integer; startAngle: Single; + sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawPieI} + + function GdipDrawPolygon(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawPolygon} + + function GdipDrawPolygonI(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawPolygonI} + + function GdipDrawPath(graphics: GPGRAPHICS; pen: GPPEN; + path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawPath} + + function GdipDrawCurve(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawCurve} + + function GdipDrawCurveI(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawCurveI} + + function GdipDrawCurve2(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINTF; + count: Integer; tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawCurve2} + + function GdipDrawCurve2I(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINT; + count: Integer; tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawCurve2I} + + function GdipDrawCurve3(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINTF; + count: Integer; offset: Integer; numberOfSegments: Integer; + tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawCurve3} + + function GdipDrawCurve3I(graphics: GPGRAPHICS; pen: GPPEN; points: GPPOINT; + count: Integer; offset: Integer; numberOfSegments: Integer; + tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawCurve3I} + + function GdipDrawClosedCurve(graphics: GPGRAPHICS; pen: GPPEN; + points: GPPOINTF; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawClosedCurve} + + function GdipDrawClosedCurveI(graphics: GPGRAPHICS; pen: GPPEN; + points: GPPOINT; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawClosedCurveI} + + function GdipDrawClosedCurve2(graphics: GPGRAPHICS; pen: GPPEN; + points: GPPOINTF; count: Integer; tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawClosedCurve2} + + function GdipDrawClosedCurve2I(graphics: GPGRAPHICS; pen: GPPEN; + points: GPPOINT; count: Integer; tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawClosedCurve2I} + + function GdipGraphicsClear(graphics: GPGRAPHICS; + color: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGraphicsClear} + + function GdipFillRectangle(graphics: GPGRAPHICS; brush: GPBRUSH; x: Single; + y: Single; width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillRectangle} + + function GdipFillRectangleI(graphics: GPGRAPHICS; brush: GPBRUSH; x: Integer; + y: Integer; width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillRectangleI} + + function GdipFillRectangles(graphics: GPGRAPHICS; brush: GPBRUSH; + rects: GPRECTF; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillRectangles} + + function GdipFillRectanglesI(graphics: GPGRAPHICS; brush: GPBRUSH; + rects: GPRECT; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillRectanglesI} + + function GdipFillPolygon(graphics: GPGRAPHICS; brush: GPBRUSH; + points: GPPOINTF; count: Integer; fillMode: GPFILLMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillPolygon} + + function GdipFillPolygonI(graphics: GPGRAPHICS; brush: GPBRUSH; + points: GPPOINT; count: Integer; fillMode: GPFILLMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillPolygonI} + + function GdipFillPolygon2(graphics: GPGRAPHICS; brush: GPBRUSH; + points: GPPOINTF; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillPolygon2} + + function GdipFillPolygon2I(graphics: GPGRAPHICS; brush: GPBRUSH; + points: GPPOINT; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillPolygon2I} + + function GdipFillEllipse(graphics: GPGRAPHICS; brush: GPBRUSH; x: Single; + y: Single; width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillEllipse} + + function GdipFillEllipseI(graphics: GPGRAPHICS; brush: GPBRUSH; x: Integer; + y: Integer; width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillEllipseI} + + function GdipFillPie(graphics: GPGRAPHICS; brush: GPBRUSH; x: Single; + y: Single; width: Single; height: Single; startAngle: Single; + sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillPie} + + function GdipFillPieI(graphics: GPGRAPHICS; brush: GPBRUSH; x: Integer; + y: Integer; width: Integer; height: Integer; startAngle: Single; + sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillPieI} + + function GdipFillPath(graphics: GPGRAPHICS; brush: GPBRUSH; + path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillPath} + + function GdipFillClosedCurve(graphics: GPGRAPHICS; brush: GPBRUSH; + points: GPPOINTF; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillClosedCurve} + + function GdipFillClosedCurveI(graphics: GPGRAPHICS; brush: GPBRUSH; + points: GPPOINT; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillClosedCurveI} + + function GdipFillClosedCurve2(graphics: GPGRAPHICS; brush: GPBRUSH; + points: GPPOINTF; count: Integer; tension: Single; + fillMode: GPFILLMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillClosedCurve2} + + function GdipFillClosedCurve2I(graphics: GPGRAPHICS; brush: GPBRUSH; + points: GPPOINT; count: Integer; tension: Single; + fillMode: GPFILLMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillClosedCurve2I} + + function GdipFillRegion(graphics: GPGRAPHICS; brush: GPBRUSH; + region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillRegion} + + function GdipDrawImage(graphics: GPGRAPHICS; image: GPIMAGE; x: Single; + y: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImage} + + function GdipDrawImageI(graphics: GPGRAPHICS; image: GPIMAGE; x: Integer; + y: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImageI} + + function GdipDrawImageRect(graphics: GPGRAPHICS; image: GPIMAGE; x: Single; + y: Single; width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImageRect} + + function GdipDrawImageRectI(graphics: GPGRAPHICS; image: GPIMAGE; x: Integer; + y: Integer; width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImageRectI} + + function GdipDrawImagePoints(graphics: GPGRAPHICS; image: GPIMAGE; + dstpoints: GPPOINTF; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImagePoints} + + function GdipDrawImagePointsI(graphics: GPGRAPHICS; image: GPIMAGE; + dstpoints: GPPOINT; count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImagePointsI} + + function GdipDrawImagePointRect(graphics: GPGRAPHICS; image: GPIMAGE; + x: Single; y: Single; srcx: Single; srcy: Single; srcwidth: Single; + srcheight: Single; srcUnit: GPUNIT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImagePointRect} + + function GdipDrawImagePointRectI(graphics: GPGRAPHICS; image: GPIMAGE; + x: Integer; y: Integer; srcx: Integer; srcy: Integer; srcwidth: Integer; + srcheight: Integer; srcUnit: GPUNIT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImagePointRectI} + + function GdipDrawImageRectRect(graphics: GPGRAPHICS; image: GPIMAGE; + dstx: Single; dsty: Single; dstwidth: Single; dstheight: Single; + srcx: Single; srcy: Single; srcwidth: Single; srcheight: Single; + srcUnit: GPUNIT; imageAttributes: GPIMAGEATTRIBUTES; + callback: DRAWIMAGEABORT; callbackData: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImageRectRect} + + function GdipDrawImageRectRectI(graphics: GPGRAPHICS; image: GPIMAGE; + dstx: Integer; dsty: Integer; dstwidth: Integer; dstheight: Integer; + srcx: Integer; srcy: Integer; srcwidth: Integer; srcheight: Integer; + srcUnit: GPUNIT; imageAttributes: GPIMAGEATTRIBUTES; + callback: DRAWIMAGEABORT; callbackData: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImageRectRectI} + + function GdipDrawImagePointsRect(graphics: GPGRAPHICS; image: GPIMAGE; + points: GPPOINTF; count: Integer; srcx: Single; srcy: Single; + srcwidth: Single; srcheight: Single; srcUnit: GPUNIT; + imageAttributes: GPIMAGEATTRIBUTES; callback: DRAWIMAGEABORT; + callbackData: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImagePointsRect} + + function GdipDrawImagePointsRectI(graphics: GPGRAPHICS; image: GPIMAGE; + points: GPPOINT; count: Integer; srcx: Integer; srcy: Integer; + srcwidth: Integer; srcheight: Integer; srcUnit: GPUNIT; + imageAttributes: GPIMAGEATTRIBUTES; callback: DRAWIMAGEABORT; + callbackData: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImagePointsRectI} + + function GdipEnumerateMetafileDestPoint(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destPoint: PGPPointF; callback: ENUMERATEMETAFILEPROC; + callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileDestPoint} + + function GdipEnumerateMetafileDestPointI(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destPoint: PGPPoint; callback: ENUMERATEMETAFILEPROC; + callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileDestPointI} + + function GdipEnumerateMetafileDestRect(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destRect: PGPRectF; callback: ENUMERATEMETAFILEPROC; + callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileDestRect} + + function GdipEnumerateMetafileDestRectI(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destRect: PGPRect; callback: ENUMERATEMETAFILEPROC; + callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileDestRectI} + + function GdipEnumerateMetafileDestPoints(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destPoints: PGPPointF; count: Integer; + callback: ENUMERATEMETAFILEPROC; callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileDestPoints} + + function GdipEnumerateMetafileDestPointsI(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destPoints: PGPPoint; count: Integer; + callback: ENUMERATEMETAFILEPROC; callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileDestPointsI} + + function GdipEnumerateMetafileSrcRectDestPoint(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destPoint: PGPPointF; srcRect: PGPRectF; srcUnit: TUNIT; + callback: ENUMERATEMETAFILEPROC; callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileSrcRectDestPoint} + + function GdipEnumerateMetafileSrcRectDestPointI(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destPoint: PGPPoint; srcRect: PGPRect; srcUnit: TUNIT; + callback: ENUMERATEMETAFILEPROC; callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileSrcRectDestPointI} + + function GdipEnumerateMetafileSrcRectDestRect(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destRect: PGPRectF; srcRect: PGPRectF; srcUnit: TUNIT; + callback: ENUMERATEMETAFILEPROC; callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileSrcRectDestRect} + + function GdipEnumerateMetafileSrcRectDestRectI(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destRect: PGPRect; srcRect: PGPRect; srcUnit: TUNIT; + callback: ENUMERATEMETAFILEPROC; callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileSrcRectDestRectI} + + function GdipEnumerateMetafileSrcRectDestPoints(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destPoints: PGPPointF; count: Integer; srcRect: PGPRectF; + srcUnit: TUNIT; callback: ENUMERATEMETAFILEPROC; callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileSrcRectDestPoints} + + function GdipEnumerateMetafileSrcRectDestPointsI(graphics: GPGRAPHICS; + metafile: GPMETAFILE; destPoints: PGPPoint; count: Integer; srcRect: PGPRect; + srcUnit: TUNIT; callback: ENUMERATEMETAFILEPROC; callbackData: Pointer; + imageAttributes: GPIMAGEATTRIBUTES): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEnumerateMetafileSrcRectDestPointsI} + + function GdipPlayMetafileRecord(metafile: GPMETAFILE; + recordType: EMFPLUSRECORDTYPE; flags: UINT; dataSize: UINT; + data: PBYTE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPlayMetafileRecord} + + function GdipSetClipGraphics(graphics: GPGRAPHICS; srcgraphics: GPGRAPHICS; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetClipGraphics} + + function GdipSetClipRect(graphics: GPGRAPHICS; x: Single; y: Single; + width: Single; height: Single; combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetClipRect} + + function GdipSetClipRectI(graphics: GPGRAPHICS; x: Integer; y: Integer; + width: Integer; height: Integer; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetClipRectI} + + function GdipSetClipPath(graphics: GPGRAPHICS; path: GPPATH; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetClipPath} + + function GdipSetClipRegion(graphics: GPGRAPHICS; region: GPREGION; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetClipRegion} + + function GdipSetClipHrgn(graphics: GPGRAPHICS; hRgn: HRGN; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetClipHrgn} + + function GdipResetClip(graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetClip} + + function GdipTranslateClip(graphics: GPGRAPHICS; dx: Single; + dy: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslateClip} + + function GdipTranslateClipI(graphics: GPGRAPHICS; dx: Integer; + dy: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipTranslateClipI} + + function GdipGetClip(graphics: GPGRAPHICS; + region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetClip} + + function GdipGetClipBounds(graphics: GPGRAPHICS; + rect: GPRECTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetClipBounds} + + function GdipGetClipBoundsI(graphics: GPGRAPHICS; + rect: GPRECT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetClipBoundsI} + + function GdipIsClipEmpty(graphics: GPGRAPHICS; + result: PBool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsClipEmpty} + + function GdipGetVisibleClipBounds(graphics: GPGRAPHICS; + rect: GPRECTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetVisibleClipBounds} + + function GdipGetVisibleClipBoundsI(graphics: GPGRAPHICS; + rect: GPRECT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetVisibleClipBoundsI} + + function GdipIsVisibleClipEmpty(graphics: GPGRAPHICS; + var result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisibleClipEmpty} + + function GdipIsVisiblePoint(graphics: GPGRAPHICS; x: Single; y: Single; + var result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisiblePoint} + + function GdipIsVisiblePointI(graphics: GPGRAPHICS; x: Integer; y: Integer; + var result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisiblePointI} + + function GdipIsVisibleRect(graphics: GPGRAPHICS; x: Single; y: Single; + width: Single; height: Single; var result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisibleRect} + + function GdipIsVisibleRectI(graphics: GPGRAPHICS; x: Integer; y: Integer; + width: Integer; height: Integer; var result: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsVisibleRectI} + + function GdipSaveGraphics(graphics: GPGRAPHICS; + var state: GRAPHICSSTATE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSaveGraphics} + + function GdipRestoreGraphics(graphics: GPGRAPHICS; + state: GRAPHICSSTATE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRestoreGraphics} + + function GdipBeginContainer(graphics: GPGRAPHICS; dstrect: GPRECTF; + srcrect: GPRECTF; unit_: GPUNIT; + var state: GRAPHICSCONTAINER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBeginContainer} + + function GdipBeginContainerI(graphics: GPGRAPHICS; dstrect: GPRECT; + srcrect: GPRECT; unit_: GPUNIT; + var state: GRAPHICSCONTAINER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBeginContainerI} + + function GdipBeginContainer2(graphics: GPGRAPHICS; + var state: GRAPHICSCONTAINER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBeginContainer2} + + function GdipEndContainer(graphics: GPGRAPHICS; + state: GRAPHICSCONTAINER): GPSTATUS; stdcall; + {$EXTERNALSYM GdipEndContainer} + + function GdipGetMetafileHeaderFromWmf(hWmf: HMETAFILE; + wmfPlaceableFileHeader: PWMFPLACEABLEFILEHEADER; + header: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetMetafileHeaderFromWmf} + + function GdipGetMetafileHeaderFromEmf(hEmf: HENHMETAFILE; + header: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetMetafileHeaderFromEmf} + + function GdipGetMetafileHeaderFromFile(filename: PWCHAR; + header: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetMetafileHeaderFromFile} + + function GdipGetMetafileHeaderFromStream(stream: ISTREAM; + header: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetMetafileHeaderFromStream} + + function GdipGetMetafileHeaderFromMetafile(metafile: GPMETAFILE; + header: Pointer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetMetafileHeaderFromMetafile} + + function GdipGetHemfFromMetafile(metafile: GPMETAFILE; + var hEmf: HENHMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetHemfFromMetafile} + + function GdipCreateStreamOnFile(filename: PWCHAR; access: UINT; + out stream: ISTREAM): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateStreamOnFile} + + function GdipCreateMetafileFromWmf(hWmf: HMETAFILE; deleteWmf: Bool; + wmfPlaceableFileHeader: PWMFPLACEABLEFILEHEADER; + out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMetafileFromWmf} + + function GdipCreateMetafileFromEmf(hEmf: HENHMETAFILE; deleteEmf: Bool; + out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMetafileFromEmf} + + function GdipCreateMetafileFromFile(file_: PWCHAR; + out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMetafileFromFile} + + function GdipCreateMetafileFromWmfFile(file_: PWCHAR; + wmfPlaceableFileHeader: PWMFPLACEABLEFILEHEADER; + out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMetafileFromWmfFile} + + function GdipCreateMetafileFromStream(stream: ISTREAM; + out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateMetafileFromStream} + + function GdipRecordMetafile(referenceHdc: HDC; type_: EMFTYPE; + frameRect: GPRECTF; frameUnit: METAFILEFRAMEUNIT; + description: PWCHAR; out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRecordMetafile} + + function GdipRecordMetafileI(referenceHdc: HDC; type_: EMFTYPE; + frameRect: GPRECT; frameUnit: METAFILEFRAMEUNIT; description: PWCHAR; + out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRecordMetafileI} + + function GdipRecordMetafileFileName(fileName: PWCHAR; referenceHdc: HDC; + type_: EMFTYPE; frameRect: GPRECTF; frameUnit: METAFILEFRAMEUNIT; + description: PWCHAR; out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRecordMetafileFileName} + + function GdipRecordMetafileFileNameI(fileName: PWCHAR; referenceHdc: HDC; + type_: EMFTYPE; frameRect: GPRECT; frameUnit: METAFILEFRAMEUNIT; + description: PWCHAR; out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRecordMetafileFileNameI} + + function GdipRecordMetafileStream(stream: ISTREAM; referenceHdc: HDC; + type_: EMFTYPE; frameRect: GPRECTF; frameUnit: METAFILEFRAMEUNIT; + description: PWCHAR; out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRecordMetafileStream} + + function GdipRecordMetafileStreamI(stream: ISTREAM; referenceHdc: HDC; + type_: EMFTYPE; frameRect: GPRECT; frameUnit: METAFILEFRAMEUNIT; + description: PWCHAR; out metafile: GPMETAFILE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipRecordMetafileStreamI} + + function GdipSetMetafileDownLevelRasterizationLimit(metafile: GPMETAFILE; + metafileRasterizationLimitDpi: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetMetafileDownLevelRasterizationLimit} + + function GdipGetMetafileDownLevelRasterizationLimit(metafile: GPMETAFILE; + var metafileRasterizationLimitDpi: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetMetafileDownLevelRasterizationLimit} + + function GdipGetImageDecodersSize(out numDecoders: UINT; + out size: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageDecodersSize} + + function GdipGetImageDecoders(numDecoders: UINT; size: UINT; + decoders: PIMAGECODECINFO): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageDecoders} + + function GdipGetImageEncodersSize(out numEncoders: UINT; + out size: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageEncodersSize} + + function GdipGetImageEncoders(numEncoders: UINT; size: UINT; + encoders: PIMAGECODECINFO): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageEncoders} + + function GdipComment(graphics: GPGRAPHICS; sizeData: UINT; + data: PBYTE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipComment} + +//---------------------------------------------------------------------------- +// FontFamily APIs +//---------------------------------------------------------------------------- + + function GdipCreateFontFamilyFromName(name: PWCHAR; + fontCollection: GPFONTCOLLECTION; + out FontFamily: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFontFamilyFromName} + + function GdipDeleteFontFamily(FontFamily: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteFontFamily} + + function GdipCloneFontFamily(FontFamily: GPFONTFAMILY; + out clonedFontFamily: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneFontFamily} + + function GdipGetGenericFontFamilySansSerif( + out nativeFamily: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetGenericFontFamilySansSerif} + + function GdipGetGenericFontFamilySerif( + out nativeFamily: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetGenericFontFamilySerif} + + function GdipGetGenericFontFamilyMonospace( + out nativeFamily: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetGenericFontFamilyMonospace} + + function GdipGetFamilyName(family: GPFONTFAMILY; name: PWideChar; + language: LANGID): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFamilyName} + + function GdipIsStyleAvailable(family: GPFONTFAMILY; style: Integer; + var IsStyleAvailable: Bool): GPSTATUS; stdcall; + {$EXTERNALSYM GdipIsStyleAvailable} + + function GdipFontCollectionEnumerable(fontCollection: GPFONTCOLLECTION; + graphics: GPGRAPHICS; var numFound: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFontCollectionEnumerable} + + function GdipFontCollectionEnumerate(fontCollection: GPFONTCOLLECTION; + numSought: Integer; gpfamilies: array of GPFONTFAMILY; + var numFound: Integer; graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFontCollectionEnumerate} + + function GdipGetEmHeight(family: GPFONTFAMILY; style: Integer; + out EmHeight: UINT16): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetEmHeight} + + function GdipGetCellAscent(family: GPFONTFAMILY; style: Integer; + var CellAscent: UINT16): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCellAscent} + + function GdipGetCellDescent(family: GPFONTFAMILY; style: Integer; + var CellDescent: UINT16): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCellDescent} + + function GdipGetLineSpacing(family: GPFONTFAMILY; style: Integer; + var LineSpacing: UINT16): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLineSpacing} + +//---------------------------------------------------------------------------- +// Font APIs +//---------------------------------------------------------------------------- + + function GdipCreateFontFromDC(hdc: HDC; out font: GPFONT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFontFromDC} + + function GdipCreateFontFromLogfontA(hdc: HDC; logfont: PLOGFONTA; + out font: GPFONT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFontFromLogfontA} + + function GdipCreateFontFromLogfontW(hdc: HDC; logfont: PLOGFONTW; + out font: GPFONT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFontFromLogfontW} + + function GdipCreateFont(fontFamily: GPFONTFAMILY; emSize: Single; + style: Integer; unit_: Integer; out font: GPFONT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFont} + + function GdipCloneFont(font: GPFONT; + out cloneFont: GPFONT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneFont} + + function GdipDeleteFont(font: GPFONT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteFont} + + function GdipGetFamily(font: GPFONT; + out family: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFamily} + + function GdipGetFontStyle(font: GPFONT; + var style: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFontStyle} + + function GdipGetFontSize(font: GPFONT; var size: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFontSize} + + function GdipGetFontUnit(font: GPFONT; var unit_: TUNIT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFontUnit} + + function GdipGetFontHeight(font: GPFONT; graphics: GPGRAPHICS; + var height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFontHeight} + + function GdipGetFontHeightGivenDPI(font: GPFONT; dpi: Single; + var height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFontHeightGivenDPI} + + function GdipGetLogFontA(font: GPFONT; graphics: GPGRAPHICS; + var logfontA: LOGFONTA): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLogFontA} + + function GdipGetLogFontW(font: GPFONT; graphics: GPGRAPHICS; + var logfontW: LOGFONTW): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetLogFontW} + + function GdipNewInstalledFontCollection( + out fontCollection: GPFONTCOLLECTION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipNewInstalledFontCollection} + + function GdipNewPrivateFontCollection( + out fontCollection: GPFONTCOLLECTION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipNewPrivateFontCollection} + + function GdipDeletePrivateFontCollection( + out fontCollection: GPFONTCOLLECTION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeletePrivateFontCollection} + + function GdipGetFontCollectionFamilyCount(fontCollection: GPFONTCOLLECTION; + var numFound: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFontCollectionFamilyCount} + + function GdipGetFontCollectionFamilyList(fontCollection: GPFONTCOLLECTION; + numSought: Integer; gpfamilies: GPFONTFAMILY; + var numFound: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetFontCollectionFamilyList} + + function GdipPrivateAddFontFile(fontCollection: GPFONTCOLLECTION; + filename: PWCHAR): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPrivateAddFontFile} + + function GdipPrivateAddMemoryFont(fontCollection: GPFONTCOLLECTION; + memory: Pointer; length: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipPrivateAddMemoryFont} + +//---------------------------------------------------------------------------- +// Text APIs +//---------------------------------------------------------------------------- + + function GdipDrawString(graphics: GPGRAPHICS; string_: PWCHAR; + length: Integer; font: GPFONT; layoutRect: PGPRectF; + stringFormat: GPSTRINGFORMAT; brush: GPBRUSH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawString} + + function GdipMeasureString(graphics: GPGRAPHICS; string_: PWCHAR; + length: Integer; font: GPFONT; layoutRect: PGPRectF; + stringFormat: GPSTRINGFORMAT; boundingBox: PGPRectF; + codepointsFitted: PInteger; linesFilled: PInteger): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMeasureString} + + function GdipMeasureCharacterRanges(graphics: GPGRAPHICS; string_: PWCHAR; + length: Integer; font: GPFONT; layoutRect: PGPRectF; + stringFormat: GPSTRINGFORMAT; regionCount: Integer; + const regions: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMeasureCharacterRanges} + + function GdipDrawDriverString(graphics: GPGRAPHICS; const text: PUINT16; + length: Integer; const font: GPFONT; const brush: GPBRUSH; + const positions: PGPPointF; flags: Integer; + const matrix: GPMATRIX): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawDriverString} + + function GdipMeasureDriverString(graphics: GPGRAPHICS; text: PUINT16; + length: Integer; font: GPFONT; positions: PGPPointF; flags: Integer; + matrix: GPMATRIX; boundingBox: PGPRectF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMeasureDriverString} + +//---------------------------------------------------------------------------- +// String format APIs +//---------------------------------------------------------------------------- + + function GdipCreateStringFormat(formatAttributes: Integer; language: LANGID; + out format: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateStringFormat} + + function GdipStringFormatGetGenericDefault( + out format: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipStringFormatGetGenericDefault} + + function GdipStringFormatGetGenericTypographic( + out format: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipStringFormatGetGenericTypographic} + + function GdipDeleteStringFormat(format: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteStringFormat} + + function GdipCloneStringFormat(format: GPSTRINGFORMAT; + out newFormat: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneStringFormat} + + function GdipSetStringFormatFlags(format: GPSTRINGFORMAT; + flags: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatFlags} + + function GdipGetStringFormatFlags(format: GPSTRINGFORMAT; + out flags: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatFlags} + + function GdipSetStringFormatAlign(format: GPSTRINGFORMAT; + align: STRINGALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatAlign} + + function GdipGetStringFormatAlign(format: GPSTRINGFORMAT; + out align: STRINGALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatAlign} + + function GdipSetStringFormatLineAlign(format: GPSTRINGFORMAT; + align: STRINGALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatLineAlign} + + function GdipGetStringFormatLineAlign(format: GPSTRINGFORMAT; + out align: STRINGALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatLineAlign} + + function GdipSetStringFormatTrimming(format: GPSTRINGFORMAT; + trimming: STRINGTRIMMING): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatTrimming} + + function GdipGetStringFormatTrimming(format: GPSTRINGFORMAT; + out trimming: STRINGTRIMMING): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatTrimming} + + function GdipSetStringFormatHotkeyPrefix(format: GPSTRINGFORMAT; + hotkeyPrefix: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatHotkeyPrefix} + + function GdipGetStringFormatHotkeyPrefix(format: GPSTRINGFORMAT; + out hotkeyPrefix: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatHotkeyPrefix} + + function GdipSetStringFormatTabStops(format: GPSTRINGFORMAT; + firstTabOffset: Single; count: Integer; + tabStops: PSingle): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatTabStops} + + function GdipGetStringFormatTabStops(format: GPSTRINGFORMAT; + count: Integer; firstTabOffset: PSingle; + tabStops: PSingle): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatTabStops} + + function GdipGetStringFormatTabStopCount(format: GPSTRINGFORMAT; + out count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatTabStopCount} + + function GdipSetStringFormatDigitSubstitution(format: GPSTRINGFORMAT; + language: LANGID; + substitute: STRINGDIGITSUBSTITUTE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatDigitSubstitution} + + function GdipGetStringFormatDigitSubstitution(format: GPSTRINGFORMAT; + language: PUINT; substitute: PSTRINGDIGITSUBSTITUTE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatDigitSubstitution} + + function GdipGetStringFormatMeasurableCharacterRangeCount(format: GPSTRINGFORMAT; + out count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatMeasurableCharacterRangeCount} + + function GdipSetStringFormatMeasurableCharacterRanges(format: GPSTRINGFORMAT; + rangeCount: Integer; ranges: PCHARACTERRANGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatMeasurableCharacterRanges} + +//---------------------------------------------------------------------------- +// Cached Bitmap APIs +//---------------------------------------------------------------------------- + + function GdipCreateCachedBitmap(bitmap: GPBITMAP; graphics: GPGRAPHICS; + out cachedBitmap: GPCACHEDBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateCachedBitmap} + + function GdipDeleteCachedBitmap( + cachedBitmap: GPCACHEDBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteCachedBitmap} + + function GdipDrawCachedBitmap(graphics: GPGRAPHICS; + cachedBitmap: GPCACHEDBITMAP; x: Integer; + y: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawCachedBitmap} + + function GdipEmfToWmfBits(hemf: HENHMETAFILE; cbData16: UINT; pData16: PBYTE; + iMapMode: Integer; eFlags: Integer): UINT; stdcall; + {$EXTERNALSYM GdipEmfToWmfBits} + +implementation + +uses + System.SysUtils; + + function GdipAlloc; external WINGDIPDLL name 'GdipAlloc'; + procedure GdipFree; external WINGDIPDLL name 'GdipFree'; + function GdiplusStartup; external WINGDIPDLL name 'GdiplusStartup'; + procedure GdiplusShutdown; external WINGDIPDLL name 'GdiplusShutdown'; + + function GdipCreatePath; external WINGDIPDLL name 'GdipCreatePath'; + function GdipCreatePath2; external WINGDIPDLL name 'GdipCreatePath2'; + function GdipCreatePath2I; external WINGDIPDLL name 'GdipCreatePath2I'; + function GdipClonePath; external WINGDIPDLL name 'GdipClonePath'; + function GdipDeletePath; external WINGDIPDLL name 'GdipDeletePath'; + function GdipResetPath; external WINGDIPDLL name 'GdipResetPath'; + function GdipGetPointCount; external WINGDIPDLL name 'GdipGetPointCount'; + function GdipGetPathTypes; external WINGDIPDLL name 'GdipGetPathTypes'; + function GdipGetPathPoints; external WINGDIPDLL name 'GdipGetPathPoints'; + function GdipGetPathPointsI; external WINGDIPDLL name 'GdipGetPathPointsI'; + function GdipGetPathFillMode; external WINGDIPDLL name 'GdipGetPathFillMode'; + function GdipSetPathFillMode; external WINGDIPDLL name 'GdipSetPathFillMode'; + function GdipGetPathData; external WINGDIPDLL name 'GdipGetPathData'; + function GdipStartPathFigure; external WINGDIPDLL name 'GdipStartPathFigure'; + function GdipClosePathFigure; external WINGDIPDLL name 'GdipClosePathFigure'; + function GdipClosePathFigures; external WINGDIPDLL name 'GdipClosePathFigures'; + function GdipSetPathMarker; external WINGDIPDLL name 'GdipSetPathMarker'; + function GdipClearPathMarkers; external WINGDIPDLL name 'GdipClearPathMarkers'; + function GdipReversePath; external WINGDIPDLL name 'GdipReversePath'; + function GdipGetPathLastPoint; external WINGDIPDLL name 'GdipGetPathLastPoint'; + function GdipAddPathLine; external WINGDIPDLL name 'GdipAddPathLine'; + function GdipAddPathLine2; external WINGDIPDLL name 'GdipAddPathLine2'; + function GdipAddPathArc; external WINGDIPDLL name 'GdipAddPathArc'; + function GdipAddPathBezier; external WINGDIPDLL name 'GdipAddPathBezier'; + function GdipAddPathBeziers; external WINGDIPDLL name 'GdipAddPathBeziers'; + function GdipAddPathCurve; external WINGDIPDLL name 'GdipAddPathCurve'; + function GdipAddPathCurve2; external WINGDIPDLL name 'GdipAddPathCurve2'; + function GdipAddPathCurve3; external WINGDIPDLL name 'GdipAddPathCurve3'; + function GdipAddPathClosedCurve; external WINGDIPDLL name 'GdipAddPathClosedCurve'; + function GdipAddPathClosedCurve2; external WINGDIPDLL name 'GdipAddPathClosedCurve2'; + function GdipAddPathRectangle; external WINGDIPDLL name 'GdipAddPathRectangle'; + function GdipAddPathRectangles; external WINGDIPDLL name 'GdipAddPathRectangles'; + function GdipAddPathEllipse; external WINGDIPDLL name 'GdipAddPathEllipse'; + function GdipAddPathPie; external WINGDIPDLL name 'GdipAddPathPie'; + function GdipAddPathPolygon; external WINGDIPDLL name 'GdipAddPathPolygon'; + function GdipAddPathPath; external WINGDIPDLL name 'GdipAddPathPath'; + function GdipAddPathString; external WINGDIPDLL name 'GdipAddPathString'; + function GdipAddPathStringI; external WINGDIPDLL name 'GdipAddPathStringI'; + function GdipAddPathLineI; external WINGDIPDLL name 'GdipAddPathLineI'; + function GdipAddPathLine2I; external WINGDIPDLL name 'GdipAddPathLine2I'; + function GdipAddPathArcI; external WINGDIPDLL name 'GdipAddPathArcI'; + function GdipAddPathBezierI; external WINGDIPDLL name 'GdipAddPathBezierI'; + function GdipAddPathBeziersI; external WINGDIPDLL name 'GdipAddPathBeziersI'; + function GdipAddPathCurveI; external WINGDIPDLL name 'GdipAddPathCurveI'; + function GdipAddPathCurve2I; external WINGDIPDLL name 'GdipAddPathCurve2I'; + function GdipAddPathCurve3I; external WINGDIPDLL name 'GdipAddPathCurve3I'; + function GdipAddPathClosedCurveI; external WINGDIPDLL name 'GdipAddPathClosedCurveI'; + function GdipAddPathClosedCurve2I; external WINGDIPDLL name 'GdipAddPathClosedCurve2I'; + function GdipAddPathRectangleI; external WINGDIPDLL name 'GdipAddPathRectangleI'; + function GdipAddPathRectanglesI; external WINGDIPDLL name 'GdipAddPathRectanglesI'; + function GdipAddPathEllipseI; external WINGDIPDLL name 'GdipAddPathEllipseI'; + function GdipAddPathPieI; external WINGDIPDLL name 'GdipAddPathPieI'; + function GdipAddPathPolygonI; external WINGDIPDLL name 'GdipAddPathPolygonI'; + function GdipFlattenPath; external WINGDIPDLL name 'GdipFlattenPath'; + function GdipWindingModeOutline; external WINGDIPDLL name 'GdipWindingModeOutline'; + function GdipWidenPath; external WINGDIPDLL name 'GdipWidenPath'; + function GdipWarpPath; external WINGDIPDLL name 'GdipWarpPath'; + function GdipTransformPath; external WINGDIPDLL name 'GdipTransformPath'; + function GdipGetPathWorldBounds; external WINGDIPDLL name 'GdipGetPathWorldBounds'; + function GdipGetPathWorldBoundsI; external WINGDIPDLL name 'GdipGetPathWorldBoundsI'; + function GdipIsVisiblePathPoint; external WINGDIPDLL name 'GdipIsVisiblePathPoint'; + function GdipIsVisiblePathPointI; external WINGDIPDLL name 'GdipIsVisiblePathPointI'; + function GdipIsOutlineVisiblePathPoint; external WINGDIPDLL name 'GdipIsOutlineVisiblePathPoint'; + function GdipIsOutlineVisiblePathPointI; external WINGDIPDLL name 'GdipIsOutlineVisiblePathPointI'; + function GdipCreatePathIter; external WINGDIPDLL name 'GdipCreatePathIter'; + function GdipDeletePathIter; external WINGDIPDLL name 'GdipDeletePathIter'; + function GdipPathIterNextSubpath; external WINGDIPDLL name 'GdipPathIterNextSubpath'; + function GdipPathIterNextSubpathPath; external WINGDIPDLL name 'GdipPathIterNextSubpathPath'; + function GdipPathIterNextPathType; external WINGDIPDLL name 'GdipPathIterNextPathType'; + function GdipPathIterNextMarker; external WINGDIPDLL name 'GdipPathIterNextMarker'; + function GdipPathIterNextMarkerPath; external WINGDIPDLL name 'GdipPathIterNextMarkerPath'; + function GdipPathIterGetCount; external WINGDIPDLL name 'GdipPathIterGetCount'; + function GdipPathIterGetSubpathCount; external WINGDIPDLL name 'GdipPathIterGetSubpathCount'; + function GdipPathIterIsValid; external WINGDIPDLL name 'GdipPathIterIsValid'; + function GdipPathIterHasCurve; external WINGDIPDLL name 'GdipPathIterHasCurve'; + function GdipPathIterRewind; external WINGDIPDLL name 'GdipPathIterRewind'; + function GdipPathIterEnumerate; external WINGDIPDLL name 'GdipPathIterEnumerate'; + function GdipPathIterCopyData; external WINGDIPDLL name 'GdipPathIterCopyData'; + function GdipCreateMatrix; external WINGDIPDLL name 'GdipCreateMatrix'; + function GdipCreateMatrix2; external WINGDIPDLL name 'GdipCreateMatrix2'; + function GdipCreateMatrix3; external WINGDIPDLL name 'GdipCreateMatrix3'; + function GdipCreateMatrix3I; external WINGDIPDLL name 'GdipCreateMatrix3I'; + function GdipCloneMatrix; external WINGDIPDLL name 'GdipCloneMatrix'; + function GdipDeleteMatrix; external WINGDIPDLL name 'GdipDeleteMatrix'; + function GdipSetMatrixElements; external WINGDIPDLL name 'GdipSetMatrixElements'; + function GdipMultiplyMatrix; external WINGDIPDLL name 'GdipMultiplyMatrix'; + function GdipTranslateMatrix; external WINGDIPDLL name 'GdipTranslateMatrix'; + function GdipScaleMatrix; external WINGDIPDLL name 'GdipScaleMatrix'; + function GdipRotateMatrix; external WINGDIPDLL name 'GdipRotateMatrix'; + function GdipShearMatrix; external WINGDIPDLL name 'GdipShearMatrix'; + function GdipInvertMatrix; external WINGDIPDLL name 'GdipInvertMatrix'; + function GdipTransformMatrixPoints; external WINGDIPDLL name 'GdipTransformMatrixPoints'; + function GdipTransformMatrixPointsI; external WINGDIPDLL name 'GdipTransformMatrixPointsI'; + function GdipVectorTransformMatrixPoints; external WINGDIPDLL name 'GdipVectorTransformMatrixPoints'; + function GdipVectorTransformMatrixPointsI; external WINGDIPDLL name 'GdipVectorTransformMatrixPointsI'; + function GdipGetMatrixElements; external WINGDIPDLL name 'GdipGetMatrixElements'; + function GdipIsMatrixInvertible; external WINGDIPDLL name 'GdipIsMatrixInvertible'; + function GdipIsMatrixIdentity; external WINGDIPDLL name 'GdipIsMatrixIdentity'; + function GdipIsMatrixEqual; external WINGDIPDLL name 'GdipIsMatrixEqual'; + function GdipCreateRegion; external WINGDIPDLL name 'GdipCreateRegion'; + function GdipCreateRegionRect; external WINGDIPDLL name 'GdipCreateRegionRect'; + function GdipCreateRegionRectI; external WINGDIPDLL name 'GdipCreateRegionRectI'; + function GdipCreateRegionPath; external WINGDIPDLL name 'GdipCreateRegionPath'; + function GdipCreateRegionRgnData; external WINGDIPDLL name 'GdipCreateRegionRgnData'; + function GdipCreateRegionHrgn; external WINGDIPDLL name 'GdipCreateRegionHrgn'; + function GdipCloneRegion; external WINGDIPDLL name 'GdipCloneRegion'; + function GdipDeleteRegion; external WINGDIPDLL name 'GdipDeleteRegion'; + function GdipSetInfinite; external WINGDIPDLL name 'GdipSetInfinite'; + function GdipSetEmpty; external WINGDIPDLL name 'GdipSetEmpty'; + function GdipCombineRegionRect; external WINGDIPDLL name 'GdipCombineRegionRect'; + function GdipCombineRegionRectI; external WINGDIPDLL name 'GdipCombineRegionRectI'; + function GdipCombineRegionPath; external WINGDIPDLL name 'GdipCombineRegionPath'; + function GdipCombineRegionRegion; external WINGDIPDLL name 'GdipCombineRegionRegion'; + function GdipTranslateRegion; external WINGDIPDLL name 'GdipTranslateRegion'; + function GdipTranslateRegionI; external WINGDIPDLL name 'GdipTranslateRegionI'; + function GdipTransformRegion; external WINGDIPDLL name 'GdipTransformRegion'; + function GdipGetRegionBounds; external WINGDIPDLL name 'GdipGetRegionBounds'; + function GdipGetRegionBoundsI; external WINGDIPDLL name 'GdipGetRegionBoundsI'; + function GdipGetRegionHRgn; external WINGDIPDLL name 'GdipGetRegionHRgn'; + function GdipIsEmptyRegion; external WINGDIPDLL name 'GdipIsEmptyRegion'; + function GdipIsInfiniteRegion; external WINGDIPDLL name 'GdipIsInfiniteRegion'; + function GdipIsEqualRegion; external WINGDIPDLL name 'GdipIsEqualRegion'; + function GdipGetRegionDataSize; external WINGDIPDLL name 'GdipGetRegionDataSize'; + function GdipGetRegionData; external WINGDIPDLL name 'GdipGetRegionData'; + function GdipIsVisibleRegionPoint; external WINGDIPDLL name 'GdipIsVisibleRegionPoint'; + function GdipIsVisibleRegionPointI; external WINGDIPDLL name 'GdipIsVisibleRegionPointI'; + function GdipIsVisibleRegionRect; external WINGDIPDLL name 'GdipIsVisibleRegionRect'; + function GdipIsVisibleRegionRectI; external WINGDIPDLL name 'GdipIsVisibleRegionRectI'; + function GdipGetRegionScansCount; external WINGDIPDLL name 'GdipGetRegionScansCount'; + function GdipGetRegionScans; external WINGDIPDLL name 'GdipGetRegionScans'; + function GdipGetRegionScansI; external WINGDIPDLL name 'GdipGetRegionScansI'; + function GdipCloneBrush; external WINGDIPDLL name 'GdipCloneBrush'; + function GdipDeleteBrush; external WINGDIPDLL name 'GdipDeleteBrush'; + function GdipGetBrushType; external WINGDIPDLL name 'GdipGetBrushType'; + function GdipCreateHatchBrush; external WINGDIPDLL name 'GdipCreateHatchBrush'; + function GdipGetHatchStyle; external WINGDIPDLL name 'GdipGetHatchStyle'; + function GdipGetHatchForegroundColor; external WINGDIPDLL name 'GdipGetHatchForegroundColor'; + function GdipGetHatchBackgroundColor; external WINGDIPDLL name 'GdipGetHatchBackgroundColor'; + function GdipCreateTexture; external WINGDIPDLL name 'GdipCreateTexture'; + function GdipCreateTexture2; external WINGDIPDLL name 'GdipCreateTexture2'; + function GdipCreateTextureIA; external WINGDIPDLL name 'GdipCreateTextureIA'; + function GdipCreateTexture2I; external WINGDIPDLL name 'GdipCreateTexture2I'; + function GdipCreateTextureIAI; external WINGDIPDLL name 'GdipCreateTextureIAI'; + function GdipGetTextureTransform; external WINGDIPDLL name 'GdipGetTextureTransform'; + function GdipSetTextureTransform; external WINGDIPDLL name 'GdipSetTextureTransform'; + function GdipResetTextureTransform; external WINGDIPDLL name 'GdipResetTextureTransform'; + function GdipMultiplyTextureTransform; external WINGDIPDLL name 'GdipMultiplyTextureTransform'; + function GdipTranslateTextureTransform; external WINGDIPDLL name 'GdipTranslateTextureTransform'; + function GdipScaleTextureTransform; external WINGDIPDLL name 'GdipScaleTextureTransform'; + function GdipRotateTextureTransform; external WINGDIPDLL name 'GdipRotateTextureTransform'; + function GdipSetTextureWrapMode; external WINGDIPDLL name 'GdipSetTextureWrapMode'; + function GdipGetTextureWrapMode; external WINGDIPDLL name 'GdipGetTextureWrapMode'; + function GdipGetTextureImage; external WINGDIPDLL name 'GdipGetTextureImage'; + function GdipCreateSolidFill; external WINGDIPDLL name 'GdipCreateSolidFill'; + function GdipSetSolidFillColor; external WINGDIPDLL name 'GdipSetSolidFillColor'; + function GdipGetSolidFillColor; external WINGDIPDLL name 'GdipGetSolidFillColor'; + function GdipCreateLineBrush; external WINGDIPDLL name 'GdipCreateLineBrush'; + function GdipCreateLineBrushI; external WINGDIPDLL name 'GdipCreateLineBrushI'; + function GdipCreateLineBrushFromRect; external WINGDIPDLL name 'GdipCreateLineBrushFromRect'; + function GdipCreateLineBrushFromRectI; external WINGDIPDLL name 'GdipCreateLineBrushFromRectI'; + function GdipCreateLineBrushFromRectWithAngle; external WINGDIPDLL name 'GdipCreateLineBrushFromRectWithAngle'; + function GdipCreateLineBrushFromRectWithAngleI; external WINGDIPDLL name 'GdipCreateLineBrushFromRectWithAngleI'; + function GdipSetLineColors; external WINGDIPDLL name 'GdipSetLineColors'; + function GdipGetLineColors; external WINGDIPDLL name 'GdipGetLineColors'; + function GdipGetLineRect; external WINGDIPDLL name 'GdipGetLineRect'; + function GdipGetLineRectI; external WINGDIPDLL name 'GdipGetLineRectI'; + function GdipSetLineGammaCorrection; external WINGDIPDLL name 'GdipSetLineGammaCorrection'; + function GdipGetLineGammaCorrection; external WINGDIPDLL name 'GdipGetLineGammaCorrection'; + function GdipGetLineBlendCount; external WINGDIPDLL name 'GdipGetLineBlendCount'; + function GdipGetLineBlend; external WINGDIPDLL name 'GdipGetLineBlend'; + function GdipSetLineBlend; external WINGDIPDLL name 'GdipSetLineBlend'; + function GdipGetLinePresetBlendCount; external WINGDIPDLL name 'GdipGetLinePresetBlendCount'; + function GdipGetLinePresetBlend; external WINGDIPDLL name 'GdipGetLinePresetBlend'; + function GdipSetLinePresetBlend; external WINGDIPDLL name 'GdipSetLinePresetBlend'; + function GdipSetLineSigmaBlend; external WINGDIPDLL name 'GdipSetLineSigmaBlend'; + function GdipSetLineLinearBlend; external WINGDIPDLL name 'GdipSetLineLinearBlend'; + function GdipSetLineWrapMode; external WINGDIPDLL name 'GdipSetLineWrapMode'; + function GdipGetLineWrapMode; external WINGDIPDLL name 'GdipGetLineWrapMode'; + function GdipGetLineTransform; external WINGDIPDLL name 'GdipGetLineTransform'; + function GdipSetLineTransform; external WINGDIPDLL name 'GdipSetLineTransform'; + function GdipResetLineTransform; external WINGDIPDLL name 'GdipResetLineTransform'; + function GdipMultiplyLineTransform; external WINGDIPDLL name 'GdipMultiplyLineTransform'; + function GdipTranslateLineTransform; external WINGDIPDLL name 'GdipTranslateLineTransform'; + function GdipScaleLineTransform; external WINGDIPDLL name 'GdipScaleLineTransform'; + function GdipRotateLineTransform; external WINGDIPDLL name 'GdipRotateLineTransform'; + function GdipCreatePathGradient; external WINGDIPDLL name 'GdipCreatePathGradient'; + function GdipCreatePathGradientI; external WINGDIPDLL name 'GdipCreatePathGradientI'; + function GdipCreatePathGradientFromPath; external WINGDIPDLL name 'GdipCreatePathGradientFromPath'; + function GdipGetPathGradientCenterColor; external WINGDIPDLL name 'GdipGetPathGradientCenterColor'; + function GdipSetPathGradientCenterColor; external WINGDIPDLL name 'GdipSetPathGradientCenterColor'; + function GdipGetPathGradientSurroundColorsWithCount; external WINGDIPDLL name 'GdipGetPathGradientSurroundColorsWithCount'; + function GdipSetPathGradientSurroundColorsWithCount; external WINGDIPDLL name 'GdipSetPathGradientSurroundColorsWithCount'; + function GdipGetPathGradientPath; external WINGDIPDLL name 'GdipGetPathGradientPath'; + function GdipSetPathGradientPath; external WINGDIPDLL name 'GdipSetPathGradientPath'; + function GdipGetPathGradientCenterPoint; external WINGDIPDLL name 'GdipGetPathGradientCenterPoint'; + function GdipGetPathGradientCenterPointI; external WINGDIPDLL name 'GdipGetPathGradientCenterPointI'; + function GdipSetPathGradientCenterPoint; external WINGDIPDLL name 'GdipSetPathGradientCenterPoint'; + function GdipSetPathGradientCenterPointI; external WINGDIPDLL name 'GdipSetPathGradientCenterPointI'; + function GdipGetPathGradientRect; external WINGDIPDLL name 'GdipGetPathGradientRect'; + function GdipGetPathGradientRectI; external WINGDIPDLL name 'GdipGetPathGradientRectI'; + function GdipGetPathGradientPointCount; external WINGDIPDLL name 'GdipGetPathGradientPointCount'; + function GdipGetPathGradientSurroundColorCount; external WINGDIPDLL name 'GdipGetPathGradientSurroundColorCount'; + function GdipSetPathGradientGammaCorrection; external WINGDIPDLL name 'GdipSetPathGradientGammaCorrection'; + function GdipGetPathGradientGammaCorrection; external WINGDIPDLL name 'GdipGetPathGradientGammaCorrection'; + function GdipGetPathGradientBlendCount; external WINGDIPDLL name 'GdipGetPathGradientBlendCount'; + function GdipGetPathGradientBlend; external WINGDIPDLL name 'GdipGetPathGradientBlend'; + function GdipSetPathGradientBlend; external WINGDIPDLL name 'GdipSetPathGradientBlend'; + function GdipGetPathGradientPresetBlendCount; external WINGDIPDLL name 'GdipGetPathGradientPresetBlendCount'; + function GdipGetPathGradientPresetBlend; external WINGDIPDLL name 'GdipGetPathGradientPresetBlend'; + function GdipSetPathGradientPresetBlend; external WINGDIPDLL name 'GdipSetPathGradientPresetBlend'; + function GdipSetPathGradientSigmaBlend; external WINGDIPDLL name 'GdipSetPathGradientSigmaBlend'; + function GdipSetPathGradientLinearBlend; external WINGDIPDLL name 'GdipSetPathGradientLinearBlend'; + function GdipGetPathGradientWrapMode; external WINGDIPDLL name 'GdipGetPathGradientWrapMode'; + function GdipSetPathGradientWrapMode; external WINGDIPDLL name 'GdipSetPathGradientWrapMode'; + function GdipGetPathGradientTransform; external WINGDIPDLL name 'GdipGetPathGradientTransform'; + function GdipSetPathGradientTransform; external WINGDIPDLL name 'GdipSetPathGradientTransform'; + function GdipResetPathGradientTransform; external WINGDIPDLL name 'GdipResetPathGradientTransform'; + function GdipMultiplyPathGradientTransform; external WINGDIPDLL name 'GdipMultiplyPathGradientTransform'; + function GdipTranslatePathGradientTransform; external WINGDIPDLL name 'GdipTranslatePathGradientTransform'; + function GdipScalePathGradientTransform; external WINGDIPDLL name 'GdipScalePathGradientTransform'; + function GdipRotatePathGradientTransform; external WINGDIPDLL name 'GdipRotatePathGradientTransform'; + function GdipGetPathGradientFocusScales; external WINGDIPDLL name 'GdipGetPathGradientFocusScales'; + function GdipSetPathGradientFocusScales; external WINGDIPDLL name 'GdipSetPathGradientFocusScales'; + function GdipCreatePen1; external WINGDIPDLL name 'GdipCreatePen1'; + function GdipCreatePen2; external WINGDIPDLL name 'GdipCreatePen2'; + function GdipClonePen; external WINGDIPDLL name 'GdipClonePen'; + function GdipDeletePen; external WINGDIPDLL name 'GdipDeletePen'; + function GdipSetPenWidth; external WINGDIPDLL name 'GdipSetPenWidth'; + function GdipGetPenWidth; external WINGDIPDLL name 'GdipGetPenWidth'; + function GdipSetPenUnit; external WINGDIPDLL name 'GdipSetPenUnit'; + function GdipGetPenUnit; external WINGDIPDLL name 'GdipGetPenUnit'; + function GdipSetPenLineCap197819; external WINGDIPDLL name 'GdipSetPenLineCap197819'; + function GdipSetPenStartCap; external WINGDIPDLL name 'GdipSetPenStartCap'; + function GdipSetPenEndCap; external WINGDIPDLL name 'GdipSetPenEndCap'; + function GdipSetPenDashCap197819; external WINGDIPDLL name 'GdipSetPenDashCap197819'; + function GdipGetPenStartCap; external WINGDIPDLL name 'GdipGetPenStartCap'; + function GdipGetPenEndCap; external WINGDIPDLL name 'GdipGetPenEndCap'; + function GdipGetPenDashCap197819; external WINGDIPDLL name 'GdipGetPenDashCap197819'; + function GdipSetPenLineJoin; external WINGDIPDLL name 'GdipSetPenLineJoin'; + function GdipGetPenLineJoin; external WINGDIPDLL name 'GdipGetPenLineJoin'; + function GdipSetPenCustomStartCap; external WINGDIPDLL name 'GdipSetPenCustomStartCap'; + function GdipGetPenCustomStartCap; external WINGDIPDLL name 'GdipGetPenCustomStartCap'; + function GdipSetPenCustomEndCap; external WINGDIPDLL name 'GdipSetPenCustomEndCap'; + function GdipGetPenCustomEndCap; external WINGDIPDLL name 'GdipGetPenCustomEndCap'; + function GdipSetPenMiterLimit; external WINGDIPDLL name 'GdipSetPenMiterLimit'; + function GdipGetPenMiterLimit; external WINGDIPDLL name 'GdipGetPenMiterLimit'; + function GdipSetPenMode; external WINGDIPDLL name 'GdipSetPenMode'; + function GdipGetPenMode; external WINGDIPDLL name 'GdipGetPenMode'; + function GdipSetPenTransform; external WINGDIPDLL name 'GdipSetPenTransform'; + function GdipGetPenTransform; external WINGDIPDLL name 'GdipGetPenTransform'; + function GdipResetPenTransform; external WINGDIPDLL name 'GdipResetPenTransform'; + function GdipMultiplyPenTransform; external WINGDIPDLL name 'GdipMultiplyPenTransform'; + function GdipTranslatePenTransform; external WINGDIPDLL name 'GdipTranslatePenTransform'; + function GdipScalePenTransform; external WINGDIPDLL name 'GdipScalePenTransform'; + function GdipRotatePenTransform; external WINGDIPDLL name 'GdipRotatePenTransform'; + function GdipSetPenColor; external WINGDIPDLL name 'GdipSetPenColor'; + function GdipGetPenColor; external WINGDIPDLL name 'GdipGetPenColor'; + function GdipSetPenBrushFill; external WINGDIPDLL name 'GdipSetPenBrushFill'; + function GdipGetPenBrushFill; external WINGDIPDLL name 'GdipGetPenBrushFill'; + function GdipGetPenFillType; external WINGDIPDLL name 'GdipGetPenFillType'; + function GdipGetPenDashStyle; external WINGDIPDLL name 'GdipGetPenDashStyle'; + function GdipSetPenDashStyle; external WINGDIPDLL name 'GdipSetPenDashStyle'; + function GdipGetPenDashOffset; external WINGDIPDLL name 'GdipGetPenDashOffset'; + function GdipSetPenDashOffset; external WINGDIPDLL name 'GdipSetPenDashOffset'; + function GdipGetPenDashCount; external WINGDIPDLL name 'GdipGetPenDashCount'; + function GdipSetPenDashArray; external WINGDIPDLL name 'GdipSetPenDashArray'; + function GdipGetPenDashArray; external WINGDIPDLL name 'GdipGetPenDashArray'; + function GdipGetPenCompoundCount; external WINGDIPDLL name 'GdipGetPenCompoundCount'; + function GdipSetPenCompoundArray; external WINGDIPDLL name 'GdipSetPenCompoundArray'; + function GdipGetPenCompoundArray; external WINGDIPDLL name 'GdipGetPenCompoundArray'; + function GdipCreateCustomLineCap; external WINGDIPDLL name 'GdipCreateCustomLineCap'; + function GdipDeleteCustomLineCap; external WINGDIPDLL name 'GdipDeleteCustomLineCap'; + function GdipCloneCustomLineCap; external WINGDIPDLL name 'GdipCloneCustomLineCap'; + function GdipGetCustomLineCapType; external WINGDIPDLL name 'GdipGetCustomLineCapType'; + function GdipSetCustomLineCapStrokeCaps; external WINGDIPDLL name 'GdipSetCustomLineCapStrokeCaps'; + function GdipGetCustomLineCapStrokeCaps; external WINGDIPDLL name 'GdipGetCustomLineCapStrokeCaps'; + function GdipSetCustomLineCapStrokeJoin; external WINGDIPDLL name 'GdipSetCustomLineCapStrokeJoin'; + function GdipGetCustomLineCapStrokeJoin; external WINGDIPDLL name 'GdipGetCustomLineCapStrokeJoin'; + function GdipSetCustomLineCapBaseCap; external WINGDIPDLL name 'GdipSetCustomLineCapBaseCap'; + function GdipGetCustomLineCapBaseCap; external WINGDIPDLL name 'GdipGetCustomLineCapBaseCap'; + function GdipSetCustomLineCapBaseInset; external WINGDIPDLL name 'GdipSetCustomLineCapBaseInset'; + function GdipGetCustomLineCapBaseInset; external WINGDIPDLL name 'GdipGetCustomLineCapBaseInset'; + function GdipSetCustomLineCapWidthScale; external WINGDIPDLL name 'GdipSetCustomLineCapWidthScale'; + function GdipGetCustomLineCapWidthScale; external WINGDIPDLL name 'GdipGetCustomLineCapWidthScale'; + function GdipCreateAdjustableArrowCap; external WINGDIPDLL name 'GdipCreateAdjustableArrowCap'; + function GdipSetAdjustableArrowCapHeight; external WINGDIPDLL name 'GdipSetAdjustableArrowCapHeight'; + function GdipGetAdjustableArrowCapHeight; external WINGDIPDLL name 'GdipGetAdjustableArrowCapHeight'; + function GdipSetAdjustableArrowCapWidth; external WINGDIPDLL name 'GdipSetAdjustableArrowCapWidth'; + function GdipGetAdjustableArrowCapWidth; external WINGDIPDLL name 'GdipGetAdjustableArrowCapWidth'; + function GdipSetAdjustableArrowCapMiddleInset; external WINGDIPDLL name 'GdipSetAdjustableArrowCapMiddleInset'; + function GdipGetAdjustableArrowCapMiddleInset; external WINGDIPDLL name 'GdipGetAdjustableArrowCapMiddleInset'; + function GdipSetAdjustableArrowCapFillState; external WINGDIPDLL name 'GdipSetAdjustableArrowCapFillState'; + function GdipGetAdjustableArrowCapFillState; external WINGDIPDLL name 'GdipGetAdjustableArrowCapFillState'; + function GdipLoadImageFromStream; external WINGDIPDLL name 'GdipLoadImageFromStream'; + function GdipLoadImageFromFile; external WINGDIPDLL name 'GdipLoadImageFromFile'; + function GdipLoadImageFromStreamICM; external WINGDIPDLL name 'GdipLoadImageFromStreamICM'; + function GdipLoadImageFromFileICM; external WINGDIPDLL name 'GdipLoadImageFromFileICM'; + function GdipCloneImage; external WINGDIPDLL name 'GdipCloneImage'; + function GdipDisposeImage; external WINGDIPDLL name 'GdipDisposeImage'; + function GdipSaveImageToFile; external WINGDIPDLL name 'GdipSaveImageToFile'; + function GdipSaveImageToStream; external WINGDIPDLL name 'GdipSaveImageToStream'; + function GdipSaveAdd; external WINGDIPDLL name 'GdipSaveAdd'; + function GdipSaveAddImage; external WINGDIPDLL name 'GdipSaveAddImage'; + function GdipGetImageGraphicsContext; external WINGDIPDLL name 'GdipGetImageGraphicsContext'; + function GdipGetImageBounds; external WINGDIPDLL name 'GdipGetImageBounds'; + function GdipGetImageDimension; external WINGDIPDLL name 'GdipGetImageDimension'; + function GdipGetImageType; external WINGDIPDLL name 'GdipGetImageType'; + function GdipGetImageWidth; external WINGDIPDLL name 'GdipGetImageWidth'; + function GdipGetImageHeight; external WINGDIPDLL name 'GdipGetImageHeight'; + function GdipGetImageHorizontalResolution; external WINGDIPDLL name 'GdipGetImageHorizontalResolution'; + function GdipGetImageVerticalResolution; external WINGDIPDLL name 'GdipGetImageVerticalResolution'; + function GdipGetImageFlags; external WINGDIPDLL name 'GdipGetImageFlags'; + function GdipGetImageRawFormat; external WINGDIPDLL name 'GdipGetImageRawFormat'; + function GdipGetImagePixelFormat; external WINGDIPDLL name 'GdipGetImagePixelFormat'; + function GdipGetImageThumbnail; external WINGDIPDLL name 'GdipGetImageThumbnail'; + function GdipGetEncoderParameterListSize; external WINGDIPDLL name 'GdipGetEncoderParameterListSize'; + function GdipGetEncoderParameterList; external WINGDIPDLL name 'GdipGetEncoderParameterList'; + function GdipImageGetFrameDimensionsCount; external WINGDIPDLL name 'GdipImageGetFrameDimensionsCount'; + function GdipImageGetFrameDimensionsList; external WINGDIPDLL name 'GdipImageGetFrameDimensionsList'; + function GdipImageGetFrameCount; external WINGDIPDLL name 'GdipImageGetFrameCount'; + function GdipImageSelectActiveFrame; external WINGDIPDLL name 'GdipImageSelectActiveFrame'; + function GdipImageRotateFlip; external WINGDIPDLL name 'GdipImageRotateFlip'; + function GdipGetImagePalette; external WINGDIPDLL name 'GdipGetImagePalette'; + function GdipSetImagePalette; external WINGDIPDLL name 'GdipSetImagePalette'; + function GdipGetImagePaletteSize; external WINGDIPDLL name 'GdipGetImagePaletteSize'; + function GdipGetPropertyCount; external WINGDIPDLL name 'GdipGetPropertyCount'; + function GdipGetPropertyIdList; external WINGDIPDLL name 'GdipGetPropertyIdList'; + function GdipGetPropertyItemSize; external WINGDIPDLL name 'GdipGetPropertyItemSize'; + function GdipGetPropertyItem; external WINGDIPDLL name 'GdipGetPropertyItem'; + function GdipGetPropertySize; external WINGDIPDLL name 'GdipGetPropertySize'; + function GdipGetAllPropertyItems; external WINGDIPDLL name 'GdipGetAllPropertyItems'; + function GdipRemovePropertyItem; external WINGDIPDLL name 'GdipRemovePropertyItem'; + function GdipSetPropertyItem; external WINGDIPDLL name 'GdipSetPropertyItem'; + function GdipImageForceValidation; external WINGDIPDLL name 'GdipImageForceValidation'; + function GdipCreateBitmapFromStream; external WINGDIPDLL name 'GdipCreateBitmapFromStream'; + function GdipCreateBitmapFromFile; external WINGDIPDLL name 'GdipCreateBitmapFromFile'; + function GdipCreateBitmapFromStreamICM; external WINGDIPDLL name 'GdipCreateBitmapFromStreamICM'; + function GdipCreateBitmapFromFileICM; external WINGDIPDLL name 'GdipCreateBitmapFromFileICM'; + function GdipCreateBitmapFromScan0; external WINGDIPDLL name 'GdipCreateBitmapFromScan0'; + function GdipCreateBitmapFromGraphics; external WINGDIPDLL name 'GdipCreateBitmapFromGraphics'; + function GdipCreateBitmapFromDirectDrawSurface; external WINGDIPDLL name 'GdipCreateBitmapFromDirectDrawSurface'; + function GdipCreateBitmapFromGdiDib; external WINGDIPDLL name 'GdipCreateBitmapFromGdiDib'; + function GdipCreateBitmapFromHBITMAP; external WINGDIPDLL name 'GdipCreateBitmapFromHBITMAP'; + function GdipCreateHBITMAPFromBitmap; external WINGDIPDLL name 'GdipCreateHBITMAPFromBitmap'; + function GdipCreateBitmapFromHICON; external WINGDIPDLL name 'GdipCreateBitmapFromHICON'; + function GdipCreateHICONFromBitmap; external WINGDIPDLL name 'GdipCreateHICONFromBitmap'; + function GdipCreateBitmapFromResource; external WINGDIPDLL name 'GdipCreateBitmapFromResource'; + function GdipCloneBitmapArea; external WINGDIPDLL name 'GdipCloneBitmapArea'; + function GdipCloneBitmapAreaI; external WINGDIPDLL name 'GdipCloneBitmapAreaI'; + function GdipBitmapLockBits; external WINGDIPDLL name 'GdipBitmapLockBits'; + function GdipBitmapUnlockBits; external WINGDIPDLL name 'GdipBitmapUnlockBits'; + function GdipBitmapGetPixel; external WINGDIPDLL name 'GdipBitmapGetPixel'; + function GdipBitmapSetPixel; external WINGDIPDLL name 'GdipBitmapSetPixel'; + function GdipBitmapSetResolution; external WINGDIPDLL name 'GdipBitmapSetResolution'; + function GdipCreateImageAttributes; external WINGDIPDLL name 'GdipCreateImageAttributes'; + function GdipCloneImageAttributes; external WINGDIPDLL name 'GdipCloneImageAttributes'; + function GdipDisposeImageAttributes; external WINGDIPDLL name 'GdipDisposeImageAttributes'; + function GdipSetImageAttributesToIdentity; external WINGDIPDLL name 'GdipSetImageAttributesToIdentity'; + function GdipResetImageAttributes; external WINGDIPDLL name 'GdipResetImageAttributes'; + function GdipSetImageAttributesColorMatrix; external WINGDIPDLL name 'GdipSetImageAttributesColorMatrix'; + function GdipSetImageAttributesThreshold; external WINGDIPDLL name 'GdipSetImageAttributesThreshold'; + function GdipSetImageAttributesGamma; external WINGDIPDLL name 'GdipSetImageAttributesGamma'; + function GdipSetImageAttributesNoOp; external WINGDIPDLL name 'GdipSetImageAttributesNoOp'; + function GdipSetImageAttributesColorKeys; external WINGDIPDLL name 'GdipSetImageAttributesColorKeys'; + function GdipSetImageAttributesOutputChannel; external WINGDIPDLL name 'GdipSetImageAttributesOutputChannel'; + function GdipSetImageAttributesOutputChannelColorProfile; external WINGDIPDLL name 'GdipSetImageAttributesOutputChannelColorProfile'; + function GdipSetImageAttributesRemapTable; external WINGDIPDLL name 'GdipSetImageAttributesRemapTable'; + function GdipSetImageAttributesWrapMode; external WINGDIPDLL name 'GdipSetImageAttributesWrapMode'; + function GdipSetImageAttributesICMMode; external WINGDIPDLL name 'GdipSetImageAttributesICMMode'; + function GdipGetImageAttributesAdjustedPalette; external WINGDIPDLL name 'GdipGetImageAttributesAdjustedPalette'; + function GdipFlush; external WINGDIPDLL name 'GdipFlush'; + function GdipCreateFromHDC; external WINGDIPDLL name 'GdipCreateFromHDC'; + function GdipCreateFromHDC2; external WINGDIPDLL name 'GdipCreateFromHDC2'; + function GdipCreateFromHWND; external WINGDIPDLL name 'GdipCreateFromHWND'; + function GdipCreateFromHWNDICM; external WINGDIPDLL name 'GdipCreateFromHWNDICM'; + function GdipDeleteGraphics; external WINGDIPDLL name 'GdipDeleteGraphics'; + function GdipGetDC; external WINGDIPDLL name 'GdipGetDC'; + function GdipReleaseDC; external WINGDIPDLL name 'GdipReleaseDC'; + function GdipSetCompositingMode; external WINGDIPDLL name 'GdipSetCompositingMode'; + function GdipGetCompositingMode; external WINGDIPDLL name 'GdipGetCompositingMode'; + function GdipSetRenderingOrigin; external WINGDIPDLL name 'GdipSetRenderingOrigin'; + function GdipGetRenderingOrigin; external WINGDIPDLL name 'GdipGetRenderingOrigin'; + function GdipSetCompositingQuality; external WINGDIPDLL name 'GdipSetCompositingQuality'; + function GdipGetCompositingQuality; external WINGDIPDLL name 'GdipGetCompositingQuality'; + function GdipSetSmoothingMode; external WINGDIPDLL name 'GdipSetSmoothingMode'; + function GdipGetSmoothingMode; external WINGDIPDLL name 'GdipGetSmoothingMode'; + function GdipSetPixelOffsetMode; external WINGDIPDLL name 'GdipSetPixelOffsetMode'; + function GdipGetPixelOffsetMode; external WINGDIPDLL name 'GdipGetPixelOffsetMode'; + function GdipSetTextRenderingHint; external WINGDIPDLL name 'GdipSetTextRenderingHint'; + function GdipGetTextRenderingHint; external WINGDIPDLL name 'GdipGetTextRenderingHint'; + function GdipSetTextContrast; external WINGDIPDLL name 'GdipSetTextContrast'; + function GdipGetTextContrast; external WINGDIPDLL name 'GdipGetTextContrast'; + function GdipSetInterpolationMode; external WINGDIPDLL name 'GdipSetInterpolationMode'; + function GdipGetInterpolationMode; external WINGDIPDLL name 'GdipGetInterpolationMode'; + function GdipSetWorldTransform; external WINGDIPDLL name 'GdipSetWorldTransform'; + function GdipResetWorldTransform; external WINGDIPDLL name 'GdipResetWorldTransform'; + function GdipMultiplyWorldTransform; external WINGDIPDLL name 'GdipMultiplyWorldTransform'; + function GdipTranslateWorldTransform; external WINGDIPDLL name 'GdipTranslateWorldTransform'; + function GdipScaleWorldTransform; external WINGDIPDLL name 'GdipScaleWorldTransform'; + function GdipRotateWorldTransform; external WINGDIPDLL name 'GdipRotateWorldTransform'; + function GdipGetWorldTransform; external WINGDIPDLL name 'GdipGetWorldTransform'; + function GdipResetPageTransform; external WINGDIPDLL name 'GdipResetPageTransform'; + function GdipGetPageUnit; external WINGDIPDLL name 'GdipGetPageUnit'; + function GdipGetPageScale; external WINGDIPDLL name 'GdipGetPageScale'; + function GdipSetPageUnit; external WINGDIPDLL name 'GdipSetPageUnit'; + function GdipSetPageScale; external WINGDIPDLL name 'GdipSetPageScale'; + function GdipGetDpiX; external WINGDIPDLL name 'GdipGetDpiX'; + function GdipGetDpiY; external WINGDIPDLL name 'GdipGetDpiY'; + function GdipTransformPoints; external WINGDIPDLL name 'GdipTransformPoints'; + function GdipTransformPointsI; external WINGDIPDLL name 'GdipTransformPointsI'; + function GdipGetNearestColor; external WINGDIPDLL name 'GdipGetNearestColor'; + function GdipCreateHalftonePalette; external WINGDIPDLL name 'GdipCreateHalftonePalette'; + function GdipDrawLine; external WINGDIPDLL name 'GdipDrawLine'; + function GdipDrawLineI; external WINGDIPDLL name 'GdipDrawLineI'; + function GdipDrawLines; external WINGDIPDLL name 'GdipDrawLines'; + function GdipDrawLinesI; external WINGDIPDLL name 'GdipDrawLinesI'; + function GdipDrawArc; external WINGDIPDLL name 'GdipDrawArc'; + function GdipDrawArcI; external WINGDIPDLL name 'GdipDrawArcI'; + function GdipDrawBezier; external WINGDIPDLL name 'GdipDrawBezier'; + function GdipDrawBezierI; external WINGDIPDLL name 'GdipDrawBezierI'; + function GdipDrawBeziers; external WINGDIPDLL name 'GdipDrawBeziers'; + function GdipDrawBeziersI; external WINGDIPDLL name 'GdipDrawBeziersI'; + function GdipDrawRectangle; external WINGDIPDLL name 'GdipDrawRectangle'; + function GdipDrawRectangleI; external WINGDIPDLL name 'GdipDrawRectangleI'; + function GdipDrawRectangles; external WINGDIPDLL name 'GdipDrawRectangles'; + function GdipDrawRectanglesI; external WINGDIPDLL name 'GdipDrawRectanglesI'; + function GdipDrawEllipse; external WINGDIPDLL name 'GdipDrawEllipse'; + function GdipDrawEllipseI; external WINGDIPDLL name 'GdipDrawEllipseI'; + function GdipDrawPie; external WINGDIPDLL name 'GdipDrawPie'; + function GdipDrawPieI; external WINGDIPDLL name 'GdipDrawPieI'; + function GdipDrawPolygon; external WINGDIPDLL name 'GdipDrawPolygon'; + function GdipDrawPolygonI; external WINGDIPDLL name 'GdipDrawPolygonI'; + function GdipDrawPath; external WINGDIPDLL name 'GdipDrawPath'; + function GdipDrawCurve; external WINGDIPDLL name 'GdipDrawCurve'; + function GdipDrawCurveI; external WINGDIPDLL name 'GdipDrawCurveI'; + function GdipDrawCurve2; external WINGDIPDLL name 'GdipDrawCurve2'; + function GdipDrawCurve2I; external WINGDIPDLL name 'GdipDrawCurve2I'; + function GdipDrawCurve3; external WINGDIPDLL name 'GdipDrawCurve3'; + function GdipDrawCurve3I; external WINGDIPDLL name 'GdipDrawCurve3I'; + function GdipDrawClosedCurve; external WINGDIPDLL name 'GdipDrawClosedCurve'; + function GdipDrawClosedCurveI; external WINGDIPDLL name 'GdipDrawClosedCurveI'; + function GdipDrawClosedCurve2; external WINGDIPDLL name 'GdipDrawClosedCurve2'; + function GdipDrawClosedCurve2I; external WINGDIPDLL name 'GdipDrawClosedCurve2I'; + function GdipGraphicsClear; external WINGDIPDLL name 'GdipGraphicsClear'; + function GdipFillRectangle; external WINGDIPDLL name 'GdipFillRectangle'; + function GdipFillRectangleI; external WINGDIPDLL name 'GdipFillRectangleI'; + function GdipFillRectangles; external WINGDIPDLL name 'GdipFillRectangles'; + function GdipFillRectanglesI; external WINGDIPDLL name 'GdipFillRectanglesI'; + function GdipFillPolygon; external WINGDIPDLL name 'GdipFillPolygon'; + function GdipFillPolygonI; external WINGDIPDLL name 'GdipFillPolygonI'; + function GdipFillPolygon2; external WINGDIPDLL name 'GdipFillPolygon2'; + function GdipFillPolygon2I; external WINGDIPDLL name 'GdipFillPolygon2I'; + function GdipFillEllipse; external WINGDIPDLL name 'GdipFillEllipse'; + function GdipFillEllipseI; external WINGDIPDLL name 'GdipFillEllipseI'; + function GdipFillPie; external WINGDIPDLL name 'GdipFillPie'; + function GdipFillPieI; external WINGDIPDLL name 'GdipFillPieI'; + function GdipFillPath; external WINGDIPDLL name 'GdipFillPath'; + function GdipFillClosedCurve; external WINGDIPDLL name 'GdipFillClosedCurve'; + function GdipFillClosedCurveI; external WINGDIPDLL name 'GdipFillClosedCurveI'; + function GdipFillClosedCurve2; external WINGDIPDLL name 'GdipFillClosedCurve2'; + function GdipFillClosedCurve2I; external WINGDIPDLL name 'GdipFillClosedCurve2I'; + function GdipFillRegion; external WINGDIPDLL name 'GdipFillRegion'; + function GdipDrawImage; external WINGDIPDLL name 'GdipDrawImage'; + function GdipDrawImageI; external WINGDIPDLL name 'GdipDrawImageI'; + function GdipDrawImageRect; external WINGDIPDLL name 'GdipDrawImageRect'; + function GdipDrawImageRectI; external WINGDIPDLL name 'GdipDrawImageRectI'; + function GdipDrawImagePoints; external WINGDIPDLL name 'GdipDrawImagePoints'; + function GdipDrawImagePointsI; external WINGDIPDLL name 'GdipDrawImagePointsI'; + function GdipDrawImagePointRect; external WINGDIPDLL name 'GdipDrawImagePointRect'; + function GdipDrawImagePointRectI; external WINGDIPDLL name 'GdipDrawImagePointRectI'; + function GdipDrawImageRectRect; external WINGDIPDLL name 'GdipDrawImageRectRect'; + function GdipDrawImageRectRectI; external WINGDIPDLL name 'GdipDrawImageRectRectI'; + function GdipDrawImagePointsRect; external WINGDIPDLL name 'GdipDrawImagePointsRect'; + function GdipDrawImagePointsRectI; external WINGDIPDLL name 'GdipDrawImagePointsRectI'; + function GdipEnumerateMetafileDestPoint; external WINGDIPDLL name 'GdipEnumerateMetafileDestPoint'; + function GdipEnumerateMetafileDestPointI; external WINGDIPDLL name 'GdipEnumerateMetafileDestPointI'; + function GdipEnumerateMetafileDestRect; external WINGDIPDLL name 'GdipEnumerateMetafileDestRect'; + function GdipEnumerateMetafileDestRectI; external WINGDIPDLL name 'GdipEnumerateMetafileDestRectI'; + function GdipEnumerateMetafileDestPoints; external WINGDIPDLL name 'GdipEnumerateMetafileDestPoints'; + function GdipEnumerateMetafileDestPointsI; external WINGDIPDLL name 'GdipEnumerateMetafileDestPointsI'; + function GdipEnumerateMetafileSrcRectDestPoint; external WINGDIPDLL name 'GdipEnumerateMetafileSrcRectDestPoint'; + function GdipEnumerateMetafileSrcRectDestPointI; external WINGDIPDLL name 'GdipEnumerateMetafileSrcRectDestPointI'; + function GdipEnumerateMetafileSrcRectDestRect; external WINGDIPDLL name 'GdipEnumerateMetafileSrcRectDestRect'; + function GdipEnumerateMetafileSrcRectDestRectI; external WINGDIPDLL name 'GdipEnumerateMetafileSrcRectDestRectI'; + function GdipEnumerateMetafileSrcRectDestPoints; external WINGDIPDLL name 'GdipEnumerateMetafileSrcRectDestPoints'; + function GdipEnumerateMetafileSrcRectDestPointsI; external WINGDIPDLL name 'GdipEnumerateMetafileSrcRectDestPointsI'; + function GdipPlayMetafileRecord; external WINGDIPDLL name 'GdipPlayMetafileRecord'; + function GdipSetClipGraphics; external WINGDIPDLL name 'GdipSetClipGraphics'; + function GdipSetClipRect; external WINGDIPDLL name 'GdipSetClipRect'; + function GdipSetClipRectI; external WINGDIPDLL name 'GdipSetClipRectI'; + function GdipSetClipPath; external WINGDIPDLL name 'GdipSetClipPath'; + function GdipSetClipRegion; external WINGDIPDLL name 'GdipSetClipRegion'; + function GdipSetClipHrgn; external WINGDIPDLL name 'GdipSetClipHrgn'; + function GdipResetClip; external WINGDIPDLL name 'GdipResetClip'; + function GdipTranslateClip; external WINGDIPDLL name 'GdipTranslateClip'; + function GdipTranslateClipI; external WINGDIPDLL name 'GdipTranslateClipI'; + function GdipGetClip; external WINGDIPDLL name 'GdipGetClip'; + function GdipGetClipBounds; external WINGDIPDLL name 'GdipGetClipBounds'; + function GdipGetClipBoundsI; external WINGDIPDLL name 'GdipGetClipBoundsI'; + function GdipIsClipEmpty; external WINGDIPDLL name 'GdipIsClipEmpty'; + function GdipGetVisibleClipBounds; external WINGDIPDLL name 'GdipGetVisibleClipBounds'; + function GdipGetVisibleClipBoundsI; external WINGDIPDLL name 'GdipGetVisibleClipBoundsI'; + function GdipIsVisibleClipEmpty; external WINGDIPDLL name 'GdipIsVisibleClipEmpty'; + function GdipIsVisiblePoint; external WINGDIPDLL name 'GdipIsVisiblePoint'; + function GdipIsVisiblePointI; external WINGDIPDLL name 'GdipIsVisiblePointI'; + function GdipIsVisibleRect; external WINGDIPDLL name 'GdipIsVisibleRect'; + function GdipIsVisibleRectI; external WINGDIPDLL name 'GdipIsVisibleRectI'; + function GdipSaveGraphics; external WINGDIPDLL name 'GdipSaveGraphics'; + function GdipRestoreGraphics; external WINGDIPDLL name 'GdipRestoreGraphics'; + function GdipBeginContainer; external WINGDIPDLL name 'GdipBeginContainer'; + function GdipBeginContainerI; external WINGDIPDLL name 'GdipBeginContainerI'; + function GdipBeginContainer2; external WINGDIPDLL name 'GdipBeginContainer2'; + function GdipEndContainer; external WINGDIPDLL name 'GdipEndContainer'; + function GdipGetMetafileHeaderFromWmf; external WINGDIPDLL name 'GdipGetMetafileHeaderFromWmf'; + function GdipGetMetafileHeaderFromEmf; external WINGDIPDLL name 'GdipGetMetafileHeaderFromEmf'; + function GdipGetMetafileHeaderFromFile; external WINGDIPDLL name 'GdipGetMetafileHeaderFromFile'; + function GdipGetMetafileHeaderFromStream; external WINGDIPDLL name 'GdipGetMetafileHeaderFromStream'; + function GdipGetMetafileHeaderFromMetafile; external WINGDIPDLL name 'GdipGetMetafileHeaderFromMetafile'; + function GdipGetHemfFromMetafile; external WINGDIPDLL name 'GdipGetHemfFromMetafile'; + function GdipCreateStreamOnFile; external WINGDIPDLL name 'GdipCreateStreamOnFile'; + function GdipCreateMetafileFromWmf; external WINGDIPDLL name 'GdipCreateMetafileFromWmf'; + function GdipCreateMetafileFromEmf; external WINGDIPDLL name 'GdipCreateMetafileFromEmf'; + function GdipCreateMetafileFromFile; external WINGDIPDLL name 'GdipCreateMetafileFromFile'; + function GdipCreateMetafileFromWmfFile; external WINGDIPDLL name 'GdipCreateMetafileFromWmfFile'; + function GdipCreateMetafileFromStream; external WINGDIPDLL name 'GdipCreateMetafileFromStream'; + function GdipRecordMetafile; external WINGDIPDLL name 'GdipRecordMetafile'; + function GdipRecordMetafileI; external WINGDIPDLL name 'GdipRecordMetafileI'; + function GdipRecordMetafileFileName; external WINGDIPDLL name 'GdipRecordMetafileFileName'; + function GdipRecordMetafileFileNameI; external WINGDIPDLL name 'GdipRecordMetafileFileNameI'; + function GdipRecordMetafileStream; external WINGDIPDLL name 'GdipRecordMetafileStream'; + function GdipRecordMetafileStreamI; external WINGDIPDLL name 'GdipRecordMetafileStreamI'; + function GdipSetMetafileDownLevelRasterizationLimit; external WINGDIPDLL name 'GdipSetMetafileDownLevelRasterizationLimit'; + function GdipGetMetafileDownLevelRasterizationLimit; external WINGDIPDLL name 'GdipGetMetafileDownLevelRasterizationLimit'; + function GdipGetImageDecodersSize; external WINGDIPDLL name 'GdipGetImageDecodersSize'; + function GdipGetImageDecoders; external WINGDIPDLL name 'GdipGetImageDecoders'; + function GdipGetImageEncodersSize; external WINGDIPDLL name 'GdipGetImageEncodersSize'; + function GdipGetImageEncoders; external WINGDIPDLL name 'GdipGetImageEncoders'; + function GdipComment; external WINGDIPDLL name 'GdipComment'; + function GdipCreateFontFamilyFromName; external WINGDIPDLL name 'GdipCreateFontFamilyFromName'; + function GdipDeleteFontFamily; external WINGDIPDLL name 'GdipDeleteFontFamily'; + function GdipCloneFontFamily; external WINGDIPDLL name 'GdipCloneFontFamily'; + function GdipGetGenericFontFamilySansSerif; external WINGDIPDLL name 'GdipGetGenericFontFamilySansSerif'; + function GdipGetGenericFontFamilySerif; external WINGDIPDLL name 'GdipGetGenericFontFamilySerif'; + function GdipGetGenericFontFamilyMonospace; external WINGDIPDLL name 'GdipGetGenericFontFamilyMonospace'; + function GdipGetFamilyName; external WINGDIPDLL name 'GdipGetFamilyName'; + function GdipIsStyleAvailable; external WINGDIPDLL name 'GdipIsStyleAvailable'; + function GdipFontCollectionEnumerable; external WINGDIPDLL name 'GdipFontCollectionEnumerable'; + function GdipFontCollectionEnumerate; external WINGDIPDLL name 'GdipFontCollectionEnumerate'; + function GdipGetEmHeight; external WINGDIPDLL name 'GdipGetEmHeight'; + function GdipGetCellAscent; external WINGDIPDLL name 'GdipGetCellAscent'; + function GdipGetCellDescent; external WINGDIPDLL name 'GdipGetCellDescent'; + function GdipGetLineSpacing; external WINGDIPDLL name 'GdipGetLineSpacing'; + function GdipCreateFontFromDC; external WINGDIPDLL name 'GdipCreateFontFromDC'; + function GdipCreateFontFromLogfontA; external WINGDIPDLL name 'GdipCreateFontFromLogfontA'; + function GdipCreateFontFromLogfontW; external WINGDIPDLL name 'GdipCreateFontFromLogfontW'; + function GdipCreateFont; external WINGDIPDLL name 'GdipCreateFont'; + function GdipCloneFont; external WINGDIPDLL name 'GdipCloneFont'; + function GdipDeleteFont; external WINGDIPDLL name 'GdipDeleteFont'; + function GdipGetFamily; external WINGDIPDLL name 'GdipGetFamily'; + function GdipGetFontStyle; external WINGDIPDLL name 'GdipGetFontStyle'; + function GdipGetFontSize; external WINGDIPDLL name 'GdipGetFontSize'; + function GdipGetFontUnit; external WINGDIPDLL name 'GdipGetFontUnit'; + function GdipGetFontHeight; external WINGDIPDLL name 'GdipGetFontHeight'; + function GdipGetFontHeightGivenDPI; external WINGDIPDLL name 'GdipGetFontHeightGivenDPI'; + function GdipGetLogFontA; external WINGDIPDLL name 'GdipGetLogFontA'; + function GdipGetLogFontW; external WINGDIPDLL name 'GdipGetLogFontW'; + function GdipNewInstalledFontCollection; external WINGDIPDLL name 'GdipNewInstalledFontCollection'; + function GdipNewPrivateFontCollection; external WINGDIPDLL name 'GdipNewPrivateFontCollection'; + function GdipDeletePrivateFontCollection; external WINGDIPDLL name 'GdipDeletePrivateFontCollection'; + function GdipGetFontCollectionFamilyCount; external WINGDIPDLL name 'GdipGetFontCollectionFamilyCount'; + function GdipGetFontCollectionFamilyList; external WINGDIPDLL name 'GdipGetFontCollectionFamilyList'; + function GdipPrivateAddFontFile; external WINGDIPDLL name 'GdipPrivateAddFontFile'; + function GdipPrivateAddMemoryFont; external WINGDIPDLL name 'GdipPrivateAddMemoryFont'; + function GdipDrawString; external WINGDIPDLL name 'GdipDrawString'; + function GdipMeasureString; external WINGDIPDLL name 'GdipMeasureString'; + function GdipMeasureCharacterRanges; external WINGDIPDLL name 'GdipMeasureCharacterRanges'; + function GdipDrawDriverString; external WINGDIPDLL name 'GdipDrawDriverString'; + function GdipMeasureDriverString; external WINGDIPDLL name 'GdipMeasureDriverString'; + function GdipCreateStringFormat; external WINGDIPDLL name 'GdipCreateStringFormat'; + function GdipStringFormatGetGenericDefault; external WINGDIPDLL name 'GdipStringFormatGetGenericDefault'; + function GdipStringFormatGetGenericTypographic; external WINGDIPDLL name 'GdipStringFormatGetGenericTypographic'; + function GdipDeleteStringFormat; external WINGDIPDLL name 'GdipDeleteStringFormat'; + function GdipCloneStringFormat; external WINGDIPDLL name 'GdipCloneStringFormat'; + function GdipSetStringFormatFlags; external WINGDIPDLL name 'GdipSetStringFormatFlags'; + function GdipGetStringFormatFlags; external WINGDIPDLL name 'GdipGetStringFormatFlags'; + function GdipSetStringFormatAlign; external WINGDIPDLL name 'GdipSetStringFormatAlign'; + function GdipGetStringFormatAlign; external WINGDIPDLL name 'GdipGetStringFormatAlign'; + function GdipSetStringFormatLineAlign; external WINGDIPDLL name 'GdipSetStringFormatLineAlign'; + function GdipGetStringFormatLineAlign; external WINGDIPDLL name 'GdipGetStringFormatLineAlign'; + function GdipSetStringFormatTrimming; external WINGDIPDLL name 'GdipSetStringFormatTrimming'; + function GdipGetStringFormatTrimming; external WINGDIPDLL name 'GdipGetStringFormatTrimming'; + function GdipSetStringFormatHotkeyPrefix; external WINGDIPDLL name 'GdipSetStringFormatHotkeyPrefix'; + function GdipGetStringFormatHotkeyPrefix; external WINGDIPDLL name 'GdipGetStringFormatHotkeyPrefix'; + function GdipSetStringFormatTabStops; external WINGDIPDLL name 'GdipSetStringFormatTabStops'; + function GdipGetStringFormatTabStops; external WINGDIPDLL name 'GdipGetStringFormatTabStops'; + function GdipGetStringFormatTabStopCount; external WINGDIPDLL name 'GdipGetStringFormatTabStopCount'; + function GdipSetStringFormatDigitSubstitution; external WINGDIPDLL name 'GdipSetStringFormatDigitSubstitution'; + function GdipGetStringFormatDigitSubstitution; external WINGDIPDLL name 'GdipGetStringFormatDigitSubstitution'; + function GdipGetStringFormatMeasurableCharacterRangeCount; external WINGDIPDLL name 'GdipGetStringFormatMeasurableCharacterRangeCount'; + function GdipSetStringFormatMeasurableCharacterRanges; external WINGDIPDLL name 'GdipSetStringFormatMeasurableCharacterRanges'; + function GdipCreateCachedBitmap; external WINGDIPDLL name 'GdipCreateCachedBitmap'; + function GdipDeleteCachedBitmap; external WINGDIPDLL name 'GdipDeleteCachedBitmap'; + function GdipDrawCachedBitmap; external WINGDIPDLL name 'GdipDrawCachedBitmap'; + function GdipEmfToWmfBits; external WINGDIPDLL name 'GdipEmfToWmfBits'; + +// ----------------------------------------------------------------------------- +// TGdiplusBase class +// ----------------------------------------------------------------------------- + + class function TGdiplusBase.NewInstance: TObject; + begin + Result := InitInstance(GdipAlloc(ULONG(instanceSize))); + end; + + procedure TGdiplusBase.FreeInstance; + begin + CleanupInstance; + GdipFree(Self); + end; + +// ----------------------------------------------------------------------------- +// macros +// ----------------------------------------------------------------------------- + +function ObjectTypeIsValid(type_: ObjectType): BOOL; +begin + result := ((type_ >= ObjectTypeMin) and (type_ <= ObjectTypeMax)); +end; + +function GDIP_WMF_RECORD_TO_EMFPLUS(n: integer): Integer; +begin + result := (n or GDIP_WMF_RECORD_BASE); +end; + +function GDIP_EMFPLUS_RECORD_TO_WMF(n: integer): Integer; +begin + result := n and (not GDIP_WMF_RECORD_BASE); +end; + +function GDIP_IS_WMF_RECORDTYPE(n: integer): BOOL; +begin + result := ((n and GDIP_WMF_RECORD_BASE) <> 0); +end; + + +//-------------------------------------------------------------------------- +// TGPPoint Util +//-------------------------------------------------------------------------- + + function MakePoint(X, Y: Integer): TGPPoint; + begin + result.X := X; + result.Y := Y; + end; + + function MakePoint(X, Y: Single): TGPPointF; + begin + Result.X := X; + result.Y := Y; + end; + +//-------------------------------------------------------------------------- +// TGPSize Util +//-------------------------------------------------------------------------- + + function MakeSize(Width, Height: Single): TGPSizeF; + begin + result.Width := Width; + result.Height := Height; + end; + + function MakeSize(Width, Height: Integer): TGPSize; + begin + result.Width := Width; + result.Height := Height; + end; + +//-------------------------------------------------------------------------- +// TCharacterRange Util +//-------------------------------------------------------------------------- + + function MakeCharacterRange(First, Length: Integer): TCharacterRange; + begin + result.First := First; + result.Length := Length; + end; + +// ----------------------------------------------------------------------------- +// RectF class +// ----------------------------------------------------------------------------- + + function MakeRect(x, y, width, height: Single): TGPRectF; overload; + begin + Result.X := x; + Result.Y := y; + Result.Width := width; + Result.Height := height; + end; + + function MakeRect(location: TGPPointF; size: TGPSizeF): TGPRectF; overload; + begin + Result.X := location.X; + Result.Y := location.Y; + Result.Width := size.Width; + Result.Height := size.Height; + end; + +// ----------------------------------------------------------------------------- +// Rect class +// ----------------------------------------------------------------------------- + + function MakeRect(x, y, width, height: Integer): TGPRect; overload; + begin + Result.X := x; + Result.Y := y; + Result.Width := width; + Result.Height := height; + end; + + function MakeRect(location: TGPPoint; size: TGPSize): TGPRect; overload; + begin + Result.X := location.X; + Result.Y := location.Y; + Result.Width := size.Width; + Result.Height := size.Height; + end; + + function MakeRect(const Rect: TRect): TGPRect; + begin + Result.X := rect.Left; + Result.Y := Rect.Top; + Result.Width := Rect.Right-Rect.Left; + Result.Height:= Rect.Bottom-Rect.Top; + end; + +// ----------------------------------------------------------------------------- +// PathData class +// ----------------------------------------------------------------------------- + + constructor TPathData.Create; + begin + Count := 0; + Points := nil; + Types := nil; + end; + + destructor TPathData.destroy; + begin + if assigned(Points) then freemem(Points); + if assigned(Types) then freemem(Types); + end; + + +function GetPixelFormatSize(pixfmt: PixelFormat): UINT; +begin + result := (pixfmt shr 8) and $ff; +end; + +function IsIndexedPixelFormat(pixfmt: PixelFormat): BOOL; +begin + result := (pixfmt and PixelFormatIndexed) <> 0; +end; + +function IsAlphaPixelFormat(pixfmt: PixelFormat): BOOL; +begin + result := (pixfmt and PixelFormatAlpha) <> 0; +end; + +function IsExtendedPixelFormat(pixfmt: PixelFormat): BOOL; +begin + result := (pixfmt and PixelFormatExtended) <> 0; +end; + +function IsCanonicalPixelFormat(pixfmt: PixelFormat): BOOL; +begin + result := (pixfmt and PixelFormatCanonical) <> 0; +end; + +// ----------------------------------------------------------------------------- +// Color class +// ----------------------------------------------------------------------------- + +{ constructor TGPColor.Create; + begin + Argb := DWORD(Black); + end; + + // Construct an opaque Color object with + // the specified Red, Green, Blue values. + // + // Color values are not premultiplied. + + constructor TGPColor.Create(r, g, b: Byte); + begin + Argb := MakeARGB(255, r, g, b); + end; + + constructor TGPColor.Create(a, r, g, b: Byte); + begin + Argb := MakeARGB(a, r, g, b); + end; + + constructor TGPColor.Create(Value: ARGB); + begin + Argb := Value; + end; + + function TGPColor.GetAlpha: BYTE; + begin + result := BYTE(Argb shr AlphaShift); + end; + + function TGPColor.GetA: BYTE; + begin + result := GetAlpha; + end; + + function TGPColor.GetRed: BYTE; + begin + result := BYTE(Argb shr RedShift); + end; + + function TGPColor.GetR: BYTE; + begin + result := GetRed; + end; + + function TGPColor.GetGreen: Byte; + begin + result := BYTE(Argb shr GreenShift); + end; + + function TGPColor.GetG: Byte; + begin + result := GetGreen; + end; + + function TGPColor.GetBlue: Byte; + begin + result := BYTE(Argb shr BlueShift); + end; + + function TGPColor.GetB: Byte; + begin + result := GetBlue; + end; + + function TGPColor.GetValue: ARGB; + begin + result := Argb; + end; + + procedure TGPColor.SetValue(Value: ARGB); + begin + Argb := Value; + end; + + procedure TGPColor.SetFromCOLORREF(rgb: COLORREF); + begin + Argb := MakeARGB(255, GetRValue(rgb), GetGValue(rgb), GetBValue(rgb)); + end; + + function TGPColor.ToCOLORREF: COLORREF; + begin + result := RGB(GetRed, GetGreen, GetBlue); + end; + + function TGPColor.MakeARGB(a, r, g, b: Byte): ARGB; + begin + result := ((DWORD(b) shl BlueShift) or + (DWORD(g) shl GreenShift) or + (DWORD(r) shl RedShift) or + (DWORD(a) shl AlphaShift)); + end; } + + function MakeColor(r, g, b: Byte): ARGB; overload; + begin + result := MakeColor(255, r, g, b); + end; + + function MakeColor(a, r, g, b: Byte): ARGB; overload; + begin + result := ((DWORD(b) shl BlueShift) or + (DWORD(g) shl GreenShift) or + (DWORD(r) shl RedShift) or + (DWORD(a) shl AlphaShift)); + end; + + function GetAlpha(color: ARGB): BYTE; + begin + result := BYTE(color shr AlphaShift); + end; + + function GetRed(color: ARGB): BYTE; + begin + result := BYTE(color shr RedShift); + end; + + function GetGreen(color: ARGB): BYTE; + begin + result := BYTE(color shr GreenShift); + end; + + function GetBlue(color: ARGB): BYTE; + begin + result := BYTE(color shr BlueShift); + end; + + function ColorRefToARGB(rgb: COLORREF): ARGB; + begin + result := MakeColor(255, GetRValue(rgb), GetGValue(rgb), GetBValue(rgb)); + end; + + function ARGBToColorRef(Color: ARGB): COLORREF; + begin + result := RGB(GetRed(Color), GetGreen(Color), GetBlue(Color)); + end; + + +// ----------------------------------------------------------------------------- +// MetafileHeader class +// ----------------------------------------------------------------------------- + + procedure TMetafileHeader.GetBounds(out Rect: TGPRect); + begin + rect.X := X; + rect.Y := Y; + rect.Width := Width; + rect.Height := Height; + end; + + function TMetafileHeader.IsWmf: BOOL; + begin + result := ((Type_ = MetafileTypeWmf) or (Type_ = MetafileTypeWmfPlaceable)); + end; + + function TMetafileHeader.IsWmfPlaceable: BOOL; + begin + result := (Type_ = MetafileTypeWmfPlaceable); + end; + + function TMetafileHeader.IsEmf: BOOL; + begin + result := (Type_ = MetafileTypeEmf); + end; + + function TMetafileHeader.IsEmfOrEmfPlus: BOOL; + begin + result := (Type_ >= MetafileTypeEmf); + end; + + function TMetafileHeader.IsEmfPlus: BOOL; + begin + result := (Type_ >= MetafileTypeEmfPlusOnly) + end; + + function TMetafileHeader.IsEmfPlusDual: BOOL; + begin + result := (Type_ = MetafileTypeEmfPlusDual) + end; + + function TMetafileHeader.IsEmfPlusOnly: BOOL; + begin + result := (Type_ = MetafileTypeEmfPlusOnly) + end; + + function TMetafileHeader.IsDisplay: BOOL; + begin + result := (IsEmfPlus and ((EmfPlusFlags and GDIP_EMFPLUSFLAGS_DISPLAY) <> 0)); + end; + + function TMetafileHeader.GetWmfHeader: PMetaHeader; + begin + if IsWmf then result := @Header.WmfHeader + else result := nil; + end; + + function TMetafileHeader.GetEmfHeader: PENHMETAHEADER3; + begin + if IsEmfOrEmfPlus then result := @Header.EmfHeader + else result := nil; + end; + +// 추가 23_0103 16:07:46 kku +function GetEncoderClsid(sFormat: String; var aClsid: TGuid): Boolean; +var + st: TStatus; + dwNum, dwSize: DWORD; + pEnum, + pImgCodecInfo: PImageCodecInfo; + i: Integer; +begin + Result := false; + + st := GdipGetImageEncodersSize(dwNum, dwSize); + if st <> TStatus.Ok then + exit; + + pImgCodecInfo := AllocMem(dwSize); + try + st := GdipGetImageEncoders(dwNum, dwSize, pImgCodecInfo); + if st <> TStatus.Ok then + exit; + + for i := 0 to Integer(dwNum) - 1 do + begin + pEnum := PImageCodecInfo(LONGLONG(pImgCodecInfo) + (i * SizeOf(TImageCodecInfo))); + if CompareText(pEnum.MimeType, sFormat) = 0 then + begin + aClsid := pEnum.Clsid; + Result := true; + exit; + end; + end; + finally + FreeMem(pImgCodecInfo); + end; +end; + +end. + + diff --git a/Tocsg.Lib/VCL/Other/EM.GSStorage.pas b/Tocsg.Lib/VCL/Other/EM.GSStorage.pas new file mode 100644 index 00000000..32936eb2 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.GSStorage.pas @@ -0,0 +1,1045 @@ +//////////////////////////////////////////////////////////////////////////////// +// +// **************************************************************************** +// * Unit Name : GSStorage +// * Purpose : ??? (Com Storage) +// * Author : ? +// * Copyright : ??2001 - 2005 ? +// * Version : 1.34 +// **************************************************************************** +// + +unit EM.GSStorage; + +interface + +uses + WinApi.Windows, Classes, WinApi.ActiveX, AxCtrls, SysUtils, WinAPi.ShlObj; + +const + CLRF = #13#10; + +type + TStatStgEx = record + pwcsName: String[30]; + dwType: Longint; + end; + + TStatStgArray = array of TStatStgEx; + TGSStorageEnum = packed record + Count: Cardinal; + ElementEnum: TStatStgArray; + end; + + GSCustomStorageException = class(Exception); + TGSStorageCursors = class; + TGSCustomStorage = class; + TGSStorage = class; + + TGSStorageCursor = class(TCollectionItem) + private + FLockCount: Integer; + FID: ShortString; + FStorageInterface: IStorage; + FSubStorage: TGSStorageCursors; + FMode: Longint; + FOwner: TGSCustomStorage; + FParent: TGSStorageCursor; + procedure SetParam(const AOwner: TGSCustomStorage; + AParent: TGSStorageCursor); + function GetPath: String; + function GetLock: Boolean; + function GetLockCount: Integer; + procedure Lock; + procedure UnLock; + property Locked: Boolean read GetLock; + {$IFDEF CLASS_INSTANCE} + class procedure AddInstance; + class procedure ReleaseInstance; + {$ENDIF} + protected + procedure Garbage; + function ExistsObject(const AName: String; const AType: Longint; + var Exists: Boolean): Boolean; + function GetName: String; + public + {$IFDEF CLASS_INSTANCE} + class function NumOfInstances: Integer; + {$ENDIF} + function Backward(var ACursor: TGSStorageCursor): Boolean; + constructor Create(Collection: TCollection); override; + function CreateStream(const AName: String): HRESULT; + function CreateStorage(const AName: String; + var ACursor: TGSStorageCursor): HRESULT; + function Copy(const AName: String; + const ACursor: TGSStorageCursor): HRESULT; + function DeleteStream(const AName: String): HRESULT; + function DeleteStorage(const AName: String): HRESULT; + destructor Destroy; override; + function Enumerate(var AData: TGSStorageEnum): HRESULT; + procedure FreeMemAfterEnum(var AData: TGSStorageEnum); + function FlushBuffer: HRESULT; + function MoveTo(const AName: String; + const ACursor: TGSStorageCursor): HRESULT; + function OpenStorage(const AName: String; + var ACursor: TGSStorageCursor; Verify: Boolean = True): HRESULT; + function StreamExists(const AName: String): Boolean; + function StorageExists(const AName: String): Boolean; +// function ReadStream(const AName: String; +// var AStream: TStream; Verify: Boolean = True): HRESULT; + function ReadStream(const AName: String; + AStream: TStream; Verify: Boolean = True): HRESULT; + function Rename(const AName, ANewName: String): HRESULT; + function WriteStream(const AName: String; const AStream: TMemoryStream): HRESULT; + procedure Release; + property Path: String read GetPath; + property Storages: TGSStorageCursors read FSubStorage; + end; + + TGSStorageCursors = class(TCollection) + private + function GetItem(Index: Integer): TGSStorageCursor; + procedure SetItem(Index: Integer; const Value: TGSStorageCursor); + function Add: TGSStorageCursor; + {$IFDEF CLASS_INSTANCE} + class procedure AddInstance; + class procedure ReleaseInstance; + {$ENDIF} + protected + function FindStorageByName( + const AName: String; var Index: Cardinal): Boolean; + public + {$IFDEF CLASS_INSTANCE} + class function NumOfInstances: Integer; + {$ENDIF} + constructor Create; + destructor Destroy; override; + property Items[Index: Integer]: TGSStorageCursor read GetItem write SetItem; default; + end; + + TGSCustomStorage = class(TPersistent) + private + FRootStorage: TGSStorageCursor; + FMode: Longint; + FFileName: String; + FCanCreate: Boolean; + function GetActive: Boolean; + {$IFDEF CLASS_INSTANCE} + class procedure AddInstance; + class procedure ReleaseInstance; + {$ENDIF} + protected + function OpenFileEx(const AFileName: String; + const CanCreate: Boolean; const AMode: LongInt; + var ACursor: TGSStorageCursor): HRESULT; + procedure Garbage; + class function ClassSupport(const AFileName: String; Change: Boolean): HRESULT; + public + {$IFDEF CLASS_INSTANCE} + class function NumOfInstances: Integer; + constructor Create; + {$ENDIF} + destructor Destroy; override; + function CreateCursor: TGSStorageCursor; + function ForceStorage(APath: String; var ACursor: TGSStorageCursor): HRESULT; + function OpenFileReadOnly(const AFileName: String; + var ACursor: TGSStorageCursor): HRESULT; + function OpenFile(const AFileName: String; + const CanCreate: Boolean; var ACursor: TGSStorageCursor): HRESULT; + function OpenStorage(APath: String; var ACursor: TGSStorageCursor): HRESULT; + procedure CloseFile; + function IsBussy: Boolean; + function ReConnect(var AStorage: TGSStorage; + var ACursor: TGSStorageCursor): HRESULT; + class function Compress(const AFileName: String): HRESULT; + class function IsStgValidBinaryFmt(const AFileName: String): HRESULT; + property Active: Boolean read GetActive; + end; + + TGSStorage = class(TGSCustomStorage); + + { TGInfoStorage = class(TGSCustomStorage) + public + function WriteInteger + end; } + +implementation + +uses Variants, System.Win.ComObj; + +{$IFDEF CLASS_INSTANCE} +var + TGSCustomStorage_Instance: Integer = 0; + TGSStorageCursor_Instance: Integer = 0; + TGSStorageCursors_Instance: Integer = 0; +{$ENDIF} + +{ TGSStorage } + +// Storage +// ============================================================================= +procedure TGSCustomStorage.CloseFile; +begin + if Assigned(FRootStorage) then + begin + FreeAndNil(FRootStorage); + {$IFDEF CREATE_FREE_LOG} + CreateFreeLog(False, 'TGSCustomStorage.FRootStorage'); + {$ENDIF} + end; +end; + +function TGSCustomStorage.CreateCursor: TGSStorageCursor; +begin + if FRootStorage = nil then + begin + Result := nil; + Exit; + end; + Result := FRootStorage; +end; + +destructor TGSCustomStorage.Destroy; +begin + if Assigned(FRootStorage) then + FRootStorage.Free; + {$IFDEF CREATE_FREE_LOG} + CreateFreeLog(False, 'TGSCustomStorage.FRootStorage'); + {$ENDIF} + + {$IFDEF CLASS_INSTANCE} + ReleaseInstance; + {$ENDIF} + inherited; +end; + + +function TGSCustomStorage.IsBussy: Boolean; +var + LocCount: Integer; +begin + LocCount := 0; + Inc(LocCount, FRootStorage.GetLockCount); + Result := LocCount > 1; +end; + + +function TGSCustomStorage.ReConnect(var AStorage: TGSStorage; + var ACursor: TGSStorageCursor): HRESULT; +begin + AStorage.CloseFile; + Result := AStorage.OpenFileEx(FFileName, FCanCreate, FMode, ACursor); +end; + + +// ForceDirectory +// ============================================================================= +function TGSCustomStorage.ForceStorage(APath: String; + var ACursor: TGSStorageCursor): HRESULT; +var + S: TStringList; + I: Integer; +begin + Result := S_FALSE; + if APath = '' then + raise Exception.Create(SysErrorMessage(ERROR_INVALID_PARAMETER)); + S := TStringList.Create; + try + ACursor := FRootStorage; + if ACursor.GetName + '\' <> Copy(APath, 1, Length(ACursor.GetName) + 1) then + begin + Result := ERROR_PATH_NOT_FOUND; + Exit; + end; + Delete(APath, 1, Length(ACursor.GetName) + 1); + S.Text := StringReplace(APath, '\', CLRF, [rfReplaceAll]); + for I := 0 to S.Count - 1 do + begin + if ACursor.StorageExists(S.Strings[I]) then + Result := ACursor.OpenStorage(S.Strings[I], ACursor) + else + Result := ACursor.CreateStorage(S.Strings[I], ACursor); + if Result <> S_OK then + begin + FRootStorage.Garbage; + Exit; + end; + end; + finally + S.Free; + end; +end; + +procedure TGSCustomStorage.Garbage; +begin + if FRootStorage <> nil then + FRootStorage.Garbage; +end; + + +// ?(???? +// ============================================================================= +function TGSCustomStorage.OpenFile(const AFileName: String; + const CanCreate: Boolean; var ACursor: TGSStorageCursor): HRESULT; +begin + Result := OpenFileEx(AFileName, CanCreate, + STGM_READWRITE or STGM_SHARE_EXCLUSIVE, ACursor); +end; + + +// ? ? ? +// ============================================================================= +function TGSCustomStorage.OpenFileEx(const AFileName: String; + const CanCreate: Boolean; const AMode: LongInt; + var ACursor: TGSStorageCursor): HRESULT; +begin + FMode := AMode; + FCanCreate := CanCreate; + FFileName := AFileName; + CloseFile; + FRootStorage := TGSStorageCursor.Create(nil); + {$IFDEF CREATE_FREE_LOG} + CreateFreeLog(True, 'TGSCustomStorage.FRootStorage'); + {$ENDIF} + if CanCreate then + begin + ACursor := FRootStorage; + ACursor.SetParam(Self, nil); + Result := StgCreateDocfile(StringToOleStr(AFileName), FMode or STGM_CREATE, 0, + ACursor.FStorageInterface); + {$IFDEF CREATE_FREE_LOG} + CreateFreeLog(True, 'TGSCustomStorage.ACursor.FStorageInterface = ' + IntToStr(Integer(ACursor.FStorageInterface))); + {$ENDIF} + ACursor.Lock; + end + else + begin + if not FileExists(AFileName) then + begin + Result := ERROR_FILE_NOT_FOUND; + Exit; + end; + Result := StgIsStorageFile(StringToOleStr(AFileName)); + if Result <> S_OK then Exit; + ACursor := FRootStorage; + ACursor.SetParam(Self, nil); + Result := StgOpenStorage(StringToOleStr(AFileName), + nil, FMode, nil, 0, ACursor.FStorageInterface); + {$IFDEF CREATE_FREE_LOG} + CreateFreeLog(True, 'TGSCustomStorage.ACursor.FStorageInterface = ' + IntToStr(Integer(ACursor.FStorageInterface))); + {$ENDIF} + ACursor.Lock; + end; +end; + + +function TGSCustomStorage.OpenStorage(APath: String; + var ACursor: TGSStorageCursor): HRESULT; +var + S: TStringList; + I: Integer; +begin + Result := S_FALSE; + if APath = '' then + raise Exception.Create(SysErrorMessage(ERROR_INVALID_PARAMETER)); + S := TStringList.Create; + try + ACursor := FRootStorage; + if APath[Length(APath)] <> '\' then APath := APath + '\'; + if ACursor.GetName + '\' <> Copy(APath, 1, Length(ACursor.GetName) + 1) then + begin + Result := ERROR_PATH_NOT_FOUND; + Exit; + end; + Delete(APath, 1, Length(ACursor.GetName) + 1); + S.Text := StringReplace(APath, '\', CLRF, [rfReplaceAll]); + for I := 0 to S.Count - 1 do + if ACursor.StorageExists(S.Strings[I]) then + begin + if ACursor.OpenStorage(S.Strings[I], ACursor) <> S_OK then Exit + end + else + raise Exception.Create(SysErrorMessage(ERROR_PATH_NOT_FOUND)); + Result := S_OK; + finally + S.Free; + end; +end; + + +// ?? ? +// ============================================================================= +function TGSCustomStorage.OpenFileReadOnly( + const AFileName: String; var ACursor: TGSStorageCursor): HRESULT; +begin + Result := OpenFileEx(AFileName, False, STGM_READ or STGM_SHARE_EXCLUSIVE, + ACursor); +end; + +{ TGSStorageCursors } + +function TGSStorageCursors.Add: TGSStorageCursor; +begin + Result := TGSStorageCursor(inherited Add); +end; + +{$IFDEF CLASS_INSTANCE} +class procedure TGSStorageCursors.AddInstance; +begin + Inc(TGSStorageCursors_Instance); +end; +{$ENDIF} + +constructor TGSStorageCursors.Create; +begin + inherited Create(TGSStorageCursor); + {$IFDEF CLASS_INSTANCE} + AddInstance; + {$ENDIF} +end; + +destructor TGSStorageCursors.Destroy; +begin + {$IFDEF CLASS_INSTANCE} + ReleaseInstance; + {$ENDIF} + inherited; +end; + + +// ??Storage ? +// ============================================================================= +function TGSStorageCursors.FindStorageByName( + const AName: String; var Index: Cardinal): Boolean; +var + I: Cardinal; +begin + Result := False; + Index := 0; + if Count = 0 then Exit; + for I := 0 to Count - 1 do + if Items[I].GetName = AName then + begin + Result := True; + Index := I; + Break; + end; +end; + +function TGSStorageCursors.GetItem(Index: Integer): TGSStorageCursor; +begin + Result := TGSStorageCursor(inherited GetItem(Index)); +end; + +{$IFDEF CLASS_INSTANCE} +class function TGSStorageCursors.NumOfInstances: Integer; +begin + Result := TGSStorageCursors_Instance; +end; + +class procedure TGSStorageCursors.ReleaseInstance; +begin + Dec(TGSStorageCursors_Instance); +end; +{$ENDIF} + +procedure TGSStorageCursors.SetItem(Index: Integer; + const Value: TGSStorageCursor); +begin + inherited SetItem(Index, Value); +end; + +{ TGSStorageCursor } + +{$IFDEF CLASS_INSTANCE} +class procedure TGSStorageCursor.AddInstance; +begin + Inc(TGSStorageCursor_Instance); +end; +{$ENDIF} + +// +// ============================================================================= +function TGSStorageCursor.Backward(var ACursor: TGSStorageCursor): Boolean; +begin + Result := FParent <> nil; + if Result then + begin + UnLock; + ACursor := FParent; + ACursor.Lock; + if not Locked then + Self.Free; + end; +end; + +function TGSStorageCursor.Copy(const AName: String; + const ACursor: TGSStorageCursor): HRESULT; +begin + if ACursor = nil then + raise EComponentError.Create('TGSStorageCursor.Copy() >> "ACursor = nil"');//SysErrorMessage(E_INVALIDARG)); + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.Copy() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + //Result := FStorageInterface.CopyTo(0, nil, nil, ACursor.FStorageInterface); + Result := FStorageInterface.MoveElementTo(StringToOleStr(AName), + ACursor.FStorageInterface, StringToOleStr(AName), STGMOVE_COPY); +end; + +constructor TGSStorageCursor.Create(Collection: TCollection); +var + ID: TGUID; +begin + inherited; + {$IFDEF CLASS_INSTANCE} + AddInstance; + {$ENDIF} + FSubStorage := TGSStorageCursors.Create; + (*{$IFDEF CREATE_FREE_LOG} + CreateFreeLog(True, 'TGSStorageCursor - ?); + CreateFreeLog(True, 'TGSStorageCursor.ACursor.FSubStorage'); + {$ENDIF}*) + FLockCount := 0; + if CreateGUID(ID) <> S_OK then + raise EComponentError.Create('TGSStorageCursor.Create() >> "CreateGUID(ID) <> S_OK"');//SysErrorMessage(E_UNEXPECTED)); + FID := GUIDToString(ID); +end; + +function TGSStorageCursor.CreateStorage(const AName: String; + var ACursor: TGSStorageCursor): HRESULT; +var + Index: Cardinal; +begin +{ if ACursor = nil then + raise EComponentError.Create(SysErrorMessage(E_INVALIDARG));} + if FSubStorage.FindStorageByName(AName, Index) then + begin + Result := ERROR_ALREADY_EXISTS; + Exit; + end; + ACursor := FSubStorage.Add; + ACursor.SetParam(FOwner, Self); + Result := FStorageInterface.CreateStorage(StringToOleStr(AName), + FMode, 0, 0, ACursor.FStorageInterface); + {$IFDEF CREATE_FREE_LOG} + CreateFreeLog(True, 'TGSStorageCursor.ACursor.FStorageInterface = ' + IntToStr(Integer(ACursor.FStorageInterface))); + {$ENDIF} + ACursor.Lock; +end; + +function TGSStorageCursor.CreateStream(const AName: String): HRESULT; +var + TmpStream:IStream; +begin + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.CreateStream( >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + Result := FStorageInterface.CreateStream(StringToOleStr(AName), + FMode, 0, 0, TmpStream); + TmpStream := nil; +end; + +function TGSStorageCursor.DeleteStorage(const AName: String): HRESULT; +var + Index: Cardinal; +begin + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.DeleteStorage() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + if FSubStorage.FindStorageByName(AName, Index) then + begin + { TODO : - ??? } + {if FSubStorage.Items[Index].Locked then + raise EComponentError.Create(SysErrorMessage(ERROR_ACCESS_DENIED)); } + FSubStorage.Delete(Index); + end; + Result := FStorageInterface.DestroyElement(StringToOleStr(AName)); +end; + +function TGSStorageCursor.DeleteStream(const AName: String): HRESULT; +begin + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.DeleteStream() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + Result := FStorageInterface.DestroyElement(StringToOleStr(AName)); +end; + +destructor TGSStorageCursor.Destroy; +begin + {$IFDEF CREATE_FREE_LOG} + //CreateFreeLog(False, 'TGSStorageCursor - '); + //CreateFreeLog(False, 'TGSStorageCursor.ACursor.FSubStorage'); + CreateFreeLog(False, 'TGSStorageCursor.FStorageInterface = ' + IntToStr(Integer(FStorageInterface))); + {$ENDIF} + FStorageInterface := nil; + FreeAndNil(FSubStorage); + {$IFDEF CLASS_INSTANCE} + ReleaseInstance; + {$ENDIF} + inherited; +end; + +function TGSStorageCursor.Enumerate(var AData: TGSStorageEnum): HRESULT; +var + Enum: IEnumStatStg; + TmpElement: TStatStg; + ShellMalloc: IMalloc; + Fetched: Int64; +begin + if (CoGetMalloc(1, ShellMalloc) <> S_OK) or (ShellMalloc = nil) then + raise EComponentError.Create('CoGetMalloc failed.'); + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.Enumerate() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + Result := FStorageInterface.EnumElements(0, nil, 0, Enum); + if Result = S_OK then + begin + AData.Count := 0; + ZeroMemory(@AData, SizeOf(AData)); + Fetched := 1; + while Fetched > 0 do + if Enum.Next(1, TmpElement, @Fetched) = S_OK then + if ShellMalloc.DidAlloc(TmpElement.pwcsName) = 1 then + begin + Inc(AData.Count); + SetLength(AData.ElementEnum, AData.Count); + AData.ElementEnum[AData.Count - 1].pwcsName := String(TmpElement.pwcsName); + ShellMalloc.Free(TmpElement.pwcsName); + AData.ElementEnum[AData.Count - 1].dwType := TmpElement.dwType; + end; + end; + Enum := nil; +end; + +function TGSStorageCursor.ExistsObject(const AName: String; const AType: Longint; + var Exists: Boolean): Boolean; +var + I: Integer; + Data: TGSStorageEnum; +begin + Data.Count := 0; + Result := Enumerate(Data) = S_OK; + try + Exists := False; + if Result then + if Data.Count > 0 then + for I := 0 to Data.Count - 1 do + begin + if Data.ElementEnum[I].pwcsName = AName then + begin + Exists := Data.ElementEnum[I].dwType = AType; + Exit; + end; + end; + finally + //FreeMemAfterEnum(Data); + end; +end; + +function TGSStorageCursor.FlushBuffer: HRESULT; +begin + Result := FStorageInterface.Commit(STGC_DEFAULT); +end; + +procedure TGSStorageCursor.FreeMemAfterEnum(var AData: TGSStorageEnum); +{var + I: Integer;} +begin +// for I := 0 to AData.Count - 1 do +// FreeMem(AData.ElementEnum[I].pwcsName); + AData.Count := 0; + SetLength(AData.ElementEnum, 0); +end; + +procedure TGSStorageCursor.Garbage; +var + I: Integer; +begin + if FSubStorage = nil then Exit; + if FSubStorage.Count > 0 then + for I := 0 to FSubStorage.Count - 1 do + begin + FSubStorage.Items[I].Garbage; + if not FSubStorage.Items[I].Locked then + FSubStorage.Items[I].Free; + end; +end; + +function TGSStorageCursor.GetLock: Boolean; +var + I: Integer; +begin + Result := FLockCount > 0; + if not Result then + if FSubStorage.Count > 0 then + for I := 0 to FSubStorage.Count - 1 do + if FSubStorage.Items[I].Locked then + begin + Result := True; + Break; + end; +end; + +function TGSStorageCursor.GetLockCount: Integer; +var + I: Integer; +begin + Result := FLockCount; + if FSubStorage.Count > 0 then + for I := 0 to FSubStorage.Count - 1 do + Inc(Result, FSubStorage.Items[I].GetLockCount); +end; + +function TGSStorageCursor.GetName: String; +var + Error: HRESULT; + StatStg: TStatStg; + ShellMalloc: IMalloc; +begin + Result := ''; + if (CoGetMalloc(1, ShellMalloc) <> S_OK) or (ShellMalloc = nil) then + raise EComponentError.Create('CoGetMalloc failed.'); + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.GetName() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + Error := FStorageInterface.Stat(StatStg, STATFLAG_DEFAULT); + if Error <> S_OK then + raise Exception.Create('TGSStorageCursor.GetName() >> "Error <> S_OK"');//SysErrorMessage(Error)); + if ShellMalloc.DidAlloc(StatStg.pwcsName) = 1 then + begin + Result := String(StatStg.pwcsName); + ShellMalloc.Free(StatStg.pwcsName); + end; +end; + +function TGSStorageCursor.GetPath: String; +begin + if FParent = nil then + Result := GetName + else + Result := FParent.GetPath + '\' + GetName; +end; + +procedure TGSStorageCursor.Lock; +begin + Inc(FLockCount); +end; + +function TGSStorageCursor.MoveTo(const AName: String; + const ACursor: TGSStorageCursor): HRESULT; +var + Index: Cardinal; +begin + if ACursor = nil then + raise EComponentError.Create('TGSStorageCursor.MoveTo() >> "ACursor = nil"');//SysErrorMessage(E_INVALIDARG)); + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.MoveTo() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + if FSubStorage.FindStorageByName(AName, Index) then + Result := E_ACCESSDENIED + else + Result := FStorageInterface.MoveElementTo(StringToOleStr(AName), + ACursor.FStorageInterface, StringToOleStr(AName), STGMOVE_MOVE); +end; + +{$IFDEF CLASS_INSTANCE} +class function TGSStorageCursor.NumOfInstances: Integer; +begin + Result := TGSStorageCursor_Instance; +end; +{$ENDIF} + +function TGSStorageCursor.OpenStorage(const AName: String; + var ACursor: TGSStorageCursor; Verify: Boolean = True): HRESULT; +var + Index: Cardinal; +begin + //if ACursor = nil then + //raise EComponentError.Create(SysErrorMessage(E_INVALIDARG)); + if fSubStorage.FindStorageByName(AName, Index) then + begin + Result := S_OK; + ACursor := FSubStorage.Items[Index]; + ACursor.Lock; + Exit; + end; + + if Verify then + if not StorageExists(AName) then + raise EComponentError.Create(SysErrorMessage(ERROR_PATH_NOT_FOUND)); + + if ACursor <> nil then + if ACursor.FID = FID then UnLock; + + ACursor := FSubStorage.Add; + ACursor.SetParam(FOwner, Self); + + Result := FStorageInterface.OpenStorage(StringToOleStr(AName), + nil, FMode, nil, 0, ACursor.FStorageInterface); + {$IFDEF CREATE_FREE_LOG} + CreateFreeLog(True, 'TGSCustomStorage.ACursor.FStorageInterface = ' + IntToStr(Integer(ACursor.FStorageInterface))); + {$ENDIF} + ACursor.Lock; +end; + +// ? ? = ? S_OK AStream <> nil +//function TGSStorageCursor.ReadStream(const AName: String; +// var AStream: TStream; Verify: Boolean = True): HRESULT; + +// Ʈ Լ ʰ 18_1123 15:53:21 sunk +function TGSStorageCursor.ReadStream(const AName: String; + AStream: TStream; Verify: Boolean = True): HRESULT; +var + TmpStream:IStream; + OS:TOleStream; + Buff: array of Byte; + I, Err: Integer; + + procedure DoReadAnything; + begin + { DONE : ?, ??AStream ??!!! } + // ? + + + // ? ?... + SetLength(Buff, OS.Size); + Err := 0; + I := 0; + OS.Position := 0; + while I < OS.Size do + try + OS.Read(Buff[I - Err], 1); + Inc(I); + except + Break; + end; + AStream.Write(Buff[0], I); + end; + +begin +// AStream := nil; + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.ReadStream() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + if Verify then + begin + if StreamExists(AName) then + Result := FStorageInterface.OpenStream(StringToOleStr(AName), + nil, FMode, 0, TmpStream) + else + raise EComponentError.Create('TGSStorageCursor.ReadStream() >> "StreamExists(AName) = false"');//SysErrorMessage(ERROR_PATH_NOT_FOUND)); + end + else + Result := FStorageInterface.OpenStream(StringToOleStr(AName), + nil, FMode, 0, TmpStream); + if Result = S_OK then + begin +// AStream := TMemoryStream.Create; + AStream.Position := 0; + OS := TOleStream.Create(TmpStream); + try + OS.Position := 0; + try + AStream.CopyFrom(OS, OS.Size); + except + on E: EOleException do + begin + Result := E.ErrorCode; + DoReadAnything; + Exit; + end; + on E: Exception do + begin + Result := S_FALSE; + DoReadAnything; + end; + end; + AStream.Position := 0; + finally + OS.Free; + TmpStream := nil; + end; + end; +end; + +procedure TGSStorageCursor.Release; +begin + if FID = FOwner.FRootStorage.FID then Exit; + Free; + FOwner.Garbage; +end; + +{$IFDEF CLASS_INSTANCE} +class procedure TGSStorageCursor.ReleaseInstance; +begin + Dec(TGSStorageCursor_Instance); +end; +{$ENDIF} + +function TGSStorageCursor.Rename(const AName, ANewName: String): HRESULT; +begin + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.Rename() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + Garbage; + Result := FStorageInterface.RenameElement(StringToOleStr(AName), + StringToOleStr(ANewName)); +end; + +procedure TGSStorageCursor.SetParam(const AOwner: TGSCustomStorage; + AParent: TGSStorageCursor); +begin + FMode := AOwner.FMode; + FOwner := AOwner; + FParent := AParent; +end; + +function TGSStorageCursor.StorageExists(const AName: String): Boolean; +var + Exists: Boolean; +begin + Result := False; + if ExistsObject(AName, STGTY_STORAGE, Exists) then + Result := Exists; +end; + +function TGSStorageCursor.StreamExists(const AName: String): Boolean; +var + Exists: Boolean; +begin + Result := False; + if ExistsObject(AName, STGTY_STREAM, Exists) then + Result := Exists; +end; + +procedure TGSStorageCursor.UnLock; +begin + Dec(FLockCount); +end; + +function TGSStorageCursor.WriteStream(const AName: String; + const AStream: TMemoryStream): HRESULT; +var + TmpStream:IStream; + OS:TOleStream; +begin + if FStorageInterface = nil then + raise EComponentError.Create('TGSStorageCursor.WriteStream() >> " FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED)); + if StreamExists(AName) then + Result := FStorageInterface.OpenStream(StringToOleStr(AName), + nil, FMode, 0, TmpStream) + else + begin + // ?? ??? + // ?? ? - ? ? + Result := FStorageInterface.CreateStream(StringToOleStr(AName), + FMode, 0, 0, TmpStream); + if Result <> S_OK then + begin + FStorageInterface.DestroyElement(StringToOleStr(AName)); + Result := FStorageInterface.CreateStream(StringToOleStr(AName), + FMode, 0, 0, TmpStream); + end; + end; + if Result = S_OK then + begin + { TODO : ?TmpStream ? } + OS := TOleStream.Create(TmpStream); + try + AStream.Position := 0; + OS.CopyFrom(AStream, AStream.Size); + finally + OS.Free; + TmpStream := nil; + end; + end; +end; + +class function TGSCustomStorage.Compress(const AFileName: String): HRESULT; +begin + Result := ClassSupport(AFileName, True); +end; + +class function TGSCustomStorage.IsStgValidBinaryFmt( + const AFileName: String): HRESULT; +begin + Result := ClassSupport(AFileName, False); +end; + +class function TGSCustomStorage.ClassSupport(const AFileName: String; + Change: Boolean): HRESULT; +var + Src, Dest: IStorage; +begin + Result := S_FALSE; + if not FileExists(AFileName) then Exit; + Result := StgOpenStorage(StringToOleStr(AFileName), nil, + STGM_READ or STGM_SHARE_EXCLUSIVE, nil, 0, Src); + if Result = S_OK then + try + Result := StgCreateDocfile(StringToOleStr(String(AFileName) + '~'), + STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, Dest); + if Result = S_OK then + try + Result := Src.CopyTo(0, nil, nil, Dest); + finally + Dest := nil; + end; + finally + Src := nil; + if Result = S_OK then + begin + if Change then + begin + if Result = S_OK then + if not DeleteFile(AFileName) then + Result := S_FALSE + else + RenameFile(AFileName + '~', AFileName); + end else begin + if Result = S_OK then + if not DeleteFile(AFileName + '~') then + Result := S_FALSE + end; + end else + DeleteFile(AFileName + '~'); // ߰ 18_0726 15:11:38 sunk + end; +end; + +function TGSCustomStorage.GetActive: Boolean; +begin + Result := FRootStorage.FStorageInterface <> nil; +end; + +{$IFDEF CLASS_INSTANCE} +class procedure TGSCustomStorage.AddInstance; +begin + Inc(TGSCustomStorage_Instance); +end; + +constructor TGSCustomStorage.Create; +begin + AddInstance; +end; + +class function TGSCustomStorage.NumOfInstances: Integer; +begin + Result := TGSCustomStorage_Instance; +end; + +class procedure TGSCustomStorage.ReleaseInstance; +begin + Dec(TGSCustomStorage_Instance); +end; +{$ENDIF} + +{$IFDEF CLASS_INSTANCE} + +initialization + +finalization + + if TGSCustomStorage_Instance > 0 then + raise GSCustomStorageException.Create(Format('%d instances of TGSCustomStorage active', [TGSCustomStorage_Instance])); + + if TGSStorageCursor_Instance > 0 then + raise GSCustomStorageException.Create(Format('%d instances of TGSStorageCursor active', [TGSStorageCursor_Instance])); + + if TGSStorageCursors_Instance > 0 then + raise GSCustomStorageException.Create(Format('%d instances of TGSStorageCursors active', [TGSStorageCursors_Instance])); + +{$ENDIF} + +end. + diff --git a/Tocsg.Lib/VCL/Other/EM.JwaBthSdpDef.pas b/Tocsg.Lib/VCL/Other/EM.JwaBthSdpDef.pas new file mode 100644 index 00000000..ecf92999 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.JwaBthSdpDef.pas @@ -0,0 +1,192 @@ +{******************************************************************************} +{ } +{ BlueTooth API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Contributors: John Penman } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI } +{ APILIB home page, located at http://jedi-apilib.sourceforge.net } +{ } +{ 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. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License 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 LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + + +unit EM.JWaBthSdpDef; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "bthsdpdef.h"'} +{$HPPEMIT ''} + +//{$I jediapilib.inc} + +interface + +uses + EM.JwaWinType; + +type + SDP_LARGE_INTEGER_16 = record + LowPart: Int64; + HighPart: Int64; + end; + {$EXTERNALSYM SDP_LARGE_INTEGER_16} + PSDP_LARGE_INTEGER_16 = ^SDP_LARGE_INTEGER_16; + {$EXTERNALSYM PSDP_LARGE_INTEGER_16} + LPSDP_LARGE_INTEGER_16 = PSDP_LARGE_INTEGER_16; + {$EXTERNALSYM LPSDP_LARGE_INTEGER_16} + TSdpLargeInteger = SDP_LARGE_INTEGER_16; + PSdpLargeInteger = PSDP_LARGE_INTEGER_16; + + SDP_ULARGE_INTEGER_16 = record + LowPart: Int64; + HighPart: Int64; + end; + {$EXTERNALSYM SDP_ULARGE_INTEGER_16} + PSDP_ULARGE_INTEGER_16 = ^SDP_ULARGE_INTEGER_16; + {$EXTERNALSYM PSDP_ULARGE_INTEGER_16} + LPSDP_ULARGE_INTEGER_16 = PSDP_ULARGE_INTEGER_16; + {$EXTERNALSYM LPSDP_ULARGE_INTEGER_16} + TSdpULargeInteger16 = SDP_ULARGE_INTEGER_16; + PSdpULargeInteger16 = PSDP_ULARGE_INTEGER_16; + + NodeContainerType = (NodeContainerTypeSequence, NodeContainerTypeAlternative); + TNodeContainerType = NodeContainerType; + + SDP_ERROR = Word; + {$EXTERNALSYM SDP_ERROR} + PSDP_ERROR = ^SDP_ERROR; + {$EXTERNALSYM PSDP_ERROR} + TSdpError = SDP_ERROR; + PSdpError = PSDP_ERROR; + +type + SDP_TYPE = DWORD; + {$EXTERNALSYM SDP_TYPE} + TSdpType = SDP_TYPE; + +const + SDP_TYPE_NIL = $00; + {$EXTERNALSYM SDP_TYPE_NIL} + SDP_TYPE_UINT = $01; + {$EXTERNALSYM SDP_TYPE_UINT} + SDP_TYPE_INT = $02; + {$EXTERNALSYM SDP_TYPE_INT} + SDP_TYPE_UUID = $03; + {$EXTERNALSYM SDP_TYPE_UUID} + SDP_TYPE_STRING = $04; + {$EXTERNALSYM SDP_TYPE_STRING} + SDP_TYPE_BOOLEAN = $05; + {$EXTERNALSYM SDP_TYPE_BOOLEAN} + SDP_TYPE_SEQUENCE = $06; + {$EXTERNALSYM SDP_TYPE_SEQUENCE} + SDP_TYPE_ALTERNATIVE = $07; + {$EXTERNALSYM SDP_TYPE_ALTERNATIVE} + SDP_TYPE_URL = $08; + {$EXTERNALSYM SDP_TYPE_URL} + // 9 - 31 are reserved + SDP_TYPE_CONTAINER = $20; + {$EXTERNALSYM SDP_TYPE_CONTAINER} + +// allow for a little easier type checking / sizing for integers and UUIDs +// ((SDP_ST_XXX & 0xF0) >> 4) == SDP_TYPE_XXX +// size of the data (in bytes) is encoded as ((SDP_ST_XXX & 0xF0) >> 8) + +type + SDP_SPECIFICTYPE = DWORD; + {$EXTERNALSYM SDP_SPECIFICTYPE} + TSdpSpecificType = SDP_SPECIFICTYPE; + +const + SDP_ST_NONE = $0000; + {$EXTERNALSYM SDP_ST_NONE} + + SDP_ST_UINT8 = $0010; + {$EXTERNALSYM SDP_ST_UINT8} + SDP_ST_UINT16 = $0110; + {$EXTERNALSYM SDP_ST_UINT16} + SDP_ST_UINT32 = $0210; + {$EXTERNALSYM SDP_ST_UINT32} + SDP_ST_UINT64 = $0310; + {$EXTERNALSYM SDP_ST_UINT64} + SDP_ST_UINT128 = $0410; + {$EXTERNALSYM SDP_ST_UINT128} + + SDP_ST_INT8 = $0020; + {$EXTERNALSYM SDP_ST_INT8} + SDP_ST_INT16 = $0120; + {$EXTERNALSYM SDP_ST_INT16} + SDP_ST_INT32 = $0220; + {$EXTERNALSYM SDP_ST_INT32} + SDP_ST_INT64 = $0320; + {$EXTERNALSYM SDP_ST_INT64} + SDP_ST_INT128 = $0420; + {$EXTERNALSYM SDP_ST_INT128} + + SDP_ST_UUID16 = $0130; + {$EXTERNALSYM SDP_ST_UUID16} + SDP_ST_UUID32 = $0220; + {$EXTERNALSYM SDP_ST_UUID32} + SDP_ST_UUID128 = $0430; + {$EXTERNALSYM SDP_ST_UUID128} + +type + _SdpAttributeRange = record + minAttribute: Word; + maxAttribute: Word; + end; + {$EXTERNALSYM _SdpAttributeRange} + SdpAttributeRange = _SdpAttributeRange; + {$EXTERNALSYM SdpAttributeRange} + TSdpAttributeRange = SdpAttributeRange; + + SdpQueryUuidUnion = record + case Integer of + 0: (uuid128: TGUID); + 1: (uuid32: ULONG); + 2: (uuid16: Word); + end; + TSdpQueryUuidUnion = SdpQueryUuidUnion; + + _SdpQueryUuid = record + u: SdpQueryUuidUnion; + uuidType: Word; + end; + {$EXTERNALSYM _SdpQueryUuid} + SdpQueryUuid = _SdpQueryUuid; + {$EXTERNALSYM SdpQueryUuid} + TSdpQueryUuid = SdpQueryUuid; + +implementation + +end. + diff --git a/Tocsg.Lib/VCL/Other/EM.PdfiumCore.pas b/Tocsg.Lib/VCL/Other/EM.PdfiumCore.pas new file mode 100644 index 00000000..f7d481dc --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.PdfiumCore.pas @@ -0,0 +1,4121 @@ +unit EM.PdfiumCore; +{$IFDEF FPC} + {$MODE DelphiUnicode} +{$ENDIF FPC} +{$IFNDEF FPC} + {$A8,B-,E-,F-,G+,H+,I+,J-,K-,M-,N-,P+,Q-,R-,S-,T-,U-,V+,X+,Z1} + {$STRINGCHECKS OFF} +{$ENDIF ~FPC} +interface +{.$UNDEF MSWINDOWS} +uses + {$IFDEF MSWINDOWS} + Windows, //WinSpool, + {$ELSE} + {$IFDEF FPC} + LCLType, + {$ENDIF FPC} + ExtCtrls, // for TTimer + {$ENDIF MSWINDOWS} + Types, SysUtils, Classes, Contnrs, + EM.PdfiumLib; +const + // DIN A4 + PdfDefaultPageWidth = 595; + PdfDefaultPageHeight = 842; +type + EPdfException = class(Exception); + EPdfUnsupportedFeatureException = class(EPdfException); + EPdfArgumentOutOfRange = class(EPdfException); + TPdfUnsupportedFeatureHandler = procedure(nType: Integer; const Typ: string) of object; + TPdfDocument = class; + TPdfPage = class; + TPdfAttachmentList = class; + TPdfAnnotationList = class; + TPdfFormField = class; + TPdfAnnotation = class; + TPdfPoint = record + X, Y: Double; + procedure Offset(XOffset, YOffset: Double); + class function Empty: TPdfPoint; static; + end; + TPdfRect = record + private + function GetHeight: Double; inline; + function GetWidth: Double; inline; + procedure SetHeight(const Value: Double); inline; + procedure SetWidth(const Value: Double); inline; + public + property Width: Double read GetWidth write SetWidth; + property Height: Double read GetHeight write SetHeight; + procedure Offset(XOffset, YOffset: Double); + function PtIn(const Pt: TPdfPoint): Boolean; + class function New(Left, Top, Right, Bottom: Double): TPdfRect; static; + class function Empty: TPdfRect; static; + public + case Integer of + 0: (Left, Top, Right, Bottom: Double); + 1: (TopLeft: TPdfPoint; BottomRight: TPdfPoint); + end; + TPdfRectArray = array of TPdfRect; + TPdfFloatArray = array of FS_FLOAT; + TPdfDocumentCustomReadProc = function(Param: Pointer; Position: LongWord; Buffer: PByte; Size: LongWord): Boolean; + TPdfNamedActionType = ( + naPrint, + naNextPage, + naPrevPage, + naFirstPage, + naLastPage + ); + TPdfPageRenderOptionType = ( + proAnnotations, // Set if annotations are to be rendered. + proLCDOptimized, // Set if using text rendering optimized for LCD display. + proNoNativeText, // Don't use the native text output available on some platforms + proNoCatch, // Set if you don't want to catch exception. + proLimitedImageCacheSize, // Limit image cache size. + proForceHalftone, // Always use halftone for image stretching. + proPrinting, // Render for printing. + proReverseByteOrder // Set whether render in a reverse Byte order, this flag only enable when render to a bitmap. + ); + TPdfPageRenderOptions = set of TPdfPageRenderOptionType; + TPdfPageRotation = ( + prNormal = 0, + pr90Clockwise = 1, + pr180 = 2, + pr90CounterClockwide = 3 + ); + TPdfDocumentSaveOption = ( + dsoIncremental = 1, + dsoNoIncremental = 2, + dsoRemoveSecurity = 3 + ); + TPdfDocumentLoadOption = ( + dloDefault, // load the file by using PDFium's file load mechanism (file stays open) + dloMemory, // load the whole file into memory + dloMMF, // load the file by using a memory mapped file (file stays open) + dloOnDemand // load the file using the custom load function (file stays open) + ); + TPdfDocumentPageMode = ( + dpmUnknown = -1, // Unknown value + dpmUseNone = 0, // Neither document outline nor thumbnail images visible + dpmUseOutlines = 1, // Document outline visible + dpmUseThumbs = 2, // Thumbnial images visible + dpmFullScreen = 3, // Full-screen mode, with no menu bar, window controls, or any other window visible + dpmUseOC = 4, // Optional content group panel visible + dpmUseAttachments = 5 // Attachments panel visible + ); + TPdfPrintMode = ( + pmEMF = FPDF_PRINTMODE_EMF, + pmTextMode = FPDF_PRINTMODE_TEXTONLY, + pmPostScript2 = FPDF_PRINTMODE_POSTSCRIPT2, + pmPostScript3 = FPDF_PRINTMODE_POSTSCRIPT3, + pmPostScriptPassThrough2 = FPDF_PRINTMODE_POSTSCRIPT2_PASSTHROUGH, + pmPostScriptPassThrough3 = FPDF_PRINTMODE_POSTSCRIPT3_PASSTHROUGH, + pmEMFImageMasks = FPDF_PRINTMODE_EMF_IMAGE_MASKS, + pmPostScript3Type42 = FPDF_PRINTMODE_POSTSCRIPT3_TYPE42, + pmPostScript3Type42PassThrough = FPDF_PRINTMODE_POSTSCRIPT3_TYPE42_PASSTHROUGH + ); + TPdfFileIdType = ( + pfiPermanent = 0, + pfiChanging = 1 + ); + TPdfBitmapFormat = ( + bfGrays = FPDFBitmap_Gray, // Gray scale bitmap, one byte per pixel. + bfBGR = FPDFBitmap_BGR, // 3 bytes per pixel, byte order: blue, green, red. + bfBGRx = FPDFBitmap_BGRx, // 4 bytes per pixel, byte order: blue, green, red, unused. + bfBGRA = FPDFBitmap_BGRA // 4 bytes per pixel, byte order: blue, green, red, alpha. + ); + TPdfFormFieldType = ( + fftUnknown = FPDF_FORMFIELD_UNKNOWN, + fftPushButton = FPDF_FORMFIELD_PUSHBUTTON, + fftCheckBox = FPDF_FORMFIELD_CHECKBOX, + fftRadioButton = FPDF_FORMFIELD_RADIOBUTTON, + fftComboBox = FPDF_FORMFIELD_COMBOBOX, + fftListBox = FPDF_FORMFIELD_LISTBOX, + fftTextField = FPDF_FORMFIELD_TEXTFIELD, + fftSignature = FPDF_FORMFIELD_SIGNATURE, + fftXFA = FPDF_FORMFIELD_XFA, + fftXFACheckBox = FPDF_FORMFIELD_XFA_CHECKBOX, + fftXFAComboBox = FPDF_FORMFIELD_XFA_COMBOBOX, + fftXFAImageField = FPDF_FORMFIELD_XFA_IMAGEFIELD, + fftXFAListBox = FPDF_FORMFIELD_XFA_LISTBOX, + fftXFAPushButton = FPDF_FORMFIELD_XFA_PUSHBUTTON, + fftXFASignature = FPDF_FORMFIELD_XFA_SIGNATURE, + fftXfaTextField = FPDF_FORMFIELD_XFA_TEXTFIELD + ); + TPdfFormFieldFlagsType = ( + fffReadOnly, + fffRequired, + fffNoExport, + fffTextMultiLine, + fffTextPassword, + fffChoiceCombo, + fffChoiceEdit, + fffChoiceMultiSelect + ); + TPdfFormFieldFlags = set of TPdfFormFieldFlagsType; + TPdfObjectType = ( + otUnknown = FPDF_OBJECT_UNKNOWN, + otBoolean = FPDF_OBJECT_BOOLEAN, + otNumber = FPDF_OBJECT_NUMBER, + otString = FPDF_OBJECT_STRING, + otName = FPDF_OBJECT_NAME, + otArray = FPDF_OBJECT_ARRAY, + otDictinary = FPDF_OBJECT_DICTIONARY, + otStream = FPDF_OBJECT_STREAM, + otNullObj = FPDF_OBJECT_NULLOBJ, + otReference = FPDF_OBJECT_REFERENCE + ); + TPdfAnnotationLinkType = ( + altUnsupported = PDFACTION_UNSUPPORTED, // Unsupported action type. + altGoto = PDFACTION_GOTO, // Go to a destination within current document. + altRemoteGoto = PDFACTION_REMOTEGOTO, // Go to a destination within another document. + altURI = PDFACTION_URI, // Universal Resource Identifier, including web pages and + // other Internet based resources. + altLaunch = PDFACTION_LAUNCH, // Launch an application or open a file. + altEmbeddedGoto = PDFACTION_EMBEDDEDGOTO // Go to a destination in an embedded file. + ); + TPdfLinkGotoDestinationViewKind = ( + lgdvUnknown = PDFDEST_VIEW_UNKNOWN_MODE, + lgdvXYZ = PDFDEST_VIEW_XYZ, + lgdvFit = PDFDEST_VIEW_FIT, + lgdvFitH = PDFDEST_VIEW_FITH, + lgdvFitV = PDFDEST_VIEW_FITV, + lgdvFitR = PDFDEST_VIEW_FITR, + lgdvFitB = PDFDEST_VIEW_FITB, + lgdvFitBH = PDFDEST_VIEW_FITBH, + lgdvFitBV = PDFDEST_VIEW_FITBV + ); + // Make the TObject.Create constructor private to hide it, so that the TPdfBitmap.Create + // overloads won't allow calling TObject.Create. + _TPdfBitmapHideCtor = class(TObject) + private + constructor Create; + end; + TPdfBitmap = class(_TPdfBitmapHideCtor) + private + FBitmap: FPDF_BITMAP; + FOwnsBitmap: Boolean; + FWidth: Integer; + FHeight: Integer; + FBytesPerScanLine: Integer; + public + constructor Create(ABitmap: FPDF_BITMAP; AOwnsBitmap: Boolean = False); overload; + constructor Create(AWidth, AHeight: Integer; AAlpha: Boolean); overload; + constructor Create(AWidth, AHeight: Integer; AFormat: TPdfBitmapFormat); overload; + constructor Create(AWidth, AHeight: Integer; AFormat: TPdfBitmapFormat; ABuffer: Pointer; ABytesPerScanline: Integer); overload; + destructor Destroy; override; + procedure FillRect(ALeft, ATop, AWidth, AHeight: Integer; AColor: FPDF_DWORD); + function GetBuffer: Pointer; + property Width: Integer read FWidth; + property Height: Integer read FHeight; + property BytesPerScanline: Integer read FBytesPerScanLine; + property Bitmap: FPDF_BITMAP read FBitmap; + end; + PPdfFormFillHandler = ^TPdfFormFillHandler; + TPdfFormFillHandler = record + FormFillInfo: FPDF_FORMFILLINFO; + Document: TPdfDocument; + end; + TPdfFormField = class(TObject) + private + FPage: TPdfPage; + FHandle: FPDF_ANNOTATION; + FAnnotation: TPdfAnnotation; + function GetFlags: TPdfFormFieldFlags; + function GetReadOnly: Boolean; + function GetName: string; + function GetAlternateName: string; + function GetFieldType: TPdfFormFieldType; + function GetValue: string; + function GetExportValue: string; + function GetOptionCount: Integer; + function GetOptionLabel(Index: Integer): string; + function GetChecked: Boolean; + function GetControlIndex: Integer; + function GetControlCount: Integer; + procedure SetValue(const Value: string); + procedure SetChecked(const Value: Boolean); + protected + constructor Create(AAnnotation: TPdfAnnotation); + function BeginEditFormField: FPDF_ANNOTATION; + procedure EndEditFormField(LastFocusedAnnot: FPDF_ANNOTATION); + public + destructor Destroy; override; + function IsXFAFormField: Boolean; + function IsOptionSelected(OptionIndex: Integer): Boolean; + function SelectComboBoxOption(OptionIndex: Integer): Boolean; + function SelectListBoxOption(OptionIndex: Integer; Selected: Boolean = True): Boolean; + property Flags: TPdfFormFieldFlags read GetFlags; + property ReadOnly: Boolean read GetReadOnly; + property Name: string read GetName; + property AlternateName: string read GetAlternateName; + property FieldType: TPdfFormFieldType read GetFieldType; + property Value: string read GetValue write SetValue; + property ExportValue: string read GetExportValue; + // ComboBox/ListBox + property OptionCount: Integer read GetOptionCount; + property OptionLabels[Index: Integer]: string read GetOptionLabel; + // CheckBox/RadioButton + property Checked: Boolean read GetChecked write SetChecked; + property ControlIndex: Integer read GetControlIndex; + property ControlCount: Integer read GetControlCount; + property Annotation: TPdfAnnotation read FAnnotation; + property Handle: FPDF_ANNOTATION read FHandle; + end; + TPdfFormFieldList = class(TObject) + private + FItems: TList; + function GetCount: Integer; + function GetItem(Index: Integer): TPdfFormField; + protected + procedure DestroyingItem(Item: TPdfFormField); + public + constructor Create(AAnnotations: TPdfAnnotationList); + destructor Destroy; override; + property Count: Integer read GetCount; + property Items[Index: Integer]: TPdfFormField read GetItem; default; + end; + TPdfLinkGotoDestination = class(TObject) + private + FPageIndex: Integer; + FXValid: Boolean; + FYValid: Boolean; + FZoomValid: Boolean; + FX: Single; + FY: Single; + FZoom: Single; + FViewKind: TPdfLinkGotoDestinationViewKind; + FViewParams: TPdfFloatArray; + public + constructor Create(APageIndex: Integer; AXValid, AYValid, AZoomValid: Boolean; AX, AY, AZoom: Single; + AViewKind: TPdfLinkGotoDestinationViewKind; const AViewParams: TPdfFloatArray); + property PageIndex: Integer read FPageIndex; + property XValid: Boolean read FXValid; + property YValid: Boolean read FYValid; + property ZoomValid: Boolean read FZoomValid; + property X: Single read FX; + property Y: Single read FY; + property Zoom: Single read FZoom; + property ViewKind: TPdfLinkGotoDestinationViewKind read FViewKind; + property ViewParams: TPdfFloatArray read FViewParams; + end; + TPdfAnnotation = class(TObject) + private + FPage: TPdfPage; + FHandle: FPDF_ANNOTATION; + FFormField: TPdfFormField; + FSubType: FPDF_ANNOTATION_SUBTYPE; + FLinkDest: FPDF_DEST; + FLinkType: TPdfAnnotationLinkType; + function GetPdfLinkAction: FPDF_ACTION; + function GetFormField: TPdfFormField; + function GetLinkUri: string; + function GetAnnotationRect: TPdfRect; + function GetLinkFileName: string; + protected + constructor Create(APage: TPdfPage; AHandle: FPDF_ANNOTATION); + public + destructor Destroy; override; + function IsFormField: Boolean; + function IsLink: Boolean; + function GetLinkGotoDestination(var LinkGotoDestination: TPdfLinkGotoDestination; ARemoteDocument: TPdfDocument = nil): Boolean; + // IsFormField: + property FormField: TPdfFormField read GetFormField; + // IsLink: + property LinkType: TPdfAnnotationLinkType read FLinkType; + property LinkUri: string read GetLinkUri; + property LinkFileName: string read GetLinkFileName; + property AnnotationRect: TPdfRect read GetAnnotationRect; + property Handle: FPDF_ANNOTATION read FHandle; + end; + TPdfAnnotationList = class(TObject) + private + FPage: TPdfPage; + FItems: TObjectList; + FFormFields: TPdfFormFieldList; + function GetCount: Integer; + function GetItem(Index: Integer): TPdfAnnotation; + function GetFormFields: TPdfFormFieldList; + function GetAnnotationsLoaded: Boolean; + protected + procedure DestroyingItem(Item: TPdfAnnotation); + procedure DestroyingFormField(FormField: TPdfFormField); + function FindLink(Link: FPDF_LINK): TPdfAnnotation; + public + constructor Create(APage: TPdfPage); + destructor Destroy; override; + procedure CloseAnnotations; + { NewTextAnnotation creates a new text annotation on the page. After adding one or more + annotations you must call Page.ApplyChanges to show them and make the persist before + saving the file. R is in page coordinates. } + function NewTextAnnotation(const Text: string; const R: TPdfRect): Boolean; {experimental;} + property AnnotationsLoaded: Boolean read GetAnnotationsLoaded; + property Count: Integer read GetCount; + property Items[Index: Integer]: TPdfAnnotation read GetItem; default; + { A list of all form field annotations } + property FormFields: TPdfFormFieldList read GetFormFields; + end; + TPdfLinkInfo = class(TObject) + private + FLinkAnnotation: TPdfAnnotation; + FWebLinkUrl: string; + function GetLinkFileName: string; + function GetLinkType: TPdfAnnotationLinkType; + function GetLinkUri: string; + public + constructor Create(ALinkAnnotation: TPdfAnnotation; const AWebLinkUrl: string); + function GetLinkGotoDestination(var LinkGotoDestination: TPdfLinkGotoDestination; ARemoteDocument: TPdfDocument = nil): Boolean; + function IsAnnontation: Boolean; + function IsWebLink: Boolean; + property LinkType: TPdfAnnotationLinkType read GetLinkType; + property LinkUri: string read GetLinkUri; + property LinkFileName: string read GetLinkFileName; + property LinkAnnotation: TPdfAnnotation read FLinkAnnotation; + end; + { TPdfPageWebLinksInfo caches all the WebLinks for one page. This makes the IsWebLinkAt() methods + much faster than always calling into the PDFium library. The URLs are not cached. } + TPdfPageWebLinksInfo = class(TObject) + private + FPage: TPdfPage; + FWebLinksRects: array of TPdfRectArray; + procedure GetPageWebLinks; + function GetWebLinkIndex(X, Y: Double): Integer; + function GetCount: Integer; + function GetRect(Index: Integer): TPdfRectArray; + function GetURL(Index: Integer): string; + public + constructor Create(APage: TPdfPage); + function IsWebLinkAt(X, Y: Double): Boolean; overload; + function IsWebLinkAt(X, Y: Double; var Url: string): Boolean; overload; + property Count: Integer read GetCount; + property URLs[Index: Integer]: string read GetURL; + property Rects[Index: Integer]: TPdfRectArray read GetRect; + end; + TPdfPage = class(TObject) + private + FDocument: TPdfDocument; + FPage: FPDF_PAGE; + FWidth: Single; + FHeight: Single; + FTransparency: Boolean; + FRotation: TPdfPageRotation; + FAnnotations: TPdfAnnotationList; + FTextHandle: FPDF_TEXTPAGE; + FSearchHandle: FPDF_SCHHANDLE; + FPageLinkHandle: FPDF_PAGELINK; + constructor Create(ADocument: TPdfDocument; APage: FPDF_PAGE); + procedure UpdateMetrics; + procedure Open; + procedure SetRotation(const Value: TPdfPageRotation); + function BeginText: Boolean; + function BeginWebLinks: Boolean; + class function GetDrawFlags(const Options: TPdfPageRenderOptions): Integer; static; + procedure AfterOpen; + function IsValidForm: Boolean; + function ShiftStateToModifier(const Shift: TShiftState): Integer; + function GetHandle: FPDF_PAGE; + function GetTextHandle: FPDF_TEXTPAGE; + function GetFormFields: TPdfFormFieldList; + protected + function GetPdfActionFilePath(Action: FPDF_ACTION): string; + function GetPdfActionUriPath(Action: FPDF_ACTION): string; + public + destructor Destroy; override; + procedure Close; + function IsLoaded: Boolean; + {$IFDEF MSWINDOWS} + // Draw the PDF page and the form into the device context. + procedure Draw(DC: HDC; X, Y, Width, Height: Integer; Rotate: TPdfPageRotation = prNormal; + const Options: TPdfPageRenderOptions = []; PageBackground: TColorRef = $FFFFFF); overload; + {$ENDIF MSWINDOWS} + // Draw the PDF page and the form into the bitmap. + procedure Draw(APdfBitmap: TPdfBitmap; X, Y, Width, Height: Integer; Rotate: TPdfPageRotation = prNormal; + const Options: TPdfPageRenderOptions = []; PageBackground: TColorRef = $FFFFFF); overload; + // Draw the PDF page without the form field values into the bitmap. + procedure DrawToPdfBitmap(APdfBitmap: TPdfBitmap; X, Y, Width, Height: Integer; Rotate: TPdfPageRotation = prNormal; + const Options: TPdfPageRenderOptions = []); + // Draw the PDF form field values into the bitmap. + procedure DrawFormToPdfBitmap(APdfBitmap: TPdfBitmap; X, Y, Width, Height: Integer; Rotate: TPdfPageRotation = prNormal; + const Options: TPdfPageRenderOptions = []); + function DeviceToPage(X, Y, Width, Height: Integer; DeviceX, DeviceY: Integer; Rotate: TPdfPageRotation = prNormal): TPdfPoint; overload; + function PageToDevice(X, Y, Width, Height: Integer; PageX, PageY: Double; Rotate: TPdfPageRotation = prNormal): TPoint; overload; + function DeviceToPage(X, Y, Width, Height: Integer; const R: TRect; Rotate: TPdfPageRotation = prNormal): TPdfRect; overload; + function PageToDevice(X, Y, Width, Height: Integer; const R: TPdfRect; Rotate: TPdfPageRotation = prNormal): TRect; overload; + procedure ApplyChanges; + procedure Flatten(AFlatPrint: Boolean); + function FormEventFocus(const Shift: TShiftState; PageX, PageY: Double): Boolean; + function FormEventMouseWheel(const Shift: TShiftState; WheelDelta: Integer; PageX, PageY: Double): Boolean; + function FormEventMouseMove(const Shift: TShiftState; PageX, PageY: Double): Boolean; + function FormEventLButtonDown(const Shift: TShiftState; PageX, PageY: Double): Boolean; + function FormEventLButtonUp(const Shift: TShiftState; PageX, PageY: Double): Boolean; + function FormEventRButtonDown(const Shift: TShiftState; PageX, PageY: Double): Boolean; + function FormEventRButtonUp(const Shift: TShiftState; PageX, PageY: Double): Boolean; + function FormEventKeyDown(KeyCode: Word; const Shift: TShiftState): Boolean; + function FormEventKeyUp(KeyCode: Word; const Shift: TShiftState): Boolean; + function FormEventKeyPress(Key: Word; const Shift: TShiftState): Boolean; + function FormEventKillFocus: Boolean; + function FormGetFocusedText: string; + function FormGetSelectedText: string; + function FormReplaceSelection(const ANewText: string): Boolean; + function FormReplaceAndKeepSelection(const ANewText: string): Boolean; + function FormSelectAllText: Boolean; + function FormCanUndo: Boolean; + function FormCanRedo: Boolean; + function FormUndo: Boolean; + function FormRedo: Boolean; + function BeginFind(const SearchString: string; MatchCase, MatchWholeWord: Boolean; FromEnd: Boolean): Boolean; + function FindNext(var CharIndex, Count: Integer): Boolean; + function FindPrev(var CharIndex, Count: Integer): Boolean; + procedure EndFind; + function GetCharCount: Integer; + function ReadChar(CharIndex: Integer): WideChar; + function GetCharFontSize(CharIndex: Integer): Double; + function GetCharBox(CharIndex: Integer): TPdfRect; + function GetCharIndexAt(PageX, PageY, ToleranceX, ToleranceY: Double): Integer; + function ReadText(CharIndex, Count: Integer): String; + function ReadText2(CharIndex, Count: Integer): String; + function GetTextAt(const R: TPdfRect): string; overload; + function GetTextAt(Left, Top, Right, Bottom: Double): string; overload; + function GetTextRectCount(CharIndex, Count: Integer): Integer; + function GetTextRect(RectIndex: Integer): TPdfRect; + function HasFormFieldAtPoint(X, Y: Double): TPdfFormFieldType; + { IsUriLinkAtPoint returns true if a Link annotation is at the specified coordinates. + X, Y are in page coordinates. } + function IsUriLinkAtPoint(X, Y: Double): Boolean; overload; + { IsUriLinkAtPoint returns true if a Link annotation is at the specified coordinates. If one is found + the Uri parameter is set to the link's URI. + X, Y are in page coordinates. } + function IsUriLinkAtPoint(X, Y: Double; var Uri: string): Boolean; overload; + { GetLinkAtPoint returns the link annotation for the specified coordinates. If no link annotation + was found it return nil. It not only returns Uri but also Goto, RemoteGoto, Launch, EmbeddedGoto + link annotations. } + function GetLinkAtPoint(X, Y: Double): TPdfAnnotation; + { WebLinks are URLs that are parsed from the PDFs text content. No link annotation exists + for them, so the IsUriLinkAtPoint and GetLinkAtPoint methods don't work for them. } + function GetWebLinkCount: Integer; + function GetWebLinkURL(LinkIndex: Integer): string; + function GetWebLinkRectCount(LinkIndex: Integer): Integer; + function GetWebLinkRect(LinkIndex, RectIndex: Integer): TPdfRect; + function IsWebLinkAtPoint(X, Y: Double): Boolean; overload; + function IsWebLinkAtPoint(X, Y: Double; var URL: string): Boolean; overload; + property Handle: FPDF_PAGE read GetHandle; + property TextHandle: FPDF_TEXTPAGE read GetTextHandle; + property Width: Single read FWidth; + property Height: Single read FHeight; + property Transparency: Boolean read FTransparency; + property Rotation: TPdfPageRotation read FRotation write SetRotation; + property Annotations: TPdfAnnotationList read FAnnotations; + property FormFields: TPdfFormFieldList read GetFormFields; + end; + TPdfFormInvalidateEvent = procedure(Document: TPdfDocument; Page: TPdfPage; const PageRect: TPdfRect) of object; + TPdfFormOutputSelectedRectEvent = procedure(Document: TPdfDocument; Page: TPdfPage; const PageRect: TPdfRect) of object; + TPdfFormGetCurrentPageEvent = procedure(Document: TPdfDocument; var CurrentPage: TPdfPage) of object; + TPdfFormFieldFocusEvent = procedure(Document: TPdfDocument; Value: PWideChar; ValueLen: Integer; FieldFocused: Boolean) of object; + TPdfExecuteNamedActionEvent = procedure(Document: TPdfDocument; NamedAction: TPdfNamedActionType) of object; + TPdfAttachment = record + private + FDocument: TPdfDocument; + FHandle: FPDF_ATTACHMENT; + procedure CheckValid; + function GetName: string; + function GetKeyValue(const Key: string): string; + procedure SetKeyValue(const Key, Value: string); + function GetContentSize: Integer; + public + // SetContent/LoadFromXxx clears the Values[] dictionary. + procedure SetContent(const ABytes: TBytes); overload; + procedure SetContent(const ABytes: TBytes; Index: NativeInt; Count: Integer); overload; + procedure SetContent(ABytes: PByte; Count: Integer); overload; + procedure SetContent(const Value: RawByteString); overload; + procedure SetContent(const Value: string; Encoding: TEncoding = nil); overload; // Default-encoding is UTF-8 + procedure LoadFromStream(Stream: TStream); + procedure LoadFromFile(const FileName: string); + procedure GetContent(var ABytes: TBytes); overload; + procedure GetContent(Buffer: PByte); overload; // use ContentSize to allocate enough memory + procedure GetContent(var Value: RawByteString); overload; + procedure GetContent(var Value: string; Encoding: TEncoding = nil); overload; + function GetContentAsBytes: TBytes; + function GetContentAsRawByteString: RawByteString; + function GetContentAsString(Encoding: TEncoding = nil): string; // Default-encoding is UTF-8 + procedure SaveToStream(Stream: TStream); + procedure SaveToFile(const FileName: string); + function HasContent: Boolean; + function HasKey(const Key: string): Boolean; + function GetValueType(const Key: string): TPdfObjectType; + property Name: string read GetName; + property Values[const Key: string]: string read GetKeyValue write SetKeyValue; + property ContentSize: Integer read GetContentSize; + property Handle: FPDF_ATTACHMENT read FHandle; + end; + TPdfAttachmentList = class(TObject) + private + FDocument: TPdfDocument; + function GetCount: Integer; + function GetItem(Index: Integer): TPdfAttachment; + public + constructor Create(ADocument: TPdfDocument); + function Add(const Name: string): TPdfAttachment; + procedure Delete(Index: Integer); + function IndexOf(const Name: string): Integer; + property Count: Integer read GetCount; + property Items[Index: Integer]: TPdfAttachment read GetItem; default; + end; + TPdfDocument = class(TObject) + private type + PCustomLoadDataRec = ^TCustomLoadDataRec; + TCustomLoadDataRec = record + Param: Pointer; + GetBlock: TPdfDocumentCustomReadProc; + FileAccess: TFPDFFileAccess; + end; + private + FDocument: FPDF_DOCUMENT; + FPages: TObjectList; + FAttachments: TPdfAttachmentList; + FFileName: string; + {$IFDEF MSWINDOWS} + FFileHandle: THandle; + FFileMapping: THandle; + {$ELSE} + FFileStream: TFileStream; + {$ENDIF MSWINDOWS} + FBuffer: PByte; + FBytes: TBytes; + FClosing: Boolean; + FUnsupportedFeatures: Boolean; + FCustomLoadData: PCustomLoadDataRec; + FForm: FPDF_FORMHANDLE; + FJSPlatform: IPDF_JsPlatform; + FFormFillHandler: TPdfFormFillHandler; + FFormFieldHighlightColor: TColorRef; + FFormFieldHighlightAlpha: Integer; + FPrintHidesFormFieldHighlight: Boolean; + FFormModified: Boolean; + FOnFormInvalidate: TPdfFormInvalidateEvent; + FOnFormOutputSelectedRect: TPdfFormOutputSelectedRectEvent; + FOnFormGetCurrentPage: TPdfFormGetCurrentPageEvent; + FOnFormFieldFocus: TPdfFormFieldFocusEvent; + FOnExecuteNamedAction: TPdfExecuteNamedActionEvent; + procedure InternLoadFromFile(const FileName: string; const Password: UTF8String); + procedure InternLoadFromMem(Buffer: PByte; Size: NativeInt; const Password: UTF8String); + procedure InternLoadFromCustom(ReadFunc: TPdfDocumentCustomReadProc; Size: LongWord; + Param: Pointer; const Password: UTF8String); + function InternImportPages(Source: TPdfDocument; PageIndices: PInteger; PageIndicesCount: Integer; + const Range: AnsiString; Index: Integer; ImportByRange: Boolean): Boolean; + function GetPage(Index: Integer): TPdfPage; + function GetPageCount: Integer; + procedure ExtractPage(APage: TPdfPage); + function ReloadPage(APage: TPdfPage): FPDF_PAGE; + function GetPrintScaling: Boolean; + function GetActive: Boolean; + procedure CheckActive; + function GetSecurityHandlerRevision: Integer; + function GetDocPermissions: Integer; + function GetFileVersion: Integer; + function GetPageSize(Index: Integer): TPdfPoint; + function GetPageMode: TPdfDocumentPageMode; + function GetNumCopies: Integer; + procedure DocumentLoaded; + procedure SetFormFieldHighlightAlpha(Value: Integer); + procedure SetFormFieldHighlightColor(const Value: TColorRef); + function FindPage(Page: FPDF_PAGE): TPdfPage; + procedure UpdateFormFieldHighlight; + public + constructor Create; + destructor Destroy; override; + procedure LoadFromCustom(ReadFunc: TPdfDocumentCustomReadProc; Size: LongWord; Param: Pointer; const Password: UTF8String = ''); + procedure LoadFromActiveStream(Stream: TStream; const Password: UTF8String = ''); // Stream must not be released until the document is closed + procedure LoadFromActiveBuffer(Buffer: Pointer; Size: NativeInt; const Password: UTF8String = ''); // Buffer must not be released until the document is closed + procedure LoadFromBytes(const Bytes: TBytes; const Password: UTF8String = ''); overload; + procedure LoadFromBytes(const Bytes: TBytes; Index: NativeInt; Count: NativeInt; const Password: UTF8String = ''); overload; + procedure LoadFromStream(Stream: TStream; const Password: UTF8String = ''); + procedure LoadFromFile(const FileName: string; const Password: UTF8String = ''; LoadOption: TPdfDocumentLoadOption = dloDefault); + procedure Close; + procedure SaveToFile(const AFileName: string; Option: TPdfDocumentSaveOption = dsoRemoveSecurity; FileVersion: Integer = -1); + procedure SaveToStream(Stream: TStream; Option: TPdfDocumentSaveOption = dsoRemoveSecurity; FileVersion: Integer = -1); + procedure SaveToBytes(var Bytes: TBytes; Option: TPdfDocumentSaveOption = dsoRemoveSecurity; FileVersion: Integer = -1); + function NewDocument: Boolean; + class function CreateNPagesOnOnePageDocument(Source: TPdfDocument; NewPageWidth, NewPageHeight: Double; NumPagesXAxis, NumPagesYAxis: Integer): TPdfDocument; overload; + class function CreateNPagesOnOnePageDocument(Source: TPdfDocument; NumPagesXAxis, NumPagesYAxis: Integer): TPdfDocument; overload; + function ImportAllPages(Source: TPdfDocument; Index: Integer = -1): Boolean; + function ImportPages(Source: TPdfDocument; const Range: string = ''; Index: Integer = -1): Boolean; + function ImportPageRange(Source: TPdfDocument; PageIndex: Integer; Count: Integer = -1; Index: Integer = -1): Boolean; + function ImportPagesByIndex(Source: TPdfDocument; const PageIndices: array of Integer; Index: Integer = -1): Boolean; + procedure DeletePage(Index: Integer); + function NewPage(Width, Height: Double; Index: Integer = -1): TPdfPage; overload; + function NewPage(Index: Integer = -1): TPdfPage; overload; + function ApplyViewerPreferences(Source: TPdfDocument): Boolean; + function IsPageLoaded(PageIndex: Integer): Boolean; + function GetFileIdentifier(IdType: TPdfFileIdType): string; + function GetMetaText(const TagName: string): string; + class function SetPrintMode(PrintMode: TPdfPrintMode): Boolean; static; + property FileName: string read FFileName; + property PageCount: Integer read GetPageCount; + property Pages[Index: Integer]: TPdfPage read GetPage; + property PageSizes[Index: Integer]: TPdfPoint read GetPageSize; + property Attachments: TPdfAttachmentList read FAttachments; + property Active: Boolean read GetActive; + property PrintScaling: Boolean read GetPrintScaling; + property NumCopies: Integer read GetNumCopies; + property SecurityHandlerRevision: Integer read GetSecurityHandlerRevision; + property DocPermissions: Integer read GetDocPermissions; + property FileVersion: Integer read GetFileVersion; + property PageMode: TPdfDocumentPageMode read GetPageMode; + // if UnsupportedFeatures is True, then the document has unsupported features. It is updated + // after accessing a page. + property UnsupportedFeatures: Boolean read FUnsupportedFeatures; + property Handle: FPDF_DOCUMENT read FDocument; + property FormHandle: FPDF_FORMHANDLE read FForm; + property FormFieldHighlightColor: TColorRef read FFormFieldHighlightColor write SetFormFieldHighlightColor default $FFE4DD; + property FormFieldHighlightAlpha: Integer read FFormFieldHighlightAlpha write SetFormFieldHighlightAlpha default 100; + property PrintHidesFormFieldHighlight: Boolean read FPrintHidesFormFieldHighlight write FPrintHidesFormFieldHighlight default True; + property FormModified: Boolean read FFormModified write FFormModified; + property OnFormInvalidate: TPdfFormInvalidateEvent read FOnFormInvalidate write FOnFormInvalidate; + property OnFormOutputSelectedRect: TPdfFormOutputSelectedRectEvent read FOnFormOutputSelectedRect write FOnFormOutputSelectedRect; + property OnFormGetCurrentPage: TPdfFormGetCurrentPageEvent read FOnFormGetCurrentPage write FOnFormGetCurrentPage; + property OnFormFieldFocus: TPdfFormFieldFocusEvent read FOnFormFieldFocus write FOnFormFieldFocus; + property OnExecuteNamedAction: TPdfExecuteNamedActionEvent read FOnExecuteNamedAction write FOnExecuteNamedAction; + end; + {$IFDEF MSWINDOWS} + TPdfDocumentPrinterStatusEvent = procedure(Sender: TObject; CurrentPageNum, PageCount: Integer) of object; + TPdfDocumentPrinter = class(TObject) + private + FBeginPrintCounter: Integer; + FPrinterDC: HDC; + FPrintPortraitOrientation: Boolean; + FPaperSize: TSize; + FPrintArea: TSize; + FMargins: TPoint; + FFitPageToPrintArea: Boolean; + FOnPrintStatus: TPdfDocumentPrinterStatusEvent; + function IsPortraitOrientation(AWidth, AHeight: Integer): Boolean; + procedure GetPrinterBounds; + protected + function PrinterStartDoc(const AJobTitle: string): Boolean; virtual; abstract; + procedure PrinterEndDoc; virtual; abstract; + procedure PrinterStartPage; virtual; abstract; + procedure PrinterEndPage; virtual; abstract; + function GetPrinterDC: HDC; virtual; abstract; + procedure InternPrintPage(APage: TPdfPage; X, Y, Width, Height: Double); + public + constructor Create; + { BeginPrint must be called before printing multiple documents. + Returns false if the printer can't print. (e.g. The user aborted the PDF Printer's FileDialog) } + function BeginPrint(const AJobTitle: string = ''): Boolean; + { EndPrint must be called after printing multiple documents were printed. } + procedure EndPrint; + { Prints a range of PDF document pages (0..PageCount-1) } + function Print(ADocument: TPdfDocument; AFromPageIndex, AToPageIndex: Integer): Boolean; overload; + { Prints all pages of the PDF document. } + function Print(ADocument: TPdfDocument): Boolean; overload; + + { If FitPageToPrintArea is true the page fill be scaled to fit into the printable area. } + property FitPageToPrintArea: Boolean read FFitPageToPrintArea write FFitPageToPrintArea default True; + { OnPrintStatus is triggered after every printed page } + property OnPrintStatus: TPdfDocumentPrinterStatusEvent read FOnPrintStatus write FOnPrintStatus; + end; + {$ENDIF MSWINDOWS} +function SetThreadPdfUnsupportedFeatureHandler(const Handler: TPdfUnsupportedFeatureHandler): TPdfUnsupportedFeatureHandler; + +function PageToBitmap(aPage: TPdfPage; sPath: String; nDPI: Integer = 600): Boolean; +function PageToPng(aPage: TPdfPage; sPath: String; nDPI: Integer = 600): Boolean; +function GetPageOcrText(aPage: TPdfPage; sOcrMdPath, sTaskDir: String; sParam: String = ''; nDPI: Integer = 150): String; + +var + PDFiumDllDir: string = ''; + PDFiumDllFileName: string = ''; // use this instead of PDFiumDllDir if you want to change the DLLs file name + {$IF declared(FPDF_InitEmbeddedLibraries)} + PDFiumResDir: string = ''; + {$IFEND} +implementation + +uses + Vcl.Graphics, Tocsg.Process, Tocsg.Strings, Vcl.Imaging.pngimage, + Tocsg.Exception, System.Math; +resourcestring + RsUnsupportedFeature = 'Function %s not supported'; + RsArgumentsOutOfRange = 'Function argument "%s" (%d) out of range'; + RsDocumentNotActive = 'PDF document is not open'; + {$IFNDEF CPUX64} + RsFileTooLarge = 'PDF file "%s" is too large'; + {$ENDIF ~CPUX64} + RsPdfCannotDeleteAttachmnent = 'Cannot delete the PDF attachment %d'; + RsPdfCannotAddAttachmnent = 'Cannot add the PDF attachment "%s"'; + RsPdfCannotSetAttachmentContent = 'Cannot set the PDF attachment content'; + RsPdfAttachmentContentNotSet = 'Content must be set before accessing string PDF attachmemt values'; + RsPdfAnnotationNotAFormFieldError = 'The annotation is not a form field'; + RsPdfAnnotationLinkRemoteGotoRequiresRemoteDocument = 'A remote goto annotation link requires a remote document'; + RsPdfErrorSuccess = 'No error'; + RsPdfErrorUnknown = 'Unknown error'; + RsPdfErrorFile = 'File not found or can''t be opened'; + RsPdfErrorFormat = 'File is not a PDF document or is corrupted'; + RsPdfErrorPassword = 'Password required oder invalid password'; + RsPdfErrorSecurity = 'Security schema is not support'; + RsPdfErrorPage = 'Page does not exist or data error'; + RsPdfErrorXFALoad = 'Load XFA error'; + RsPdfErrorXFALayout = 'Layout XFA error'; +threadvar + ThreadPdfUnsupportedFeatureHandler: TPdfUnsupportedFeatureHandler; + UnsupportedFeatureCurrentDocument: TPdfDocument; +type + { We don't want to use a TBytes temporary array if we can convert directly into the destination + buffer. } + TEncodingAccess = class(TEncoding) + public + function GetMemCharCount(Bytes: PByte; ByteCount: Integer): Integer; + function GetMemChars(Bytes: PByte; ByteCount: Integer; Chars: PWideChar; CharCount: Integer): Integer; + end; +function TEncodingAccess.GetMemCharCount(Bytes: PByte; ByteCount: Integer): Integer; +begin + Result := GetCharCount(Bytes, ByteCount); +end; +function TEncodingAccess.GetMemChars(Bytes: PByte; ByteCount: Integer; Chars: PWideChar; CharCount: Integer): Integer; +begin + Result := GetChars(Bytes, ByteCount, Chars, CharCount); +end; +function SetThreadPdfUnsupportedFeatureHandler(const Handler: TPdfUnsupportedFeatureHandler): TPdfUnsupportedFeatureHandler; +begin + Result := ThreadPdfUnsupportedFeatureHandler; + ThreadPdfUnsupportedFeatureHandler := Handler; +end; +{$IF defined(MSWINDOWS) and not declared(GetFileSizeEx)} +function GetFileSizeEx(hFile: THandle; var lpFileSize: Int64): BOOL; stdcall; + external kernel32 name 'GetFileSizeEx'; +{$IFEND} +procedure SwapInts(var X, Y: Integer); +var + Tmp: Integer; +begin + Tmp := X; + X := Y; + Y := Tmp; +end; +function GetUnsupportedFeatureName(nType: Integer): string; +begin + case nType of + FPDF_UNSP_DOC_XFAFORM: + Result := 'XFA'; + FPDF_UNSP_DOC_PORTABLECOLLECTION: + Result := 'Portfolios_Packages'; + FPDF_UNSP_DOC_ATTACHMENT, + FPDF_UNSP_ANNOT_ATTACHMENT: + Result := 'Attachment'; + FPDF_UNSP_DOC_SECURITY: + Result := 'Rights_Management'; + FPDF_UNSP_DOC_SHAREDREVIEW: + Result := 'Shared_Review'; + FPDF_UNSP_DOC_SHAREDFORM_ACROBAT, + FPDF_UNSP_DOC_SHAREDFORM_FILESYSTEM, + FPDF_UNSP_DOC_SHAREDFORM_EMAIL: + Result := 'Shared_Form'; + FPDF_UNSP_ANNOT_3DANNOT: + Result := '3D'; + FPDF_UNSP_ANNOT_MOVIE: + Result := 'Movie'; + FPDF_UNSP_ANNOT_SOUND: + Result := 'Sound'; + FPDF_UNSP_ANNOT_SCREEN_MEDIA, + FPDF_UNSP_ANNOT_SCREEN_RICHMEDIA: + Result := 'Screen'; + FPDF_UNSP_ANNOT_SIG: + Result := 'Digital_Signature'; + else + Result := 'Unknown'; + end; +end; +procedure UnsupportedHandler(pThis: PUNSUPPORT_INFO; nType: Integer); cdecl; +var + Document: TPdfDocument; +begin + Document := UnsupportedFeatureCurrentDocument; + if Document <> nil then + Document.FUnsupportedFeatures := True; + if Assigned(ThreadPdfUnsupportedFeatureHandler) then + ThreadPdfUnsupportedFeatureHandler(nType, GetUnsupportedFeatureName(nType)); + //raise EPdfUnsupportedFeatureException.CreateResFmt(@RsUnsupportedFeature, [GetUnsupportedFeatureName]); +end; +var + PDFiumInitCritSect: TRTLCriticalSection; + UnsupportInfo: TUnsupportInfo = ( + version: 1; + FSDK_UnSupport_Handler: UnsupportedHandler; + ); +procedure InitLib; +{$J+} +const + Initialized: Integer = 0; +{$J-} +begin + if Initialized = 0 then + begin + EnterCriticalSection(PDFiumInitCritSect); + try + if Initialized = 0 then + begin + if PDFiumDllFileName <> '' then + InitPDFiumEx(PDFiumDllFileName {$IF declared(FPDF_InitEmbeddedLibraries)}, PDFiumResDir{$IFEND}) + else + InitPDFium(PDFiumDllDir {$IF declared(FPDF_InitEmbeddedLibraries)}, PDFiumResDir{$IFEND}); + FSDK_SetUnSpObjProcessHandler(@UnsupportInfo); + Initialized := 1; + end; + finally + LeaveCriticalSection(PDFiumInitCritSect); + end; + end; +end; +procedure RaiseLastPdfError; +begin + case FPDF_GetLastError() of + FPDF_ERR_SUCCESS: + raise EPdfException.CreateRes(@RsPdfErrorSuccess); + FPDF_ERR_FILE: + raise EPdfException.CreateRes(@RsPdfErrorFile); + FPDF_ERR_FORMAT: + raise EPdfException.CreateRes(@RsPdfErrorFormat); + FPDF_ERR_PASSWORD: + raise EPdfException.CreateRes(@RsPdfErrorPassword); + FPDF_ERR_SECURITY: + raise EPdfException.CreateRes(@RsPdfErrorSecurity); + FPDF_ERR_PAGE: + raise EPdfException.CreateRes(@RsPdfErrorPage); + {$IF declared(FPDF_ERR_XFALOAD)} + FPDF_ERR_XFALOAD: + raise EPdfException.CreateRes(@RsPdfErrorXFALoad); + FPDF_ERR_XFALAYOUT: + raise EPdfException.CreateRes(@RsPdfErrorXFALayout); + {$IFEND} + else + raise EPdfException.CreateRes(@RsPdfErrorUnknown); + end; +end; +procedure FFI_Invalidate(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE; left, top, right, bottom: Double); cdecl; +var + Handler: PPdfFormFillHandler; + Pg: TPdfPage; + R: TPdfRect; +begin + Handler := PPdfFormFillHandler(pThis); + if Assigned(Handler.Document.OnFormInvalidate) then + begin + Pg := Handler.Document.FindPage(page); + if Pg <> nil then + begin + R.Left := left; + R.Top := top; + R.Right := right; + R.Bottom := bottom; + Handler.Document.OnFormInvalidate(Handler.Document, Pg, R); + end; + end; +end; +procedure FFI_Change(pThis: PFPDF_FORMFILLINFO); cdecl; +var + Handler: PPdfFormFillHandler; +begin + Handler := PPdfFormFillHandler(pThis); + Handler.Document.FormModified := True; +end; +procedure FFI_OutputSelectedRect(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE; left, top, right, bottom: Double); cdecl; +var + Handler: PPdfFormFillHandler; + Pg: TPdfPage; + R: TPdfRect; +begin + Handler := PPdfFormFillHandler(pThis); + if Assigned(Handler.Document.OnFormOutputSelectedRect) then + begin + Pg := Handler.Document.FindPage(Page); + if Pg <> nil then + begin + R.Left := left; + R.Top := top; + R.Right := right; + R.Bottom := bottom; + Handler.Document.OnFormOutputSelectedRect(Handler.Document, Pg, R); + end; + end; +end; +{$IFDEF MSWINDOWS} +type + TFFITimer = record + Id: UINT; + Proc: TFPDFTimerCallback; + end; +var + FFITimers: array of TFFITimer; + FFITimersCritSect: TRTLCriticalSection; +procedure FormTimerProc(hwnd: HWND; uMsg: UINT; timerId: UINT; dwTime: DWORD); stdcall; +var + I: Integer; + Proc: TFPDFTimerCallback; +begin + Proc := nil; + EnterCriticalSection(FFITimersCritSect); + try + for I := 0 to Length(FFITimers) - 1 do + begin + if FFITimers[I].Id = timerId then + begin + Proc := FFITimers[I].Proc; + Break; + end; + end; + finally + LeaveCriticalSection(FFITimersCritSect); + end; + if Assigned(Proc) then + Proc(timerId); +end; +function FFI_SetTimer(pThis: PFPDF_FORMFILLINFO; uElapse: Integer; lpTimerFunc: TFPDFTimerCallback): Integer; cdecl; +var + I: Integer; + Id: UINT; +begin + Id := SetTimer(0, 0, uElapse, @FormTimerProc); + Result := Integer(Id); + if Id <> 0 then + begin + EnterCriticalSection(FFITimersCritSect); + try + for I := 0 to Length(FFITimers) - 1 do + begin + if FFITimers[I].Id = 0 then + begin + FFITimers[I].Id := Id; + FFITimers[I].Proc := lpTimerFunc; + Exit; + end; + end; + I := Length(FFITimers); + SetLength(FFITimers, I + 1); + FFITimers[I].Id := Id; + FFITimers[I].Proc := lpTimerFunc; + finally + LeaveCriticalSection(FFITimersCritSect); + end; + end; +end; +procedure FFI_KillTimer(pThis: PFPDF_FORMFILLINFO; nTimerID: Integer); cdecl; +var + I: Integer; +begin + if nTimerID <> 0 then + begin + KillTimer(0, nTimerID); + EnterCriticalSection(FFITimersCritSect); + try + for I := 0 to Length(FFITimers) - 1 do + begin + if FFITimers[I].Id = UINT(nTimerID) then + begin + FFITimers[I].Id := 0; + FFITimers[I].Proc := nil; + end; + end; + I := Length(FFITimers) - 1; + while (I >= 0) and (FFITimers[I].Id = 0) do + Dec(I); + if Length(FFITimers) <> I + 1 then + SetLength(FFITimers, I + 1); + finally + LeaveCriticalSection(FFITimersCritSect); + end; + end; +end; +{$ELSE} +type + TFFITimer = class(TTimer) + public + FId: Integer; + FTimerFunc: TFPDFTimerCallback; + procedure DoTimerEvent(Sender: TObject); + end; +var + FFITimers: array of TFFITimer; + FFITimersCritSect: TRTLCriticalSection; +{ TFFITimer } +procedure TFFITimer.DoTimerEvent(Sender: TObject); +begin + FTimerFunc(FId); +end; +function FFI_SetTimer(pThis: PFPDF_FORMFILLINFO; uElapse: Integer; lpTimerFunc: TFPDFTimerCallback): Integer; cdecl; +var + I: Integer; + Id: Integer; + Timer: TFFITimer; +begin + // Find highest Id + EnterCriticalSection(FFITimersCritSect); + try + Id := 0; + for I := 0 to Length(FFITimers) - 1 do + if (FFITimers[I] <> nil) and (FFITimers[I].FId > Id) then + Id := FFITimers[I].FId; + Inc(Id); + Timer := TFFITimer.Create(nil); + Timer.FId := Id; + Timer.FTimerFunc:= lpTimerFunc; + Timer.OnTimer := Timer.DoTimerEvent; + Timer.Interval := uElapse; + Result := Id; + for I := 0 to Length(FFITimers) - 1 do + begin + if FFITimers[I] = nil then + begin + FFITimers[I] := Timer; + Exit; + end; + end; + I := Length(FFITimers); + SetLength(FFITimers, I + 1); + FFITimers[I] := Timer; + finally + LeaveCriticalSection(FFITimersCritSect); + end; +end; +procedure FFI_KillTimer(pThis: PFPDF_FORMFILLINFO; nTimerID: Integer); cdecl; +var + I: Integer; +begin + if nTimerID <> 0 then + begin + EnterCriticalSection(FFITimersCritSect); + try + for I := 0 to Length(FFITimers) - 1 do + if (FFITimers[I] <> nil) and (FFITimers[I].FId = nTimerID) then + FreeAndNil(FFITimers[I]); + I := Length(FFITimers) - 1; + while (I >= 0) and (FFITimers[I] = nil) do + Dec(I); + if Length(FFITimers) <> I + 1 then + SetLength(FFITimers, I + 1); + finally + LeaveCriticalSection(FFITimersCritSect); + end; + end; +end; +{$ENDIF MSWINDOWS} +function FFI_GetLocalTime(pThis: PFPDF_FORMFILLINFO): FPDF_SYSTEMTIME; cdecl; +{$IF not declared(PSystemTime)} +type + PSystemTime = ^TSystemTime; +{$IFEND} +begin + GetLocalTime(PSystemTime(@Result)^); +end; +function FFI_GetPage(pThis: PFPDF_FORMFILLINFO; document: FPDF_DOCUMENT; nPageIndex: Integer): FPDF_PAGE; cdecl; +var + Handler: PPdfFormFillHandler; +begin + Handler := PPdfFormFillHandler(pThis); + Result := nil; + if (Handler.Document <> nil) and (Handler.Document.FDocument = document) then + begin + if (nPageIndex >= 0) and (nPageIndex < Handler.Document.PageCount) then + Result := Handler.Document.Pages[nPageIndex].FPage; + end; +end; +function FFI_GetCurrentPage(pThis: PFPDF_FORMFILLINFO; document: FPDF_DOCUMENT): FPDF_PAGE; cdecl; +var + Handler: PPdfFormFillHandler; + Pg: TPdfPage; +begin + Handler := PPdfFormFillHandler(pThis); + Result := nil; + if (Handler.Document <> nil) and (Handler.Document.FDocument = document) and Assigned(Handler.Document.OnFormGetCurrentPage) then + begin + Pg := nil; + Handler.Document.OnFormGetCurrentPage(Handler.Document, Pg); + Result := nil; + if Pg <> nil then + Result := Pg.FPage; + end; +end; +function FFI_GetRotation(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE): Integer; cdecl; +begin + Result := 0; +end; +procedure FFI_ExecuteNamedAction(pThis: PFPDF_FORMFILLINFO; namedAction: FPDF_BYTESTRING); cdecl; +var + Handler: PPdfFormFillHandler; + NamedActionType: TPdfNamedActionType; + S: UTF8String; +begin + Handler := PPdfFormFillHandler(pThis); + if Assigned(Handler.Document.OnExecuteNamedAction) then + begin + S := namedAction; + if S = 'Print' then + NamedActionType := naPrint + else if S = 'NextPage' then + NamedActionType := naNextPage + else if S = 'PrevPage' then + NamedActionType := naPrevPage + else if S = 'FirstPage' then + NamedActionType := naFirstPage + else if S = 'LastPage' then + NamedActionType := naLastPage + else + Exit; + Handler.Document.OnExecuteNamedAction(Handler.Document, NamedActionType); + end; +end; +procedure FFI_SetCursor(pThis: PFPDF_FORMFILLINFO; nCursorType: Integer); cdecl; +begin + // A better solution is to check what form field type is under the mouse cursor in the + // MoveMove event. Chrome/Edge doesn't rely on SetCursor either. +end; +procedure FFI_SetTextFieldFocus(pThis: PFPDF_FORMFILLINFO; value: FPDF_WIDESTRING; valueLen: FPDF_DWORD; is_focus: FPDF_BOOL); cdecl; +var + Handler: PPdfFormFillHandler; +begin + Handler := PPdfFormFillHandler(pThis); + if (Handler.Document <> nil) and Assigned(Handler.Document.OnFormFieldFocus) then + Handler.Document.OnFormFieldFocus(Handler.Document, value, valueLen, is_focus <> 0); +end; +procedure FFI_FocusChange(param: PFPDF_FORMFILLINFO; annot: FPDF_ANNOTATION; page_index: Integer); cdecl; +begin +end; + +{ TPdfRect } +procedure TPdfRect.Offset(XOffset, YOffset: Double); +begin + Left := Left + XOffset; + Top := Top + YOffset; + Right := Right + XOffset; + Bottom := Bottom + YOffset; +end; +class function TPdfRect.Empty: TPdfRect; +begin + Result.Left := 0; + Result.Top := 0; + Result.Right := 0; + Result.Bottom := 0; +end; +function TPdfRect.GetHeight: Double; +begin + Result := Bottom - Top; +end; +function TPdfRect.GetWidth: Double; +begin + Result := Right - Left; +end; +procedure TPdfRect.SetHeight(const Value: Double); +begin + Bottom := Top + Value; +end; +procedure TPdfRect.SetWidth(const Value: Double); +begin + Right := Left + Value; +end; +class function TPdfRect.New(Left, Top, Right, Bottom: Double): TPdfRect; +begin + Result.Left := Left; + Result.Top := Top; + Result.Right := Right; + Result.Bottom := Bottom; +end; +function TPdfRect.PtIn(const Pt: TPdfPoint): Boolean; +begin + Result := (Pt.X >= Left) and (Pt.X < Right); + if Result then + begin + // Page coordinates are upside down. + if Top > Bottom then + Result := (Pt.Y >= Bottom) and (Pt.Y < Top) + else + Result := (Pt.Y >= Top) and (Pt.Y < Bottom) + end; +end; + +{ TPdfDocument } +constructor TPdfDocument.Create; +begin + inherited Create; + FPages := TObjectList.Create; + FAttachments := TPdfAttachmentList.Create(Self); + {$IFDEF MSWINDOWS} + FFileHandle := INVALID_HANDLE_VALUE; + {$ENDIF MSWINDOWS} + FFormFieldHighlightColor := $FFE4DD; + FFormFieldHighlightAlpha := 100; + FPrintHidesFormFieldHighlight := True; + InitLib; +end; +destructor TPdfDocument.Destroy; +begin + Close; + FAttachments.Free; + FPages.Free; + inherited Destroy; +end; +procedure TPdfDocument.Close; +begin + FClosing := True; + try + FPages.Clear; + FUnsupportedFeatures := False; + if FDocument <> nil then + begin + if FForm <> nil then + begin + FORM_DoDocumentAAction(FForm, FPDFDOC_AACTION_WC); + FPDFDOC_ExitFormFillEnvironment(FForm); + FForm := nil; + end; + FPDF_CloseDocument(FDocument); + FDocument := nil; + end; + if FCustomLoadData <> nil then + begin + Dispose(FCustomLoadData); + FCustomLoadData := nil; + end; + {$IFDEF MSWINDOWS} + if FFileMapping <> 0 then + begin + if FBuffer <> nil then + begin + UnmapViewOfFile(FBuffer); + FBuffer := nil; + end; + CloseHandle(FFileMapping); + FFileMapping := 0; + end + else + {$ENDIF MSWINDOWS} + if FBuffer <> nil then + begin + FreeMem(FBuffer); + FBuffer := nil; + end; + FBytes := nil; + {$IFDEF MSWINDOWS} + if FFileHandle <> INVALID_HANDLE_VALUE then + begin + CloseHandle(FFileHandle); + FFileHandle := INVALID_HANDLE_VALUE; + end; + {$ELSE} + FreeAndNil(FFileStream); + {$ENDIF MSWINDOWS} + FFileName := ''; + FFormModified := False; + finally + FClosing := False; + end; +end; +{$IFDEF MSWINDOWS} +function ReadFromActiveFileHandle(Param: Pointer; Position: LongWord; Buffer: PByte; Size: LongWord): Boolean; +var + NumRead: DWORD; +begin + if Buffer <> nil then + begin + SetFilePointer(THandle(Param), Position, nil, FILE_BEGIN); + Result := ReadFile(THandle(Param), Buffer^, Size, NumRead, nil) and (NumRead = Size); + end + else + Result := Size = 0; +end; +{$ENDIF MSWINDOWS} +procedure TPdfDocument.LoadFromFile(const FileName: string; const Password: UTF8String; LoadOption: TPdfDocumentLoadOption); +{$IFDEF MSWINDOWS} +var + Size: Int64; + Offset: NativeInt; + NumRead: DWORD; + LastError: DWORD; +{$ENDIF MSWINDOWS} +begin + Close; + if LoadOption = dloDefault then + begin + InternLoadFromFile(FileName, Password); + FFileName := FileName; + Exit; + end; + {$IFDEF MSWINDOWS} + FFileHandle := CreateFileW(PWideChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + if FFileHandle = INVALID_HANDLE_VALUE then + RaiseLastOSError; + try + if not GetFileSizeEx(FFileHandle, Size) then + RaiseLastOSError; + if Size > High(Integer) then // PDFium LoadCustomDocument() can only handle PDFs up to 2 GB (see FPDF_FILEACCESS) + begin + {$IFDEF CPUX64} + // FPDF_LoadCustomDocument wasn't updated to load larger files, so we fall back to MMF. + if LoadOption = dloOnDemand then + LoadOption := dloMMF; + {$ELSE} + raise EPdfException.CreateResFmt(@RsFileTooLarge, [ExtractFileName(FileName)]); + {$ENDIF CPUX64} + end; + case LoadOption of + dloMemory: + begin + if Size > 0 then + begin + try + GetMem(FBuffer, Size); + Offset := 0; + while Offset < Size do + begin + if ((Size - Offset) and not $FFFFFFFF) <> 0 then + NumRead := $40000000 + else + NumRead := Size - Offset; + if not ReadFile(FFileHandle, FBuffer[Offset], NumRead, NumRead, nil) then + begin + LastError := GetLastError; + FreeMem(FBuffer); + FBuffer := nil; + RaiseLastOSError(LastError); + end; + Inc(Offset, NumRead); + end; + finally + CloseHandle(FFileHandle); + FFileHandle := INVALID_HANDLE_VALUE; + end; + InternLoadFromMem(FBuffer, Size, Password); + end; + end; + dloMMF: + begin + FFileMapping := CreateFileMapping(FFileHandle, nil, PAGE_READONLY, 0, 0, nil); + if FFileMapping = 0 then + RaiseLastOSError; + FBuffer := MapViewOfFile(FFileMapping, FILE_MAP_READ, 0, 0, Size); + if FBuffer = nil then + RaiseLastOSError; + InternLoadFromMem(FBuffer, Size, Password); + end; + dloOnDemand: + InternLoadFromCustom(ReadFromActiveFileHandle, Size, Pointer(FFileHandle), Password); + end; + except + Close; + raise; + end; + {$ELSE} + FFileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + case LoadOption of + dloMemory, dloMMF: + begin + try + LoadFromStream(FFileStream, Password); + finally + FreeAndNil(FFileStream); + end; + end; + dloOnDemand: + LoadFromActiveStream(FFileStream, Password); + end; + except + FreeAndNil(FFileStream); + raise; + end; + {$ENDIF MSWINDOWS} + FFileName := FileName; +end; +procedure TPdfDocument.LoadFromStream(Stream: TStream; const Password: UTF8String); +var + Size: NativeInt; +begin + Close; + Size := Stream.Size; + if Size > 0 then + begin + GetMem(FBuffer, Size); + try + Stream.ReadBuffer(FBuffer^, Size); + InternLoadFromMem(FBuffer, Size, Password); + except + Close; + raise; + end; + end; +end; +procedure TPdfDocument.LoadFromActiveBuffer(Buffer: Pointer; Size: NativeInt; const Password: UTF8String); +begin + Close; + InternLoadFromMem(Buffer, Size, Password); +end; +procedure TPdfDocument.LoadFromBytes(const Bytes: TBytes; const Password: UTF8String); +begin + LoadFromBytes(Bytes, 0, Length(Bytes), Password); +end; +procedure TPdfDocument.LoadFromBytes(const Bytes: TBytes; Index, Count: NativeInt; + const Password: UTF8String); +var + Len: NativeInt; +begin + Close; + Len := Length(Bytes); + if Index >= Len then + raise EPdfArgumentOutOfRange.CreateResFmt(@RsArgumentsOutOfRange, ['Index', Index]); + if Index + Count > Len then + raise EPdfArgumentOutOfRange.CreateResFmt(@RsArgumentsOutOfRange, ['Count', Count]); + FBytes := Bytes; // keep alive after return + InternLoadFromMem(@Bytes[Index], Count, Password); +end; +function ReadFromActiveStream(Param: Pointer; Position: LongWord; Buffer: PByte; Size: LongWord): Boolean; +begin + if Buffer <> nil then + begin + TStream(Param).Seek(Position, TSeekOrigin.soBeginning); + Result := TStream(Param).Read(Buffer^, Size) = Integer(Size); + end + else + Result := Size = 0; +end; +procedure TPdfDocument.LoadFromActiveStream(Stream: TStream; const Password: UTF8String); +begin + if Stream = nil then + Close + else + LoadFromCustom(ReadFromActiveStream, Stream.Size, Stream, Password); +end; +procedure TPdfDocument.LoadFromCustom(ReadFunc: TPdfDocumentCustomReadProc; Size: LongWord; + Param: Pointer; const Password: UTF8String); +begin + Close; + InternLoadFromCustom(ReadFunc, Size, Param, Password); +end; +function GetLoadFromCustomBlock(Param: Pointer; Position: LongWord; Buffer: PByte; Size: LongWord): Integer; cdecl; +var + Data: TPdfDocument.PCustomLoadDataRec; +begin + Data := TPdfDocument(param).FCustomLoadData; + Result := Ord(Data.GetBlock(Data.Param, Position, Buffer, Size)); +end; +procedure TPdfDocument.InternLoadFromCustom(ReadFunc: TPdfDocumentCustomReadProc; Size: LongWord; + Param: Pointer; const Password: UTF8String); +var + OldCurDoc: TPdfDocument; +begin + if Assigned(ReadFunc) then + begin + New(FCustomLoadData); + FCustomLoadData.Param := Param; + FCustomLoadData.GetBlock := ReadFunc; + FCustomLoadData.FileAccess.m_FileLen := Size; + FCustomLoadData.FileAccess.m_GetBlock := GetLoadFromCustomBlock; + FCustomLoadData.FileAccess.m_Param := Self; + OldCurDoc := UnsupportedFeatureCurrentDocument; + try + UnsupportedFeatureCurrentDocument := Self; + FDocument := FPDF_LoadCustomDocument(@FCustomLoadData.FileAccess, PAnsiChar(Pointer(Password))); + finally + UnsupportedFeatureCurrentDocument := OldCurDoc; + end; + DocumentLoaded; + end; +end; +procedure TPdfDocument.InternLoadFromMem(Buffer: PByte; Size: NativeInt; const Password: UTF8String); +var + OldCurDoc: TPdfDocument; +begin + if Size > 0 then + begin + OldCurDoc := UnsupportedFeatureCurrentDocument; + try + UnsupportedFeatureCurrentDocument := Self; + FDocument := FPDF_LoadMemDocument64(Buffer, Size, PAnsiChar(Pointer(Password))); + finally + UnsupportedFeatureCurrentDocument := OldCurDoc; + end; + DocumentLoaded; + end; +end; +procedure TPdfDocument.InternLoadFromFile(const FileName: string; const Password: UTF8String); +var + OldCurDoc: TPdfDocument; + Utf8FileName: UTF8String; +begin + Utf8FileName := UTF8Encode(FileName); + OldCurDoc := UnsupportedFeatureCurrentDocument; + try + UnsupportedFeatureCurrentDocument := Self; + // UTF8 now works with LoadDocument and it can handle large PDF files (2 GB+) what + // FPDF_LoadCustomDocument can't because of the data types in FPDF_FILEACCESS. + FDocument := FPDF_LoadDocument(PAnsiChar(Utf8FileName), PAnsiChar(Pointer(Password))); + finally + UnsupportedFeatureCurrentDocument := OldCurDoc; + end; + DocumentLoaded; +end; +procedure TPdfDocument.DocumentLoaded; +begin + FFormModified := False; + if FDocument = nil then + RaiseLastPdfError; + FPages.Count := FPDF_GetPageCount(FDocument); + FillChar(FFormFillHandler, SizeOf(TPdfFormFillHandler), 0); + FFormFillHandler.Document := Self; + FFormFillHandler.FormFillInfo.version := 1; // will be set to 2 if we use an XFA-enabled DLL + FFormFillHandler.FormFillInfo.FFI_Invalidate := FFI_Invalidate; + FFormFillHandler.FormFillInfo.FFI_OnChange := FFI_Change; + FFormFillHandler.FormFillInfo.FFI_OutputSelectedRect := FFI_OutputSelectedRect; + FFormFillHandler.FormFillInfo.FFI_SetTimer := FFI_SetTimer; + FFormFillHandler.FormFillInfo.FFI_KillTimer := FFI_KillTimer; + FFormFillHandler.FormFillInfo.FFI_GetLocalTime := FFI_GetLocalTime; + FFormFillHandler.FormFillInfo.FFI_GetPage := FFI_GetPage; + FFormFillHandler.FormFillInfo.FFI_GetCurrentPage := FFI_GetCurrentPage; + FFormFillHandler.FormFillInfo.FFI_GetRotation := FFI_GetRotation; + FFormFillHandler.FormFillInfo.FFI_ExecuteNamedAction := FFI_ExecuteNamedAction; + FFormFillHandler.FormFillInfo.FFI_SetCursor := FFI_SetCursor; + FFormFillHandler.FormFillInfo.FFI_SetTextFieldFocus := FFI_SetTextFieldFocus; + FFormFillHandler.FormFillInfo.FFI_OnFocusChange := FFI_FocusChange; +// FFormFillHandler.FormFillInfo.FFI_DoURIAction := FFI_DoURIAction; +// FFormFillHandler.FormFillInfo.FFI_DoGoToAction := FFI_DoGoToAction; + if PDF_USE_XFA then + begin + FJSPlatform.version := 3; + // FJSPlatform callbacks not implemented + FFormFillHandler.FormFillInfo.m_pJsPlatform := @FJSPlatform; + FFormFillHandler.FormFillInfo.version := 2; + FFormFillHandler.FormFillInfo.xfa_disabled := 1; // Disable XFA support for now + end; + FForm := FPDFDOC_InitFormFillEnvironment(FDocument, @FFormFillHandler.FormFillInfo); + if FForm <> nil then + begin + if PDF_USE_XFA and (FFormFillHandler.FormFillInfo.xfa_disabled = 0) then + FPDF_LoadXFA(FDocument); + UpdateFormFieldHighlight; + FORM_DoDocumentJSAction(FForm); + FORM_DoDocumentOpenAction(FForm); + end; +end; +procedure TPdfDocument.UpdateFormFieldHighlight; +begin + FPDF_SetFormFieldHighlightColor(FForm, 0, FFormFieldHighlightColor); + FPDF_SetFormFieldHighlightAlpha(FForm, FFormFieldHighlightAlpha); +end; +function TPdfDocument.IsPageLoaded(PageIndex: Integer): Boolean; +var + Page: TPdfPage; +begin + Page := TPdfPage(FPages[PageIndex]); + Result := (Page <> nil) and Page.IsLoaded; +end; +function TPdfDocument.GetPage(Index: Integer): TPdfPage; +var + LPage: FPDF_PAGE; +begin + Result := TPdfPage(FPages[Index]); + if Result = nil then + begin + LPage := FPDF_LoadPage(FDocument, Index); + if LPage = nil then + RaiseLastPdfError; + Result := TPdfPage.Create(Self, LPage); + FPages[Index] := Result; + end +end; +function TPdfDocument.GetPageCount: Integer; +begin + Result := FPages.Count; +end; +procedure TPdfDocument.ExtractPage(APage: TPdfPage); +begin + if not FClosing then + FPages.Extract(APage); +end; +function TPdfDocument.ReloadPage(APage: TPdfPage): FPDF_PAGE; +var + Index: Integer; +begin + CheckActive; + Index := FPages.IndexOf(APage); + Result := FPDF_LoadPage(FDocument, Index); + if Result = nil then + RaiseLastPdfError; +end; +function TPdfDocument.GetPrintScaling: Boolean; +begin + CheckActive; + Result := FPDF_VIEWERREF_GetPrintScaling(FDocument) <> 0; +end; +function TPdfDocument.GetActive: Boolean; +begin + Result := FDocument <> nil; +end; +procedure TPdfDocument.CheckActive; +begin + if not Active then + raise EPdfException.CreateRes(@RsDocumentNotActive); +end; +class function TPdfDocument.CreateNPagesOnOnePageDocument(Source: TPdfDocument; + NumPagesXAxis, NumPagesYAxis: Integer): TPdfDocument; +begin + if Source.PageCount > 0 then + Result := CreateNPagesOnOnePageDocument(Source, Source.PageSizes[0].X, Source.PageSizes[0].Y, NumPagesXAxis, NumPagesYAxis) + else + Result := CreateNPagesOnOnePageDocument(Source, PdfDefaultPageWidth, PdfDefaultPageHeight, NumPagesXAxis, NumPagesYAxis); // DIN A4 page +end; +class function TPdfDocument.CreateNPagesOnOnePageDocument(Source: TPdfDocument; + NewPageWidth, NewPageHeight: Double; NumPagesXAxis, NumPagesYAxis: Integer): TPdfDocument; +var + OldCurDoc: TPdfDocument; +begin + Result := TPdfDocument.Create; + try + if (Source = nil) or not Source.Active then + Result.NewDocument + else + begin + OldCurDoc := UnsupportedFeatureCurrentDocument; + try + UnsupportedFeatureCurrentDocument := Result; + Result.FDocument := FPDF_ImportNPagesToOne(Source.FDocument, NewPageWidth, NewPageHeight, NumPagesXAxis, NumPagesYAxis); + finally + UnsupportedFeatureCurrentDocument := OldCurDoc; + end; + if Result.FDocument <> nil then + Result.DocumentLoaded + else + Result.NewDocument; + end; + except + Result.Free; + raise; + end; +end; +function TPdfDocument.InternImportPages(Source: TPdfDocument; PageIndices: PInteger; PageIndicesCount: Integer; + const Range: AnsiString; Index: Integer; ImportByRange: Boolean): Boolean; +var + I, NewCount, OldCount, InsertCount: Integer; +begin + CheckActive; + Source.CheckActive; + OldCount := FPDF_GetPageCount(FDocument); + if Index < 0 then + Index := OldCount; + if ImportByRange then // Range = '' => Import all pages + Result := FPDF_ImportPages(FDocument, Source.FDocument, PAnsiChar(Pointer(Range)), Index) <> 0 + else + Result := FPDF_ImportPagesByIndex(FDocument, Source.FDocument, PageIndices, PageIndicesCount, Index) <> 0; + NewCount := FPDF_GetPageCount(FDocument); + InsertCount := NewCount - OldCount; + if InsertCount > 0 then + begin + FPages.Count := NewCount; + if Index < OldCount then + begin + Move(FPages.List[Index], FPages.List[Index + InsertCount], (OldCount - Index) * SizeOf(TObject)); + for I := Index to Index + InsertCount - 1 do + FPages.List[Index] := nil; + end; + end; +end; +function TPdfDocument.ImportAllPages(Source: TPdfDocument; Index: Integer): Boolean; +begin + Result := InternImportPages(Source, nil, 0, '', Index, False); +end; +function TPdfDocument.ImportPages(Source: TPdfDocument; const Range: string; Index: Integer): Boolean; +begin + Result := InternImportPages(Source, nil, 0, AnsiString(Range), Index, True) +end; +function TPdfDocument.ImportPageRange(Source: TPdfDocument; PageIndex, Count, Index: Integer): Boolean; +begin + Result := False; + if (Source <> nil) and (PageIndex >= 0) then + begin + if Count = -1 then + Count := Source.PageCount - PageIndex + else if Count < 0 then + Exit; + if Count > 0 then + begin + if PageIndex + Count > Source.PageCount then + begin + Count := Source.PageCount - PageIndex; + if Count = 0 then + Exit; + end; + if (PageIndex = 0) and (Count = Source.PageCount) then + Result := ImportAllPages(Source, Index) + else + Result := ImportPages(Source, Format('%d-%d', [PageIndex, PageIndex + Count - 1])); + end; + end; +end; +function TPdfDocument.ImportPagesByIndex(Source: TPdfDocument; const PageIndices: array of Integer; Index: Integer = -1): Boolean; +begin + if Length(PageIndices) > 0 then + Result := InternImportPages(Source, @PageIndices[0], Length(PageIndices), '', Index, False) + else + Result := ImportAllPages(Source, Index); +end; +procedure TPdfDocument.SaveToFile(const AFileName: string; Option: TPdfDocumentSaveOption; FileVersion: Integer); +var + Stream: TFileStream; +begin + Stream := TFileStream.Create(AFileName, fmCreate or fmShareDenyWrite); + try + SaveToStream(Stream, Option, FileVersion); + finally + Stream.Free; + end; +end; +type + PFPDFFileWriteEx = ^TFPDFFileWriteEx; + TFPDFFileWriteEx = record + Inner: TFPDFFileWrite; // emulate object inheritance + Stream: TStream; + end; +function WriteBlockToStream(pThis: PFPDF_FILEWRITE; pData: Pointer; size: LongWord): Integer; cdecl; +begin + Result := Ord(LongWord(PFPDFFileWriteEx(pThis).Stream.Write(pData^, size)) = size); +end; +procedure TPdfDocument.SaveToStream(Stream: TStream; Option: TPdfDocumentSaveOption; FileVersion: Integer); +var + FileWriteInfo: TFPDFFileWriteEx; +begin + CheckActive; + FileWriteInfo.Inner.version := 1; + FileWriteInfo.Inner.WriteBlock := @WriteBlockToStream; + FileWriteInfo.Stream := Stream; + if FForm <> nil then + begin + FORM_ForceToKillFocus(FForm); // also save the form field data that is currently focused + FORM_DoDocumentAAction(FForm, FPDFDOC_AACTION_WS); // BeforeSave + end; + if FileVersion <> -1 then + FPDF_SaveWithVersion(FDocument, @FileWriteInfo, Ord(Option), FileVersion) + else + FPDF_SaveAsCopy(FDocument, @FileWriteInfo, Ord(Option)); + if FForm <> nil then + FORM_DoDocumentAAction(FForm, FPDFDOC_AACTION_DS); // AfterSave +end; +procedure TPdfDocument.SaveToBytes(var Bytes: TBytes; Option: TPdfDocumentSaveOption; FileVersion: Integer); +var + Stream: TBytesStream; + Size: NativeInt; +begin + CheckActive; + Stream := TBytesStream.Create(nil); + try + SaveToStream(Stream, Option, FileVersion); + Size := Stream.Size; + Bytes := Stream.Bytes; + finally + Stream.Free; + end; + // Trim the byte array from the stream's capacity to the actual size + if Length(Bytes) <> Size then + SetLength(Bytes, Size); +end; +function TPdfDocument.NewDocument: Boolean; +begin + Close; + FDocument := FPDF_CreateNewDocument; + Result := FDocument <> nil; + FFormModified := False; +end; +procedure TPdfDocument.DeletePage(Index: Integer); +begin + CheckActive; + FPages.Delete(Index); + FPDFPage_Delete(FDocument, Index); +end; +function TPdfDocument.NewPage(Width, Height: Double; Index: Integer): TPdfPage; +var + LPage: FPDF_PAGE; +begin + CheckActive; + if Index < 0 then + Index := FPages.Count; // append new page + LPage := FPDFPage_New(FDocument, Index, Width, Height); + if LPage <> nil then + begin + Result := TPdfPage.Create(Self, LPage); + FPages.Insert(Index, Result); + end + else + Result := nil; +end; +function TPdfDocument.NewPage(Index: Integer = -1): TPdfPage; +begin + Result := NewPage(PdfDefaultPageWidth, PdfDefaultPageHeight, Index); +end; +function TPdfDocument.ApplyViewerPreferences(Source: TPdfDocument): Boolean; +begin + CheckActive; + Source.CheckActive; + Result := FPDF_CopyViewerPreferences(FDocument, Source.FDocument) <> 0; +end; +function TPdfDocument.GetFileIdentifier(IdType: TPdfFileIdType): string; +var + Len: Integer; + A: AnsiString; +begin + CheckActive; + Len := FPDF_GetFileIdentifier(FDocument, FPDF_FILEIDTYPE(IdType), nil, 0) div SizeOf(AnsiChar) - 1; + if Len > 0 then + begin + SetLength(A, Len); + FPDF_GetFileIdentifier(FDocument, FPDF_FILEIDTYPE(IdType), PAnsiChar(A), (Len + 1) * SizeOf(AnsiChar)); + Result := string(A); + end + else + Result := ''; +end; +function TPdfDocument.GetMetaText(const TagName: string): string; +var + Len: Integer; + A: AnsiString; +begin + CheckActive; + A := AnsiString(TagName); + Len := FPDF_GetMetaText(FDocument, PAnsiChar(A), nil, 0) div SizeOf(WideChar) - 1; + if Len > 0 then + begin + SetLength(Result, Len); + FPDF_GetMetaText(FDocument, PAnsiChar(A), PWideChar(Result), (Len + 1) * SizeOf(WideChar)); + end + else + Result := ''; +end; +function TPdfDocument.GetSecurityHandlerRevision: Integer; +begin + CheckActive; + Result := FPDF_GetSecurityHandlerRevision(FDocument); +end; +function TPdfDocument.GetDocPermissions: Integer; +begin + CheckActive; + Result := Integer(FPDF_GetDocPermissions(FDocument)); +end; +function TPdfDocument.GetFileVersion: Integer; +begin + CheckActive; + if FPDF_GetFileVersion(FDocument, Result) = 0 then + Result := 0; +end; +function TPdfDocument.GetPageSize(Index: Integer): TPdfPoint; +var + SizeF: TFSSizeF; +begin + CheckActive; + Result.X := 0; + Result.Y := 0; + if FPDF_GetPageSizeByIndexF(FDocument, Index, @SizeF) <> 0 then + begin + Result.X := SizeF.width; + Result.Y := SizeF.height; + end; +end; +function TPdfDocument.GetPageMode: TPdfDocumentPageMode; +begin + CheckActive; + Result := TPdfDocumentPageMode(FPDFDoc_GetPageMode(FDocument)); +end; +function TPdfDocument.GetNumCopies: Integer; +begin + CheckActive; + Result := FPDF_VIEWERREF_GetNumCopies(FDocument); +end; +class function TPdfDocument.SetPrintMode(PrintMode: TPdfPrintMode): Boolean; +begin + InitLib; + {$IFDEF MSWINDOWS} + Result := FPDF_SetPrintMode(Ord(PrintMode)) <> 0; + {$ELSE} + Result := False; + {$ENDIF MSWINDOWS} +end; +procedure TPdfDocument.SetFormFieldHighlightAlpha(Value: Integer); +begin + if Value < 0 then + Value := 0; + if Value > 255 then + Value := 255; + if Value <> FFormFieldHighlightAlpha then + begin + FFormFieldHighlightAlpha := Value; + if Active then + FPDF_SetFormFieldHighlightAlpha(FForm, FFormFieldHighlightAlpha); + end; +end; +procedure TPdfDocument.SetFormFieldHighlightColor(const Value: TColorRef); +begin + if Value <> FFormFieldHighlightColor then + begin + FFormFieldHighlightColor := Value; + if Active then + FPDF_SetFormFieldHighlightColor(FForm, 0, FFormFieldHighlightColor); + end; +end; +function TPdfDocument.FindPage(Page: FPDF_PAGE): TPdfPage; +var + I: Integer; +begin + // The page must be already loaded + for I := 0 to PageCount - 1 do + begin + Result := TPdfPage(FPages[I]); + if (Result <> nil) and (Result.FPage = Page) then + Exit; + end; + Result := nil; +end; + +{ TPdfPage } +constructor TPdfPage.Create(ADocument: TPdfDocument; APage: FPDF_PAGE); +begin + inherited Create; + FDocument := ADocument; + FPage := APage; + FAnnotations := TPdfAnnotationList.Create(Self); + AfterOpen; +end; +destructor TPdfPage.Destroy; +begin + Close; + FDocument.ExtractPage(Self); + FreeAndNil(FAnnotations); + inherited Destroy; +end; +function TPdfPage.IsValidForm: Boolean; +begin + Result := (FDocument <> nil) and (FDocument.FForm <> nil) and (FPage <> nil); +end; +procedure TPdfPage.AfterOpen; +var + OldCurDoc: TPdfDocument; +begin + if IsValidForm then + begin + OldCurDoc := UnsupportedFeatureCurrentDocument; + try + UnsupportedFeatureCurrentDocument := FDocument; + FORM_OnAfterLoadPage(FPage, FDocument.FForm); + FORM_DoPageAAction(FPage, FDocument.FForm, FPDFPAGE_AACTION_OPEN); + finally + UnsupportedFeatureCurrentDocument := OldCurDoc; + end; + end; + UpdateMetrics; +end; +procedure TPdfPage.Close; +begin + FAnnotations.CloseAnnotations; + if IsValidForm then + begin + FORM_DoPageAAction(FPage, FDocument.FForm, FPDFPAGE_AACTION_CLOSE); + FORM_OnBeforeClosePage(FPage, FDocument.FForm); + end; + if FPageLinkHandle <> nil then + begin + FPDFLink_CloseWebLinks(FPageLinkHandle); + FPageLinkHandle := nil; + end; + if FSearchHandle <> nil then + begin + FPDFText_FindClose(FSearchHandle); + FSearchHandle := nil; + end; + if FTextHandle <> nil then + begin + FPDFText_ClosePage(FTextHandle); + FTextHandle := nil; + end; + if FPage <> nil then + begin + FPDF_ClosePage(FPage); + FPage := nil; + end; +end; +procedure TPdfPage.Open; +begin + if FPage = nil then + begin + FPage := FDocument.ReloadPage(Self); + AfterOpen; + end; +end; +function TPdfPage.GetPdfActionFilePath(Action: FPDF_ACTION): string; +var + ByteSize: Integer; + Buf: UTF8String; +begin + Result := ''; + if Action <> nil then + begin + case FPDFAction_GetType(Action) of + PDFACTION_LAUNCH, + PDFACTION_REMOTEGOTO: + begin + ByteSize := FPDFAction_GetFilePath(Action, nil, 0); + if ByteSize > 0 then + begin + SetLength(Buf, ByteSize); // we could optimize this with "SetLength(Buf, ByteSize - 1)" and use already existing #0 terminator + ByteSize := FPDFAction_GetFilePath(Action, PAnsiChar(Buf), Length(Buf)); + end; + if ByteSize > 0 then + begin + SetLength(Buf, ByteSize - 1); // ByteSize includes #0 + Result := UTF8ToString(Buf); + end; + end; + end; + end; +end; +function TPdfPage.GetPdfActionUriPath(Action: FPDF_ACTION): string; +var + ByteSize: Integer; + Buf: UTF8String; +begin + Result := ''; + if Action <> nil then + begin + ByteSize := FPDFAction_GetURIPath(FDocument.Handle, Action, nil, 0); + if ByteSize > 0 then + begin + SetLength(Buf, ByteSize); // we could optimize this with "SetLength(Buf, ByteSize - 1)" and use already existing #0 terminator + ByteSize := FPDFAction_GetURIPath(FDocument.Handle, Action, PAnsiChar(Buf), Length(Buf)); + end; + if ByteSize > 0 then + begin + SetLength(Buf, ByteSize - 1); // ByteSize includes #0 + Result := UTF8ToString(Buf); + end; + end; +end; +class function TPdfPage.GetDrawFlags(const Options: TPdfPageRenderOptions): Integer; +begin + Result := 0; + if proAnnotations in Options then + Result := Result or FPDF_ANNOT; + if proLCDOptimized in Options then + Result := Result or FPDF_LCD_TEXT; + if proNoNativeText in Options then + Result := Result or FPDF_NO_NATIVETEXT; + if proNoCatch in Options then + Result := Result or FPDF_NO_CATCH; + if proLimitedImageCacheSize in Options then + Result := Result or FPDF_RENDER_LIMITEDIMAGECACHE; + if proForceHalftone in Options then + Result := Result or FPDF_RENDER_FORCEHALFTONE; + if proPrinting in Options then + Result := Result or FPDF_PRINTING; + if proReverseByteOrder in Options then + Result := Result or FPDF_REVERSE_BYTE_ORDER; +end; +{$IFDEF MSWINDOWS} +procedure TPdfPage.Draw(DC: HDC; X, Y, Width, Height: Integer; Rotate: TPdfPageRotation; + const Options: TPdfPageRenderOptions; PageBackground: TColorRef); +var + BitmapInfo: TBitmapInfo; + Bmp, OldBmp: HBITMAP; + BmpBits: Pointer; + PdfBmp: TPdfBitmap; + BmpDC: HDC; + SavedCW: WORD; +begin + Open; + if proPrinting in Options then + begin + SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]); + + if IsValidForm and (FPDFPage_GetAnnotCount(FPage) > 0) then + begin + // Form content isn't printed unless it was flattend and the page was reloaded. + ApplyChanges; + Flatten(True); + Close; + Open; + end; + + // FPU 예외 마스킹 (부동소수점 예외를 무시하게 함) + // 현재 FPU 컨트롤 워드 저장 +// SavedCW := Get8087CW; +// try +// // 모든 FPU 예외 마스크 +// SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]); + + FPDF_RenderPage(DC, FPage, X, Y, Width, Height, Ord(Rotate), GetDrawFlags(Options)); +// finally +// // 원래 상태 복원 +// Set8087CW(SavedCW); +// end; + Exit; + end; + FillChar(BitmapInfo, SizeOf(BitmapInfo), 0); + BitmapInfo.bmiHeader.biSize := SizeOf(BitmapInfo); + BitmapInfo.bmiHeader.biWidth := Width; + BitmapInfo.bmiHeader.biHeight := -Height; // negative Height means top to bottom for Y values + BitmapInfo.bmiHeader.biPlanes := 1; + BitmapInfo.bmiHeader.biBitCount := 32; + BitmapInfo.bmiHeader.biCompression := BI_RGB; + BmpBits := nil; + Bmp := CreateDIBSection(DC, BitmapInfo, DIB_RGB_COLORS, BmpBits, 0, 0); + if Bmp <> 0 then + begin + try + // Use the Windows Bitmap's bits for the PdfBmp + PdfBmp := TPdfBitmap.Create(Width, Height, bfBGRA, BmpBits, Width * 4); + try + Draw(PdfBmp, 0, 0, Width, Height, Rotate, Options, PageBackground); + finally + PdfBmp.Free; + end; + BmpDC := CreateCompatibleDC(DC); + OldBmp := SelectObject(BmpDC, Bmp); + BitBlt(DC, X, Y, Width, Height, BmpDC, 0, 0, SRCCOPY); + SelectObject(BmpDC, OldBmp); + DeleteDC(BmpDC); + finally + DeleteObject(Bmp); + end; + end; +end; +{$ENDIF MSWINDOWS} +procedure TPdfPage.Draw(APdfBitmap: TPdfBitmap; X, Y, Width, Height: Integer; Rotate: TPdfPageRotation = prNormal; + const Options: TPdfPageRenderOptions = []; PageBackground: TColorRef = $FFFFFF); +begin + APdfBitmap.FillRect(0, 0, Width, Height, $FF000000 or PageBackground); + DrawToPdfBitmap(APdfBitmap, 0, 0, Width, Height, Rotate, Options); + DrawFormToPdfBitmap(APdfBitmap, 0, 0, Width, Height, Rotate, Options); +end; +procedure TPdfPage.DrawToPdfBitmap(APdfBitmap: TPdfBitmap; X, Y, Width, Height: Integer; + Rotate: TPdfPageRotation; const Options: TPdfPageRenderOptions); +begin + Open; + FPDF_RenderPageBitmap(APdfBitmap.FBitmap, FPage, X, Y, Width, Height, Ord(Rotate), GetDrawFlags(Options)); +end; +procedure TPdfPage.DrawFormToPdfBitmap(APdfBitmap: TPdfBitmap; X, Y, Width, Height: Integer; + Rotate: TPdfPageRotation; const Options: TPdfPageRenderOptions); +begin + Open; + if IsValidForm then + begin + if proPrinting in Options then + begin + if FDocument.PrintHidesFormFieldHighlight then + FPDF_RemoveFormFieldHighlight(FDocument.FForm); + //FPDF_SetFormFieldHighlightAlpha(FDocument.FForm, 0); // hide the highlight + FormEventKillFocus; + end; + try + FPDF_FFLDraw(FDocument.FForm, APdfBitmap.FBitmap, FPage, X, Y, Width, Height, Ord(Rotate), GetDrawFlags(Options)); + finally + if (proPrinting in Options) and FDocument.PrintHidesFormFieldHighlight then + FDocument.UpdateFormFieldHighlight; + end; + end; +end; +procedure TPdfPage.UpdateMetrics; +begin + FWidth := FPDF_GetPageWidthF(FPage); + FHeight := FPDF_GetPageHeightF(FPage); + FTransparency := FPDFPage_HasTransparency(FPage) <> 0; + FRotation := TPdfPageRotation(FPDFPage_GetRotation(FPage)); +end; +function TPdfPage.DeviceToPage(X, Y, Width, Height: Integer; DeviceX, DeviceY: Integer; Rotate: TPdfPageRotation): TPdfPoint; +begin + Open; + FPDF_DeviceToPage(FPage, X, Y, Width, Height, Ord(Rotate), DeviceX, DeviceY, Result.X, Result.Y); +end; +function TPdfPage.PageToDevice(X, Y, Width, Height: Integer; PageX, PageY: Double; + Rotate: TPdfPageRotation): TPoint; +begin + Open; + FPDF_PageToDevice(FPage, X, Y, Width, Height, Ord(Rotate), PageX, PageY, Result.X, Result.Y); +end; +function TPdfPage.DeviceToPage(X, Y, Width, Height: Integer; const R: TRect; Rotate: TPdfPageRotation): TPdfRect; +begin + Result.TopLeft := DeviceToPage(X, Y, Width, Height, R.Left, R.Top, Rotate); + Result.BottomRight := DeviceToPage(X, Y, Width, Height, R.Right, R.Bottom, Rotate); +end; +function TPdfPage.PageToDevice(X, Y, Width, Height: Integer; const R: TPdfRect; Rotate: TPdfPageRotation): TRect; +var + T: Integer; +begin + Result.TopLeft := PageToDevice(X, Y, Width, Height, R.Left, R.Top, Rotate); + Result.BottomRight := PageToDevice(X, Y, Width, Height, R.Right, R.Bottom, Rotate); + // Page coordinales are upside down, but device coordinates aren't. + if Result.Top > Result.Bottom then + begin + T := Result.Top; + Result.Top := Result.Bottom; + Result.Bottom := T; + end; +end; +procedure TPdfPage.SetRotation(const Value: TPdfPageRotation); +begin + Open; + FPDFPage_SetRotation(FPage, Ord(Value)); + FRotation := TPdfPageRotation(FPDFPage_GetRotation(FPage)); +end; +procedure TPdfPage.ApplyChanges; +begin + if FPage <> nil then + begin + FPDFPage_GenerateContent(FPage); + // Newly added text annotations will not show the text popup unless the page is notified. + FAnnotations.CloseAnnotations; + if IsValidForm then + begin + FORM_DoPageAAction(FPage, FDocument.FForm, FPDFPAGE_AACTION_CLOSE); + FORM_OnBeforeClosePage(FPage, FDocument.FForm); + FORM_OnAfterLoadPage(FPage, FDocument.FForm); + FORM_DoPageAAction(FPage, FDocument.FForm, FPDFPAGE_AACTION_OPEN); + end; + end; +end; +procedure TPdfPage.Flatten(AFlatPrint: Boolean); +const + Flags: array[Boolean] of Integer = (FLAT_NORMALDISPLAY, FLAT_PRINT); +begin + if FPage <> nil then + FPDFPage_Flatten(FPage, Flags[AFlatPrint]); +end; +function TPdfPage.BeginText: Boolean; +begin + if FTextHandle = nil then + begin + Open; + FTextHandle := FPDFText_LoadPage(FPage); + end; + Result := FTextHandle <> nil; +end; +function TPdfPage.BeginWebLinks: Boolean; +begin + // WebLinks are not stored in the PDF but are created by parsing the page's text for URLs. + // They are accessed differently than annotation links, which are stored in the PDF. + if (FPageLinkHandle = nil) and BeginText then + FPageLinkHandle := FPDFLink_LoadWebLinks(FTextHandle); + Result := FPageLinkHandle <> nil; +end; +function TPdfPage.BeginFind(const SearchString: string; MatchCase, MatchWholeWord, + FromEnd: Boolean): Boolean; +var + Flags, StartIndex: Integer; +begin + EndFind; + if BeginText then + begin + Flags := 0; + if MatchCase then + Flags := Flags or FPDF_MATCHCASE; + if MatchWholeWord then + Flags := Flags or FPDF_MATCHWHOLEWORD; + if FromEnd then + StartIndex := -1 + else + StartIndex := 0; + FSearchHandle := FPDFText_FindStart(FTextHandle, PWideChar(SearchString), Flags, StartIndex); + end; + Result := FSearchHandle <> nil; +end; +procedure TPdfPage.EndFind; +begin + if FSearchHandle <> nil then + begin + FPDFText_FindClose(FSearchHandle); + FSearchHandle := nil; + end; +end; +function TPdfPage.FindNext(var CharIndex, Count: Integer): Boolean; +begin + CharIndex := 0; + Count := 0; + if FSearchHandle <> nil then + begin + Result := FPDFText_FindNext(FSearchHandle) <> 0; + if Result then + begin + CharIndex := FPDFText_GetSchResultIndex(FSearchHandle); + Count := FPDFText_GetSchCount(FSearchHandle); + end; + end + else + Result := False; +end; +function TPdfPage.FindPrev(var CharIndex, Count: Integer): Boolean; +begin + CharIndex := 0; + Count := 0; + if FSearchHandle <> nil then + begin + Result := FPDFText_FindPrev(FSearchHandle) <> 0; + if Result then + begin + CharIndex := FPDFText_GetSchResultIndex(FSearchHandle); + Count := FPDFText_GetSchCount(FSearchHandle); + end; + end + else + Result := False; +end; +function TPdfPage.GetCharCount: Integer; +begin + if BeginText then + Result := FPDFText_CountChars(FTextHandle) + else + Result := 0; +end; +function TPdfPage.ReadChar(CharIndex: Integer): WideChar; +begin + if BeginText then + Result := FPDFText_GetUnicode(FTextHandle, CharIndex) + else + Result := #0; +end; +function TPdfPage.GetCharFontSize(CharIndex: Integer): Double; +begin + if BeginText then + Result := FPDFText_GetFontSize(FTextHandle, CharIndex) + else + Result := 0; +end; +function TPdfPage.GetCharBox(CharIndex: Integer): TPdfRect; +begin + if BeginText then + FPDFText_GetCharBox(FTextHandle, CharIndex, Result.Left, Result.Right, Result.Bottom, Result.Top) + else + Result := TPdfRect.Empty; +end; +function TPdfPage.GetCharIndexAt(PageX, PageY, ToleranceX, ToleranceY: Double): Integer; +begin + if BeginText then + Result := FPDFText_GetCharIndexAtPos(FTextHandle, PageX, PageY, ToleranceX, ToleranceY) + else + Result := 0; +end; +function TPdfPage.ReadText(CharIndex, Count: Integer): String; +var + Len: Integer; +begin + if (Count > 0) and BeginText then + begin + SetLength(Result, Count); // we let GetText overwrite our #0 terminator with its #0 + Len := FPDFText_GetText(FTextHandle, CharIndex, Count, PWideChar(Result)) - 1; // returned length includes the #0 + if Len <= 0 then + Result := '' + else if Len < Count then + SetLength(Result, Len); + end + else + Result := ''; +end; + +function TPdfPage.ReadText2(CharIndex, Count: Integer): String; +var + Len: Integer; + arrBuf: array of Char; + i: Integer; +begin + Result := ''; + if (Count > 0) and BeginText then + begin + for i := 0 to Count - 1 do + begin + Result := Result + FPDFText_GetUnicode(FTextHandle, i); + end; + exit; + SetLength(arrBuf, Count + 1); + if FPDFText_GetText(FTextHandle, 0, Count, @arrBuf[0]) > 0 then + begin + Result := String(@arrBuf[0]); +// Result := Format('%s%s', [sLineBreak, PageText]) + sLineBreak + sLineBreak; + end; + end else + Result := ''; +end; + +function TPdfPage.GetTextAt(Left, Top, Right, Bottom: Double): string; +var + Len: Integer; +begin + if BeginText then + begin + Len := FPDFText_GetBoundedText(FTextHandle, Left, Top, Right, Bottom, nil, 0); // excluding #0 terminator + SetLength(Result, Len); + if Len > 0 then + FPDFText_GetBoundedText(FTextHandle, Left, Top, Right, Bottom, PWideChar(Result), Len); + end + else + Result := ''; +end; +function TPdfPage.GetTextAt(const R: TPdfRect): string; +begin + Result := GetTextAt(R.Left, R.Top, R.Right, R.Bottom); +end; +function TPdfPage.GetTextRectCount(CharIndex, Count: Integer): Integer; +begin + if BeginText then + Result := FPDFText_CountRects(FTextHandle, CharIndex, Count) + else + Result := 0; +end; +function TPdfPage.GetTextRect(RectIndex: Integer): TPdfRect; +begin + if BeginText then + FPDFText_GetRect(FTextHandle, RectIndex, Result.Left, Result.Top, Result.Right, Result.Bottom) + else + Result := TPdfRect.Empty; +end; +function TPdfPage.IsUriLinkAtPoint(X, Y: Double): Boolean; +var + Link: FPDF_LINK; + Action: FPDF_ACTION; +begin + Result := False; + Link := FPDFLink_GetLinkAtPoint(Handle, X, Y); + if Link <> nil then + begin + Action := FPDFLink_GetAction(Link); + if (Action <> nil) and (FPDFAction_GetType(Action) = PDFACTION_URI) then + Result := True; + end; +end; +function TPdfPage.IsUriLinkAtPoint(X, Y: Double; var Uri: string): Boolean; +var + Link: FPDF_LINK; + Action: FPDF_ACTION; +begin + Action := nil; + Result := False; + Link := FPDFLink_GetLinkAtPoint(Handle, X, Y); + if Link <> nil then + begin + Action := FPDFLink_GetAction(Link); + if (Action <> nil) and (FPDFAction_GetType(Action) = PDFACTION_URI) then + Result := True; + end; + if Result then + Uri := GetPdfActionUriPath(Action) + else + Uri := ''; +end; +function TPdfPage.GetLinkAtPoint(X, Y: Double): TPdfAnnotation; +var + Link: FPDF_LINK; +begin + Link := FPDFLink_GetLinkAtPoint(Handle, X, Y); + if Link <> nil then + begin + Result := Annotations.FindLink(Link); + if (Result <> nil) and (Result.LinkType = altUnsupported) then + Result := nil; + end + else + Result := nil; +end; +function TPdfPage.GetWebLinkCount: Integer; +begin + if BeginWebLinks then + begin + Result := FPDFLink_CountWebLinks(FPageLinkHandle); + if Result < 0 then + Result := 0; + end + else + Result := 0; +end; +function TPdfPage.GetWebLinkURL(LinkIndex: Integer): string; +var + Len: Integer; +begin + Result := ''; + if BeginWebLinks then + begin + Len := FPDFLink_GetURL(FPageLinkHandle, LinkIndex, nil, 0) - 1; // including #0 terminator + if Len > 0 then + begin + SetLength(Result, Len); + FPDFLink_GetURL(FPageLinkHandle, LinkIndex, PWideChar(Result), Len + 1); // including #0 terminator + end; + end; +end; +function TPdfPage.GetWebLinkRectCount(LinkIndex: Integer): Integer; +begin + if BeginWebLinks then + Result := FPDFLink_CountRects(FPageLinkHandle, LinkIndex) + else + Result := 0; +end; +function TPdfPage.GetWebLinkRect(LinkIndex, RectIndex: Integer): TPdfRect; +begin + if BeginWebLinks then + FPDFLink_GetRect(FPageLinkHandle, LinkIndex, RectIndex, Result.Left, Result.Top, Result.Right, Result.Bottom) + else + Result := TPdfRect.Empty; +end; +function TPdfPage.IsWebLinkAtPoint(X, Y: Double): Boolean; +var + LinkIndex, RectIndex: Integer; + Pt: TPdfPoint; +begin + Result := True; + Pt.X := X; + Pt.Y := Y; + for LinkIndex := 0 to GetWebLinkCount - 1 do + for RectIndex := 0 to GetWebLinkRectCount(LinkIndex) - 1 do + if GetWebLinkRect(LinkIndex, RectIndex).PtIn(Pt) then + Exit; + Result := False; +end; +function TPdfPage.IsWebLinkAtPoint(X, Y: Double; var URL: string): Boolean; +var + LinkIndex, RectIndex: Integer; + Pt: TPdfPoint; +begin + Result := True; + Pt.X := X; + Pt.Y := Y; + for LinkIndex := 0 to GetWebLinkCount - 1 do + begin + for RectIndex := 0 to GetWebLinkRectCount(LinkIndex) - 1 do + begin + if GetWebLinkRect(LinkIndex, RectIndex).PtIn(Pt) then + begin + URL := GetWebLinkURL(LinkIndex); + Exit; + end; + end; + end; + Result := False; +end; +function TPdfPage.ShiftStateToModifier(const Shift: TShiftState): Integer; +begin + Result := 0; + if ssShift in Shift then + Result := Result or FWL_EVENTFLAG_ShiftKey; + if ssCtrl in Shift then + Result := Result or FWL_EVENTFLAG_ControlKey; + if ssAlt in Shift then + Result := Result or FWL_EVENTFLAG_AltKey; + if ssLeft in Shift then + Result := Result or FWL_EVENTFLAG_LeftButtonDown; + if ssMiddle in Shift then + Result := Result or FWL_EVENTFLAG_MiddleButtonDown; + if ssRight in Shift then + Result := Result or FWL_EVENTFLAG_RightButtonDown; +end; +function TPdfPage.FormEventFocus(const Shift: TShiftState; PageX, PageY: Double): Boolean; +begin + if IsValidForm then + Result := FORM_OnFocus(FDocument.FForm, FPage, ShiftStateToModifier(Shift), PageX, PageY) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventMouseWheel(const Shift: TShiftState; WheelDelta: Integer; PageX, PageY: Double): Boolean; +var + Pt: TFSPointF; + WheelX, WheelY: Integer; +begin + if IsValidForm then + begin + Pt.X := PageX; + Pt.Y := PageY; + WheelX := 0; + WheelY := 0; + if ssShift in Shift then + WheelX := WheelDelta + else + WheelY := WheelDelta; + Result := FORM_OnMouseWheel(FDocument.FForm, FPage, ShiftStateToModifier(Shift), @Pt, WheelX, WheelY) <> 0; + end + else + Result := False; +end; +function TPdfPage.FormEventMouseMove(const Shift: TShiftState; PageX, PageY: Double): Boolean; +begin + if IsValidForm then + Result := FORM_OnMouseMove(FDocument.FForm, FPage, ShiftStateToModifier(Shift), PageX, PageY) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventLButtonDown(const Shift: TShiftState; PageX, PageY: Double): Boolean; +begin + if IsValidForm then + Result := FORM_OnLButtonDown(FDocument.FForm, FPage, ShiftStateToModifier(Shift), PageX, PageY) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventLButtonUp(const Shift: TShiftState; PageX, PageY: Double): Boolean; +begin + if IsValidForm then + Result := FORM_OnLButtonUp(FDocument.FForm, FPage, ShiftStateToModifier(Shift), PageX, PageY) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventRButtonDown(const Shift: TShiftState; PageX, PageY: Double): Boolean; +begin + if IsValidForm then + Result := FORM_OnRButtonDown(FDocument.FForm, FPage, ShiftStateToModifier(Shift), PageX, PageY) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventRButtonUp(const Shift: TShiftState; PageX, PageY: Double): Boolean; +begin + if IsValidForm then + Result := FORM_OnRButtonUp(FDocument.FForm, FPage, ShiftStateToModifier(Shift), PageX, PageY) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventKeyDown(KeyCode: Word; const Shift: TShiftState): Boolean; +begin + if IsValidForm then + Result := FORM_OnKeyDown(FDocument.FForm, FPage, KeyCode, ShiftStateToModifier(Shift)) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventKeyUp(KeyCode: Word; const Shift: TShiftState): Boolean; +begin + if IsValidForm then + Result := FORM_OnKeyUp(FDocument.FForm, FPage, KeyCode, ShiftStateToModifier(Shift)) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventKeyPress(Key: Word; const Shift: TShiftState): Boolean; +begin + if IsValidForm then + Result := FORM_OnChar(FDocument.FForm, FPage, Key, ShiftStateToModifier(Shift)) <> 0 + else + Result := False; +end; +function TPdfPage.FormEventKillFocus: Boolean; +begin + if IsValidForm then + Result := FORM_ForceToKillFocus(FDocument.FForm) <> 0 + else + Result := False; +end; +function TPdfPage.FormGetFocusedText: string; +var + ByteLen: LongWord; +begin + if IsValidForm then + begin + ByteLen := FORM_GetFocusedText(FDocument.FForm, FPage, nil, 0); // UTF 16 including #0 terminator in byte size + if ByteLen <= 2 then // WideChar(#0) => empty string + Result := '' + else + begin + SetLength(Result, ByteLen div SizeOf(WideChar) - 1); + FORM_GetFocusedText(FDocument.FForm, FPage, PWideChar(Result), ByteLen); + end; + end + else + Result := ''; +end; +function TPdfPage.FormGetSelectedText: string; +var + ByteLen: LongWord; +begin + if IsValidForm then + begin + ByteLen := FORM_GetSelectedText(FDocument.FForm, FPage, nil, 0); // UTF 16 including #0 terminator in byte size + if ByteLen <= 2 then // WideChar(#0) => empty string + Result := '' + else + begin + SetLength(Result, ByteLen div SizeOf(WideChar) - 1); + FORM_GetSelectedText(FDocument.FForm, FPage, PWideChar(Result), ByteLen); + end; + end + else + Result := ''; +end; +function TPdfPage.FormReplaceSelection(const ANewText: string): Boolean; +begin + if IsValidForm then + begin + FORM_ReplaceSelection(FDocument.FForm, FPage, PWideChar(ANewText)); + Result := True; + end + else + Result := False; +end; +function TPdfPage.FormReplaceAndKeepSelection(const ANewText: string): Boolean; +begin + if IsValidForm then + begin + FORM_ReplaceAndKeepSelection(FDocument.FForm, FPage, PWideChar(ANewText)); + Result := True; + end + else + Result := False; +end; +function TPdfPage.FormSelectAllText: Boolean; +begin + if IsValidForm then + Result := FORM_SelectAllText(FDocument.FForm, FPage) <> 0 + else + Result := False; +end; +function TPdfPage.FormCanUndo: Boolean; +begin + if IsValidForm then + Result := FORM_CanUndo(FDocument.FForm, FPage) <> 0 + else + Result := False; +end; +function TPdfPage.FormCanRedo: Boolean; +begin + if IsValidForm then + Result := FORM_CanRedo(FDocument.FForm, FPage) <> 0 + else + Result := False; +end; +function TPdfPage.FormUndo: Boolean; +begin + if IsValidForm then + Result := FORM_Undo(FDocument.FForm, FPage) <> 0 + else + Result := False; +end; +function TPdfPage.FormRedo: Boolean; +begin + if IsValidForm then + Result := FORM_Redo(FDocument.FForm, FPage) <> 0 + else + Result := False; +end; +function TPdfPage.HasFormFieldAtPoint(X, Y: Double): TPdfFormFieldType; +begin + Result := TPdfFormFieldType(FPDFPage_HasFormFieldAtPoint(FDocument.FForm, FPage, X, Y)); + if (Result < Low(TPdfFormFieldType)) or (Result > High(TPdfFormFieldType)) then + Result := fftUnknown; +end; +function TPdfPage.GetHandle: FPDF_PAGE; +begin + Open; + Result := FPage; +end; +function TPdfPage.IsLoaded: Boolean; +begin + Result := FPage <> nil; +end; +function TPdfPage.GetTextHandle: FPDF_TEXTPAGE; +begin + if BeginText then + Result := FTextHandle + else + Result := nil; +end; +function TPdfPage.GetFormFields: TPdfFormFieldList; +begin + Result := Annotations.FormFields; +end; + +{ _TPdfBitmapHideCtor } +constructor _TPdfBitmapHideCtor.Create; +begin + inherited Create; +end; + +{ TPdfBitmap } +constructor TPdfBitmap.Create(ABitmap: FPDF_BITMAP; AOwnsBitmap: Boolean); +begin + inherited Create; + FBitmap := ABitmap; + FOwnsBitmap := AOwnsBitmap; + if FBitmap <> nil then + begin + FWidth := FPDFBitmap_GetWidth(FBitmap); + FHeight := FPDFBitmap_GetHeight(FBitmap); + FBytesPerScanLine := FPDFBitmap_GetStride(FBitmap); + end; +end; +constructor TPdfBitmap.Create(AWidth, AHeight: Integer; AAlpha: Boolean); +begin + Create(FPDFBitmap_Create(AWidth, AHeight, Ord(AAlpha)), True); +end; +constructor TPdfBitmap.Create(AWidth, AHeight: Integer; AFormat: TPdfBitmapFormat); +begin + Create(FPDFBitmap_CreateEx(AWidth, AHeight, Ord(AFormat), nil, 0), True); +end; +constructor TPdfBitmap.Create(AWidth, AHeight: Integer; AFormat: TPdfBitmapFormat; ABuffer: Pointer; + ABytesPerScanLine: Integer); +begin + Create(FPDFBitmap_CreateEx(AWidth, AHeight, Ord(AFormat), ABuffer, ABytesPerScanline), True); +end; +destructor TPdfBitmap.Destroy; +begin + if FOwnsBitmap and (FBitmap <> nil) then + FPDFBitmap_Destroy(FBitmap); + inherited Destroy; +end; +function TPdfBitmap.GetBuffer: Pointer; +begin + if FBitmap <> nil then + Result := FPDFBitmap_GetBuffer(FBitmap) + else + Result := nil; +end; +procedure TPdfBitmap.FillRect(ALeft, ATop, AWidth, AHeight: Integer; AColor: FPDF_DWORD); +begin + if FBitmap <> nil then + FPDFBitmap_FillRect(FBitmap, ALeft, ATop, AWidth, AHeight, AColor); +end; +{ TPdfPoint } +procedure TPdfPoint.Offset(XOffset, YOffset: Double); +begin + X := X + XOffset; + Y := Y + YOffset; +end; +class function TPdfPoint.Empty: TPdfPoint; +begin + Result.X := 0; + Result.Y := 0; +end; + +{ TPdfAttachmentList } +constructor TPdfAttachmentList.Create(ADocument: TPdfDocument); +begin + inherited Create; + FDocument := ADocument; +end; +function TPdfAttachmentList.GetCount: Integer; +begin + FDocument.CheckActive; + Result := FPDFDoc_GetAttachmentCount(FDocument.Handle); +end; +function TPdfAttachmentList.GetItem(Index: Integer): TPdfAttachment; +var + Attachment: FPDF_ATTACHMENT; +begin + FDocument.CheckActive; + Attachment := FPDFDoc_GetAttachment(FDocument.Handle, Index); + if Attachment = nil then + raise EPdfArgumentOutOfRange.CreateResFmt(@RsArgumentsOutOfRange, ['Index']); + Result.FDocument := FDocument; + Result.FHandle := Attachment; +end; +procedure TPdfAttachmentList.Delete(Index: Integer); +begin + FDocument.CheckActive; + if FPDFDoc_DeleteAttachment(FDocument.Handle, Index) = 0 then + raise EPdfException.CreateResFmt(@RsPdfCannotDeleteAttachmnent, [Index]); +end; +function TPdfAttachmentList.Add(const Name: string): TPdfAttachment; +begin + FDocument.CheckActive; + Result.FDocument := FDocument; + Result.FHandle := FPDFDoc_AddAttachment(FDocument.Handle, PWideChar(Name)); + if Result.FHandle = nil then + raise EPdfException.CreateResFmt(@RsPdfCannotAddAttachmnent, [Name]); +end; +function TPdfAttachmentList.IndexOf(const Name: string): Integer; +begin + for Result := 0 to Count - 1 do + if Items[Result].Name = Name then + Exit; + Result := -1; +end; + +{ TPdfAttachment } +function TPdfAttachment.GetName: string; +var + ByteLen: LongWord; +begin + CheckValid; + ByteLen := FPDFAttachment_GetName(Handle, nil, 0); // UTF 16 including #0 terminator in byte size + if ByteLen <= 2 then + Result := '' + else + begin + SetLength(Result, ByteLen div SizeOf(WideChar) - 1); + FPDFAttachment_GetName(FHandle, PWideChar(Result), ByteLen); + end; +end; +procedure TPdfAttachment.CheckValid; +begin + if FDocument <> nil then + FDocument.CheckActive; +end; +procedure TPdfAttachment.SetContent(ABytes: PByte; Count: Integer); +begin + CheckValid; + if FPDFAttachment_SetFile(FHandle, FDocument.Handle, ABytes, Count) = 0 then + raise EPdfException.CreateResFmt(@RsPdfCannotSetAttachmentContent, [Name]); +end; +procedure TPdfAttachment.SetContent(const Value: RawByteString); +begin + if Value = '' then + SetContent(nil, 0) + else + SetContent(PByte(PAnsiChar(Value)), Length(Value) * SizeOf(AnsiChar)); +end; +procedure TPdfAttachment.SetContent(const Value: string; Encoding: TEncoding = nil); +begin + CheckValid; + if Value = '' then + SetContent(nil, 0) + else if (Encoding = nil) or (Encoding = TEncoding.UTF8) then + SetContent(UTF8Encode(Value)) + else + SetContent(Encoding.GetBytes(Value)); +end; +procedure TPdfAttachment.SetContent(const ABytes: TBytes; Index: NativeInt; Count: Integer); +var + Len: NativeInt; +begin + CheckValid; + Len := Length(ABytes); + if Index >= Len then + raise EPdfArgumentOutOfRange.CreateResFmt(@RsArgumentsOutOfRange, ['Index', Index]); + if Index + Count > Len then + raise EPdfArgumentOutOfRange.CreateResFmt(@RsArgumentsOutOfRange, ['Count', Count]); + if Count = 0 then + SetContent(nil, 0) + else + SetContent(@ABytes[Index], Count); +end; +procedure TPdfAttachment.SetContent(const ABytes: TBytes); +begin + SetContent(ABytes, 0, Length(ABytes)); +end; +procedure TPdfAttachment.LoadFromStream(Stream: TStream); +var + StreamPos, StreamSize: Int64; + Buf: PByte; + Count: Integer; +begin + CheckValid; + StreamPos := Stream.Position; + StreamSize := Stream.Size; + Count := StreamSize - StreamPos; + if Count = 0 then + SetContent(nil, 0) + else + begin + if Stream is TCustomMemoryStream then // direct access to the memory + begin + SetContent(PByte(TCustomMemoryStream(Stream).Memory) + StreamPos, Count); + Stream.Position := StreamSize; // simulate the ReadBuffer call + end + else + begin + if Count = 0 then + SetContent(nil, 0) + else + begin + GetMem(Buf, Count); + try + Stream.ReadBuffer(Buf^, Count); + SetContent(Buf, Count); + finally + FreeMem(Buf); + end; + end; + end; + end; +end; +procedure TPdfAttachment.LoadFromFile(const FileName: string); +var + Stream: TFileStream; +begin + CheckValid; + Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; +function TPdfAttachment.HasKey(const Key: string): Boolean; +begin + CheckValid; + Result := FPDFAttachment_HasKey(FHandle, PAnsiChar(UTF8Encode(Key))) <> 0; +end; +function TPdfAttachment.GetValueType(const Key: string): TPdfObjectType; +begin + CheckValid; + Result := TPdfObjectType(FPDFAttachment_GetValueType(FHandle, PAnsiChar(UTF8Encode(Key)))); +end; +procedure TPdfAttachment.SetKeyValue(const Key, Value: string); +begin + CheckValid; + if FPDFAttachment_SetStringValue(FHandle, PAnsiChar(UTF8Encode(Key)), PWideChar(Value)) = 0 then + raise EPdfException.CreateRes(@RsPdfAttachmentContentNotSet); +end; +function TPdfAttachment.GetKeyValue(const Key: string): string; +var + ByteLen: LongWord; + Utf8Key: UTF8String; +begin + CheckValid; + Utf8Key := UTF8Encode(Key); + ByteLen := FPDFAttachment_GetStringValue(FHandle, PAnsiChar(Utf8Key), nil, 0); + if ByteLen = 0 then + raise EPdfException.CreateRes(@RsPdfAttachmentContentNotSet); + if ByteLen <= 2 then + Result := '' + else + begin + SetLength(Result, (ByteLen div SizeOf(WideChar) - 1)); + FPDFAttachment_GetStringValue(FHandle, PAnsiChar(Utf8Key), PWideChar(Result), ByteLen); + end; +end; +function TPdfAttachment.GetContentSize: Integer; +var + OutBufLen: LongWord; +begin + CheckValid; + if FPDFAttachment_GetFile(FHandle, nil, 0, OutBufLen) = 0 then + Result := 0 + else + Result := Integer(OutBufLen); +end; +function TPdfAttachment.HasContent: Boolean; +var + OutBufLen: LongWord; +begin + CheckValid; + Result := FPDFAttachment_GetFile(FHandle, nil, 0, OutBufLen) <> 0; +end; +procedure TPdfAttachment.SaveToFile(const FileName: string); +var + Stream: TStream; +begin + CheckValid; + Stream := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; +procedure TPdfAttachment.SaveToStream(Stream: TStream); +var + Size: Integer; + OutBufLen: LongWord; + StreamPos: Int64; + Buf: PByte; +begin + Size := ContentSize; + if Size > 0 then + begin + if Stream is TCustomMemoryStream then // direct access to the memory + begin + StreamPos := Stream.Position; + if StreamPos + Size > Stream.Size then + Stream.Size := StreamPos + Size; // allocate enough memory + Stream.Position := StreamPos; + FPDFAttachment_GetFile(FHandle, PByte(TCustomMemoryStream(Stream).Memory) + StreamPos, Size, OutBufLen); + Stream.Position := StreamPos + Size; // simulate Stream.WriteBuffer + end + else + begin + GetMem(Buf, Size); + try + FPDFAttachment_GetFile(FHandle, Buf, Size, OutBufLen); + Stream.WriteBuffer(Buf^, Size); + finally + FreeMem(Buf); + end; + end; + end; +end; +procedure TPdfAttachment.GetContent(var Value: string; Encoding: TEncoding); +var + Size: Integer; + OutBufLen: LongWord; + Buf: PByte; +begin + Size := ContentSize; + if Size <= 0 then + Value := '' + else if Encoding = TEncoding.Unicode then // no conversion needed + begin + SetLength(Value, Size div SizeOf(WideChar)); + FPDFAttachment_GetFile(FHandle, PWideChar(Value), Size, OutBufLen); + end + else + begin + if Encoding = nil then + Encoding := TEncoding.UTF8; + GetMem(Buf, Size); + try + FPDFAttachment_GetFile(FHandle, Buf, Size, OutBufLen); + SetLength(Value, TEncodingAccess(Encoding).GetMemCharCount(Buf, Size)); + if Value <> '' then + TEncodingAccess(Encoding).GetMemChars(Buf, Size, PWideChar(Value), Length(Value)); + finally + FreeMem(Buf); + end; + end; +end; +procedure TPdfAttachment.GetContent(var Value: RawByteString); +var + Size: Integer; + OutBufLen: LongWord; +begin + Size := ContentSize; + if Size <= 0 then + Value := '' + else + begin + SetLength(Value, Size); + FPDFAttachment_GetFile(FHandle, PAnsiChar(Value), Size, OutBufLen); + end; +end; +procedure TPdfAttachment.GetContent(Buffer: PByte); +var + OutBufLen: LongWord; +begin + FPDFAttachment_GetFile(FHandle, Buffer, ContentSize, OutBufLen); +end; +procedure TPdfAttachment.GetContent(var ABytes: TBytes); +var + Size: Integer; + OutBufLen: LongWord; +begin + Size := ContentSize; + if Size <= 0 then + ABytes := nil + else + begin + SetLength(ABytes, Size); + FPDFAttachment_GetFile(FHandle, @ABytes[0], Size, OutBufLen); + end; +end; +function TPdfAttachment.GetContentAsBytes: TBytes; +begin + GetContent(Result); +end; +function TPdfAttachment.GetContentAsRawByteString: RawByteString; +begin + GetContent(Result); +end; +function TPdfAttachment.GetContentAsString(Encoding: TEncoding): string; +begin + GetContent(Result, Encoding); +end; + +{ TPdfAnnotationList } +constructor TPdfAnnotationList.Create(APage: TPdfPage); +begin + inherited Create; + FPage := APage; + FItems := TObjectList.Create; +end; +destructor TPdfAnnotationList.Destroy; +begin + FreeAndNil(FFormFields); + FreeAndNil(FItems); // closes all annotations + inherited Destroy; +end; +procedure TPdfAnnotationList.CloseAnnotations; +begin + FreeAndNil(FFormFields); + FreeAndNil(FItems); // closes all annotations + FItems := TObjectList.Create; +end; +function TPdfAnnotationList.GetCount: Integer; +begin + Result := FPDFPage_GetAnnotCount(FPage.Handle); +end; +function TPdfAnnotationList.GetItem(Index: Integer): TPdfAnnotation; +var + Annot: FPDF_ANNOTATION; +begin + FPage.FDocument.CheckActive; + if (Index < 0) or (Index >= FItems.Count) or (FItems[Index] = nil) then + begin + Annot := FPDFPage_GetAnnot(FPage.Handle, Index); + if Annot = nil then + raise EPdfArgumentOutOfRange.CreateResFmt(@RsArgumentsOutOfRange, ['Index']); + while FItems.Count <= Index do + FItems.Add(nil); + FItems[Index] := TPdfAnnotation.Create(FPage, Annot); + end; + Result := FItems[Index] as TPdfAnnotation; +end; +procedure TPdfAnnotationList.DestroyingItem(Item: TPdfAnnotation); +var + Index: Integer; +begin + if (Item <> nil) and (FItems <> nil) then + begin + Index := FItems.IndexOf(Item); + if Index <> -1 then + FItems.List[Index] := nil; // Bypass the Items[] setter to not destroy the Item twice + end; +end; +procedure TPdfAnnotationList.DestroyingFormField(FormField: TPdfFormField); +begin + if FFormFields <> nil then + FFormFields.DestroyingItem(FormField); +end; +function TPdfAnnotationList.GetFormFields: TPdfFormFieldList; +begin + if FFormFields = nil then + FFormFields := TPdfFormFieldList.Create(Self); + Result := FFormFields; +end; +function TPdfAnnotationList.GetAnnotationsLoaded: Boolean; +begin + Result := FItems.Count > 0; +end; +function TPdfAnnotationList.NewTextAnnotation(const Text: string; const R: TPdfRect): Boolean; +var + Annot: FPDF_ANNOTATION; + SingleR: FS_RECTF; +begin + FPage.FDocument.CheckActive; + SingleR.left := R.Left; + SingleR.right := R.Right; + // Page coordinates are upside down + if R.Top < R.Bottom then + begin + SingleR.top := R.Bottom; + SingleR.bottom := R.Top; + end + else + begin + SingleR.top := R.Top; + SingleR.bottom := R.Bottom; + end; + + Annot := FPDFPage_CreateAnnot(FPage.Handle, FPDF_ANNOT_TEXT); + Result := Annot <> nil; + if Result then + begin + FPDFAnnot_SetRect(Annot, @SingleR); + FPDFAnnot_SetStringValue(Annot, 'Contents', PWideChar(Text)); + end; +end; +function TPdfAnnotationList.FindLink(Link: FPDF_LINK): TPdfAnnotation; +var + I: Integer; +begin + for I := 0 to Count - 1 do + begin + Result := Items[I]; + if (Result.IsLink) and (FPDFAnnot_GetLink(Result.Handle) = Link) then + Exit; + end; + Result := nil; +end; + +{ TPdfFormFieldList } +constructor TPdfFormFieldList.Create(AAnnotations: TPdfAnnotationList); +var + I: Integer; +begin + inherited Create; + FItems := TList.Create; + for I := 0 to AAnnotations.Count - 1 do + if AAnnotations[I].IsFormField then + FItems.Add(AAnnotations[I].FormField); +end; +destructor TPdfFormFieldList.Destroy; +begin + FItems.Free; + inherited Destroy; +end; +function TPdfFormFieldList.GetCount: Integer; +begin + Result := FItems.Count; +end; +function TPdfFormFieldList.GetItem(Index: Integer): TPdfFormField; +begin + Result := TObject(FItems[Index]) as TPdfFormField; +end; +procedure TPdfFormFieldList.DestroyingItem(Item: TPdfFormField); +begin + if (Item <> nil) and (FItems <> nil) then + FItems.Extract(Item); +end; + +{ TPdfAnnotation } +constructor TPdfAnnotation.Create(APage: TPdfPage; AHandle: FPDF_ANNOTATION); +var + Action: FPDF_ACTION; +begin + inherited Create; + FPage := APage; + FHandle := AHandle; + FSubType := FPDFAnnot_GetSubtype(FHandle); + FLinkType := altUnsupported; + case FSubType of + FPDF_ANNOT_WIDGET, + FPDF_ANNOT_XFAWIDGET: + FFormField := TPdfFormField.Create(Self); + FPDF_ANNOT_LINK: + begin + Action := GetPdfLinkAction; + if Action <> nil then + FLinkType := TPdfAnnotationLinkType(FPDFAction_GetType(Action)) + else + begin + // If we have a Dest-Link then we treat it like a Goto Action-Link (see GetLinkGotoDestination) + FLinkDest := FPDFLink_GetDest(FPage.FDocument.Handle, FPDFAnnot_GetLink(Handle)); + if FLinkDest <> nil then + FLinkType := altGoto; + end; + end; + end; +end; +destructor TPdfAnnotation.Destroy; +begin + FreeAndNil(FFormField); + if FHandle <> nil then + begin + FPDFPage_CloseAnnot(FHandle); + FHandle := nil; + end; + if FPage.FAnnotations <> nil then + FPage.FAnnotations.DestroyingItem(Self); + inherited Destroy; +end; +function TPdfAnnotation.GetPdfLinkAction: FPDF_ACTION; +var + Link: FPDF_LINK; +begin + Result := nil; + if FSubType = FPDF_ANNOT_LINK then + begin + Link := FPDFAnnot_GetLink(Handle); + if Link <> nil then + Result := FPDFLink_GetAction(Link); + end; +end; +function TPdfAnnotation.IsLink: Boolean; +begin + Result := FSubType = FPDF_ANNOT_LINK; +end; +function TPdfAnnotation.IsFormField: Boolean; +begin + Result := FFormField <> nil; +end; +function TPdfAnnotation.GetFormField: TPdfFormField; +begin + if FFormField = nil then + raise EPdfException.CreateRes(@RsPdfAnnotationNotAFormFieldError); + Result := FFormField; +end; +function TPdfAnnotation.GetAnnotationRect: TPdfRect; +var + R: FS_RECTF; +begin + if FPDFAnnot_GetRect(Handle, @R) <> 0 then + Result := TPdfRect.New(R.left, R.top, R.right, R.bottom) + else + Result := TPdfRect.Empty; +end; +function TPdfAnnotation.GetLinkUri: string; +begin + if LinkType = altURI then + Result := FPage.GetPdfActionUriPath(GetPdfLinkAction) + else + Result := ''; +end; +function TPdfAnnotation.GetLinkFileName: string; +begin + if LinkType in [altRemoteGoto, altLaunch, altEmbeddedGoto] then // PDFium documentation is missing the PDFACTION_EMBEDDEDGOTO part. + Result := FPage.GetPdfActionFilePath(GetPdfLinkAction) + else + Result := ''; +end; +function TPdfAnnotation.GetLinkGotoDestination(var LinkGotoDestination: TPdfLinkGotoDestination; ARemoteDocument: TPdfDocument): Boolean; +var + Action: FPDF_ACTION; + Dest: FPDF_DEST; + Doc: TPdfDocument; + PageIndex: Integer; + HasXVal, HasYVal, HasZoomVal: FPDF_BOOL; + X, Y, Zoom: FS_FLOAT; + ViewKind: TPdfLinkGotoDestinationViewKind; + NumViewParams: LongWord; + ViewParams: TPdfFloatArray; +begin + Result := False; + Action := GetPdfLinkAction; + if ((Action <> nil) or (FLinkDest <> nil)) and (LinkType in [altGoto, altRemoteGoto, altEmbeddedGoto]) then + begin + Doc := FPage.FDocument; + if LinkType = altRemoteGoto then + begin + // For RemoteGoto the FPDFAction_GetDest function must be called with the remote document + if ARemoteDocument <> nil then + raise EPdfException.CreateRes(@RsPdfAnnotationLinkRemoteGotoRequiresRemoteDocument); + ARemoteDocument.CheckActive; + Doc := ARemoteDocument; + end; + // If we have a Dest-Link instead of a Goto Action-Link we treat it as if it was a Goto Action-Link + if FLinkDest <> nil then + Dest := FLinkDest + else + Dest := FPDFAction_GetDest(Doc.Handle, Action); + // Extract the information + if Dest <> nil then + begin + PageIndex := FPDFDest_GetDestPageIndex(Doc.Handle, Dest); + if PageIndex <> -1 then + begin + if FPDFDest_GetLocationInPage(Dest, HasXVal, HasYVal, HasZoomVal, X, Y, Zoom) <> 0 then + begin + SetLength(ViewParams, 4); // max. 4 params + NumViewParams := 4; + ViewKind := TPdfLinkGotoDestinationViewKind(FPDFDest_GetView(Dest, @NumViewParams, @ViewParams[0])); + if NumViewParams > 4 then // range check + NumViewParams := 4; + SetLength(ViewParams, NumViewParams); + LinkGotoDestination := TPdfLinkGotoDestination.Create( + PageIndex, + HasXVal <> 0, HasYVal <> 0, HasZoomVal <> 0, + X, Y, Zoom, + ViewKind, ViewParams + ); + Result := True; + end; + end; + end; + end; +end; + +{ TPdfFormField } +constructor TPdfFormField.Create(AAnnotation: TPdfAnnotation); +begin + inherited Create; + FAnnotation := AAnnotation; + FPage := FAnnotation.FPage; + FHandle := FAnnotation.Handle; +end; +destructor TPdfFormField.Destroy; +begin + FAnnotation.FFormField := nil; + FAnnotation.FPage.Annotations.DestroyingFormField(Self); + inherited Destroy; +end; +function TPdfFormField.IsXFAFormField: Boolean; +begin + Result := IS_XFA_FORMFIELD(FPDFAnnot_GetFormFieldType(FPage.FDocument.FormHandle, Handle)); +end; +function TPdfFormField.GetReadOnly: Boolean; +begin + Result := fffReadOnly in Flags; +end; +function TPdfFormField.GetFlags: TPdfFormFieldFlags; +var + FormFlags: Integer; +begin + FormFlags := FPDFAnnot_GetFormFieldFlags(FPage.FDocument.FormHandle, Handle); + Result := []; + if FormFlags <> FPDF_FORMFLAG_NONE then + begin + if FormFlags and FPDF_FORMFLAG_READONLY <> 0 then + Include(Result, fffReadOnly); + if FormFlags and FPDF_FORMFLAG_REQUIRED <> 0 then + Include(Result, fffRequired); + if FormFlags and FPDF_FORMFLAG_NOEXPORT <> 0 then + Include(Result, fffNoExport); + if FormFlags and FPDF_FORMFLAG_TEXT_MULTILINE <> 0 then + Include(Result, fffTextMultiLine); + if FormFlags and FPDF_FORMFLAG_TEXT_PASSWORD <> 0 then + Include(Result, fffTextPassword); + if FormFlags and FPDF_FORMFLAG_CHOICE_COMBO <> 0 then + Include(Result, fffChoiceCombo); + if FormFlags and FPDF_FORMFLAG_CHOICE_EDIT <> 0 then + Include(Result, fffChoiceEdit); + if FormFlags and FPDF_FORMFLAG_CHOICE_MULTI_SELECT <> 0 then + Include(Result, fffChoiceMultiSelect); + end; +end; +function TPdfFormField.GetName: string; +var + Len: Integer; +begin + Len := FPDFAnnot_GetFormFieldName(FPage.FDocument.FormHandle, Handle, nil, 0) div SizeOf(WideChar) - 1; + if Len > 0 then + begin + SetLength(Result, Len); + FPDFAnnot_GetFormFieldName(FPage.FDocument.FormHandle, Handle, PWideChar(Result), (Len + 1) * SizeOf(WideChar)); + end + else + Result := ''; +end; +function TPdfFormField.GetAlternateName: string; +var + Len: Integer; +begin + Len := FPDFAnnot_GetFormFieldAlternateName(FPage.FDocument.FormHandle, Handle, nil, 0) div SizeOf(WideChar) - 1; + if Len > 0 then + begin + SetLength(Result, Len); + FPDFAnnot_GetFormFieldAlternateName(FPage.FDocument.FormHandle, Handle, PWideChar(Result), (Len + 1) * SizeOf(WideChar)); + end + else + Result := ''; +end; +function TPdfFormField.GetFieldType: TPdfFormFieldType; +begin + Result := TPdfFormFieldType(FPDFAnnot_GetFormFieldType(FPage.FDocument.FormHandle, Handle)); + if (Result < Low(TPdfFormFieldType)) or (Result > High(TPdfFormFieldType)) then + Result := fftUnknown; +end; +function TPdfFormField.GetValue: string; +var + Len: Integer; +begin + Len := FPDFAnnot_GetFormFieldValue(FPage.FDocument.FormHandle, Handle, nil, 0) div SizeOf(WideChar) - 1; + if Len > 0 then + begin + SetLength(Result, Len); + FPDFAnnot_GetFormFieldValue(FPage.FDocument.FormHandle, Handle, PWideChar(Result), (Len + 1) * SizeOf(WideChar)); + end + else + Result := ''; +end; +function TPdfFormField.GetExportValue: string; +var + Len: Integer; +begin + Len := FPDFAnnot_GetFormFieldExportValue(FPage.FDocument.FormHandle, Handle, nil, 0) div SizeOf(WideChar) - 1; + if Len > 0 then + begin + SetLength(Result, Len); + FPDFAnnot_GetFormFieldExportValue(FPage.FDocument.FormHandle, Handle, PWideChar(Result), (Len + 1) * SizeOf(WideChar)); + end + else + Result := ''; +end; +function TPdfFormField.GetOptionCount: Integer; +begin + Result := FPDFAnnot_GetOptionCount(FPage.FDocument.FormHandle, Handle); + if Result < 0 then // annotation types that don't support options will return -1 + Result := 0; +end; +function TPdfFormField.GetOptionLabel(Index: Integer): string; +var + Len: Integer; +begin + Len := FPDFAnnot_GetOptionLabel(FPage.FDocument.FormHandle, Handle, Index, nil, 0) div SizeOf(WideChar) - 1; + if Len > 0 then + begin + SetLength(Result, Len); + FPDFAnnot_GetOptionLabel(FPage.FDocument.FormHandle, Handle, Index, PWideChar(Result), (Len + 1) * SizeOf(WideChar)); + end + else + Result := ''; +end; +function TPdfFormField.IsOptionSelected(OptionIndex: Integer): Boolean; +begin + Result := FPDFAnnot_IsOptionSelected(FPage.FDocument.FormHandle, Handle, OptionIndex) <> 0; +end; +function TPdfFormField.GetChecked: Boolean; +begin + Result := FPDFAnnot_IsChecked(FPage.FDocument.FormHandle, Handle) <> 0; +end; +function TPdfFormField.GetControlCount: Integer; +begin + Result := FPDFAnnot_GetFormControlCount(FPage.FDocument.FormHandle, Handle); +end; +function TPdfFormField.GetControlIndex: Integer; +begin + Result := FPDFAnnot_GetFormControlIndex(FPage.FDocument.FormHandle, Handle); +end; +function TPdfFormField.BeginEditFormField: FPDF_ANNOTATION; +var + AnnotPageIndex: Integer; +begin + FPage.FDocument.CheckActive; + // Obtain the currently focused form field/annotation so that we can restore the focus after + // editing our form field. + if FORM_GetFocusedAnnot(FPage.FDocument.FormHandle, AnnotPageIndex, Result) = 0 then + Result := nil; +end; +procedure TPdfFormField.EndEditFormField(LastFocusedAnnot: FPDF_ANNOTATION); +begin + // Restore the focus to the form field/annotation that had the focus before changing our form field. + // If no previous form field was focused, kill the focus. + if LastFocusedAnnot <> nil then + begin + if FORM_SetFocusedAnnot(FPage.FDocument.FormHandle, Handle) = 0 then + FORM_ForceToKillFocus(FPage.FDocument.FormHandle); + FPDFPage_CloseAnnot(LastFocusedAnnot); + end + else + FORM_ForceToKillFocus(FPage.FDocument.FormHandle); +end; +procedure TPdfFormField.SetValue(const Value: string); +var + LastFocusedAnnot: FPDF_ANNOTATION; +begin + FPage.FDocument.CheckActive; + if not ReadOnly then + begin + LastFocusedAnnot := BeginEditFormField(); + try + if FORM_SetFocusedAnnot(FPage.FDocument.FormHandle, Handle) <> 0 then + begin + FORM_SelectAllText(FPage.FDocument.FormHandle, FPage.Handle); + FORM_ReplaceSelection(FPage.FDocument.FormHandle, FPage.Handle, PWideChar(Value)); + end; + finally + EndEditFormField(LastFocusedAnnot); + end; + end; +end; +function TPdfFormField.SelectComboBoxOption(OptionIndex: Integer): Boolean; +begin + Result := SelectListBoxOption(OptionIndex, True); +end; +function TPdfFormField.SelectListBoxOption(OptionIndex: Integer; Selected: Boolean): Boolean; +var + LastFocusedAnnot: FPDF_ANNOTATION; +begin + FPage.FDocument.CheckActive; + Result := False; + if not ReadOnly then + begin + LastFocusedAnnot := BeginEditFormField(); + try + if FORM_SetFocusedAnnot(FPage.FDocument.FormHandle, Handle) <> 0 then + Result := FORM_SetIndexSelected(FPage.FDocument.FormHandle, FPage.Handle, OptionIndex, Ord(Selected <> False)) <> 0; + finally + EndEditFormField(LastFocusedAnnot); + end; + end; +end; +procedure TPdfFormField.SetChecked(const Value: Boolean); +var + LastFocusedAnnot: FPDF_ANNOTATION; +begin + FPage.FDocument.CheckActive; + if not ReadOnly and (FieldType in [fftCheckBox, fftRadioButton, fftXFACheckBox]) then + begin + if Value <> Checked then + begin + LastFocusedAnnot := BeginEditFormField(); + try + if FORM_SetFocusedAnnot(FPage.FDocument.FormHandle, Handle) <> 0 then + begin + // Toggle the RadioButton/Checkbox by emulating "pressing the space bar". + FORM_OnKeyDown(FPage.FDocument.FormHandle, FPage.Handle, Ord(' '), 0); + FORM_OnChar(FPage.FDocument.FormHandle, FPage.Handle, Ord(' '), 0); + FORM_OnKeyUp(FPage.FDocument.FormHandle, FPage.Handle, Ord(' '), 0); + end; + finally + EndEditFormField(LastFocusedAnnot); + end; + end; + end; +end; + +{ TPdfLinkGotoDestination } +constructor TPdfLinkGotoDestination.Create(APageIndex: Integer; AXValid, AYValid, AZoomValid: Boolean; + AX, AY, AZoom: Single; AViewKind: TPdfLinkGotoDestinationViewKind; const AViewParams: TPdfFloatArray); +begin + inherited Create; + FPageIndex := APageIndex; + FXValid := AXValid; + FYValid := AYValid; + FZoomValid := AZoomValid; + FX := AX; + FY := AY; + FZoom := AZoom; + FViewKind := AViewKind; + FViewParams := AViewParams; +end; + +{ TPdfLinkInfo } +constructor TPdfLinkInfo.Create(ALinkAnnotation: TPdfAnnotation; const AWebLinkUrl: string); +begin + inherited Create; + FLinkAnnotation := ALinkAnnotation; + FWebLinkUrl := AWebLinkUrl; +end; +function TPdfLinkInfo.IsAnnontation: Boolean; +begin + Result := FLinkAnnotation <> nil; +end; +function TPdfLinkInfo.IsWebLink: Boolean; +begin + Result := FLinkAnnotation = nil; +end; +function TPdfLinkInfo.GetLinkFileName: string; +begin + if FLinkAnnotation <> nil then + Result := FLinkAnnotation.LinkFileName; +end; +function TPdfLinkInfo.GetLinkType: TPdfAnnotationLinkType; +begin + if FLinkAnnotation <> nil then + Result := FLinkAnnotation.LinkType + else if FWebLinkUrl <> '' then + Result := altURI + else + Result := altUnsupported; +end; +function TPdfLinkInfo.GetLinkUri: string; +begin + if FLinkAnnotation <> nil then + Result := FLinkAnnotation.LinkUri + else + Result := FWebLinkUrl; +end; +function TPdfLinkInfo.GetLinkGotoDestination(var LinkGotoDestination: TPdfLinkGotoDestination; + ARemoteDocument: TPdfDocument): Boolean; +begin + if FLinkAnnotation <> nil then + Result := FLinkAnnotation.GetLinkGotoDestination(LinkGotoDestination, ARemoteDocument) + else + Result := False; +end; + +{ TPdfPageWebLinksInfo } +constructor TPdfPageWebLinksInfo.Create(APage: TPdfPage); +begin + inherited Create; + FPage := APage; + GetPageWebLinks; +end; +procedure TPdfPageWebLinksInfo.GetPageWebLinks; +var + LinkIndex, LinkCount: Integer; + RectIndex, RectCount: Integer; +begin + if FPage <> nil then + begin + LinkCount := FPage.GetWebLinkCount; + SetLength(FWebLinksRects, LinkCount); + for LinkIndex := 0 to LinkCount - 1 do + begin + RectCount := FPage.GetWebLinkRectCount(LinkIndex); + SetLength(FWebLinksRects[LinkIndex], RectCount); + for RectIndex := 0 to RectCount - 1 do + FWebLinksRects[LinkIndex][RectIndex] := FPage.GetWebLinkRect(LinkIndex, RectIndex); + end; + end; +end; +function TPdfPageWebLinksInfo.GetWebLinkIndex(X, Y: Double): Integer; +var + RectIndex: Integer; + Pt: TPdfPoint; +begin + if FPage <> nil then + begin + Pt.X := X; + Pt.Y := Y; + for Result := 0 to Length(FWebLinksRects) - 1 do + for RectIndex := 0 to Length(FWebLinksRects[Result]) - 1 do + if FWebLinksRects[Result][RectIndex].PtIn(Pt) then + Exit; + end; + Result := -1; +end; +function TPdfPageWebLinksInfo.GetCount: Integer; +begin + Result := Length(FWebLinksRects); +end; +function TPdfPageWebLinksInfo.GetRect(Index: Integer): TPdfRectArray; +begin + Result := FWebLinksRects[Index]; +end; +function TPdfPageWebLinksInfo.GetURL(Index: Integer): string; +begin + Result := FPage.GetWebLinkURL(Index); +end; +function TPdfPageWebLinksInfo.IsWebLinkAt(X, Y: Double): Boolean; +begin + Result := GetWebLinkIndex(X, Y) <> -1; +end; +function TPdfPageWebLinksInfo.IsWebLinkAt(X, Y: Double; var Url: string): Boolean; +var + Index: Integer; +begin + Index := GetWebLinkIndex(X, Y); + Result := Index <> -1; + if Result then + Url := FPage.GetWebLinkURL(Index) + else + Url := ''; +end; +{$IFDEF MSWINDOWS} +{ TPdfDocumentPrinter } +constructor TPdfDocumentPrinter.Create; +begin + inherited Create; + FFitPageToPrintArea := True; +end; +function TPdfDocumentPrinter.IsPortraitOrientation(AWidth, AHeight: Integer): Boolean; +begin + Result := AHeight > AWidth; +end; +procedure TPdfDocumentPrinter.GetPrinterBounds; +begin + FPaperSize.cx := GetDeviceCaps(FPrinterDC, PHYSICALWIDTH); + FPaperSize.cy := GetDeviceCaps(FPrinterDC, PHYSICALHEIGHT); + FPrintArea.cx := GetDeviceCaps(FPrinterDC, HORZRES); + FPrintArea.cy := GetDeviceCaps(FPrinterDC, VERTRES); + FMargins.X := GetDeviceCaps(FPrinterDC, PHYSICALOFFSETX); + FMargins.Y := GetDeviceCaps(FPrinterDC, PHYSICALOFFSETY); +end; +function TPdfDocumentPrinter.BeginPrint(const AJobTitle: string): Boolean; +begin + Inc(FBeginPrintCounter); + if FBeginPrintCounter = 1 then + begin + Result := PrinterStartDoc(AJobTitle); + if Result then + begin + FPrinterDC := GetPrinterDC; + GetPrinterBounds; + FPrintPortraitOrientation := IsPortraitOrientation(FPaperSize.cx, FPaperSize.cy); + end + else + begin + FPrinterDC := 0; + Dec(FBeginPrintCounter); + end; + end + else + Result := True; +end; +procedure TPdfDocumentPrinter.EndPrint; +begin + Dec(FBeginPrintCounter); + if FBeginPrintCounter = 0 then + begin + if FPrinterDC <> 0 then + begin + FPrinterDC := 0; + PrinterEndDoc; + end; + end; +end; +function TPdfDocumentPrinter.Print(ADocument: TPdfDocument): Boolean; +begin + if ADocument <> nil then + Result := Print(ADocument, 0, ADocument.PageCount - 1) + else + Result := False; +end; +function TPdfDocumentPrinter.Print(ADocument: TPdfDocument; AFromPageIndex, AToPageIndex: Integer): Boolean; +var + PageIndex: Integer; + WasPageLoaded: Boolean; + PdfPage: TPdfPage; + PagePortraitOrientation: Boolean; + X, Y, W, H: Integer; + PrintedPageNum, PrintPageCount: Integer; +begin + Result := False; + if ADocument = nil then + Exit; + if AFromPageIndex < 0 then + raise EPdfArgumentOutOfRange.CreateResFmt(@RsArgumentsOutOfRange, ['FromPage', AFromPageIndex]); + if (AToPageIndex < AFromPageIndex) or (AToPageIndex >= ADocument.PageCount) then + raise EPdfArgumentOutOfRange.CreateResFmt(@RsArgumentsOutOfRange, ['ToPage', AToPageIndex]); + PrintedPageNum := 0; + PrintPageCount := AToPageIndex - AFromPageIndex + 1; + if BeginPrint then + begin + try + if ADocument.FForm <> nil then + FORM_DoDocumentAAction(ADocument.FForm, FPDFDOC_AACTION_WP); // BeforePrint + for PageIndex := AFromPageIndex to AToPageIndex do + begin + PdfPage := nil; + WasPageLoaded := ADocument.IsPageLoaded(PageIndex); + try + PdfPage := ADocument.Pages[PageIndex]; + PagePortraitOrientation := IsPortraitOrientation(Trunc(PdfPage.Width), Trunc(PdfPage.Height)); + if FitPageToPrintArea then + begin + X := 0; + Y := 0; + W := FPrintArea.cx; + H := FPrintArea.cy; + end + else + begin + X := -FMargins.X; + Y := -FMargins.Y; + W := FPaperSize.cx; + H := FPaperSize.cy; + end; + if PagePortraitOrientation <> FPrintPortraitOrientation then + begin + SwapInts(X, Y); + SwapInts(W, H); + end; + // Print page + PrinterStartPage; + try + if (W > 0) and (H > 0) then + InternPrintPage(PdfPage, X, Y, W, H); + finally + PrinterEndPage; + end; + Inc(PrintedPageNum); + if Assigned(OnPrintStatus) then + OnPrintStatus(Self, PrintedPageNum, PrintPageCount); + finally + if not WasPageLoaded and (PdfPage <> nil) then + PdfPage.Close; // release memory + end; + if ADocument.FForm <> nil then + FORM_DoDocumentAAction(ADocument.FForm, FPDFDOC_AACTION_DP); // AfterPrint + end; + finally + EndPrint; + end; + Result := True; + end; +end; +procedure TPdfDocumentPrinter.InternPrintPage(APage: TPdfPage; X, Y, Width, Height: Double); + function RoundToInt(Value: Double): Integer; + var + F: Double; + begin + Result := Trunc(Value); + F := Frac(Value); + if F < 0 then + begin + if F <= -0.5 then + Result := Result - 1; + end + else if F >= 0.5 then + Result := Result + 1; + end; +var + PageWidth, PageHeight: Double; + PageScale, PrintScale: Double; + ScaledWidth, ScaledHeight: Double; +begin + PageWidth := APage.Width; + PageHeight := APage.Height; + PageScale := PageHeight / PageWidth; + PrintScale := Height / Width; + ScaledWidth := Width; + ScaledHeight := Height; + if PageScale > PrintScale then + ScaledWidth := Width * (PrintScale / PageScale) + else + ScaledHeight := Height * (PageScale / PrintScale); + X := X + (Width - ScaledWidth) / 2; + Y := Y + (Height - ScaledHeight) / 2; + APage.Draw( + FPrinterDC, + RoundToInt(X), RoundToInt(Y), RoundToInt(ScaledWidth), RoundToInt(ScaledHeight), + prNormal, [proPrinting, proAnnotations] + ); +end; + +function PageToBitmap(aPage: TPdfPage; sPath: String; nDPI: Integer = 600): Boolean; +var + bmp: TBitmap; + nW, nH: Integer; +begin + Result := false; + + try + bmp := TBitmap.Create; + try + nW := Round(aPage.Width / 72 * nDPI); + nH := Round(aPage.Height / 72 * nDPI); + + bmp.PixelFormat := pf32bit; + bmp.SetSize(nW, nH); + + aPage.Draw(bmp.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, prNormal, [proPrinting]); + bmp.SaveToFile(sPath); + Result := FileExists(sPath); + finally + bmp.Free; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. PageToBitmap()'); + end; +end; + +function PageToPng(aPage: TPdfPage; sPath: String; nDPI: Integer = 600): Boolean; +var + bmp: TBitmap; + png: TPngImage; + nW, nH: Integer; +begin + Result := false; + + try + bmp := TBitmap.Create; + png := TPngImage.Create; + try + nW := Round(aPage.Width / 72 * nDPI); + nH := Round(aPage.Height / 72 * nDPI); + + bmp.PixelFormat := pf32bit; + bmp.SetSize(nW, nH); + + aPage.Draw(bmp.Canvas.Handle, 0, 0, nW, nH, prNormal, [proPrinting]); + png.Assign(bmp); + png.SaveToFile(sPath); + Result := FileExists(sPath); + finally + png.Free; + bmp.Free; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. PageToPng()'); + end; +end; + +function GetPageOcrText(aPage: TPdfPage; sOcrMdPath, sTaskDir: String; sParam: String = ''; nDPI: Integer = 150): String; +var + sImgPath, sTxtPath: String; +begin + Result := ''; + try + sImgPath := sTaskDir + '$img.bmp'; + sTxtPath := sTaskDir + '$img.txt'; + try + if PageToPng(aPage, sImgPath, nDPI) then + begin + if FileExists(sOcrMdPath) then + begin + if sParam <> '' then + sParam := Trim(sParam) + ' '; + // ExecuteAppWaitUntilTerminate(sOcrPath, + // Format('-r "%s" "%s"', [sImgPath, sTxtPath]), SW_HIDE, 10000); + ExecuteAppWaitUntilTerminate(sOcrMdPath, sParam + Format('"%s" "%s"', [sImgPath, sTxtPath]), SW_HIDE, 10000); + + if FileExists(sTxtPath) then + Result := ExtractTextSafe(sTxtPath); + end; + end; + finally + DeleteFile(sImgPath); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetPageOcrText()'); + end; +end; + +{$ENDIF MSWINDOWS} +initialization + {$IFDEF FPC} + InitCriticalSection(PDFiumInitCritSect); + InitCriticalSection(FFITimersCritSect); + {$ELSE} + InitializeCriticalSectionAndSpinCount(PDFiumInitCritSect, 4000); + InitializeCriticalSectionAndSpinCount(FFITimersCritSect, 4000); + {$ENDIF FPC} +finalization + {$IFDEF FPC} + DoneCriticalSection(FFITimersCritSect); + DoneCriticalSection(PDFiumInitCritSect); + {$ELSE} + DeleteCriticalSection(FFITimersCritSect); + DeleteCriticalSection(PDFiumInitCritSect); + {$ENDIF FPC} +end. diff --git a/Tocsg.Lib/VCL/Other/EM.PdfiumCtrl.pas b/Tocsg.Lib/VCL/Other/EM.PdfiumCtrl.pas new file mode 100644 index 00000000..e2f9504e --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.PdfiumCtrl.pas @@ -0,0 +1,2866 @@ +{$IFDEF FPC} + {$MODE DelphiUnicode} +{$ENDIF FPC} + +{$A8,B-,E-,F-,G+,H+,I+,J-,K-,M-,N-,P+,Q-,R-,S-,T-,U-,V+,X+,Z1} +{$STRINGCHECKS OFF} + +unit EM.PdfiumCtrl; + +// Show invalidated paint regions. Don't enable this if you aren't trying to optimize the repainting +{.$DEFINE REPAINTTEST} + +{$IFDEF FPC} + {$DEFINE USE_PRINTCLIENT_WORKAROUND} +{$ELSE} + {$IF CompilerVersion <= 20.0} // 2009 and older + {$DEFINE USE_PRINTCLIENT_WORKAROUND} + {$IFEND} + {$IF CompilerVersion >= 21.0} // 2010+ + {$DEFINE VCL_HAS_TOUCH} + {$IFEND} +{$ENDIF FPC} + +interface + +uses + {$IFDEF FPC} + LCLType, PrintersDlgs, Win32Extra, + {$ENDIF FPC} + Windows, Messages, ShellAPI, Types, SysUtils, Classes, Contnrs, Graphics, Controls, + Forms, Dialogs, EM.PdfiumCore; + +type + TPdfControlLinkOptionType = ( + loAutoGoto, // Jumps in the document are allowed and automatically handled + loAutoRemoteGotoReplaceDocument, // Jumps to a remote document are allowed and automatically handled by replacing the loaded document + loAutoOpenURI, // Jumps to URI are allowed and automatically handled by using ShellExecuteEx. Disables OnWebLinkClick if loTreatWebLinkAsUriAnnotationLink is set + loAutoLaunch, // Allow executing/opening a program/file automatically by using ShellExecuteEx + loAutoEmbeddedGotoReplaceDocument, // Jumps to an attached PDF document are allowed and automatically handled by replacing the loaded document + + loTreatWebLinkAsUriAnnotationLink, // OnAnnotationLinkClick also handles WebLinks + loAlwaysDetectWebAndUriLink // If if OnWebLinkClick and OnAnnotationLinkClick aren't assigned, URI and WebLinks are detected + ); + TPdfControlLinkOptions = set of TPdfControlLinkOptionType; + +const + cPdfControlDefaultDrawOptions = [proAnnotations]; + cPdfControlDefaultLinkOptions = [loAutoGoto, loTreatWebLinkAsUriAnnotationLink, loAlwaysDetectWebAndUriLink]; + cPdfControlAllAutoLinkOptions = [loAutoGoto, loAutoRemoteGotoReplaceDocument, loAutoOpenURI, + loAutoLaunch, loAutoEmbeddedGotoReplaceDocument]; + +type + TPdfControlScaleMode = ( + smFitAuto, + smFitWidth, + smFitHeight, + smZoom + ); + + TPdfControlWebLinkClickEvent = procedure(Sender: TObject; Url: string) of object; + TPdfControlAnnotationLinkClickEvent = procedure(Sender: TObject; LinkInfo: TPdfLinkInfo; var Handled: Boolean) of object; + TPdfControlRectArray = array of TRect; + + TPdfControl = class(TCustomControl) + private + FDocument: TPdfDocument; + FPageIndex: Integer; + FRenderedPageIndex: Integer; + FPageBitmap: HBITMAP; + FDrawX: Integer; + FDrawY: Integer; + FDrawWidth: Integer; + FDrawHeight: Integer; + FRotation: TPdfPageRotation; + {$IFDEF USE_PRINTCLIENT_WORKAROUND} + FPrintClient: Boolean; + {$ENDIF USE_PRINTCLIENT_WORKAROUND} + FMousePressed: Boolean; + FSelectionActive: Boolean; + FAllowUserTextSelection: Boolean; + FAllowUserPageChange: Boolean; + FAllowFormEvents: Boolean; + FBufferedPageDraw: Boolean; + FSmoothScroll: Boolean; + FScrollTimerActive: Boolean; + FScrollTimer: Boolean; + FChangePageOnMouseScrolling: Boolean; + FSelStartCharIndex: Integer; + FSelStopCharIndex: Integer; + FMouseDownPt: TPoint; + FCheckForTrippleClick: Boolean; + FWebLinkInfo: TPdfPageWebLinksInfo; + FDrawOptions: TPdfPageRenderOptions; + FScaleMode: TPdfControlScaleMode; + FZoomPercentage: Integer; + FPageColor: TColor; + FScrollMousePos: TPoint; + FLinkOptions: TPdfControlLinkOptions; + FHighlightTextRects: TPdfRectArray; + FHighlightTexts: TObjectList; + FFormOutputSelectedRects: TPdfRectArray; + FFormFieldFocused: Boolean; + FPageShadowSize: Integer; + FPageShadowColor: TColor; + FPageShadowPadding: Integer; + FPageBorderColor: TColor; + + FOnWebLinkClick: TPdfControlWebLinkClickEvent; + FOnAnnotationLinkClick: TPdfControlAnnotationLinkClickEvent; + FOnPageChange: TNotifyEvent; + FOnPaint: TNotifyEvent; + FOnPrintDocument: TNotifyEvent; + + procedure WMTimer(var Message: TWMTimer); message WM_TIMER; + procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL; + procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL; + procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; + procedure CMColorchanged(var Message: TMessage); message CM_COLORCHANGED; + {$IFDEF USE_PRINTCLIENT_WORKAROUND} + procedure WMPrintClient(var Message: TWMPrintClient); message WM_PRINTCLIENT; + {$ENDIF USE_PRINTCLIENT_WORKAROUND} + procedure CMMouseleave(var Message: TMessage); message CM_MOUSELEAVE; + + procedure GetPageWebLinks; + function GetCurrentPage: TPdfPage; + function GetPageCount: Integer; + procedure SetPageIndex(Value: Integer); + function InternSetPageIndex(Value: Integer; ScrollTransition, InverseScrollTransition: Boolean): Boolean; + procedure SetRotation(const Value: TPdfPageRotation); + function SetSelStopCharIndex(X, Y: Integer): Boolean; + function GetSelText: string; + function GetSelLength: Integer; + function GetSelStart: Integer; + procedure SetSelection(Active: Boolean; StartIndex, StopIndex: Integer); + procedure SetScaleMode(const Value: TPdfControlScaleMode); + procedure SetPageBorderColor(const Value: TColor); + procedure SetPageShadowColor(const Value: TColor); + procedure SetPageShadowPadding(const Value: Integer); + procedure SetPageShadowSize(const Value: Integer); + procedure AdjustDrawPos; + procedure UpdatePageDrawInfo; + procedure SetPageColor(const Value: TColor); + procedure SetDrawOptions(const Value: TPdfPageRenderOptions); + procedure InvalidateRectDiffs(const OldRects, NewRects: TPdfControlRectArray); + procedure InvalidatePdfRectDiffs(const OldRects, NewRects: TPdfRectArray); + procedure StopScrollTimer; + procedure DocumentLoaded; + procedure DrawSelection(DC: HDC; Page: TPdfPage); + procedure DrawHighlightText(DC: HDC; Page: TPdfPage); + procedure DrawBorderAndShadow(DC: HDC); + function InternPageToDevice(Page: TPdfPage; PageRect: TPdfRect; ANormalize: Boolean): TRect; + procedure SetZoomPercentage(Value: Integer); + procedure DrawPage(DC: HDC; Page: TPdfPage; DirectDrawPage: Boolean); + procedure CalcHighlightTextRects; + procedure InitDocument; + function ShellOpenFileName(const FileName: string; Launch: Boolean): Boolean; + + procedure FormInvalidate(Document: TPdfDocument; Page: TPdfPage; const PageRect: TPdfRect); + procedure FormOutputSelectedRect(Document: TPdfDocument; Page: TPdfPage; const PageRect: TPdfRect); + procedure FormGetCurrentPage(Document: TPdfDocument; var Page: TPdfPage); + procedure FormFieldFocus(Document: TPdfDocument; Value: PWideChar; ValueLen: Integer; FieldFocused: Boolean); + procedure ExecuteNamedAction(Document: TPdfDocument; NamedAction: TPdfNamedActionType); + + procedure DrawAlphaRects(DC: HDC; Page: TPdfPage; const Rects: TPdfRectArray; Color: TColor); + procedure DrawAlphaSelection(DC: HDC; Page: TPdfPage; const Rects: TPdfRectArray); + procedure DrawFormOutputSelectedRects(DC: HDC; Page: TPdfPage); + protected + procedure Paint; override; + procedure Resize; override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; + function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure WMKeyDown(var Message: TWMKeyDown); message {$IFDEF FPC}CN_KEYDOWN{$ELSE}WM_KEYDOWN{$ENDIF}; + procedure WMKeyUp(var Message: TWMKeyUp); message {$IFDEF FPC}CN_KEYUP{$ELSE}WM_KEYUP{$ENDIF}; + procedure WMChar(var Message: TWMChar); message {$IFDEF FPC}CN_CHAR{$ELSE}WM_CHAR{$ENDIF}; + procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS; + + function LinkHandlingNeeded: Boolean; + function IsClickableLinkAt(X, Y: Integer): Boolean; + procedure WebLinkClick(const Url: string); virtual; + procedure AnnotationLinkClick(LinkInfo: TPdfLinkInfo); virtual; + procedure PageChange; virtual; + procedure PageContentChanged(Closing: Boolean); + procedure PageLayoutChanged; + function IsPageValid: Boolean; + function GetSelectionRects: TPdfControlRectArray; + procedure DestroyWnd; override; + + property DrawX: Integer read FDrawX; + property DrawY: Integer read FDrawY; + property DrawWidth: Integer read FDrawWidth; + property DrawHeight: Integer read FDrawHeight; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + { InvalidatePage forces the page to be rendered again and invalidates the control. } + procedure InvalidatePage; + { PrintDocument uses OnPrintDocument to print. If OnPrintDocument is not assigned it does nothing. } + procedure PrintDocument; + + procedure OpenWithDocument(Document: TPdfDocument); // takes ownership + procedure LoadFromCustom(ReadFunc: TPdfDocumentCustomReadProc; Size: LongWord; Param: Pointer; const Password: UTF8String = ''); + procedure LoadFromActiveStream(Stream: TStream; const Password: UTF8String = ''); // Stream must not be released until the document is closed + procedure LoadFromActiveBuffer(Buffer: Pointer; Size: Int64; const Password: UTF8String = ''); // Buffer must not be released until the document is closed + procedure LoadFromBytes(const Bytes: TBytes; const Password: UTF8String = ''); overload; // The content of the Bytes array must not be changed until the document is closed + procedure LoadFromBytes(const Bytes: TBytes; Index: Integer; Count: Integer; const Password: UTF8String = ''); overload; // The content of the Bytes array must not be changed until the document is closed + procedure LoadFromStream(Stream: TStream; const Password: UTF8String = ''); + procedure LoadFromFile(const FileName: string; const Password: UTF8String = ''; LoadOption: TPdfDocumentLoadOption = dloDefault); + procedure Close; + + function DeviceToPage(DeviceX, DeviceY: Integer): TPdfPoint; overload; + function DeviceToPage(DeviceRect: TRect): TPdfRect; overload; + function PageToDevice(PageX, PageY: Double): TPoint; overload; + function PageToDevice(PageRect: TPdfRect): TRect; overload; + function GetPageRect: TRect; + + procedure CopyFormTextToClipboard; + procedure CutFormTextToClipboard; + procedure PasteFormTextFromClipboard; + procedure SelectAllFormText; + + procedure CopyToClipboard; + procedure ClearSelection; + procedure SelectAll; + procedure SelectText(CharIndex, Count: Integer); + function SelectWord(CharIndex: Integer): Boolean; // includes symbols like Chrome + function SelectLine(CharIndex: Integer): Boolean; + + function GetTextInRect(const R: TRect): string; + { HightlightText() highlights all occurences of the specified text and clears previously + hightlighted texts. } + procedure HightlightText(const SearchText: string; MatchCase, MatchWholeWord: Boolean); + { AddHightlightText() highlights all occurences of the specified text but keeps previously + hightlighted texts. } + procedure AddHightlightText(const SearchText: string; MatchCase, MatchWholeWord: Boolean); + procedure ClearHighlightText; + + function IsWebLinkAt(X, Y: Integer): Boolean; overload; + function IsWebLinkAt(X, Y: Integer; var Url: string): Boolean; overload; + function IsUriAnnotationLinkAt(X, Y: Integer): Boolean; + function IsAnnotationLinkAt(X, Y: Integer): Boolean; + function GetAnnotationLinkAt(X, Y: Integer): TPdfAnnotation; + + function GotoNextPage(ScrollTransition: Boolean = False): Boolean; + function GotoPrevPage(ScrollTransition: Boolean = False): Boolean; + function ScrollContent(XOffset, YOffset: Integer; Smooth: Boolean = False): Boolean; virtual; + function ScrollContentTo(X, Y: Integer; Smooth: Boolean = False): Boolean; + function GotoDestination(const LinkGotoDestination: TPdfLinkGotoDestination): Boolean; + + property Document: TPdfDocument read FDocument; + property CurrentPage: TPdfPage read GetCurrentPage; + + property PageCount: Integer read GetPageCount; + property PageIndex: Integer read FPageIndex write SetPageIndex; + property SelStart: Integer read GetSelStart; // in CharIndex, not TextIndex (Length(SelText) may not be SelLength) + property SelLength: Integer read GetSelLength; // in CharIndex, not TextIndex (Length(SelText) may not be SelLength) + property SelText: string read GetSelText; + + property Canvas; + published + property ScaleMode: TPdfControlScaleMode read FScaleMode write SetScaleMode default smFitAuto; + property ZoomPercentage: Integer read FZoomPercentage write SetZoomPercentage default 100; + property PageColor: TColor read FPageColor write SetPageColor default clWhite; + property Rotation: TPdfPageRotation read FRotation write SetRotation default prNormal; + property BufferedPageDraw: Boolean read FBufferedPageDraw write FBufferedPageDraw default True; + property AllowUserTextSelection: Boolean read FAllowUserTextSelection write FAllowUserTextSelection default True; + property AllowUserPageChange: Boolean read FAllowUserPageChange write FAllowUserPageChange default True; // PgDn/PgUp + property AllowFormEvents: Boolean read FAllowFormEvents write FAllowFormEvents default True; + property DrawOptions: TPdfPageRenderOptions read FDrawOptions write SetDrawOptions default cPdfControlDefaultDrawOptions; + property SmoothScroll: Boolean read FSmoothScroll write FSmoothScroll default False; + property ScrollTimer: Boolean read FScrollTimer write FScrollTimer default True; + property ChangePageOnMouseScrolling: Boolean read FChangePageOnMouseScrolling write FChangePageOnMouseScrolling default False; + property LinkOptions: TPdfControlLinkOptions read FLinkOptions write FLinkOptions default cPdfControlDefaultLinkOptions; + + property PageBorderColor: TColor read FPageBorderColor write SetPageBorderColor default clNone; + property PageShadowColor: TColor read FPageShadowColor write SetPageShadowColor default clNone; + property PageShadowSize: Integer read FPageShadowSize write SetPageShadowSize default 4; + property PageShadowPadding: Integer read FPageShadowPadding write SetPageShadowPadding default 44; + + { OnWebLinkClick is only called for WebLinks (URLs parsed from the document text). If OnAnnotationLinkClick is + not assigned, OnWebLinkClick is also called URI link annontations for backward compatibility reasons. } + property OnWebLinkClick: TPdfControlWebLinkClickEvent read FOnWebLinkClick write FOnWebLinkClick; + { OnAnnotationLinkClick is called for all link annotation but not for WebLinks. } + property OnAnnotationLinkClick: TPdfControlAnnotationLinkClickEvent read FOnAnnotationLinkClick write FOnAnnotationLinkClick; + { OnPageChange is called if the current page is switched. } + property OnPageChange: TNotifyEvent read FOnPageChange write FOnPageChange; + { OnPrintDocument is called from PrintDocument } + property OnPrintDocument: TNotifyEvent read FOnPrintDocument write FOnPrintDocument; + + property Align; + property Anchors; + property Color default clGray; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property ParentBackground default False; + property ParentColor default False; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop default True; + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFNDEF FPC} + property OnMouseActivate; + {$ENDIF ~FPC} + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnPaint: TNotifyEvent read FOnPaint write FOnPaint; + property OnStartDock; + property OnStartDrag; + {$IFDEF VCL_HAS_TOUCH} + property Touch; + property OnGesture; + {$ENDIF VCL_HAS_TOUCH} + end; + + TPdfDocumentVclPrinter = class(TPdfDocumentPrinter) + private + FBeginDocCalled: Boolean; + FPagePrinted: Boolean; + protected + function PrinterStartDoc(const AJobTitle: string): Boolean; override; + procedure PrinterEndDoc; override; + procedure PrinterStartPage; override; + procedure PrinterEndPage; override; + function GetPrinterDC: HDC; override; + public + { If AShowPrintDialog is false PrintDocument prints the document to the default printer. + If AShowPrintDialog is true the print dialog is shown and the user can select the + printer, page range and number of copies (if supported by the printer driver). + Returns true if the page was send to the printer driver. } + class function PrintDocument(ADocument: TPdfDocument; const AJobTitle: string; + AShowPrintDialog: Boolean = True; AllowPageRange: Boolean = True; + AParentWnd: HWND = 0): Boolean; static; + end; + +implementation + +uses + Math, Clipbrd, Character, Printers; + +const + cScrollTimerId = 1; + cTrippleClickTimerId = 2; + cScrollTimerInterval = 50; + cDefaultScrollOffset = 25; + +type + THighlightTextInfo = class(TObject) + private + FText: string; + FMatchCase: Boolean; + FMatchWholeWord: Boolean; + public + constructor Create(const AText: string; AMatchCase, AMatchWholeWord: Boolean); + function IsSame(const AText: string; AMatchCase, AMatchWholeWord: Boolean): Boolean; + + property Text: string read FText; + property MatchCase: Boolean read FMatchCase; + property MatchWholeWord: Boolean read FMatchWholeWord; + end; + +function IsWhitespace(Ch: Char): Boolean; +begin + {$IFDEF FPC} + Result := TCharacter.IsWhiteSpace(Ch); + {$ELSE} + {$IF CompilerVersion >= 25.0} // XE4 + Result := Ch.IsWhiteSpace; + {$ELSE} + Result := TCharacter.IsWhiteSpace(Ch); + {$IFEND} + {$ENDIF FPC} +end; + +function VclAbortProc(Prn: HDC; Error: Integer): Bool; stdcall; +begin + Application.ProcessMessages; + Result := not Printer.Aborted; +end; + +function FastVclAbortProc(Prn: HDC; Error: Integer): Bool; stdcall; +begin + Result := not Printer.Aborted; +end; + + +{ THighlightTextInfo } + +constructor THighlightTextInfo.Create(const AText: string; AMatchCase, AMatchWholeWord: Boolean); +begin + inherited Create; + FText := AText; + FMatchCase := AMatchCase; + FMatchWholeWord := AMatchWholeWord; +end; + +function THighlightTextInfo.IsSame(const AText: string; AMatchCase, AMatchWholeWord: Boolean): Boolean; +begin + Result := (AMatchCase = FMatchCase) and + (AMatchWholeWord = FMatchWholeWord) and + (AText = FText); +end; + +{ TPdfDocumentVclPrinter } + +function TPdfDocumentVclPrinter.PrinterStartDoc(const AJobTitle: string): Boolean; +begin + Result := False; + FPagePrinted := False; + if not Printer.Printing then + begin + if AJobTitle <> '' then + Printer.Title := AJobTitle; + Printer.BeginDoc; + FBeginDocCalled := Printer.Printing; + Result := FBeginDocCalled; + end; + if Result and Printer.Printing then + begin + // The Printers.AbortProc function calls ProcessMessages. That not only slows down the performance + // but it also allows the user to do things in the UI. + SetAbortProc(GetPrinterDC, @FastVclAbortProc); + end; +end; + +procedure TPdfDocumentVclPrinter.PrinterEndDoc; +begin + if Printer.Printing then + begin + SetAbortProc(GetPrinterDC, @VclAbortProc); // restore default behavior + if FBeginDocCalled then + Printer.EndDoc; + end; +end; + +procedure TPdfDocumentVclPrinter.PrinterStartPage; +begin + // Printer has only "NewPage" and the very first page doesn't need a NewPage call because + // Printer.BeginDoc already called Windows.StartPage. + if (Printer.PageNumber > 1) or FPagePrinted then + Printer.NewPage; +end; + +procedure TPdfDocumentVclPrinter.PrinterEndPage; +begin + FPagePrinted := True; + // The VCL uses "NewPage". For the very last page Printer.EndDoc calls Windows.EndPage. +end; + +function TPdfDocumentVclPrinter.GetPrinterDC: HDC; +begin + Result := Printer.Canvas.Handle; +end; + +class function TPdfDocumentVclPrinter.PrintDocument(ADocument: TPdfDocument; + const AJobTitle: string; AShowPrintDialog, AllowPageRange: Boolean; AParentWnd: HWND): Boolean; +var + PdfPrinter: TPdfDocumentVclPrinter; + Dlg: TPrintDialog; + FromPage, ToPage: Integer; +begin + Result := False; + if ADocument = nil then + Exit; + + FromPage := 1; + ToPage := ADocument.PageCount; + + if AShowPrintDialog then + begin + Dlg := TPrintDialog.Create(nil); + try + // Set the PrintDialog options + if AllowPageRange then + begin + Dlg.MinPage := 1; + Dlg.MaxPage := ADocument.PageCount; + Dlg.Options := Dlg.Options + [poPageNums]; + end; + + // Show the PrintDialog + {$IFDEF FPC} + Result := Dlg.Execute; + {$ELSE} + if (AParentWnd = 0) or not IsWindow(AParentWnd) then + Result := Dlg.Execute + else + Result := Dlg.Execute(AParentWnd); + {$ENDIF FPC} + + if not Result then + Exit; + + // Adjust print options + if AllowPageRange and (Dlg.PrintRange = prPageNums) then + begin + FromPage := Dlg.FromPage; + ToPage := Dlg.ToPage; + end; + finally + Dlg.Free; + end; + end; + + PdfPrinter := TPdfDocumentVclPrinter.Create; + try + if PdfPrinter.BeginPrint(AJobTitle) then + begin + try + Result := PdfPrinter.Print(ADocument, FromPage - 1, ToPage - 1); + finally + PdfPrinter.EndPrint; + end; + end; + finally + PdfPrinter.Free; + end; +end; + + +{ TPdfControl } + +constructor TPdfControl.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := ControlStyle + [csOpaque]; + + FScaleMode := smFitAuto; + FZoomPercentage := 100; + FPageColor := clWhite; + FRotation := prNormal; + FAllowUserTextSelection := True; + FAllowUserPageChange := True; + FAllowFormEvents := True; + FDrawOptions := cPdfControlDefaultDrawOptions; + FScrollTimer := True; + FBufferedPageDraw := True; + FLinkOptions := cPdfControlDefaultLinkOptions; + + FPageBorderColor := clNone; + FPageShadowColor := clNone; + FPageShadowSize := 4; + FPageShadowPadding := 44; + + FDocument := TPdfDocument.Create; + InitDocument; + + ParentDoubleBuffered := False; + ParentBackground := False; + ParentColor := False; + TabStop := True; + Color := clGray; + Width := 130; + Height := 180; +end; + +destructor TPdfControl.Destroy; +begin + if FPageBitmap <> 0 then + DeleteObject(FPageBitmap); + FreeAndNil(FWebLinkInfo); + FDocument.Free; + inherited Destroy; +end; + +procedure TPdfControl.InitDocument; +begin + FDocument.OnFormInvalidate := FormInvalidate; + FDocument.OnFormOutputSelectedRect := FormOutputSelectedRect; + FDocument.OnFormGetCurrentPage := FormGetCurrentPage; + FDocument.OnFormFieldFocus := FormFieldFocus; + FDocument.OnExecuteNamedAction := ExecuteNamedAction; +end; + +procedure TPdfControl.DestroyWnd; +begin + StopScrollTimer; + if FCheckForTrippleClick then + KillTimer(Handle, cTrippleClickTimerId); + inherited DestroyWnd; +end; + +{$IFDEF USE_PRINTCLIENT_WORKAROUND} +procedure TPdfControl.WMPrintClient(var Message: TWMPrintClient); +// Emulate Delphi 2010's TControlState.csPrintClient +var + LastPrintClient: Boolean; +begin + LastPrintClient := FPrintClient; + try + FPrintClient := True; + inherited; + finally + FPrintClient := LastPrintClient; + end; +end; +{$ENDIF USE_PRINTCLIENT_WORKAROUND} + +procedure TPdfControl.WMEraseBkgnd(var Message: TWMEraseBkgnd); +begin + Message.Result := 1; +end; + +procedure TPdfControl.DrawAlphaSelection(DC: HDC; Page: TPdfPage; const Rects: TPdfRectArray); +begin + DrawAlphaRects(DC, Page, Rects, RGB(50, 142, 254)); +end; + +procedure TPdfControl.DrawAlphaRects(DC: HDC; Page: TPdfPage; const Rects: TPdfRectArray; Color: TColor); +var + Count: Integer; + I: Integer; + R: TRect; + BmpDC: HDC; + SelBmp: TBitmap; + BlendFunc: TBlendFunction; +begin + Count := Length(Rects); + if Count > 0 then + begin + SelBmp := TBitmap.Create; + try + SelBmp.Canvas.Brush.Color := Color; + SelBmp.SetSize(100, 50); + {$IFDEF FPC} + // Delphi fills the bitmap with the brush if it is resized, FPC doesn't + SelBmp.Canvas.FillRect(0, 0, SelBmp.Width, SelBmp.Height); + {$ENDIF FPC} + BlendFunc.BlendOp := AC_SRC_OVER; + BlendFunc.BlendFlags := 0; + BlendFunc.SourceConstantAlpha := 127; + BlendFunc.AlphaFormat := 0; + BmpDC := SelBmp.Canvas.Handle; + for I := 0 to Count - 1 do + begin + R := InternPageToDevice(Page, Rects[I], True); + if RectVisible(DC, R) then + AlphaBlend(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, + BmpDC, 0, 0, SelBmp.Width, SelBmp.Height, + BlendFunc); + end; + finally + SelBmp.Free; + end; + end; +end; + +procedure TPdfControl.DrawSelection(DC: HDC; Page: TPdfPage); +var + Count: Integer; + I: Integer; + Rects: TPdfRectArray; +begin + Count := Page.GetTextRectCount(SelStart, SelLength); + if Count > 0 then + begin + SetLength(Rects, Count); + for I := 0 to Count - 1 do + Rects[I] := Page.GetTextRect(I); + DrawAlphaSelection(DC, Page, Rects); + end; +end; + +procedure TPdfControl.DrawFormOutputSelectedRects(DC: HDC; Page: TPdfPage); +begin + DrawAlphaSelection(DC, Page, FFormOutputSelectedRects); +end; + +procedure TPdfControl.DrawHighlightText(DC: HDC; Page: TPdfPage); +begin + DrawAlphaRects(DC, Page, FHighlightTextRects, RGB(254, 142, 50)); +end; + +procedure TPdfControl.DrawBorderAndShadow(DC: HDC); +var + BorderBrush, ShadowBrush: HBRUSH; +begin + // Draw page borders + if PageBorderColor <> clNone then + begin + BorderBrush := CreateSolidBrush(ColorToRGB(PageBorderColor)); + FillRect(DC, Rect(FDrawX, FDrawY, FDrawX + FDrawWidth, FDrawY + 1), BorderBrush); // top border + FillRect(DC, Rect(FDrawX, FDrawY, FDrawX + 1, FDrawY + FDrawHeight), BorderBrush); // left border + FillRect(DC, Rect(FDrawX + FDrawWidth - 1, FDrawY, FDrawX + FDrawWidth, FDrawY + FDrawHeight), BorderBrush); // right border + FillRect(DC, Rect(FDrawX, FDrawY + FDrawHeight - 1, FDrawX + FDrawWidth, FDrawY + FDrawHeight), BorderBrush); // bottom border + DeleteObject(BorderBrush); + end; + + // Draw page shadow + if (PageShadowColor <> clNone) and (PageShadowSize > 0) then + begin + ShadowBrush := CreateSolidBrush(ColorToRGB(PageShadowColor)); + FillRect(DC, Rect(FDrawX + FDrawWidth, FDrawY + PageShadowSize, + FDrawX + FDrawWidth + PageShadowSize, FDrawY + FDrawHeight + PageShadowSize), + ShadowBrush); // right shadow + FillRect(DC, Rect(FDrawX + PageShadowSize, FDrawY + FDrawHeight, + FDrawX + FDrawWidth + PageShadowSize, FDrawY + FDrawHeight + PageShadowSize), + ShadowBrush); // bottom shadow + DeleteObject(ShadowBrush); + end; +end; + +procedure TPdfControl.DrawPage(DC: HDC; Page: TPdfPage; DirectDrawPage: Boolean); + + procedure Draw(DC: HDC; X, Y: Integer; Page: TPdfPage); + var + PageBrush: HBRUSH; + ColorRef: TColorRef; + begin + if PageColor = clDefault then + ColorRef := ColorToRGB(Color) + else + ColorRef := ColorToRGB(PageColor); + + // Page.Draw doesn't paint the background if proPrinting is enabled. + if proPrinting in FDrawOptions then + begin + PageBrush := CreateSolidBrush(ColorRef); + FillRect(DC, Rect(X, Y, X + FDrawWidth, Y + FDrawHeight), PageBrush); + DeleteObject(PageBrush); + end; + + Page.Draw(DC, X, Y, FDrawWidth, FDrawHeight, Rotation, FDrawOptions, ColorRef); + end; + +var + PageDC: HDC; + OldPageBmp: HBITMAP; + bmi: TBitmapInfo; + BmpData: Windows.TBitmap; + Bits: Pointer; +begin + if DirectDrawPage then + begin + if FPageBitmap <> 0 then + begin + DeleteObject(FPageBitmap); + FPageBitmap := 0; + end; + FRenderedPageIndex := -1; + Draw(DC, FDrawX, FDrawY, Page); + end + else + begin + if (FPageBitmap = 0) or + (GetObject(FPageBitmap, SizeOf(BmpData), @BmpData) <> SizeOf(BmpData)) or + (FDrawWidth <> BmpData.bmWidth) or + (FDrawHeight <> BmpData.bmHeight) then + begin + FRenderedPageIndex := -1; // force rendering + if FPageBitmap <> 0 then + DeleteObject(FPageBitmap); + if GetDeviceCaps(DC, BITSPIXEL) = 32 then + FPageBitmap := CreateCompatibleBitmap(DC, FDrawWidth, FDrawHeight) + else + begin + FillChar(bmi, SizeOf(bmi), 0); + bmi.bmiHeader.biSize := SizeOf(TBitmapInfoHeader); + bmi.bmiHeader.biWidth := FDrawWidth; + bmi.bmiHeader.biHeight := -FDrawHeight; // top-down + bmi.bmiHeader.biPlanes := 1; + bmi.bmiHeader.biBitCount := 32; + bmi.bmiHeader.biCompression := BI_RGB; + FPageBitmap := CreateDIBSection(DC, bmi, DIB_RGB_COLORS, Bits, 0, 0); + end; + end; + + PageDC := CreateCompatibleDC(DC); + OldPageBmp := SelectObject(PageDC, FPageBitmap); + try + if FRenderedPageIndex <> PageIndex then + begin + FRenderedPageIndex := PageIndex; + Draw(PageDC, 0, 0, Page); + end; + BitBlt(DC, FDrawX, FDrawY, FDrawWidth, FDrawHeight, PageDC, 0, 0, SRCCOPY); + finally + SelectObject(PageDC, OldPageBmp); + DeleteDC(PageDC); + end; + end; +end; + +procedure TPdfControl.Paint; +var + Page: TPdfPage; + DC, DrawDC: HDC; + DrawBmp, OldDrawBmp: HBITMAP; + Rgn: HRGN; + DirectPageDraw: Boolean; + WndR, ClipR: TRect; +begin + DC := Canvas.Handle; + {$IFDEF REPAINTTEST} + FillRect(DC, ClientRect, GetStockObject(BLACK_BRUSH)); + GdiFlush; + Sleep(70); + {$ENDIF REPAINTTEST} + + if IsPageValid then + begin + DirectPageDraw := not BufferedPageDraw or + ((Int64(FDrawWidth) * FDrawHeight) > (Int64(Width) * Height)) and + (Int64(FDrawWidth) * FDrawHeight > 4096*2160); // 4K is too much for the system resources + + if DirectPageDraw or FSelectionActive or (FHighlightTextRects <> nil) then + begin + case GetClipBox(DC, ClipR) of + NULLREGION: + Exit; // nothing to paint + ERROR: + Windows.GetClientRect(Handle, ClipR); + end; + // Double buffer, minimal bitmap size + DrawDC := CreateCompatibleDC(DC); + DrawBmp := CreateCompatibleBitmap(DC, ClipR.Right - ClipR.Left, ClipR.Bottom - ClipR.Top); + OldDrawBmp := SelectObject(DrawDC, DrawBmp); + OffsetWindowOrgEx(DrawDC, ClipR.Left, ClipR.Top, nil); + + // copy the clipping region and adjust to the bitmap's device units + Rgn := CreateRectRgn(0, 0, 1, 1); + {$IFDEF USE_PRINTCLIENT_WORKAROUND} + if FPrintClient then + {$ELSE} + if csPrintClient in ControlState then + {$ENDIF USE_PRINTCLIENT_WORKAROUND} + begin + if GetClipRgn(DC, Rgn) = 1 then // application clip region + begin + OffsetRgn(Rgn, -ClipR.Left, -ClipR.Top); + if SelectClipRgn(DrawDC, Rgn) = NULLREGION then + Exit; // nothing to paint + end; + end + else + begin + if GetRandomRgn(DC, Rgn, SYSRGN) = 1 then // system clip region, set by BeginPaint, in screen coordinates + begin + GetWindowRect(Handle, WndR); + OffsetRgn(Rgn, -WndR.Left - ClipR.Left, -WndR.Top - ClipR.Top); + SelectClipRgn(DrawDC, Rgn); + if SelectClipRgn(DrawDC, Rgn) = NULLREGION then + Exit; // nothing to paint + end; + end; + DeleteObject(Rgn); + end + else + begin + DrawDC := DC; + DrawBmp := 0; + OldDrawBmp := 0; + end; + + try + // Draw borders + FillRect(DrawDC, Rect(0, 0, Width, FDrawY), Brush.Handle); // top bar + FillRect(DrawDC, Rect(0, FDrawY, FDrawX, FDrawY + FDrawHeight), Brush.Handle); // left bar + FillRect(DrawDC, Rect(FDrawX + FDrawWidth, FDrawY, Width, FDrawY + FDrawHeight), Brush.Handle); // right bar + FillRect(DrawDC, Rect(0, FDrawY + FDrawHeight, Width, Height), Brush.Handle); // bottom bar + + // Draw the page + Page := CurrentPage; + DrawPage(DrawDC, Page, DirectPageDraw); + // Draw the selection overlay + if FSelectionActive then + DrawSelection(DrawDC, Page); + + DrawFormOutputSelectedRects(DrawDC, Page); + + // Draw the highlighted text overlay + DrawHighlightText(DrawDC, Page); + + DrawBorderAndShadow(DrawDC); + + // User painting + if Assigned(FOnPaint) then + begin + Canvas.Handle := DrawDC; + try + FOnPaint(Self); + finally + Canvas.Handle := DC; + end; + end; + + if DrawDC <> DC then + BitBlt(DC, 0, 0, Width, Height, DrawDC, 0, 0, SRCCOPY); + finally + if DrawBmp <> 0 then + begin + SelectObject(DrawDC, OldDrawBmp); + DeleteObject(DrawBmp); + end; + if DrawDC <> DC then + DeleteDC(DrawDC); + end; + end + else + begin + // empty page + if FPageBitmap <> 0 then + begin + DeleteObject(FPageBitmap); + FPageBitmap := 0; + end; + FillRect(DC, Rect(0, 0, Width, Height), Brush.Handle); + DrawBorderAndShadow(DC); + if Assigned(FOnPaint) then + FOnPaint(Self); + end; +end; + +procedure TPdfControl.PageContentChanged(Closing: Boolean); +begin + FSelStartCharIndex := 0; + FSelStopCharIndex := 0; + FSelectionActive := False; + CalcHighlightTextRects; + GetPageWebLinks; + PageLayoutChanged; + if not Closing then + PageChange; +end; + +procedure TPdfControl.PageLayoutChanged; +begin + FRenderedPageIndex := -1; + UpdatePageDrawInfo; + Invalidate; +end; + +procedure TPdfControl.InvalidatePage; +var + R: TRect; +begin + FRenderedPageIndex := -1; + if HandleAllocated then + begin + R := GetPageRect; + InvalidateRect(Handle, @R, True); + end; +end; + +procedure TPdfControl.PrintDocument; +begin + if Document.Active then + begin + if Assigned(FOnPrintDocument) then + FOnPrintDocument(Self) + else + TPdfDocumentVclPrinter.PrintDocument(Document, ExtractFileName(Document.FileName)); + end; +end; + +function TPdfControl.GetCurrentPage: TPdfPage; +begin + if IsPageValid then + Result := FDocument.Pages[PageIndex] + else + Result := nil; +end; + +function TPdfControl.GetPageCount: Integer; +begin + Result := FDocument.PageCount; +end; + +procedure TPdfControl.SetPageIndex(Value: Integer); +begin + InternSetPageIndex(Value, False, False); +end; + +function TPdfControl.InternSetPageIndex(Value: Integer; ScrollTransition, InverseScrollTransition: Boolean): Boolean; +var + ScrollInfo: TScrollInfo; + ScrollY: Integer; + OldPageIndex: Integer; +begin + if Value >= PageCount then + Value := PageCount - 1; + if Value < 0 then + Value := 0; + + if Value <> FPageIndex then + begin + ClearSelection; + // Close the previous page to keep memory usage low (especially for large PDF files) + if (FPageIndex >= 0) and (FPageIndex < PageCount) and FDocument.IsPageLoaded(FPageIndex) and + not FDocument.Pages[FPageIndex].Annotations.AnnotationsLoaded then // Issue #28: Don't close the page if annotations are loaded + begin + FDocument.Pages[FPageIndex].Close; + end; + OldPageIndex := FPageIndex; + FPageIndex := Value; + ScrollInfo.cbSize := SizeOf(ScrollInfo); + if ScrollTransition then + begin + // Keep the Scroll XOffset but scroll the page to the top or the bottom depending on the + // PageIndex change. + ScrollY := 0; + ScrollInfo.fMask := SIF_RANGE or SIF_PAGE or SIF_POS; + if GetScrollInfo(Handle, SB_VERT, ScrollInfo) then + begin + if InverseScrollTransition then + begin + if FPageIndex < OldPageIndex then + ScrollY := 0 + else + ScrollY := ScrollInfo.nMax {- Integer(ScrollInfo.nPage)}; + end + else + begin + if FPageIndex > OldPageIndex then + ScrollY := 0 + else + ScrollY := ScrollInfo.nMax {- Integer(ScrollInfo.nPage)}; + end; + end; + if ScrollInfo.nPos <> ScrollY then + begin + ScrollInfo.fMask := SIF_POS; + ScrollInfo.nPos := ScrollY; + SetScrollInfo(Handle, SB_VERT, ScrollInfo, True); + end; + end + else // Scroll to the page to the left/top corner + begin + ScrollInfo.fMask := SIF_POS; + ScrollInfo.nPos := 0; + SetScrollInfo(Handle, SB_VERT, ScrollInfo, True); + SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True); + end; + PageContentChanged(False); + Result := True; + end + else + Result := False; +end; + +function TPdfControl.GotoNextPage(ScrollTransition: Boolean): Boolean; +begin + Result := PageIndex < PageCount - 1; + if Result then + InternSetPageIndex(PageIndex + 1, ScrollTransition, False); +end; + +function TPdfControl.GotoPrevPage(ScrollTransition: Boolean): Boolean; +begin + Result := PageIndex > 0; + if Result then + InternSetPageIndex(PageIndex - 1, ScrollTransition, False); +end; + +procedure TPdfControl.PageChange; +begin + if Assigned(FOnPageChange) then + FOnPageChange(Self); +end; + +function TPdfControl.IsPageValid: Boolean; +begin + Result := FDocument.Active and (PageIndex < PageCount); +end; + +procedure TPdfControl.DocumentLoaded; +begin + FPageIndex := 0; + PageContentChanged(False); +end; + +procedure TPdfControl.OpenWithDocument(Document: TPdfDocument); +begin + Close; + if Document = nil then + Exit; + + FreeAndNil(FDocument); + FDocument := Document; + InitDocument; +end; + +procedure TPdfControl.LoadFromCustom(ReadFunc: TPdfDocumentCustomReadProc; Size: LongWord; + Param: Pointer; const Password: UTF8String); +begin + try + FDocument.LoadFromCustom(ReadFunc, Size, Param, Password); + finally + DocumentLoaded; + end; +end; + +procedure TPdfControl.LoadFromActiveStream(Stream: TStream; const Password: UTF8String); +begin + try + FDocument.LoadFromActiveStream(Stream, Password); + finally + DocumentLoaded; + end; +end; + +procedure TPdfControl.LoadFromActiveBuffer(Buffer: Pointer; Size: Int64; const Password: UTF8String); +begin + try + FDocument.LoadFromActiveBuffer(Buffer, Size, Password); + finally + DocumentLoaded; + end; +end; + +procedure TPdfControl.LoadFromBytes(const Bytes: TBytes; Index, Count: Integer; + const Password: UTF8String); +begin + try + FDocument.LoadFromBytes(Bytes, Index, Count, Password); + finally + DocumentLoaded; + end; +end; + +procedure TPdfControl.LoadFromBytes(const Bytes: TBytes; const Password: UTF8String); +begin + try + FDocument.LoadFromBytes(Bytes, Password); + finally + DocumentLoaded; + end; +end; + +procedure TPdfControl.LoadFromStream(Stream: TStream; const Password: UTF8String); +begin + try + FDocument.LoadFromStream(Stream, Password); + finally + DocumentLoaded; + end; +end; + +procedure TPdfControl.LoadFromFile(const FileName: string; const Password: UTF8String; + LoadOption: TPdfDocumentLoadOption); +begin + try + FDocument.LoadFromFile(FileName, Password, LoadOption); + finally + DocumentLoaded; + end; +end; + +procedure TPdfControl.Close; +begin + FDocument.Close; + FPageIndex := 0; + FFormFieldFocused := False; + PageContentChanged(True); +end; + +procedure TPdfControl.CMColorchanged(var Message: TMessage); +begin + inherited; + if PageColor = clDefault then + PageLayoutChanged + else + Invalidate; +end; + +procedure TPdfControl.Resize; +begin + UpdatePageDrawInfo; + inherited Resize; +end; + +procedure TPdfControl.SetScaleMode(const Value: TPdfControlScaleMode); +begin + if Value <> FScaleMode then + begin + FScaleMode := Value; + UpdatePageDrawInfo; + PageLayoutChanged; + end; +end; + +procedure TPdfControl.SetZoomPercentage(Value: Integer); +begin + if Value < 1 then + Value := 1 + else if Value > 10000 then + Value := 10000; + if Value <> FZoomPercentage then + begin + FZoomPercentage := Value; + PageLayoutChanged; + end; +end; + +procedure TPdfControl.SetPageColor(const Value: TColor); +begin + if Value <> FPageColor then + begin + FPageColor := Value; + InvalidatePage; + end; +end; + +procedure TPdfControl.SetDrawOptions(const Value: TPdfPageRenderOptions); +begin + if Value <> FDrawOptions then + begin + FDrawOptions := Value; + InvalidatePage; + end; +end; + +procedure TPdfControl.SetRotation(const Value: TPdfPageRotation); +begin + if Value <> FRotation then + begin + FRotation := Value; + PageLayoutChanged; + end; +end; + +procedure TPdfControl.SetPageBorderColor(const Value: TColor); +begin + if Value <> FPageBorderColor then + begin + FPageBorderColor := Value; + InvalidatePage; + end; +end; + +procedure TPdfControl.SetPageShadowColor(const Value: TColor); +begin + if Value <> FPageShadowColor then + begin + FPageShadowColor := Value; + InvalidatePage; + end; +end; + +procedure TPdfControl.SetPageShadowPadding(const Value: Integer); +begin + if Value <> FPageShadowPadding then + begin + FPageShadowPadding := Value; + InvalidatePage; + end; +end; + +procedure TPdfControl.SetPageShadowSize(const Value: Integer); +begin + if Value <> FPageShadowSize then + begin + FPageShadowSize := Value; + InvalidatePage; + end; +end; + +function TPdfControl.GetPageRect: TRect; +begin + Result := Rect(FDrawX, FDrawY, FDrawX + FDrawWidth, FDrawY + FDrawHeight); +end; + +function TPdfControl.DeviceToPage(DeviceX, DeviceY: Integer): TPdfPoint; +var + Page: TPdfPage; +begin + Page := CurrentPage; + if Page <> nil then + Result := Page.DeviceToPage(FDrawX, FDrawY, FDrawWidth, FDrawHeight, DeviceX, DeviceY, Rotation) + else + Result := TPdfPoint.Empty; +end; + +function TPdfControl.DeviceToPage(DeviceRect: TRect): TPdfRect; +var + Page: TPdfPage; +begin + Page := CurrentPage; + if Page <> nil then + Result := Page.DeviceToPage(FDrawX, FDrawY, FDrawWidth, FDrawHeight, DeviceRect, Rotation) + else + Result := TPdfRect.Empty; +end; + +function TPdfControl.PageToDevice(PageX, PageY: Double): TPoint; +var + Page: TPdfPage; +begin + Page := CurrentPage; + if Page <> nil then + Result := Page.PageToDevice(FDrawX, FDrawY, FDrawWidth, FDrawHeight, PageX, PageY, Rotation) + else + Result := Point(0, 0); +end; + +function TPdfControl.PageToDevice(PageRect: TPdfRect): TRect; +var + Page: TPdfPage; +begin + Page := CurrentPage; + if Page <> nil then + Result := Page.PageToDevice(FDrawX, FDrawY, FDrawWidth, FDrawHeight, PageRect, Rotation) + else + Result := Rect(0, 0, 0, 0); +end; + +function TPdfControl.InternPageToDevice(Page: TPdfPage; PageRect: TPdfRect; ANormalize: Boolean): TRect; +var + Value: Integer; +begin + Result := Page.PageToDevice(FDrawX, FDrawY, FDrawWidth, FDrawHeight, PageRect, Rotation); + if ANormalize then + begin + if Result.Left > Result.Right then + begin + Value := Result.Right; + Result.Right := Result.Left; + Result.Left := Value; + end; + if Result.Top > Result.Bottom then + begin + Value := Result.Bottom; + Result.Bottom := Result.Top; + Result.Top := Value; + end; + end; +end; + +function TPdfControl.SetSelStopCharIndex(X, Y: Integer): Boolean; +var + PagePt: TPdfPoint; + CharIndex: Integer; + Active: Boolean; + R: TRect; + Page: TPdfPage; +begin + Page := CurrentPage; + if Page <> nil then + begin + PagePt := DeviceToPage(X, Y); + CharIndex := Page.GetCharIndexAt(PagePt.X, PagePt.Y, MAXWORD, MAXWORD); + Result := CharIndex >= 0; + if not Result then + CharIndex := FSelStopCharIndex; + + if FSelStartCharIndex <> CharIndex then + Active := True + else + begin + R := PageToDevice(Page.GetCharBox(FSelStartCharIndex)); + Active := PtInRect(R, FMouseDownPt) xor PtInRect(R, Point(X, Y)); + end; + SetSelection(Active, FSelStartCharIndex, CharIndex); + end + else + Result := False; +end; + +procedure TPdfControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + PagePt: TPdfPoint; + CharIndex: Integer; + Page: TPdfPage; +begin + inherited MouseDown(Button, Shift, X, Y); + if Button = mbLeft then + begin + StopScrollTimer; + SetFocus; + FMousePressed := True; + FMouseDownPt := Point(X, Y); // used to find out if the selection must be cleared or not + end; + + Page := CurrentPage; + if Page <> nil then + begin + if AllowFormEvents then + begin + PagePt := DeviceToPage(X, Y); + if Button = mbLeft then + begin + if Page.FormEventLButtonDown(Shift, PagePt.X, PagePt.Y) then + Exit; + end + else if Button = mbRight then + begin + if Page.FormEventFocus(Shift, PagePt.X, PagePt.Y) then + Exit; + if Page.FormEventRButtonDown(Shift, PagePt.X, PagePt.Y) then + Exit; + end; + end; + + if AllowUserTextSelection and not FFormFieldFocused then + begin + if Button = mbLeft then + begin + PagePt := DeviceToPage(X, Y); + CharIndex := Page.GetCharIndexAt(PagePt.X, PagePt.Y, MAXWORD, MAXWORD); + if FCheckForTrippleClick and (CharIndex >= SelStart) and (CharIndex < SelStart + SelLength) then + begin + FMousePressed := False; + KillTimer(Handle, cTrippleClickTimerId); + FCheckForTrippleClick := False; + SelectLine(CharIndex); + end + else if ssDouble in Shift then + begin + FMousePressed := False; + SelectWord(CharIndex); + FCheckForTrippleClick := True; + SetTimer(Handle, cTrippleClickTimerId, GetDoubleClickTime, nil); + end + else + begin + FCheckForTrippleClick := False; + SetSelection(False, CharIndex, CharIndex); + end; + end; + end; + end; +end; + +procedure TPdfControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + PagePt: TPdfPoint; + Url: string; + Page: TPdfPage; + LinkAnnotation: TPdfAnnotation; + LinkInfo: TPdfLinkInfo; +begin + inherited MouseUp(Button, Shift, X, Y); + + if AllowFormEvents and IsPageValid then + begin + PagePt := DeviceToPage(X, Y); + Page := CurrentPage; + if (Button = mbLeft) and Page.FormEventLButtonUp(Shift, PagePt.X, PagePt.Y) then + begin + if FMousePressed and (Button = mbLeft) then + begin + FMousePressed := False; + StopScrollTimer; + end; + Exit; + end; + if (Button = mbRight) and Page.FormEventRButtonUp(Shift, PagePt.X, PagePt.Y) then + Exit; + end; + + if FMousePressed then + begin + if Button = mbLeft then + begin + FMousePressed := False; + StopScrollTimer; + if AllowUserTextSelection and not FFormFieldFocused then + SetSelStopCharIndex(X, Y); + if not FSelectionActive then + begin + if LinkHandlingNeeded then + begin + LinkAnnotation := GetAnnotationLinkAt(X, Y); + LinkInfo := nil; + if LinkAnnotation <> nil then + LinkInfo := TPdfLinkInfo.Create(LinkAnnotation, '') + else if IsWebLinkAt(X, Y, Url) then // If we have a Link Annotation and a WebLink, then the link annotation is prefered + begin + if loTreatWebLinkAsUriAnnotationLink in LinkOptions then + LinkInfo := TPdfLinkInfo.Create(nil, Url) + else + WebLinkClick(Url); + end; + if LinkInfo <> nil then + begin + try + AnnotationLinkClick(LinkInfo); + finally + LinkInfo.Free; + end; + end; + end; + end; + end; + end; +end; + +procedure TPdfControl.MouseMove(Shift: TShiftState; X, Y: Integer); +var + PagePt: TPdfPoint; + Style: NativeInt; + NewCursor: TCursor; + Page: TPdfPage; + Proceed: Boolean; +begin + inherited MouseMove(Shift, X, Y); + NewCursor := Cursor; + try + if AllowFormEvents and IsPageValid then + begin + PagePt := DeviceToPage(X, Y); + Page := CurrentPage; + if Page.FormEventMouseMove(Shift, PagePt.X, PagePt.Y) then + begin + Proceed := False; + case Page.HasFormFieldAtPoint(PagePt.X, PagePt.Y) of + fftUnknown: + // Could be a annotation link with a URL + Proceed := True; + fftTextField: + NewCursor := crIBeam; + fftComboBox, + fftSignature: + NewCursor := crHandPoint; + else + NewCursor := crDefault; + end; + if not Proceed then + Exit; + end; + end; + + if AllowUserTextSelection and not FFormFieldFocused then + begin + if FMousePressed then + begin + // Auto scroll + FScrollMousePos := Point(X, Y); + Style := GetWindowLong(Handle, GWL_STYLE); + if ((Style and WS_VSCROLL <> 0) and ((Y < 0) or (Y > Height))) or + ((Style and WS_HSCROLL <> 0) and ((X < 0) or (X > Width))) then + begin + if ScrollTimer and not FScrollTimerActive then + begin + SetTimer(Handle, cScrollTimerId, cScrollTimerInterval, nil); + FScrollTimerActive := True; + end; + end + else + StopScrollTimer; + + if SetSelStopCharIndex(X, Y) then + begin + if NewCursor <> crIBeam then + begin + NewCursor := crIBeam; + Cursor := NewCursor; + SetCursor(Screen.Cursors[Cursor]); // show the mouse cursor change immediately + end; + end; + end + else + begin + if IsPageValid then + begin + PagePt := DeviceToPage(X, Y); + if IsClickableLinkAt(X, Y) then + NewCursor := crHandPoint + else if CurrentPage.GetCharIndexAt(PagePt.X, PagePt.Y, 5, 5) >= 0 then + NewCursor := crIBeam + else if Cursor <> crDefault then + NewCursor := crDefault; + end; + end; + end; + finally + if NewCursor <> Cursor then + Cursor := NewCursor; + end; +end; + +procedure TPdfControl.CMMouseleave(var Message: TMessage); +begin + if (Cursor = crIBeam) or (Cursor = crHandPoint) then + begin + if AllowUserTextSelection or Assigned(FOnWebLinkClick) or Assigned(FOnAnnotationLinkClick) or (LinkOptions <> []) then + Cursor := crDefault; + end; + inherited; +end; + +function TPdfControl.GetTextInRect(const R: TRect): string; +begin + if IsPageValid then + Result := CurrentPage.GetTextAt(DeviceToPage(R)) + else + Result := ''; +end; + +procedure TPdfControl.CopyToClipboard; +begin + Clipboard.AsText := GetSelText; +end; + +procedure TPdfControl.CopyFormTextToClipboard; +var + S: string; +begin + if FFormFieldFocused and IsPageValid then + begin + S := CurrentPage.FormGetSelectedText; + if S <> '' then + Clipboard.AsText := S; + end; +end; + +procedure TPdfControl.CutFormTextToClipboard; +begin + if FFormFieldFocused and IsPageValid then + begin + CopyFormTextToClipboard; + CurrentPage.FormReplaceSelection(''); + end; +end; + +procedure TPdfControl.PasteFormTextFromClipboard; +begin + if FFormFieldFocused and IsPageValid then + begin + Clipboard.Open; + try + if Clipboard.HasFormat(CF_UNICODETEXT) or Clipboard.HasFormat(CF_TEXT) then + CurrentPage.FormReplaceSelection(Clipboard.AsText); + finally + Clipboard.Close; + end; + end; +end; + +procedure TPdfControl.SelectAllFormText; +begin + if FFormFieldFocused and IsPageValid then + CurrentPage.FormSelectAllText; +end; + +function TPdfControl.GetSelText: string; +begin + if FSelectionActive and IsPageValid then + Result := CurrentPage.ReadText(SelStart, SelLength) + else + Result := ''; +end; + +function TPdfControl.GetSelLength: Integer; +begin + if FSelectionActive and IsPageValid then + Result := Abs(FSelStartCharIndex - FSelStopCharIndex) + 1 + else + Result := 0; +end; + +function TPdfControl.GetSelStart: Integer; +begin + if FSelectionActive and IsPageValid then + Result := Min(FSelStartCharIndex, FSelStopCharIndex) + else + Result := 0; +end; + +function TPdfControl.GetSelectionRects: TPdfControlRectArray; +var + Count: Integer; + I: Integer; + Page: TPdfPage; +begin + if FSelectionActive and HandleAllocated then + begin + Page := CurrentPage; + if Page <> nil then + begin + Count := Page.GetTextRectCount(SelStart, SelLength); + SetLength(Result, Count); + for I := 0 to Count - 1 do + Result[I] := InternPageToDevice(Page, Page.GetTextRect(I), True); + Exit; + end; + end; + Result := nil; +end; + +procedure TPdfControl.InvalidateRectDiffs(const OldRects, NewRects: TPdfControlRectArray); + + function ContainsRect(const Rects: TPdfControlRectArray; const R: TRect): Boolean; + var + I: Integer; + begin + Result := True; + for I := 0 to Length(Rects) - 1 do + if (Rects[I].Left = R.Left) and (Rects[I].Top = R.Top) and (Rects[I].Right = R.Right) and (Rects[I].Bottom = R.Bottom) then + Exit; + Result := False; + end; + +var + I: Integer; +begin + if HandleAllocated then + begin + for I := 0 to Length(OldRects) - 1 do + if not ContainsRect(NewRects, OldRects[I]) then + InvalidateRect(Handle, @OldRects[I], True); + + for I := 0 to Length(NewRects) - 1 do + if not ContainsRect(OldRects, NewRects[I]) then + InvalidateRect(Handle, @NewRects[I], True); + end; +end; + +procedure TPdfControl.InvalidatePdfRectDiffs(const OldRects, NewRects: TPdfRectArray); +var + I: Integer; + OldRs, NewRs: TPdfControlRectArray; + Page: TPdfPage; +begin + Page := CurrentPage; + if (Page <> nil) and HandleAllocated then + begin + SetLength(OldRs, Length(OldRects)); + for I := 0 to Length(OldRects) - 1 do + OldRs[I] := InternPageToDevice(Page, OldRects[I], True); + + SetLength(NewRs, Length(NewRects)); + for I := 0 to Length(NewRects) - 1 do + NewRs[I] := InternPageToDevice(Page, NewRects[I], True); + + InvalidateRectDiffs(OldRs, NewRs); + end; +end; + +procedure TPdfControl.SetSelection(Active: Boolean; StartIndex, StopIndex: Integer); +var + OldRects, NewRects: TPdfControlRectArray; +begin + if (Active <> FSelectionActive) or (StartIndex <> FSelStartCharIndex) or (StopIndex <> FSelStopCharIndex) then + begin + OldRects := GetSelectionRects; + + FSelStartCharIndex := StartIndex; + FSelStopCharIndex := StopIndex; + FSelectionActive := Active and (FSelStartCharIndex >= 0) and (FSelStopCharIndex >= 0); + + NewRects := GetSelectionRects; + InvalidateRectDiffs(OldRects, NewRects); + end; +end; + +procedure TPdfControl.ClearSelection; +begin + SetSelection(False, 0, 0); +end; + +procedure TPdfControl.SelectAll; +begin + SelectText(0, -1); +end; + +procedure TPdfControl.SelectText(CharIndex, Count: Integer); +begin + if (Count = 0) or not IsPageValid then + ClearSelection + else + begin + if Count = -1 then + SetSelection(True, 0, CurrentPage.GetCharCount - 1) + else + SetSelection(True, CharIndex, Min(CharIndex + Count - 1, CurrentPage.GetCharCount - 1)); + end; +end; + +function TPdfControl.SelectWord(CharIndex: Integer): Boolean; +var + Ch: WideChar; + StartCharIndex, StopCharIndex, CharCount: Integer; + Page: TPdfPage; +begin + Result := False; + Page := CurrentPage; + if Page <> nil then + begin + ClearSelection; + CharCount := Page.GetCharCount; + if (CharIndex >= 0) and (CharIndex < CharCount) then + begin + while (CharIndex < CharCount) and IsWhiteSpace(Page.ReadChar(CharIndex)) do + Inc(CharIndex); + + if CharIndex < CharCount then + begin + StartCharIndex := CharIndex - 1; + while StartCharIndex >= 0 do + begin + Ch := Page.ReadChar(StartCharIndex); + if IsWhiteSpace(Ch) then + Break; + Dec(StartCharIndex); + end; + Inc(StartCharIndex); + + StopCharIndex := CharIndex + 1; + while StopCharIndex < CharCount do + begin + Ch := Page.ReadChar(StopCharIndex); + if IsWhiteSpace(Ch) then + Break; + Inc(StopCharIndex); + end; + Dec(StopCharIndex); + + SetSelection(True, StartCharIndex, StopCharIndex); + Result := True; + end; + end; + end; +end; + +function TPdfControl.SelectLine(CharIndex: Integer): Boolean; +var + Ch: WideChar; + StartCharIndex, StopCharIndex, CharCount: Integer; + Page: TPdfPage; +begin + Result := False; + Page := CurrentPage; + if Page <> nil then + begin + ClearSelection; + CharCount := Page.GetCharCount; + if (CharIndex >= 0) and (CharIndex < CharCount) then + begin + StartCharIndex := CharIndex - 1; + while StartCharIndex >= 0 do + begin + Ch := Page.ReadChar(StartCharIndex); + case Ch of + #10, #13: + Break; + end; + Dec(StartCharIndex); + end; + Inc(StartCharIndex); + + StopCharIndex := CharIndex + 1; + while StopCharIndex < CharCount do + begin + Ch := Page.ReadChar(StopCharIndex); + case Ch of + #10, #13: + Break; + end; + Inc(StopCharIndex); + end; + Dec(StopCharIndex); + + SetSelection(True, StartCharIndex, StopCharIndex); + Result := True; + end; + end; +end; + +procedure TPdfControl.WMGetDlgCode(var Message: TWMGetDlgCode); +begin + inherited; + Message.Result := Message.Result or DLGC_WANTARROWS or DLGC_WANTTAB; +end; + +procedure TPdfControl.KeyDown(var Key: Word; Shift: TShiftState); +var + XOffset, YOffset: Integer; + ScrollInfo: TScrollInfo; +begin + inherited KeyDown(Key, Shift); + XOffset := 0; + YOffset := 0; + case Key of + Ord('C'), VK_INSERT: + if AllowUserTextSelection then + begin + if Shift = [ssCtrl] then + begin + if FSelectionActive then + CopyToClipboard; + Key := 0; + end + end; + + Ord('A'): + if AllowUserTextSelection then + begin + if Shift = [ssCtrl] then + begin + SelectAll; + Key := 0; + end; + end; + + VK_LEFT, VK_RIGHT: + begin + if ssShift in Shift then + XOffset := cDefaultScrollOffset * 2 + else + XOffset := cDefaultScrollOffset; + if Key = VK_LEFT then + XOffset := -XOffset; + end; + + VK_UP, VK_DOWN: + begin + if ssShift in Shift then + YOffset := cDefaultScrollOffset * 2 + else + YOffset := cDefaultScrollOffset; + if Key = VK_UP then + YOffset := -YOffset; + end; + + VK_PRIOR, VK_NEXT: + begin + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_PAGE or SIF_RANGE or SIF_POS; + if AllowUserPageChange and (GetWindowLong(Handle, GWL_STYLE) and WS_VSCROLL = 0) then + begin + if Key = VK_NEXT then + GotoNextPage(True) + else + GotoPrevPage(True); + end + else if GetScrollInfo(Handle, SB_VERT, ScrollInfo) then + begin + if Key = VK_NEXT then + begin + if AllowUserPageChange and (ScrollInfo.nPos >= ScrollInfo.nMax - Integer(ScrollInfo.nPage)) then + GotoNextPage(True) + else + YOffset := ScrollInfo.nPage + end + else + begin + if AllowUserPageChange and (ScrollInfo.nPos = 0) then + GotoPrevPage(True) + else + YOffset := -ScrollInfo.nPage; + end; + end; + end; + + VK_HOME, VK_END: + begin + if ssCtrl in Shift then + begin + if Key = VK_HOME then + InternSetPageIndex(0, True, True) + else + InternSetPageIndex(PageCount - 1, True, True); + end + else + begin + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_RANGE; + + if ssShift in Shift then + begin + if GetScrollInfo(Handle, SB_HORZ, ScrollInfo) then + begin + if Key = VK_END then + XOffset := ScrollInfo.nMax + else + XOffset := -ScrollInfo.nMax; + end; + end + else + begin + if GetScrollInfo(Handle, SB_VERT, ScrollInfo) then + begin + if Key = VK_END then + YOffset := ScrollInfo.nMax + else + YOffset := -ScrollInfo.nMax; + end; + end; + end; + end; + end; + + if (XOffset <> 0) or (YOffset <> 0) then + begin + ScrollContent(XOffset, YOffset, SmoothScroll); + Key := 0; + end; +end; + +procedure TPdfControl.WMKeyDown(var Message: TWMKeyDown); +var + Shift: TShiftState; +begin + if AllowFormEvents and IsPageValid then + begin + Shift := KeyDataToShiftState(Message.KeyData); + if CurrentPage.FormEventKeyDown(Message.CharCode, Shift) then + begin + // PDFium doesn't handle Copy&Paste&Cut keyboard shortcuts in form fields + case Message.CharCode of + Ord('C'), Ord('X'), Ord('V'), VK_INSERT, VK_DELETE: + begin + if Shift = [ssCtrl] then + begin + case Message.CharCode of + Ord('C'), VK_INSERT: + CopyFormTextToClipboard; + Ord('X'): + CutFormTextToClipboard; + Ord('V'): + PasteFormTextFromClipboard; + end; + end + else if Shift = [ssShift] then + begin + case Message.CharCode of + VK_INSERT: + PasteFormTextFromClipboard; + VK_DELETE: + CutFormTextToClipboard; + end; + end; + end; + end; + Exit; + end; + end; + inherited; +end; + +procedure TPdfControl.WMKeyUp(var Message: TWMKeyUp); +begin + if AllowFormEvents and IsPageValid + and CurrentPage.FormEventKeyUp(Message.CharCode, KeyDataToShiftState(Message.KeyData)) then + Exit; + inherited; +end; + +procedure TPdfControl.WMChar(var Message: TWMChar); +begin + if AllowFormEvents and IsPageValid + and CurrentPage.FormEventKeyPress(Message.CharCode, KeyDataToShiftState(Message.KeyData)) then + Exit; + inherited; +end; + +procedure TPdfControl.WMKillFocus(var Message: TWMKillFocus); +begin + if AllowFormEvents and IsPageValid then + CurrentPage.FormEventKillFocus; + inherited; +end; + +procedure TPdfControl.GetPageWebLinks; +var + Page: TPdfPage; +begin + FreeAndNil(FWebLinkInfo); + Page := CurrentPage; + if Page <> nil then + FWebLinkInfo := TPdfPageWebLinksInfo.Create(Page); +end; + +function TPdfControl.LinkHandlingNeeded: Boolean; +begin + // If an event handler is assigned, we need link handling + Result := Assigned(FOnAnnotationLinkClick) or Assigned(FOnWebLinkClick); + if not Result then + begin + // If no event handler is assigned, we may need link handling depending on the loAutoXXX options. + Result := LinkOptions * cPdfControlAllAutoLinkOptions <> []; + end; +end; + +function TPdfControl.IsClickableLinkAt(X, Y: Integer): Boolean; +var + LinkAnnotation: TPdfAnnotation; +begin + Result := False; + if LinkHandlingNeeded then + begin + LinkAnnotation := GetAnnotationLinkAt(X, Y); + if LinkAnnotation <> nil then + begin + if Assigned(FOnAnnotationLinkClick) then + Result := True + else + begin + case LinkAnnotation.LinkType of + altGoto: + Result := loAutoGoto in LinkOptions; + altRemoteGoto: + Result := loAutoRemoteGotoReplaceDocument in LinkOptions; + altURI: + Result := (loAutoOpenURI in LinkOptions) or (loAlwaysDetectWebAndUriLink in LinkOptions) or Assigned(FOnWebLinkClick); // Fallback to OnWebLinkClick for URIs + altLaunch: + Result := loAutoLaunch in LinkOptions; + altEmbeddedGoto: + Result := loAutoEmbeddedGotoReplaceDocument in LinkOptions; + else + Result := False; + end; + end; + end + else if IsWebLinkAt(X, Y) then + begin + if Assigned(FOnWebLinkClick) or (loAlwaysDetectWebAndUriLink in LinkOptions) then + Result := True + else if Assigned(FOnAnnotationLinkClick) and (loTreatWebLinkAsUriAnnotationLink in LinkOptions) then + Result := True + else if not Assigned(FOnAnnotationLinkClick) and (loTreatWebLinkAsUriAnnotationLink in LinkOptions) and (loAutoOpenURI in LinkOptions) then + Result := True; + end; + end; +end; + +function TPdfControl.IsWebLinkAt(X, Y: Integer): Boolean; +var + PdfPt: TPdfPoint; +begin + if (FWebLinkInfo <> nil) and IsPageValid then + begin + PdfPt := DeviceToPage(X, Y); + Result := FWebLinkInfo.IsWebLinkAt(PdfPt.X, PdfPt.Y); + end + else + Result := False; +end; + +function TPdfControl.IsWebLinkAt(X, Y: Integer; var Url: string): Boolean; +var + PdfPt: TPdfPoint; +begin + Url := ''; + if (FWebLinkInfo <> nil) and IsPageValid then + begin + PdfPt := DeviceToPage(X, Y); + Result := FWebLinkInfo.IsWebLinkAt(PdfPt.X, PdfPt.Y, Url); + end + else + Result := False; +end; + +function TPdfControl.IsUriAnnotationLinkAt(X, Y: Integer): Boolean; +var + PdfPt: TPdfPoint; +begin + if IsPageValid then + begin + PdfPt := DeviceToPage(X, Y); + Result := CurrentPage.IsUriLinkAtPoint(PdfPt.X, PdfPt.Y); + end + else + Result := False; +end; + +function TPdfControl.IsAnnotationLinkAt(X, Y: Integer): Boolean; +begin + Result := GetAnnotationLinkAt(X, Y) <> nil; +end; + +function TPdfControl.GetAnnotationLinkAt(X, Y: Integer): TPdfAnnotation; +var + PdfPt: TPdfPoint; +begin + if IsPageValid then + begin + PdfPt := DeviceToPage(X, Y); + Result := CurrentPage.GetLinkAtPoint(PdfPt.X, PdfPt.Y); + end + else + Result := nil; +end; + +function TPdfControl.ShellOpenFileName(const FileName: string; Launch: Boolean): Boolean; +var + Info: TShellExecuteInfoW; +begin + FillChar(Info, SizeOf(Info), 0); + Info.cbSize := SizeOf(Info); + if HandleAllocated then + Info.Wnd := Handle; + if Launch then + Info.lpVerb := nil + else + Info.lpVerb := 'open'; + Info.lpFile := PChar(FileName); + Info.lpDirectory := PChar(ExtractFileDir(Document.FileName)); + Info.nShow := SW_NORMAL; + Result := ShellExecuteExW(@Info); +end; + +procedure TPdfControl.WebLinkClick(const Url: string); +begin + if Assigned(FOnWebLinkClick) then + FOnWebLinkClick(Self, Url); +end; + +function TPdfControl.GotoDestination(const LinkGotoDestination: TPdfLinkGotoDestination): Boolean; +var + X, Y: Double; + //Zoom: Integer; + Pt: TPoint; +begin + Result := False; + if Document.Active then + begin + X := 0; + Y := 0; + //Zoom := 100; + if LinkGotoDestination.XValid then + X := LinkGotoDestination.X; + if LinkGotoDestination.YValid then + Y := LinkGotoDestination.Y; + //if Dest.ZoomValid then + // Zoom := Int(Dest.Zoom); + + if (LinkGotoDestination.PageIndex >= 0) and (LinkGotoDestination.PageIndex < Document.PageCount) then + begin + Pt := PageToDevice(X, Y); + + PageIndex := LinkGotoDestination.PageIndex; + //ZoomPercentage := Zoom; + ScrollContentTo(Pt.X, Pt.Y); + Result := True; + end; + end; +end; + +procedure TPdfControl.AnnotationLinkClick(LinkInfo: TPdfLinkInfo); +var + Handled: Boolean; + Dest: TPdfLinkGotoDestination; + FileName: string; + RemoteDoc: TPdfDocument; + DestValid: Boolean; + AttachmentIndex: Integer; +begin + Handled := False; + if not Document.Active then + Exit; + + if Assigned(FOnAnnotationLinkClick) then + FOnAnnotationLinkClick(Self, LinkInfo, Handled) + else if Assigned(FOnWebLinkClick) and (LinkInfo.LinkType = altURI) and not (loAutoOpenURI in LinkOptions) then + begin + WebLinkClick(LinkInfo.LinkUri); + Exit; + end; + + if not Handled and Document.Active then + begin + case LinkInfo.LinkType of + altGoto: + if loAutoGoto in LinkOptions then + begin + if LinkInfo.GetLinkGotoDestination(Dest) then + GotoDestination(Dest); + end; + + altRemoteGoto: + if loAutoRemoteGotoReplaceDocument in LinkOptions then + begin + Dest := nil; + RemoteDoc := TPdfDocument.Create; + try + // Open the remote document + RemoteDoc.LoadFromFile(LinkInfo.LinkFileName); + // Get the link destination from the remote document + DestValid := LinkInfo.GetLinkGotoDestination(Dest, RemoteDoc); + except + RemoteDoc.Free; + raise; + end; + if DestValid then + begin + // Replace the current document with the remote document + OpenWithDocument(RemoteDoc); + GotoDestination(Dest); + end; + end; + + altURI: + if loAutoOpenURI in LinkOptions then + ShellOpenFileName(LinkInfo.LinkUri, False); + + altLaunch: + if loAutoLaunch in LinkOptions then + ShellOpenFileName(LinkInfo.LinkFileName, True); + + altEmbeddedGoto: + if loAutoEmbeddedGotoReplaceDocument in LinkOptions then + begin + FileName := LinkInfo.LinkFileName; + AttachmentIndex := Document.Attachments.IndexOf(FileName); + if AttachmentIndex <> -1 then + begin + // Same as RemoteGoto but with a byte array + Dest := nil; + RemoteDoc := TPdfDocument.Create; + try + // Open the embedded document + RemoteDoc.LoadFromBytes(Document.Attachments[AttachmentIndex].GetContentAsBytes); + // Get the link destination from the remote document + DestValid := LinkInfo.GetLinkGotoDestination(Dest, RemoteDoc); + except + RemoteDoc.Free; + raise; + end; + if DestValid then + begin + // Replace the current document with the remote document + OpenWithDocument(RemoteDoc); + GotoDestination(Dest); + end; + end; + end; + end; + end; +end; + +procedure TPdfControl.UpdatePageDrawInfo; + + procedure GetWidthHeight(PageWidth, PageHeight: Double; DpiX, DpiY, MaxWidth, MaxHeight: Integer; var W, H: Integer); + begin + case ScaleMode of + smFitAuto: + begin + W := Round(MaxHeight * (PageWidth / PageHeight)); + H := MaxHeight; + if W > MaxWidth then + begin + W := MaxWidth; + H := Round(MaxWidth * (PageHeight / PageWidth)); + end; + end; + + smFitWidth: + begin + W := MaxWidth; + H := Round(MaxWidth * (PageHeight / PageWidth)); + end; + + smFitHeight: + begin + W := Round(MaxHeight * (PageWidth / PageHeight)); + H := MaxHeight; + end; + + smZoom: // PDFium's 100% is not AcrobatReader's 100% + begin + W := Round(PageWidth / 72 * DpiX * (ZoomPercentage / 100)); + H := Round(PageHeight / 72 * DpiY * (ZoomPercentage / 100)); + end; + end; + + if (PageShadowColor <> clNone) and (PageShadowSize > 0) and (PageShadowPadding > 0) then + begin + W := W - (PageShadowPadding + PageShadowSize); + H := H - (PageShadowPadding + PageShadowSize); + end; + end; + +var + Page: TPdfPage; + MaxWidth, MaxHeight: Integer; + W, H: Integer; + PageWidth, PageHeight: Double; + DpiX, DpiY: Integer; + ScrollInfo: TScrollInfo; + Style: NativeInt; +begin + Page := CurrentPage; + if (Page <> nil) and (Page.Width > 0) and (Page.Height > 0) and HandleAllocated then + begin + Style := GetWindowLong(Handle, GWL_STYLE); + + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_RANGE or SIF_PAGE; + ScrollInfo.nMin := 0; + + // Take "Rotation" into account + if Rotation in [prNormal, pr180] then + begin + PageWidth := Page.Width; + PageHeight := Page.Height; + DpiX := GetDeviceCaps(Canvas.Handle, LOGPIXELSX); + DpiY := GetDeviceCaps(Canvas.Handle, LOGPIXELSY); + end + else + begin + PageHeight := Page.Width; + PageWidth := Page.Height; + DpiY := GetDeviceCaps(Canvas.Handle, LOGPIXELSX); + DpiX := GetDeviceCaps(Canvas.Handle, LOGPIXELSY); + end; + + + MaxWidth := Width; + MaxHeight := Height; + GetWidthHeight(PageWidth, PageHeight, DpiX, DpiY, MaxWidth, MaxHeight, W, H); + if W > MaxWidth then + begin + MaxHeight := MaxHeight - GetSystemMetrics(SM_CYHSCROLL); + GetWidthHeight(PageWidth, PageHeight, DpiX, DpiY, MaxWidth, MaxHeight, W, H); + end; + if H > MaxHeight then + begin + MaxWidth := MaxWidth - GetSystemMetrics(SM_CXVSCROLL); + GetWidthHeight(PageWidth, PageHeight, DpiX, DpiY, MaxWidth, MaxHeight, W, H); + end; + + if W > MaxWidth then + begin + ScrollInfo.nMax := W; + ScrollInfo.nPage := MaxWidth; + SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True); + end + else + begin + if Style and WS_HSCROLL <> 0 then + begin + ShowScrollBar(Handle, SB_HORZ, False); + RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_FRAME); + InvalidateRect(Handle, nil, True); + end; + end; + + if H > MaxHeight then + begin + ScrollInfo.nMax := H; + ScrollInfo.nPage := MaxHeight; + SetScrollInfo(Handle, SB_VERT, ScrollInfo, True); + ShowScrollBar(Handle, SB_VERT, True); + end + else + begin + if Style and WS_VSCROLL <> 0 then + begin + ShowScrollBar(Handle, SB_VERT, False); + RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_FRAME); + InvalidateRect(Handle, nil, True); + end; + end; + + FDrawWidth := W; + FDrawHeight := H; + AdjustDrawPos; + end; +end; + +procedure TPdfControl.AdjustDrawPos; +var + ScrollInfo: TScrollInfo; + X, Y, HPos, VPos: Integer; + Style: NativeInt; + MaxWidth: Integer; + MaxHeight: Integer; +begin + Style := GetWindowLong(Handle, GWL_STYLE); + MaxWidth := Width; + MaxHeight := Height; + HPos := 0; + VPos := 0; + + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_POS; + if (Style and WS_HSCROLL <> 0) then + begin + MaxHeight := MaxHeight - GetSystemMetrics(SM_CXHSCROLL); + if GetScrollInfo(Handle, SB_HORZ, ScrollInfo) then + HPos := ScrollInfo.nPos; + end; + if (Style and WS_VSCROLL <> 0) then + begin + MaxWidth := MaxWidth - GetSystemMetrics(SM_CXVSCROLL); + if GetScrollInfo(Handle, SB_VERT, ScrollInfo) then + VPos := ScrollInfo.nPos; + end; + + X := (MaxWidth - FDrawWidth) div 2; + Y := (MaxHeight - FDrawHeight) div 2; + if X < 0 then + X := 0; + if Y < 0 then + Y := 0; + + Dec(X, HPos); + Dec(Y, VPos); + if (FDrawX <> X) or (FDrawY <> Y) then + begin + FDrawX := X; + FDrawY := Y; + end; +end; + +function TPdfControl.ScrollContent(XOffset, YOffset: Integer; Smooth: Boolean): Boolean; +var + ScrollInfo: TScrollInfo; + X, Y: Integer; + Style: NativeInt; + Flags: UINT; +begin + if Smooth then + Update; + + Style := GetWindowLong(Handle, GWL_STYLE); + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_POS; + + // Vertical scroll + if (YOffset <> 0) and (Style and WS_VSCROLL <> 0) and GetScrollInfo(Handle, SB_VERT, ScrollInfo) then + begin + Y := ScrollInfo.nPos; + ScrollInfo.nPos := Y + YOffset; + SetScrollInfo(Handle, SB_VERT, ScrollInfo, True); + GetScrollInfo(Handle, SB_VERT, ScrollInfo); // let Windows do the range checking + YOffset := Y - ScrollInfo.nPos; + end + else + YOffset := 0; + + // Horizontal scroll + if (XOffset <> 0) and (Style and WS_HSCROLL <> 0) and GetScrollInfo(Handle, SB_HORZ, ScrollInfo) then + begin + X := ScrollInfo.nPos; + ScrollInfo.nPos := X + XOffset; + SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True); + GetScrollInfo(Handle, SB_HORZ, ScrollInfo); // let Windows do the range checking + XOffset := X - ScrollInfo.nPos; + end + else + XOffset := 0; + + if (XOffset <> 0) or (YOffset <> 0) then + begin + AdjustDrawPos; // adjust DrawX/DrawY for ScrollWindowEx + Flags := 0; + if Smooth then + Flags := Flags or SW_SMOOTHSCROLL or (150 shl 16); + ScrollWindowEx(Handle, XOffset, YOffset, nil, nil, 0, nil, SW_INVALIDATE or Flags); + UpdateWindow(Handle); + Result := True; + end + else + Result := False; +end; + +function TPdfControl.ScrollContentTo(X, Y: Integer; Smooth: Boolean = False): Boolean; +var + ScrollInfo: TScrollInfo; + XOffset, YOffset: Integer; +begin + XOffset := 0; + YOffset := 0; + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_POS; + if GetScrollInfo(Handle, SB_HORZ, ScrollInfo) then + XOffset := X - ScrollInfo.nPos; + if GetScrollInfo(Handle, SB_VERT, ScrollInfo) then + YOffset := Y - ScrollInfo.nPos; + Result := ScrollContent(XOffset, YOffset, Smooth); +end; + +procedure TPdfControl.WMVScroll(var Message: TWMVScroll); +var + ScrollInfo: TScrollInfo; + Offset: Integer; +begin + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_ALL; + GetScrollInfo(Handle, SB_VERT, ScrollInfo); + Offset := 0; + case Message.ScrollCode of + SB_LINEUP: + Offset := -cDefaultScrollOffset; + SB_LINEDOWN: + Offset := cDefaultScrollOffset; + SB_PAGEUP: + Offset := -ScrollInfo.nPage; + SB_PAGEDOWN: + Offset := ScrollInfo.nPage; + SB_THUMBTRACK: + Offset := ScrollInfo.nTrackPos - ScrollInfo.nPos; + end; + ScrollContent(0, Offset, SmoothScroll); + Message.Result := 0; +end; + +procedure TPdfControl.WMHScroll(var Message: TWMHScroll); +var + ScrollInfo: TScrollInfo; + Offset: Integer; +begin + ScrollInfo.cbSize := SizeOf(ScrollInfo); + ScrollInfo.fMask := SIF_ALL; + GetScrollInfo(Handle, SB_HORZ, ScrollInfo); + Offset := 0; + case Message.ScrollCode of + SB_LINELEFT: + Offset := -cDefaultScrollOffset; + SB_LINERIGHT: + Offset := cDefaultScrollOffset; + SB_PAGELEFT: + Offset := -ScrollInfo.nPage; + SB_PAGERIGHT: + Offset := ScrollInfo.nPage; + SB_THUMBTRACK: + Offset := ScrollInfo.nTrackPos - ScrollInfo.nPos; + end; + ScrollContent(Offset, 0, SmoothScroll); + Message.Result := 0; +end; + +function TPdfControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; + MousePos: TPoint): Boolean; +var + PagePt: TPdfPoint; +begin + Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos); + + if not Result then + begin + if IsPageValid and AllowFormEvents then + begin + PagePt := DeviceToPage(MousePos.X, MousePos.Y); + if CurrentPage.FormEventMouseWheel(Shift, WheelDelta, PagePt.X, PagePt.Y) then + Exit; + end; + + if ssCtrl in Shift then + begin + if ScaleMode = smZoom then + begin + ZoomPercentage := ZoomPercentage + (WheelDelta div WHEEL_DELTA) * 5; + Result := True; + end; + end + else + begin + if ssShift in Shift then + Result := ScrollContent(-WheelDelta, 0, SmoothScroll) + else + Result := ScrollContent(0, -WheelDelta, SmoothScroll); + + if not Result and FChangePageOnMouseScrolling then + begin + if WheelDelta < 0 then + GotoNextPage() + else if PageIndex > 0 then + begin + GotoPrevPage(); + ScrollContentTo(0, MaxInt); + end; + end + else + Result := True; + end; + end; +end; + +procedure TPdfControl.WMTimer(var Message: TWMTimer); +var + XOffset, YOffset: Integer; +begin + case Message.TimerID of + cScrollTimerId: + begin + if FMousePressed and FScrollTimerActive then + begin + XOffset := 0; + YOffset := 0; + if FScrollMousePos.X < 0 then + XOffset := -cDefaultScrollOffset + else if FScrollMousePos.X >= Width then + XOffset := cDefaultScrollOffset + else if FScrollMousePos.Y < 0 then + YOffset := -cDefaultScrollOffset + else if FScrollMousePos.Y >= Height then + YOffset := cDefaultScrollOffset; + ScrollContent(XOffset, YOffset, SmoothScroll); + end + else + StopScrollTimer; + end; + + cTrippleClickTimerId: + begin + FCheckForTrippleClick := False; + KillTimer(Handle, cTrippleClickTimerId); + end; + else + inherited; + end; +end; + +procedure TPdfControl.StopScrollTimer; +begin + if FScrollTimerActive then + begin + KillTimer(Handle, cScrollTimerId); + FScrollTimerActive := False; + end; +end; + +procedure TPdfControl.HightlightText(const SearchText: string; MatchCase, MatchWholeWord: Boolean); +begin + if FHighlightTexts <> nil then + FHighlightTexts.Clear; + AddHightlightText(SearchText, MatchCase, MatchWholeWord); +end; + +procedure TPdfControl.AddHightlightText(const SearchText: string; MatchCase, MatchWholeWord: Boolean); +var + HLTextInfo: THighlightTextInfo; + I: Integer; +begin + if SearchText = '' then + Exit; + + // Prevent duplicates + if FHighlightTexts <> nil then + for I := 0 to FHighlightTexts.Count - 1 do + if (FHighlightTexts[I] as THighlightTextInfo).IsSame(SearchText, MatchCase, MatchWholeWord) then + Exit; + + if FHighlightTexts = nil then + FHighlightTexts := TObjectList.Create; + HLTextInfo := THighlightTextInfo.Create(SearchText, MatchCase, MatchWholeWord); + FHighlightTexts.Add(HLTextInfo); + + CalcHighlightTextRects; +end; + +procedure TPdfControl.CalcHighlightTextRects; +var + OldHighlightTextRects: TPdfRectArray; + HLTextInfo: THighlightTextInfo; + Page: TPdfPage; + CharIndex, CharCount, I, Count, TextsIndex: Integer; + Num: Integer; +begin + OldHighlightTextRects := FHighlightTextRects; + FHighlightTextRects := nil; + if (FHighlightTexts <> nil) and (FHighlightTexts.Count > 0) and IsPageValid then + begin + Page := CurrentPage; + Num := 0; + for TextsIndex := 0 to FHighlightTexts.Count - 1 do + begin + HLTextInfo := FHighlightTexts[TextsIndex] as THighlightTextInfo; + if HLTextInfo.Text <> '' then // prevent infinite loop in FPDFText_FindNext() + begin + if Page.BeginFind(HLTextInfo.Text, HLTextInfo.MatchCase, HLTextInfo.MatchWholeWord, False) then + begin + try + while Page.FindNext(CharIndex, CharCount) do + begin + Count := Page.GetTextRectCount(CharIndex, CharCount); + if Num + Count > Length(FHighlightTextRects) then + SetLength(FHighlightTextRects, (Num + Count) * 2); + for I := 0 to Count - 1 do + begin + FHighlightTextRects[Num] := Page.GetTextRect(I); + Inc(Num); + end; + end; + finally + Page.EndFind; + end; + end; + end; + end; + + // truncate to the actual number + if Num <> Length(FHighlightTextRects) then + SetLength(FHighlightTextRects, Num); + end; + InvalidatePdfRectDiffs(OldHighlightTextRects, FHighlightTextRects); +end; + +procedure TPdfControl.ClearHighlightText; +begin + FreeAndNil(FHighlightTexts); + InvalidatePdfRectDiffs(FHighlightTextRects, nil); + FHighlightTextRects := nil; +end; + +procedure TPdfControl.FormInvalidate(Document: TPdfDocument; Page: TPdfPage; + const PageRect: TPdfRect); +var + R: TRect; +begin + FRenderedPageIndex := -1; // content has changed => render into the background bitmap + FFormOutputSelectedRects := nil; + if HandleAllocated then + begin + R := InternPageToDevice(Page, PageRect, True); + InvalidateRect(Handle, @R, True); + end; +end; + +procedure TPdfControl.FormOutputSelectedRect(Document: TPdfDocument; Page: TPdfPage; + const PageRect: TPdfRect); +begin + if HandleAllocated then + begin + SetLength(FFormOutputSelectedRects, Length(FFormOutputSelectedRects) + 1); + FFormOutputSelectedRects[Length(FFormOutputSelectedRects) - 1] := PageRect; + end; +end; + +procedure TPdfControl.FormGetCurrentPage(Document: TPdfDocument; var Page: TPdfPage); +begin + Page := CurrentPage; +end; + +procedure TPdfControl.FormFieldFocus(Document: TPdfDocument; Value: PWideChar; + ValueLen: Integer; FieldFocused: Boolean); +begin + ClearSelection; + FFormFieldFocused := FieldFocused; +end; + +procedure TPdfControl.ExecuteNamedAction(Document: TPdfDocument; NamedAction: TPdfNamedActionType); +begin + case NamedAction of + naPrint: + PrintDocument; + naNextPage: + PageIndex := PageIndex + 1; + naPrevPage: + PageIndex := PageIndex - 1; + naFirstPage: + PageIndex := 0; + naLastPage: + PageIndex := Document.PageCount - 1; + end; +end; + +end. + diff --git a/Tocsg.Lib/VCL/Other/EM.PdfiumLib.pas b/Tocsg.Lib/VCL/Other/EM.PdfiumLib.pas new file mode 100644 index 00000000..b4ac7a9e --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.PdfiumLib.pas @@ -0,0 +1,9310 @@ +// Use DLLs (x64, x86) from https://github.com/bblanchon/pdfium-binaries +// +// DLL Version: chromium/6611 + +unit EM.PdfiumLib; +{$IFDEF FPC} + {$MODE DelphiUnicode} +{$ENDIF FPC} + +{$IFNDEF FPC} + {$A8,B-,E-,F-,G+,H+,I+,J-,K-,M-,N-,P+,Q-,R-,S-,T-,U-,V+,X+,Z1} + {$STRINGCHECKS OFF} // It only slows down Delphi strings in Delphi 2009 and 2010 +{$ENDIF ~FPC} +{$SCOPEDENUMS ON} + +{.$DEFINE DLLEXPORT} // stdcall in WIN32 instead of CDECL in WIN32 (The library switches between those from release to release) + +{$DEFINE PDF_USE_SKIA} +{$DEFINE PDF_ENABLE_XFA} +{$DEFINE PDF_ENABLE_V8} + +interface + +uses + {$IFDEF FPC} + {$IFDEF MSWINDOWS} + Windows; + {$ELSE} + dynlibs; + {$ENDIF MSWINDOWS} + {$ELSE} + {$IF CompilerVersion >= 23.0} // XE2+ + WinApi.Windows; + {$ELSE} + Windows; + {$IFEND} + {$ENDIF FPC} + +type + // Delphi/FPC version compatibility types + {$IF not declared(SIZE_T)} + SIZE_T = LongWord; + {$IFEND} + {$IF not declared(DWORD)} + DWORD = UInt32; + {$IFEND} + {$IF not declared(UINT)} + UINT = LongWord; + {$IFEND} + {$IF not declared(PUINT)} + PUINT = ^UINT; + {$IFEND} + TIME_T = Longint; + PTIME_T = ^TIME_T; + +// Returns True if the pdfium.dll supports Skia. +function PDF_IsSkiaAvailable: Boolean; + + +// *** _FPDFVIEW_H_ *** + +{.$IFDEF PDF_ENABLE_XFA} +// PDF_USE_XFA is set in confirmation that this version of PDFium can support +// XFA forms as requested by the PDF_ENABLE_XFA setting. +function PDF_USE_XFA: Boolean; +{.$ENDIF PDF_ENABLE_XFA} + +const + // PDF object types + FPDF_OBJECT_UNKNOWN = 0; + FPDF_OBJECT_BOOLEAN = 1; + FPDF_OBJECT_NUMBER = 2; + FPDF_OBJECT_STRING = 3; + FPDF_OBJECT_NAME = 4; + FPDF_OBJECT_ARRAY = 5; + FPDF_OBJECT_DICTIONARY = 6; + FPDF_OBJECT_STREAM = 7; + FPDF_OBJECT_NULLOBJ = 8; + FPDF_OBJECT_REFERENCE = 9; + +// PDF text rendering modes +type + FPDF_TEXT_RENDERMODE = Integer; +const + FPDF_TEXTRENDERMODE_UNKNOWN = -1; + FPDF_TEXTRENDERMODE_FILL = 0; + FPDF_TEXTRENDERMODE_STROKE = 1; + FPDF_TEXTRENDERMODE_FILL_STROKE = 2; + FPDF_TEXTRENDERMODE_INVISIBLE = 3; + FPDF_TEXTRENDERMODE_FILL_CLIP = 4; + FPDF_TEXTRENDERMODE_STROKE_CLIP = 5; + FPDF_TEXTRENDERMODE_FILL_STROKE_CLIP = 6; + FPDF_TEXTRENDERMODE_CLIP = 7; + FPDF_TEXTRENDERMODE_LAST = FPDF_TEXTRENDERMODE_CLIP; + +type + // Helper data type for type safety. + __FPDF_PTRREC = record end; + __PFPDF_PTRREC = ^__FPDF_PTRREC; + PFPDF_LINK = ^FPDF_LINK; // array + PFPDF_PAGE = ^FPDF_PAGE; // array + + // PDF types - use incomplete types (never completed) to force API type safety. + FPDF_ACTION = type __PFPDF_PTRREC; + FPDF_ANNOTATION = type __PFPDF_PTRREC; + FPDF_ATTACHMENT = type __PFPDF_PTRREC; + FPDF_AVAIL = type __PFPDF_PTRREC; + FPDF_BITMAP = type __PFPDF_PTRREC; + FPDF_BOOKMARK = type __PFPDF_PTRREC; + FPDF_CLIPPATH = type __PFPDF_PTRREC; + FPDF_DEST = type __PFPDF_PTRREC; + FPDF_DOCUMENT = type __PFPDF_PTRREC; + FPDF_FONT = type __PFPDF_PTRREC; + FPDF_FORMHANDLE = type __PFPDF_PTRREC; + FPDF_GLYPHPATH = type __PFPDF_PTRREC; + FPDF_JAVASCRIPT_ACTION = type __PFPDF_PTRREC; + FPDF_LINK = type __PFPDF_PTRREC; + FPDF_PAGE = type __PFPDF_PTRREC; + FPDF_PAGELINK = type __PFPDF_PTRREC; + FPDF_PAGEOBJECT = type __PFPDF_PTRREC; // (text, path, etc.) + FPDF_PAGEOBJECTMARK = type __PFPDF_PTRREC; + FPDF_PAGERANGE = type __PFPDF_PTRREC; + FPDF_PATHSEGMENT = type __PFPDF_PTRREC; + FPDF_SCHHANDLE = type __PFPDF_PTRREC; + FPDF_SIGNATURE = type __PFPDF_PTRREC; + FPDF_SKIA_CANVAS = type Pointer; // Passed into Skia as an SkCanvas. + FPDF_STRUCTELEMENT = type __PFPDF_PTRREC; + FPDF_STRUCTELEMENT_ATTR = type __PFPDF_PTRREC; + FPDF_STRUCTELEMENT_ATTR_VALUE = type __PFPDF_PTRREC; + FPDF_STRUCTTREE = type __PFPDF_PTRREC; + FPDF_TEXTPAGE = type __PFPDF_PTRREC; + FPDF_WIDGET = type __PFPDF_PTRREC; + FPDF_XOBJECT = type __PFPDF_PTRREC; + + // Basic data types + FPDF_BOOL = Integer; + FPDF_RESULT = Integer; + FPDF_DWORD = LongWord; + FS_FLOAT = Single; + PFS_FLOAT = ^FS_FLOAT; + + // Duplex types + FPDF_DUPLEXTYPE = ( + DuplexUndefined = 0, + Simplex, + DuplexFlipShortEdge, + DuplexFlipLongEdge + ); + + // String types + PFPDF_WCHAR = PWideChar; + FPDF_WCHAR = WideChar; + + // The public PDFium API uses three types of strings: byte string, wide string + // (UTF-16LE encoded), and platform dependent string. + + // Public PDFium API type for byte strings. + FPDF_BYTESTRING = PAnsiChar; + + // The public PDFium API always uses UTF-16LE encoded wide strings, each + // character uses 2 bytes (except surrogation), with the low byte first. + FPDF_WIDESTRING = PFPDF_WCHAR; + + // Structure for persisting a string beyond the duration of a callback. + // Note: although represented as a char*, string may be interpreted as + // a UTF-16LE formated string. Used only by XFA callbacks. + PFPDF_BSTR = ^FPDF_BSTR; + FPDF_BSTR = record + str: PAnsiChar; // String buffer, manipulate only with FPDF_BStr_* methods. + len: Integer; // Length of the string, in bytes. + end; + PFPdfBStr = ^TFPdfBStr; + TFPdfBStr = FPDF_BSTR; + + // For Windows programmers: In most cases it's OK to treat FPDF_WIDESTRING as a + // Windows unicode string, however, special care needs to be taken if you + // expect to process Unicode larger than 0xffff. + // + // For Linux/Unix programmers: most compiler/library environments use 4 bytes + // for a Unicode character, and you have to convert between FPDF_WIDESTRING and + // system wide string by yourself. + FPDF_STRING = PAnsiChar; + + // Matrix for transformation, in the form [a b c d e f], equivalent to: + // | a b 0 | + // | c d 0 | + // | e f 1 | + // + // Translation is performed with [1 0 0 1 tx ty]. + // Scaling is performed with [sx 0 0 sy 0 0]. + // See PDF Reference 1.7, 4.2.2 Common Transformations for more. + PFS_MATRIX = ^FS_MATRIX; + FS_MATRIX = record + a: Single; + b: Single; + c: Single; + d: Single; + e: Single; + f: Single; + end; + PFSMatrix = ^TFSMatrix; + TFSMatrix = FS_MATRIX; + + // Rectangle area(float) in device or page coordinate system. + PFS_RECTF = ^FS_RECTF; + FS_RECTF = record + // The x-coordinate of the left-top corner. + left: Single; + // The y-coordinate of the left-top corner. + top: Single; + // The x-coordinate of the right-bottom corner. + right: Single; + // The y-coordinate of the right-bottom corner. + bottom: Single; + end; + // Const Pointer to FS_RECTF structure. + FS_LPCRECTF = ^FS_RECTF; + PFSRectF = ^TFSRectF; + TFSRectF = FS_RECTF; + + // Rectangle size. Coordinate system agnostic. + PFS_SIZEF = ^FS_SIZEF; + FS_SIZEF = record + width: Single; + height: Single; + end; + PFSSizeF = ^TFSSizeF; + TFSSizeF = FS_SIZEF; + + // Const Pointer to FS_SIZEF structure. + PFS_POINTF = ^FS_POINTF; + FS_POINTF = record + x: Single; + y: Single; + end; + PFSPointF = ^TFSPointF; + TFSPointF = FS_POINTF; + + // Const Pointer to FS_POINTF structure. + FS_LPCPOINTF = ^FS_POINTF; + + PFS_QUADPOINTSF = ^FS_QUADPOINTSF; + FS_QUADPOINTSF = record + x1: FS_FLOAT; + y1: FS_FLOAT; + x2: FS_FLOAT; + y2: FS_FLOAT; + x3: FS_FLOAT; + y3: FS_FLOAT; + x4: FS_FLOAT; + y4: FS_FLOAT; + end; + PFSQuadPointsF = ^TFSQuadPointsF; + TFSQuadPointsF = FS_QUADPOINTSF; + + // Annotation enums. + FPDF_ANNOTATION_SUBTYPE = Integer; + PFPDF_ANNOTATION_SUBTYPE = ^FPDF_ANNOTATION_SUBTYPE; + FPDF_ANNOT_APPEARANCEMODE = Integer; + + // Dictionary value types. + FPDF_OBJECT_TYPE = Integer; + +// PDF renderer types - Experimental. +// Selection of 2D graphics library to use for rendering to FPDF_BITMAPs. +type + FPDF_RENDERER_TYPE = Integer; +const + // Anti-Grain Geometry - https://sourceforge.net/projects/agg/ + FPDF_RENDERERTYPE_AGG = 0; + // Skia - https://skia.org/ + FPDF_RENDERERTYPE_SKIA = 1; + +type + // Process-wide options for initializing the library. + PFPDF_LIBRARY_CONFIG = ^FPDF_LIBRARY_CONFIG; + FPDF_LIBRARY_CONFIG = record + // Version number of the interface. Currently must be 2. + // Support for version 1 will be deprecated in the future. + version: Integer; + + // Array of paths to scan in place of the defaults when using built-in + // FXGE font loading code. The array is terminated by a NULL pointer. + // The Array may be NULL itself to use the default paths. May be ignored + // entirely depending upon the platform. + m_pUserFontPaths: PPAnsiChar; + + // Version 2. + + // Pointer to the v8::Isolate to use, or NULL to force PDFium to create one. + m_pIsolate: Pointer; + + // The embedder data slot to use in the v8::Isolate to store PDFium's + // per-isolate data. The value needs to be in the range + // [0, |v8::Internals::kNumIsolateDataLots|). Note that 0 is fine for most + // embedders. + m_v8EmbedderSlot: Cardinal; + + // Version 3 - Experimental. + + // Pointer to the V8::Platform to use. + m_pPlatform: Pointer; + + // Version 4 - Experimental. + + // Explicit specification of core renderer to use. |m_RendererType| must be + // a valid value for |FPDF_LIBRARY_CONFIG| versions of this level or higher, + // or else the initialization will fail with an immediate crash. + // Note that use of a specified |FPDF_RENDERER_TYPE| value for which the + // corresponding render library is not included in the build will similarly + // fail with an immediate crash. + m_RendererType: FPDF_RENDERER_TYPE; + end; + PFPdfLibraryConfig = ^TFPdfLibraryConfig; + TFPdfLibraryConfig = FPDF_LIBRARY_CONFIG; + +// Function: FPDF_InitLibraryWithConfig +// Initialize the PDFium library and allocate global resources for it. +// Parameters: +// config - configuration information as above. +// Return value: +// None. +// Comments: +// You have to call this function before you can call any PDF +// processing functions. +var + FPDF_InitLibraryWithConfig: procedure(config: PFPDF_LIBRARY_CONFIG); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_InitLibrary +// Initialize the PDFium library (alternative form). +// Parameters: +// None +// Return value: +// None. +// Comments: +// Convenience function to call FPDF_InitLibraryWithConfig() with a +// default configuration for backwards compatibility purposes. New +// code should call FPDF_InitLibraryWithConfig() instead. This will +// be deprecated in the future. +var + FPDF_InitLibrary: procedure(); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_DestroyLibary +// Release global resources allocated to the PDFium library by +// FPDF_InitLibrary() or FPDF_InitLibraryWithConfig(). +// Parameters: +// None. +// Return value: +// None. +// Comments: +// After this function is called, you must not call any PDF +// processing functions. +// +// Calling this function does not automatically close other +// objects. It is recommended to close other objects before +// closing the library with this function. +var + FPDF_DestroyLibrary: procedure(); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Policy for accessing the local machine time. +const + FPDF_POLICY_MACHINETIME_ACCESS = 0; + +// Function: FPDF_SetSandBoxPolicy +// Set the policy for the sandbox environment. +// Parameters: +// policy - The specified policy for setting, for example: +// FPDF_POLICY_MACHINETIME_ACCESS. +// enable - True to enable, false to disable the policy. +// Return value: +// None. +var + FPDF_SetSandBoxPolicy: procedure(policy: FPDF_DWORD; enable: FPDF_BOOL); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +{$IFDEF MSWINDOWS} +// Experimental API. +// Function: FPDF_SetPrintMode +// Set printing mode when printing on Windows. +// Parameters: +// mode - FPDF_PRINTMODE_EMF to output EMF (default) +// FPDF_PRINTMODE_TEXTONLY to output text only (for charstream +// devices) +// FPDF_PRINTMODE_POSTSCRIPT2 to output level 2 PostScript into +// EMF as a series of GDI comments. +// FPDF_PRINTMODE_POSTSCRIPT3 to output level 3 PostScript into +// EMF as a series of GDI comments. +// FPDF_PRINTMODE_POSTSCRIPT2_PASSTHROUGH to output level 2 +// PostScript via ExtEscape() in PASSTHROUGH mode. +// FPDF_PRINTMODE_POSTSCRIPT3_PASSTHROUGH to output level 3 +// PostScript via ExtEscape() in PASSTHROUGH mode. +// FPDF_PRINTMODE_EMF_IMAGE_MASKS to output EMF, with more +// efficient processing of documents containing image masks. +// FPDF_PRINTMODE_POSTSCRIPT3_TYPE42 to output level 3 +// PostScript with embedded Type 42 fonts, when applicable, into +// EMF as a series of GDI comments. +// FPDF_PRINTMODE_POSTSCRIPT3_TYPE42_PASSTHROUGH to output level +// 3 PostScript with embedded Type 42 fonts, when applicable, +// via ExtEscape() in PASSTHROUGH mode. +// Return value: +// True if successful, false if unsuccessful (typically invalid input). +var + FPDF_SetPrintMode: function(mode: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +{$ENDIF MSWINDOWS} + +// Function: FPDF_LoadDocument +// Open and load a PDF document. +// Parameters: +// file_path - Path to the PDF file (including extension). +// password - A string used as the password for the PDF file. +// If no password is needed, empty or NULL can be used. +// See comments below regarding the encoding. +// Return value: +// A handle to the loaded document, or NULL on failure. +// Comments: +// Loaded document can be closed by FPDF_CloseDocument(). +// If this function fails, you can use FPDF_GetLastError() to retrieve +// the reason why it failed. +// +// The encoding for |file_path| is UTF-8. +// +// The encoding for |password| can be either UTF-8 or Latin-1. PDFs, +// depending on the security handler revision, will only accept one or +// the other encoding. If |password|'s encoding and the PDF's expected +// encoding do not match, FPDF_LoadDocument() will automatically +// convert |password| to the other encoding. +var + FPDF_LoadDocument: function(file_path: FPDF_STRING; password: FPDF_BYTESTRING): FPDF_DOCUMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_LoadMemDocument +// Open and load a PDF document from memory. +// Parameters: +// data_buf - Pointer to a buffer containing the PDF document. +// size - Number of bytes in the PDF document. +// password - A string used as the password for the PDF file. +// If no password is needed, empty or NULL can be used. +// Return value: +// A handle to the loaded document, or NULL on failure. +// Comments: +// The memory buffer must remain valid when the document is open. +// The loaded document can be closed by FPDF_CloseDocument. +// If this function fails, you can use FPDF_GetLastError() to retrieve +// the reason why it failed. +// +// See the comments for FPDF_LoadDocument() regarding the encoding for +// |password|. +// Notes: +// If PDFium is built with the XFA module, the application should call +// FPDF_LoadXFA() function after the PDF document loaded to support XFA +// fields defined in the fpdfformfill.h file. +var + FPDF_LoadMemDocument: function(data_buf: Pointer; size: Integer; password: FPDF_BYTESTRING): FPDF_DOCUMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_LoadMemDocument64 +// Open and load a PDF document from memory. +// Parameters: +// data_buf - Pointer to a buffer containing the PDF document. +// size - Number of bytes in the PDF document. +// password - A string used as the password for the PDF file. +// If no password is needed, empty or NULL can be used. +// Return value: +// A handle to the loaded document, or NULL on failure. +// Comments: +// The memory buffer must remain valid when the document is open. +// The loaded document can be closed by FPDF_CloseDocument. +// If this function fails, you can use FPDF_GetLastError() to retrieve +// the reason why it failed. +// +// See the comments for FPDF_LoadDocument() regarding the encoding for +// |password|. +// Notes: +// If PDFium is built with the XFA module, the application should call +// FPDF_LoadXFA() function after the PDF document loaded to support XFA +// fields defined in the fpdfformfill.h file. +var + FPDF_LoadMemDocument64: function(data_buf: Pointer; size: SIZE_T; password: FPDF_BYTESTRING): FPDF_DOCUMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Structure for custom file access. +type + PFPDF_FILEACCESS = ^FPDF_FILEACCESS; + FPDF_FILEACCESS = record + // File length, in bytes. + m_FileLen: LongWord; + + // A function pointer for getting a block of data from a specific position. + // Position is specified by byte offset from the beginning of the file. + // The pointer to the buffer is never NULL and the size is never 0. + // The position and size will never go out of range of the file length. + // It may be possible for PDFium to call this function multiple times for + // the same position. + // Return value: should be non-zero if successful, zero for error. + m_GetBlock: function(param: Pointer; position: LongWord; pBuf: PByte; size: LongWord): Integer; cdecl; + + // A custom pointer for all implementation specific data. This pointer will + // be used as the first parameter to the m_GetBlock callback. + m_Param: Pointer; + end; + PFPdfFileAccess = ^TFPdfFileAccess; + TFPdfFileAccess = FPDF_FILEACCESS; + + // Structure for file reading or writing (I/O). + // + // Note: This is a handler and should be implemented by callers, + // and is only used from XFA. + PFPDF_FILEHANDLER = ^FPDF_FILEHANDLER; + FPDF_FILEHANDLER = record + // User-defined data. + // Note: Callers can use this field to track controls. + clientData: Pointer; + + // Callback function to release the current file stream object. + // + // Parameters: + // clientData - Pointer to user-defined data. + // Returns: + // None. + Release: procedure(clientData: Pointer); cdecl; + + // Callback function to retrieve the current file stream size. + // + // Parameters: + // clientData - Pointer to user-defined data. + // Returns: + // Size of file stream. + GetSize: function(clientData: Pointer): FPDF_DWORD; cdecl; + + // Callback function to read data from the current file stream. + // + // Parameters: + // clientData - Pointer to user-defined data. + // offset - Offset position starts from the beginning of file + // stream. This parameter indicates reading position. + // buffer - Memory buffer to store data which are read from + // file stream. This parameter should not be NULL. + // size - Size of data which should be read from file stream, + // in bytes. The buffer indicated by |buffer| must be + // large enough to store specified data. + // Returns: + // 0 for success, other value for failure. + ReadBlock: function(clientData: Pointer; offset: FPDF_DWORD; buffer: Pointer; size: FPDF_DWORD): FPDF_RESULT; cdecl; + + // Callback function to write data into the current file stream. + // + // Parameters: + // clientData - Pointer to user-defined data. + // offset - Offset position starts from the beginning of file + // stream. This parameter indicates writing position. + // buffer - Memory buffer contains data which is written into + // file stream. This parameter should not be NULL. + // size - Size of data which should be written into file + // stream, in bytes. + // Returns: + // 0 for success, other value for failure. + WriteBlock: function(clientData: Pointer; offset: FPDF_DWORD; const buffer: Pointer; size: FPDF_DWORD): FPDF_RESULT; cdecl; + + // Callback function to flush all internal accessing buffers. + // + // Parameters: + // clientData - Pointer to user-defined data. + // Returns: + // 0 for success, other value for failure. + Flush: function(clientData: Pointer): FPDF_RESULT; cdecl; + + // Callback function to change file size. + // + // Description: + // This function is called under writing mode usually. Implementer + // can determine whether to realize it based on application requests. + // Parameters: + // clientData - Pointer to user-defined data. + // size - New size of file stream, in bytes. + // Returns: + // 0 for success, other value for failure. + Truncate: function(clientData: Pointer; size: FPDF_DWORD): FPDF_RESULT; cdecl; + end; + PFPdfFileHandler = ^TFPdfFileHandler; + TFPdfFileHandler = FPDF_FILEHANDLER; + +// Function: FPDF_LoadCustomDocument +// Load PDF document from a custom access descriptor. +// Parameters: +// pFileAccess - A structure for accessing the file. +// password - Optional password for decrypting the PDF file. +// Return value: +// A handle to the loaded document, or NULL on failure. +// Comments: +// The application must keep the file resources |pFileAccess| points to +// valid until the returned FPDF_DOCUMENT is closed. |pFileAccess| +// itself does not need to outlive the FPDF_DOCUMENT. +// +// The loaded document can be closed with FPDF_CloseDocument(). +// +// See the comments for FPDF_LoadDocument() regarding the encoding for +// |password|. +// Notes: +// If PDFium is built with the XFA module, the application should call +// FPDF_LoadXFA() function after the PDF document loaded to support XFA +// fields defined in the fpdfformfill.h file. +var + FPDF_LoadCustomDocument: function(pFileAccess: PFPDF_FILEACCESS; password: FPDF_BYTESTRING): FPDF_DOCUMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetFileVersion +// Get the file version of the given PDF document. +// Parameters: +// doc - Handle to a document. +// fileVersion - The PDF file version. File version: 14 for 1.4, 15 for 1.5, ... +// Return value: +// True if succeeds, false otherwise. +// Comments: +// If the document was created by FPDF_CreateNewDocument, +// then this function will always fail. +var + FPDF_GetFileVersion: function(doc: FPDF_DOCUMENT; var fileVersion: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +const + FPDF_ERR_SUCCESS = 0; // No error. + FPDF_ERR_UNKNOWN = 1; // Unknown error. + FPDF_ERR_FILE = 2; // File not found or could not be opened. + FPDF_ERR_FORMAT = 3; // File not in PDF format or corrupted. + FPDF_ERR_PASSWORD = 4; // Password required or incorrect password. + FPDF_ERR_SECURITY = 5; // Unsupported security scheme. + FPDF_ERR_PAGE = 6; // Page not found or content error. +{$IFDEF PDF_ENABLE_XFA} + FPDF_ERR_XFALOAD = 7; // Load XFA error. + FPDF_ERR_XFALAYOUT = 8; // Layout XFA error. +{$ENDIF PDF_ENABLE_XFA} + +// Function: FPDF_GetLastError +// Get last error code when a function fails. +// Parameters: +// None. +// Return value: +// A 32-bit integer indicating error code as defined above. +// Comments: +// If the previous SDK call succeeded, the return value of this +// function is not defined. This function only works in conjunction +// with APIs that mention FPDF_GetLastError() in their documentation. +var + FPDF_GetLastError: function(): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_DocumentHasValidCrossReferenceTable +// Whether the document's cross reference table is valid or not. +// Parameters: +// document - Handle to a document. Returned by FPDF_LoadDocument. +// Return value: +// True if the PDF parser did not encounter problems parsing the cross +// reference table. False if the parser could not parse the cross +// reference table and the table had to be rebuild from other data +// within the document. +// Comments: +// The return value can change over time as the PDF parser evolves. +var + FPDF_DocumentHasValidCrossReferenceTable: function(document: FPDF_DOCUMENT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_GetTrailerEnds +// Get the byte offsets of trailer ends. +// Parameters: +// document - Handle to document. Returned by FPDF_LoadDocument(). +// buffer - The address of a buffer that receives the +// byte offsets. +// length - The size, in ints, of |buffer|. +// Return value: +// Returns the number of ints in the buffer on success, 0 on error. +// +// |buffer| is an array of integers that describes the exact byte offsets of the +// trailer ends in the document. If |length| is less than the returned length, +// or |document| or |buffer| is NULL, |buffer| will not be modified. +var + FPDF_GetTrailerEnds: function(document: FPDF_DOCUMENT; buffer: PUINT; length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetDocPermissions +// Get file permission flags of the document. +// Parameters: +// document - Handle to a document. Returned by FPDF_LoadDocument. +// Return value: +// A 32-bit integer indicating permission flags. Please refer to the +// PDF Reference for detailed descriptions. If the document is not +// protected or was unlocked by the owner, 0xffffffff will be returned. +var + FPDF_GetDocPermissions: function(document: FPDF_DOCUMENT): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetDocUserPermissions +// Get user file permission flags of the document. +// Parameters: +// document - Handle to a document. Returned by FPDF_LoadDocument. +// Return value: +// A 32-bit integer indicating permission flags. Please refer to the +// PDF Reference for detailed descriptions. If the document is not +// protected, 0xffffffff will be returned. Always returns user +// permissions, even if the document was unlocked by the owner. +var + FPDF_GetDocUserPermissions: function(document: FPDF_DOCUMENT): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetSecurityHandlerRevision +// Get the revision for the security handler. +// Parameters: +// document - Handle to a document. Returned by FPDF_LoadDocument. +// Return value: +// The security handler revision number. Please refer to the PDF +// Reference for a detailed description. If the document is not +// protected, -1 will be returned. +var + FPDF_GetSecurityHandlerRevision: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetPageCount +// Get total number of pages in the document. +// Parameters: +// document - Handle to document. Returned by FPDF_LoadDocument. +// Return value: +// Total number of pages in the document. +var + FPDF_GetPageCount: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_LoadPage +// Load a page inside the document. +// Parameters: +// document - Handle to document. Returned by FPDF_LoadDocument +// page_index - Index number of the page. 0 for the first page. +// Return value: +// A handle to the loaded page, or NULL if page load fails. +// Comments: +// The loaded page can be rendered to devices using FPDF_RenderPage. +// The loaded page can be closed using FPDF_ClosePage. +var + FPDF_LoadPage: function(document: FPDF_DOCUMENT; page_index: Integer): FPDF_PAGE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API +// Function: FPDF_GetPageWidthF +// Get page width. +// Parameters: +// page - Handle to the page. Returned by FPDF_LoadPage(). +// Return value: +// Page width (excluding non-displayable area) measured in points. +// One point is 1/72 inch (around 0.3528 mm). +var + FPDF_GetPageWidthF: function(page: FPDF_PAGE): Single; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// Function: FPDF_GetPageWidth +// Get page width. +// Parameters: +// page - Handle to the page. Returned by FPDF_LoadPage. +// Return value: +// Page width (excluding non-displayable area) measured in points. +// One point is 1/72 inch (around 0.3528 mm). +// Note: +// Prefer FPDF_GetPageWidthF() above. This will be deprecated in the +// future. +var + FPDF_GetPageWidth: function(page: FPDF_PAGE): Double; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API +// Function: FPDF_GetPageHeightF +// Get page height. +// Parameters: +// page - Handle to the page. Returned by FPDF_LoadPage(). +// Return value: +// Page height (excluding non-displayable area) measured in points. +// One point is 1/72 inch (around 0.3528 mm) +var + FPDF_GetPageHeightF: function(page: FPDF_PAGE): Single; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetPageHeight +// Get page height. +// Parameters: +// page - Handle to the page. Returned by FPDF_LoadPage. +// Return value: +// Page height (excluding non-displayable area) measured in points. +// One point is 1/72 inch (around 0.3528 mm) +// Note: +// Prefer FPDF_GetPageHeightF() above. This will be deprecated in the +// future. +var + FPDF_GetPageHeight: function(page: FPDF_PAGE): Double; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_GetPageBoundingBox +// Get the bounding box of the page. This is the intersection between +// its media box and its crop box. +// Parameters: +// page - Handle to the page. Returned by FPDF_LoadPage. +// rect - Pointer to a rect to receive the page bounding box. +// On an error, |rect| won't be filled. +// Return value: +// True for success. +var + FPDF_GetPageBoundingBox: function(page: FPDF_PAGE; rect: PFS_RECTF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_GetPageSizeByIndexF +// Get the size of the page at the given index. +// Parameters: +// document - Handle to document. Returned by FPDF_LoadDocument(). +// page_index - Page index, zero for the first page. +// size - Pointer to a FS_SIZEF to receive the page size. +// (in points). +// Return value: +// Non-zero for success. 0 for error (document or page not found). +var + FPDF_GetPageSizeByIndexF: function(document: FPDF_DOCUMENT; page_index: Integer; size: PFS_SIZEF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetPageSizeByIndex +// Get the size of the page at the given index. +// Parameters: +// document - Handle to document. Returned by FPDF_LoadDocument. +// page_index - Page index, zero for the first page. +// width - Pointer to a double to receive the page width +// (in points). +// height - Pointer to a double to receive the page height +// (in points). +// Return value: +// Non-zero for success. 0 for error (document or page not found). +// Note: +// Prefer FPDF_GetPageSizeByIndexF() above. This will be deprecated in +// the future. +var + FPDF_GetPageSizeByIndex: function(document: FPDF_DOCUMENT; page_index: Integer; var width, height: Double): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Page rendering flags. They can be combined with bit-wise OR. +const + FPDF_ANNOT = $01; // Set if annotations are to be rendered. + FPDF_LCD_TEXT = $02; // Set if using text rendering optimized for LCD display. This flag will only take effect if anti-aliasing is enabled for text. + FPDF_NO_NATIVETEXT = $04; // Don't use the native text output available on some platforms + FPDF_GRAYSCALE = $08 deprecated; // Obsolete, has no effect, retained for compatibility. + FPDF_DEBUG_INFO = $80 deprecated; // Obsolete, has no effect, retained for compatibility. + FPDF_NO_CATCH = $100; // Set if you don't want to catch exceptions. + FPDF_RENDER_LIMITEDIMAGECACHE = $200; // Limit image cache size. + FPDF_RENDER_FORCEHALFTONE = $400; // Always use halftone for image stretching. + FPDF_PRINTING = $800; // Render for printing. + FPDF_RENDER_NO_SMOOTHTEXT = $1000; // Set to disable anti-aliasing on text. This flag will also disable LCD optimization for text rendering. + FPDF_RENDER_NO_SMOOTHIMAGE = $2000; // Set to disable anti-aliasing on images. + FPDF_RENDER_NO_SMOOTHPATH = $4000; // Set to disable anti-aliasing on paths. + // Set whether to render in a reverse Byte order, this flag is only used when + // rendering to a bitmap. + FPDF_REVERSE_BYTE_ORDER = $10; + // Set whether fill paths need to be stroked. This flag is only used when + // FPDF_COLORSCHEME is passed in, since with a single fill color for paths the + // boundaries of adjacent fill paths are less visible. + FPDF_CONVERT_FILL_TO_STROKE = $20; + +type + // Struct for color scheme. + // Each should be a 32-bit value specifying the color, in 8888 ARGB format. + + PFPDF_COLORSCHEME = ^FPDF_COLORSCHEME; + FPDF_COLORSCHEME = record + path_fill_color: FPDF_DWORD; + path_stroke_color: FPDF_DWORD; + text_fill_color: FPDF_DWORD; + text_stroke_color: FPDF_DWORD; + end; + PFPdfColorScheme = ^TFPdfColorScheme; + TFPdfColorScheme = FPDF_COLORSCHEME; + +{$IFDEF MSWINDOWS} +// Function: FPDF_RenderPage +// Render contents of a page to a device (screen, bitmap, or printer). +// This function is only supported on Windows. +// Parameters: +// dc - Handle to the device context. +// page - Handle to the page. Returned by FPDF_LoadPage. +// start_x - Left pixel position of the display area in +// device coordinates. +// start_y - Top pixel position of the display area in device +// coordinates. +// size_x - Horizontal size (in pixels) for displaying the page. +// size_y - Vertical size (in pixels) for displaying the page. +// rotate - Page orientation: +// 0 (normal) +// 1 (rotated 90 degrees clockwise) +// 2 (rotated 180 degrees) +// 3 (rotated 90 degrees counter-clockwise) +// flags - 0 for normal display, or combination of flags +// defined above. +// Return value: +// None. +var + FPDF_RenderPage: procedure(DC: HDC; page: FPDF_PAGE; start_x, start_y, size_x, size_y: Integer; + rotate: Integer; flags: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +{$ENDIF MSWINDOWS} + +// Function: FPDF_RenderPageBitmap +// Render contents of a page to a device independent bitmap. +// Parameters: +// bitmap - Handle to the device independent bitmap (as the +// output buffer). The bitmap handle can be created +// by FPDFBitmap_Create or retrieved from an image +// object by FPDFImageObj_GetBitmap. +// page - Handle to the page. Returned by FPDF_LoadPage +// start_x - Left pixel position of the display area in +// bitmap coordinates. +// start_y - Top pixel position of the display area in bitmap +// coordinates. +// size_x - Horizontal size (in pixels) for displaying the page. +// size_y - Vertical size (in pixels) for displaying the page. +// rotate - Page orientation: +// 0 (normal) +// 1 (rotated 90 degrees clockwise) +// 2 (rotated 180 degrees) +// 3 (rotated 90 degrees counter-clockwise) +// flags - 0 for normal display, or combination of the Page +// Rendering flags defined above. With the FPDF_ANNOT +// flag, it renders all annotations that do not require +// user-interaction, which are all annotations except +// widget and popup annotations. +// Return value: +// None. +var + FPDF_RenderPageBitmap: procedure(bitmap: FPDF_BITMAP; page: FPDF_PAGE; start_x, start_y, size_x, size_y: Integer; + rotate: Integer; flags: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_RenderPageBitmapWithMatrix +// Render contents of a page to a device independent bitmap. +// Parameters: +// bitmap - Handle to the device independent bitmap (as the +// output buffer). The bitmap handle can be created +// by FPDFBitmap_Create or retrieved by +// FPDFImageObj_GetBitmap. +// page - Handle to the page. Returned by FPDF_LoadPage. +// matrix - The transform matrix, which must be invertible. +// See PDF Reference 1.7, 4.2.2 Common Transformations. +// clipping - The rect to clip to in device coords. +// flags - 0 for normal display, or combination of the Page +// Rendering flags defined above. With the FPDF_ANNOT +// flag, it renders all annotations that do not require +// user-interaction, which are all annotations except +// widget and popup annotations. +// Return value: +// None. Note that behavior is undefined if det of |matrix| is 0. +var + FPDF_RenderPageBitmapWithMatrix: procedure(bitmap: FPDF_BITMAP; page: FPDF_PAGE; matrix: PFS_MATRIX; + clipping: PFS_RECTF; flags: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +{$IFDEF PDF_USE_SKIA} +// Function: FPDF_RenderPageSkia +// Render contents of a page to a Skia SkCanvas. +// Parameters: +// canvas - SkCanvas to render to. +// page - Handle to the page. +// size_x - Horizontal size (in pixels) for displaying the page. +// size_y - Vertical size (in pixels) for displaying the page. +// Return value: +// None. +var + FPDF_RenderPageSkia: procedure(canvas: FPDF_SKIA_CANVAS; page: FPDF_PAGE; size_x, size_y: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +{$ENDIF PDF_USE_SKIA} + +// Function: FPDF_ClosePage +// Close a loaded PDF page. +// Parameters: +// page - Handle to the loaded page. +// Return value: +// None. +var + FPDF_ClosePage: procedure(page: FPDF_PAGE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_CloseDocument +// Close a loaded PDF document. +// Parameters: +// document - Handle to the loaded document. +// Return value: +// None. +var + FPDF_CloseDocument: procedure(document: FPDF_DOCUMENT); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_DeviceToPage +// Convert the screen coordinates of a point to page coordinates. +// Parameters: +// page - Handle to the page. Returned by FPDF_LoadPage. +// start_x - Left pixel position of the display area in +// device coordinates. +// start_y - Top pixel position of the display area in device +// coordinates. +// size_x - Horizontal size (in pixels) for displaying the page. +// size_y - Vertical size (in pixels) for displaying the page. +// rotate - Page orientation: +// 0 (normal) +// 1 (rotated 90 degrees clockwise) +// 2 (rotated 180 degrees) +// 3 (rotated 90 degrees counter-clockwise) +// device_x - X value in device coordinates to be converted. +// device_y - Y value in device coordinates to be converted. +// page_x - A pointer to a double receiving the converted X +// value in page coordinates. +// page_y - A pointer to a double receiving the converted Y +// value in page coordinates. +// Return value: +// Returns true if the conversion succeeds, and |page_x| and |page_y| +// successfully receives the converted coordinates. +// Comments: +// The page coordinate system has its origin at the left-bottom corner +// of the page, with the X-axis on the bottom going to the right, and +// the Y-axis on the left side going up. +// +// NOTE: this coordinate system can be altered when you zoom, scroll, +// or rotate a page, however, a point on the page should always have +// the same coordinate values in the page coordinate system. +// +// The device coordinate system is device dependent. For screen device, +// its origin is at the left-top corner of the window. However this +// origin can be altered by the Windows coordinate transformation +// utilities. +// +// You must make sure the start_x, start_y, size_x, size_y +// and rotate parameters have exactly same values as you used in +// the FPDF_RenderPage() function call. +var + FPDF_DeviceToPage: procedure(page: FPDF_PAGE; start_x, start_y, size_x, size_y: Integer; + rotate: Integer; device_x, device_y: Integer; var page_x, page_y: Double); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_PageToDevice +// Convert the page coordinates of a point to screen coordinates. +// Parameters: +// page - Handle to the page. Returned by FPDF_LoadPage. +// start_x - Left pixel position of the display area in +// device coordinates. +// start_y - Top pixel position of the display area in device +// coordinates. +// size_x - Horizontal size (in pixels) for displaying the page. +// size_y - Vertical size (in pixels) for displaying the page. +// rotate - Page orientation: +// 0 (normal) +// 1 (rotated 90 degrees clockwise) +// 2 (rotated 180 degrees) +// 3 (rotated 90 degrees counter-clockwise) +// page_x - X value in page coordinates. +// page_y - Y value in page coordinate. +// device_x - A pointer to an integer receiving the result X +// value in device coordinates. +// device_y - A pointer to an integer receiving the result Y +// value in device coordinates. +// Return value: +// Returns true if the conversion succeeds, and |device_x| and +// |device_y| successfully receives the converted coordinates. +// Comments: +// See comments for FPDF_DeviceToPage(). +var + FPDF_PageToDevice: procedure(page: FPDF_PAGE; start_x, start_y, size_x, size_y: Integer; + rotate: Integer; page_x, page_y: Double; var device_x, device_y: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFBitmap_Create +// Create a device independent bitmap (FXDIB). +// Parameters: +// width - The number of pixels in width for the bitmap. +// Must be greater than 0. +// height - The number of pixels in height for the bitmap. +// Must be greater than 0. +// alpha - A flag indicating whether the alpha channel is used. +// Non-zero for using alpha, zero for not using. +// Return value: +// The created bitmap handle, or NULL if a parameter error or out of +// memory. +// Comments: +// The bitmap always uses 4 bytes per pixel. The first byte is always +// double word aligned. +// +// The byte order is BGRx (the last byte unused if no alpha channel) or +// BGRA. +// +// The pixels in a horizontal line are stored side by side, with the +// left most pixel stored first (with lower memory address). +// Each line uses width * 4 bytes. +// +// Lines are stored one after another, with the top most line stored +// first. There is no gap between adjacent lines. +// +// This function allocates enough memory for holding all pixels in the +// bitmap, but it doesn't initialize the buffer. Applications can use +// FPDFBitmap_FillRect() to fill the bitmap using any color. If the OS +// allows it, this function can allocate up to 4 GB of memory. + FPDFBitmap_Create: function(width, height: Integer; alpha: Integer): FPDF_BITMAP; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +const + // More DIB formats + FPDFBitmap_Unknown = 0; // Unknown or unsupported format. + FPDFBitmap_Gray = 1; // Gray scale bitmap, one byte per pixel. + FPDFBitmap_BGR = 2; // 3 bytes per pixel, byte order: blue, green, red. + FPDFBitmap_BGRx = 3; // 4 bytes per pixel, byte order: blue, green, red, unused. + FPDFBitmap_BGRA = 4; // 4 bytes per pixel, byte order: blue, green, red, alpha. + +// Function: FPDFBitmap_CreateEx +// Create a device independent bitmap (FXDIB) +// Parameters: +// width - The number of pixels in width for the bitmap. +// Must be greater than 0. +// height - The number of pixels in height for the bitmap. +// Must be greater than 0. +// format - A number indicating for bitmap format, as defined +// above. +// first_scan - A pointer to the first byte of the first line if +// using an external buffer. If this parameter is NULL, +// then the a new buffer will be created. +// then a new buffer will be created. +// stride - Number of bytes for each scan line. The value must +// be 0 or greater. When the value is 0, +// FPDFBitmap_CreateEx() will automatically calculate +// the appropriate value using |width| and |format|. +// When using an external buffer, it is recommended for +// the caller to pass in the value. +// When not using an external buffer, it is recommended +// for the caller to pass in 0. +// Return value: +// The bitmap handle, or NULL if parameter error or out of memory. +// Comments: +// Similar to FPDFBitmap_Create function, but allows for more formats +// and an external buffer is supported. The bitmap created by this +// function can be used in any place that a FPDF_BITMAP handle is +// required. +// +// If an external buffer is used, then the caller should destroy the +// buffer. FPDFBitmap_Destroy() will not destroy the buffer. +// +// It is recommended to use FPDFBitmap_GetStride() to get the stride +// value. +var + FPDFBitmap_CreateEx: function(width, height: Integer; format: Integer; first_scan: Pointer; + stride: Integer): FPDF_BITMAP; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFBitmap_GetFormat +// Get the format of the bitmap. +// Parameters: +// bitmap - Handle to the bitmap. Returned by FPDFBitmap_Create +// or FPDFImageObj_GetBitmap. +// Return value: +// The format of the bitmap. +// Comments: +// Only formats supported by FPDFBitmap_CreateEx are supported by this +// function; see the list of such formats above. +var + FPDFBitmap_GetFormat: function(bitmap: FPDF_BITMAP): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFBitmap_FillRect +// Fill a rectangle in a bitmap. +// Parameters: +// bitmap - The handle to the bitmap. Returned by +// FPDFBitmap_Create. +// left - The left position. Starting from 0 at the +// left-most pixel. +// top - The top position. Starting from 0 at the +// top-most line. +// width - Width in pixels to be filled. +// height - Height in pixels to be filled. +// color - A 32-bit value specifing the color, in 8888 ARGB +// format. +// Return value: +// None. +// Comments: +// This function sets the color and (optionally) alpha value in the +// specified region of the bitmap. +// +// NOTE: If the alpha channel is used, this function does NOT +// composite the background with the source color, instead the +// background will be replaced by the source color and the alpha. +// +// If the alpha channel is not used, the alpha parameter is ignored. +var + FPDFBitmap_FillRect: procedure(bitmap: FPDF_BITMAP; left, top, width, height: Integer; color: FPDF_DWORD); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFBitmap_GetBuffer +// Get data buffer of a bitmap. +// Parameters: +// bitmap - Handle to the bitmap. Returned by FPDFBitmap_Create +// or FPDFImageObj_GetBitmap. +// Return value: +// The pointer to the first byte of the bitmap buffer. +// Comments: +// The stride may be more than width * number of bytes per pixel +// +// Applications can use this function to get the bitmap buffer pointer, +// then manipulate any color and/or alpha values for any pixels in the +// bitmap. +// +// Use FPDFBitmap_GetFormat() to find out the format of the data. +var + FPDFBitmap_GetBuffer: function(bitmap: FPDF_BITMAP): Pointer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFBitmap_GetWidth +// Get width of a bitmap. +// Parameters: +// bitmap - Handle to the bitmap. Returned by FPDFBitmap_Create +// or FPDFImageObj_GetBitmap. +// Return value: +// The width of the bitmap in pixels. +var + FPDFBitmap_GetWidth: function(bitmap: FPDF_BITMAP): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFBitmap_GetHeight +// Get height of a bitmap. +// Parameters: +// bitmap - Handle to the bitmap. Returned by FPDFBitmap_Create +// or FPDFImageObj_GetBitmap. +// Return value: +// The height of the bitmap in pixels. +var + FPDFBitmap_GetHeight: function(bitmap: FPDF_BITMAP): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFBitmap_GetStride +// Get number of bytes for each line in the bitmap buffer. +// Parameters: +// bitmap - Handle to the bitmap. Returned by FPDFBitmap_Create +// or FPDFImageObj_GetBitmap. +// Return value: +// The number of bytes for each line in the bitmap buffer. +// Comments: +// The stride may be more than width * number of bytes per pixel. +var + FPDFBitmap_GetStride: function(bitmap: FPDF_BITMAP): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFBitmap_Destroy +// Destroy a bitmap and release all related buffers. +// Parameters: +// bitmap - Handle to the bitmap. Returned by FPDFBitmap_Create +// or FPDFImageObj_GetBitmap. +// Return value: +// None. +// Comments: +// This function will not destroy any external buffers provided when +// the bitmap was created. +var + FPDFBitmap_Destroy: procedure(bitmap: FPDF_BITMAP); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_VIEWERREF_GetPrintScaling +// Whether the PDF document prefers to be scaled or not. +// Parameters: +// document - Handle to the loaded document. +// Return value: +// None. +var + FPDF_VIEWERREF_GetPrintScaling: function(document: FPDF_DOCUMENT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_VIEWERREF_GetNumCopies +// Returns the number of copies to be printed. +// Parameters: +// document - Handle to the loaded document. +// Return value: +// The number of copies to be printed. +var + FPDF_VIEWERREF_GetNumCopies: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_VIEWERREF_GetPrintPageRange +// Page numbers to initialize print dialog box when file is printed. +// Parameters: +// document - Handle to the loaded document. +// Return value: +// The print page range to be used for printing. +var + FPDF_VIEWERREF_GetPrintPageRange: function(document: FPDF_DOCUMENT): FPDF_PAGERANGE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_VIEWERREF_GetPrintPageRangeCount +// Returns the number of elements in a FPDF_PAGERANGE. +// Parameters: +// pagerange - Handle to the page range. +// Return value: +// The number of elements in the page range. Returns 0 on error. +var + FPDF_VIEWERREF_GetPrintPageRangeCount: function(pagerange: FPDF_PAGERANGE): SIZE_T; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_VIEWERREF_GetPrintPageRangeElement +// Returns an element from a FPDF_PAGERANGE. +// Parameters: +// pagerange - Handle to the page range. +// index - Index of the element. +// Return value: +// The value of the element in the page range at a given index. +// Returns -1 on error. +var + FPDF_VIEWERREF_GetPrintPageRangeElement: function(pagerange: FPDF_PAGERANGE; index: SIZE_T): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_VIEWERREF_GetDuplex +// Returns the paper handling option to be used when printing from +// the print dialog. +// Parameters: +// document - Handle to the loaded document. +// Return value: +// The paper handling option to be used when printing. +var + FPDF_VIEWERREF_GetDuplex: function(document: FPDF_DOCUMENT): FPDF_DUPLEXTYPE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_VIEWERREF_GetName +// Gets the contents for a viewer ref, with a given key. The value must +// be of type "name". +// Parameters: +// document - Handle to the loaded document. +// key - Name of the key in the viewer pref dictionary, +// encoded in UTF-8. +// buffer - Caller-allocate buffer to receive the key, or NULL +// - to query the required length. +// length - Length of the buffer. +// Return value: +// The number of bytes in the contents, including the NULL terminator. +// Thus if the return value is 0, then that indicates an error, such +// as when |document| is invalid or |buffer| is NULL. If |length| is +// as when |document| is invalid. If |length| is less than the required +// length, or |buffer| is NULL, |buffer| will not be modified. +var + FPDF_VIEWERREF_GetName: function(document: FPDF_DOCUMENT; key: FPDF_BYTESTRING; buffer: PAnsiChar; + length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_CountNamedDests +// Get the count of named destinations in the PDF document. +// Parameters: +// document - Handle to a document +// Return value: +// The count of named destinations. +var + FPDF_CountNamedDests: function(document: FPDF_DOCUMENT): FPDF_DWORD; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetNamedDestByName +// Get a the destination handle for the given name. +// Parameters: +// document - Handle to the loaded document. +// name - The name of a destination. +// Return value: +// The handle to the destination. +var + FPDF_GetNamedDestByName: function(document: FPDF_DOCUMENT; name: FPDF_BYTESTRING): FPDF_DEST; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetNamedDest +// Get the named destination by index. +// Parameters: +// document - Handle to a document +// index - The index of a named destination. +// buffer - The buffer to store the destination name, +// used as wchar_t*. +// buflen [in/out] - Size of the buffer in bytes on input, +// length of the result in bytes on output +// or -1 if the buffer is too small. +// Return value: +// The destination handle for a given index, or NULL if there is no +// named destination corresponding to |index|. +// Comments: +// Call this function twice to get the name of the named destination: +// 1) First time pass in |buffer| as NULL and get buflen. +// 2) Second time pass in allocated |buffer| and buflen to retrieve +// |buffer|, which should be used as wchar_t*. +// +// If buflen is not sufficiently large, it will be set to -1 upon +// return. +var + FPDF_GetNamedDest: function(document: FPDF_DOCUMENT; index: Integer; buffer: Pointer; var buflen: LongWord): FPDF_DEST; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_GetXFAPacketCount +// Get the number of valid packets in the XFA entry. +// Parameters: +// document - Handle to the document. +// Return value: +// The number of valid packets, or -1 on error. +var + FPDF_GetXFAPacketCount: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_GetXFAPacketName +// Get the name of a packet in the XFA array. +// Parameters: +// document - Handle to the document. +// index - Index number of the packet. 0 for the first packet. +// buffer - Buffer for holding the name of the XFA packet. +// buflen - Length of |buffer| in bytes. +// Return value: +// The length of the packet name in bytes, or 0 on error. +// +// |document| must be valid and |index| must be in the range [0, N), where N is +// the value returned by FPDF_GetXFAPacketCount(). +// |buffer| is only modified if it is non-NULL and |buflen| is greater than or +// equal to the length of the packet name. The packet name includes a +// terminating NUL character. |buffer| is unmodified on error. +var + FPDF_GetXFAPacketName: function(document: FPDF_DOCUMENT; index: Integer; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_GetXFAPacketContent +// Get the content of a packet in the XFA array. +// Parameters: +// document - Handle to the document. +// index - Index number of the packet. 0 for the first packet. +// buffer - Buffer for holding the content of the XFA packet. +// buflen - Length of |buffer| in bytes. +// out_buflen - Pointer to the variable that will receive the minimum +// buffer size needed to contain the content of the XFA +// packet. +// Return value: +// Whether the operation succeeded or not. +// +// |document| must be valid and |index| must be in the range [0, N), where N is +// the value returned by FPDF_GetXFAPacketCount(). |out_buflen| must not be +// NULL. When the aforementioned arguments are valid, the operation succeeds, +// and |out_buflen| receives the content size. |buffer| is only modified if +// |buffer| is non-null and long enough to contain the content. Callers must +// check both the return value and the input |buflen| is no less than the +// returned |out_buflen| before using the data in |buffer|. +var + FPDF_GetXFAPacketContent: function(document: FPDF_DOCUMENT; index: Integer; buffer: Pointer; + buflen: LongWord; var out_buflen: LongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +{$IFDEF PDF_ENABLE_V8} +// Function: FPDF_GetRecommendedV8Flags +// Returns a space-separated string of command line flags that are +// recommended to be passed into V8 via V8::SetFlagsFromString() +// prior to initializing the PDFium library. +// Parameters: +// None. +// Return value: +// NUL-terminated string of the form "--flag1 --flag2". +// The caller must not attempt to modify or free the result. +var + FPDF_GetRecommendedV8Flags: function: PAnsiChar; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_GetArrayBufferAllocatorSharedInstance() +// Helper function for initializing V8 isolates that will +// use PDFium's internal memory management. +// Parameters: +// None. +// Return Value: +// Pointer to a suitable v8::ArrayBuffer::Allocator, returned +// as void for C compatibility. +// Notes: +// Use is optional, but allows external creation of isolates +// matching the ones PDFium will make when none is provided +// via |FPDF_LIBRARY_CONFIG::m_pIsolate|. +// +// Can only be called when the library is in an uninitialized or +// destroyed state. +var + FPDF_GetArrayBufferAllocatorSharedInstance: function: Pointer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +{$ENDIF PDF_ENABLE_V8} + +{$IFDEF PDF_ENABLE_XFA} +// Function: FPDF_BStr_Init +// Helper function to initialize a FPDF_BSTR. +var + FPDF_BStr_Init: function(bstr: PFPDF_BSTR): FPDF_RESULT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_BStr_Set +// Helper function to copy string data into the FPDF_BSTR. +var + FPDF_BStr_Set: function(vstr: PFPDF_BSTR; const cstr: PAnsiChar; length: Integer): FPDF_RESULT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_BStr_Clear +// Helper function to clear a FPDF_BSTR. +var + FPDF_BStr_Clear: function(bstr: PFPDF_BSTR): FPDF_RESULT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +{$ENDIF PDF_ENABLE_XFA} + + +// *** _FPDFEDIT_H_ *** + +function FPDF_ARGB(a, r, g, b: Byte): DWORD; inline; +function FPDF_GetBValue(argb: DWORD): Byte; inline; +function FPDF_GetGValue(argb: DWORD): Byte; inline; +function FPDF_GetRValue(argb: DWORD): Byte; inline; +function FPDF_GetAValue(argb: DWORD): Byte; inline; + + +const + // Refer to PDF Reference version 1.7 table 4.12 for all color space families. + FPDF_COLORSPACE_UNKNOWN = 0; + FPDF_COLORSPACE_DEVICEGRAY = 1; + FPDF_COLORSPACE_DEVICERGB = 2; + FPDF_COLORSPACE_DEVICECMYK = 3; + FPDF_COLORSPACE_CALGRAY = 4; + FPDF_COLORSPACE_CALRGB = 5; + FPDF_COLORSPACE_LAB = 6; + FPDF_COLORSPACE_ICCBASED = 7; + FPDF_COLORSPACE_SEPARATION = 8; + FPDF_COLORSPACE_DEVICEN = 9; + FPDF_COLORSPACE_INDEXED = 10; + FPDF_COLORSPACE_PATTERN = 11; + + // The page object constants. + FPDF_PAGEOBJ_UNKNOWN = 0; + FPDF_PAGEOBJ_TEXT = 1; + FPDF_PAGEOBJ_PATH = 2; + FPDF_PAGEOBJ_IMAGE = 3; + FPDF_PAGEOBJ_SHADING = 4; + FPDF_PAGEOBJ_FORM = 5; + + // The path segment constants. + FPDF_SEGMENT_UNKNOWN = -1; + FPDF_SEGMENT_LINETO = 0; + FPDF_SEGMENT_BEZIERTO = 1; + FPDF_SEGMENT_MOVETO = 2; + + FPDF_FILLMODE_NONE = 0; + FPDF_FILLMODE_ALTERNATE = 1; + FPDF_FILLMODE_WINDING = 2; + + FPDF_FONT_TYPE1 = 1; + FPDF_FONT_TRUETYPE = 2; + + FPDF_LINECAP_BUTT = 0; + FPDF_LINECAP_ROUND = 1; + FPDF_LINECAP_PROJECTING_SQUARE = 2; + + FPDF_LINEJOIN_MITER = 0; + FPDF_LINEJOIN_ROUND = 1; + FPDF_LINEJOIN_BEVEL = 2; + + // See FPDF_SetPrintMode() for descriptions. + FPDF_PRINTMODE_EMF = 0; + FPDF_PRINTMODE_TEXTONLY = 1; + FPDF_PRINTMODE_POSTSCRIPT2 = 2; + FPDF_PRINTMODE_POSTSCRIPT3 = 3; + FPDF_PRINTMODE_POSTSCRIPT2_PASSTHROUGH = 4; + FPDF_PRINTMODE_POSTSCRIPT3_PASSTHROUGH = 5; + FPDF_PRINTMODE_EMF_IMAGE_MASKS = 6; + FPDF_PRINTMODE_POSTSCRIPT3_TYPE42 = 7; + FPDF_PRINTMODE_POSTSCRIPT3_TYPE42_PASSTHROUGH= 8; + +type + PFPDF_IMAGEOBJ_METADATA = ^FPDF_IMAGEOBJ_METADATA; + FPDF_IMAGEOBJ_METADATA = record + // The image width in pixels. + width: Cardinal; + // The image height in pixels. + height: Cardinal; + // The image's horizontal pixel-per-inch. + horizontal_dpi: Single; + // The image's vertical pixel-per-inch. + vertical_dpi: Single; + // The number of bits used to represent each pixel. + bits_per_pixel: Cardinal; + // The image's colorspace. See above for the list of FPDF_COLORSPACE_*. + colorspace: Integer; + // The image's marked content ID. Useful for pairing with associated alt-text. + // A value of -1 indicates no ID. + marked_content_id: Integer; + end; + PFPdfImageObjMetaData = ^TFPdfImageObjMetaData; + TFPdfImageObjMetaData = FPDF_IMAGEOBJ_METADATA; + +// Create a new PDF document. +// +// Returns a handle to a new document, or NULL on failure. +var + FPDF_CreateNewDocument: function: FPDF_DOCUMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Create a new PDF page. +// +// document - handle to document. +// page_index - suggested 0-based index of the page to create. If it is larger +// than document's current last index(L), the created page index +// is the next available index -- L+1. +// width - the page width in points. +// height - the page height in points. +// +// Returns the handle to the new page or NULL on failure. +// +// The page should be closed with FPDF_ClosePage() when finished as +// with any other page in the document. +var + FPDFPage_New: function(document: FPDF_DOCUMENT; page_index: Integer; width, height: Double): FPDF_PAGE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Delete the page at |page_index|. +// +// document - handle to document. +// page_index - the index of the page to delete. +var + FPDFPage_Delete: procedure(document: FPDF_DOCUMENT; page_index: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Move the given pages to a new index position. +// +// page_indices - the ordered list of pages to move. No duplicates allowed. +// page_indices_len - the number of elements in |page_indices| +// dest_page_index - the new index position to which the pages in +// |page_indices| are moved. +// +// Returns TRUE on success. If it returns FALSE, the document may be left in an +// indeterminate state. +// +// Example: The PDF document starts out with pages [A, B, C, D], with indices +// [0, 1, 2, 3]. +// +// > Move(doc, [3, 2], 2, 1); // returns true +// > // The document has pages [A, D, C, B]. +// > +// > Move(doc, [0, 4, 3], 3, 1); // returns false +// > // Returned false because index 4 is out of range. +// > +// > Move(doc, [0, 3, 1], 3, 2); // returns false +// > // Returned false because index 2 is out of range for 3 page indices. +// > +// > Move(doc, [2, 2], 2, 0); // returns false +// > // Returned false because [2, 2] contains duplicates. +// +var + FPDF_MovePages: function(document: FPDF_DOCUMENT; page_indices: PInteger; page_indices_len: LongWord; + dest_page_index: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the rotation of |page|. +// +// page - handle to a page +// +// Returns one of the following indicating the page rotation: +// 0 - No rotation. +// 1 - Rotated 90 degrees clockwise. +// 2 - Rotated 180 degrees clockwise. +// 3 - Rotated 270 degrees clockwise. +var + FPDFPage_GetRotation: function(page: FPDF_PAGE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set rotation for |page|. +// +// page - handle to a page. +// rotate - the rotation value, one of: +// 0 - No rotation. +// 1 - Rotated 90 degrees clockwise. +// 2 - Rotated 180 degrees clockwise. +// 3 - Rotated 270 degrees clockwise. +var + FPDFPage_SetRotation: procedure(page: FPDF_PAGE; rotate: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Insert |page_object| into |page|. +// +// page - handle to a page +// page_object - handle to a page object. The |page_object| will be +// automatically freed. +var + FPDFPage_InsertObject: procedure(page: FPDF_PAGE; page_object: FPDF_PAGEOBJECT); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Remove |page_object| from |page|. +// +// page - handle to a page +// page_object - handle to a page object to be removed. +// +// Returns TRUE on success. +// +// Ownership is transferred to the caller. Call FPDFPageObj_Destroy() to free +// it. +// Note that when removing a |page_object| of type FPDF_PAGEOBJ_TEXT, all +// FPDF_TEXTPAGE handles for |page| are no longer valid. +var + FPDFPage_RemoveObject: function(page: FPDF_PAGE; page_object: FPDF_PAGEOBJECT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get number of page objects inside |page|. +// +// page - handle to a page. +// +// Returns the number of objects in |page|. +var + FPDFPage_CountObjects: function(page: FPDF_PAGE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get object in |page| at |index|. +// +// page - handle to a page. +// index - the index of a page object. +// +// Returns the handle to the page object, or NULL on failed. +var + FPDFPage_GetObject: function(page: FPDF_PAGE; index: Integer): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Checks if |page| contains transparency. +// +// page - handle to a page. +// +// Returns TRUE if |page| contains transparency. +var + FPDFPage_HasTransparency: function(page: FPDF_PAGE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Generate the content of |page|. +// +// page - handle to a page. +// +// Returns TRUE on success. +// +// Before you save the page to a file, or reload the page, you must call +// |FPDFPage_GenerateContent| or any changes to |page| will be lost. +var + FPDFPage_GenerateContent: function(page: FPDF_PAGE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Destroy |page_object| by releasing its resources. |page_object| must have +// been created by FPDFPageObj_CreateNew{Path|Rect}() or +// FPDFPageObj_New{Text|Image}Obj(). This function must be called on +// newly-created objects if they are not added to a page through +// FPDFPage_InsertObject() or to an annotation through FPDFAnnot_AppendObject(). +// +// page_object - handle to a page object. +var + FPDFPageObj_Destroy: procedure(page_obj: FPDF_PAGEOBJECT); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Checks if |page_object| contains transparency. +// +// page_object - handle to a page object. +// +// Returns TRUE if |page_object| contains transparency. +var + FPDFPageObj_HasTransparency: function(page_object: FPDF_PAGEOBJECT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get type of |page_object|. +// +// page_object - handle to a page object. +// +// Returns one of the FPDF_PAGEOBJ_* values on success, FPDF_PAGEOBJ_UNKNOWN on +// error. +var + FPDFPageObj_GetType: function(page_object: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Transform |page_object| by the given matrix. +// +// page_object - handle to a page object. +// a - matrix value. +// b - matrix value. +// c - matrix value. +// d - matrix value. +// e - matrix value. +// f - matrix value. +// +// The matrix is composed as: +// |a c e| +// |b d f| +// and can be used to scale, rotate, shear and translate the |page_object|. +var + FPDFPageObj_Transform: procedure(page_object: FPDF_PAGEOBJECT; a, b, c, d, e, f: Double); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Transform |page_object| by the given matrix. +// +// page_object - handle to a page object. +// matrix - the transform matrix. +// +// Returns TRUE on success. +// +// This can be used to scale, rotate, shear and translate the |page_object|. +// It is an improved version of FPDFPageObj_Transform() that does not do +// unnecessary double to float conversions, and only uses 1 parameter for the +// matrix. It also returns whether the operation succeeded or not. +var + FPDFPageObj_TransformF: function(page_object: FPDF_PAGEOBJECT; matrix: PFS_MATRIX): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the transform matrix of a page object. +// +// page_object - handle to a page object. +// matrix - pointer to struct to receive the matrix value. +// +// The matrix is composed as: +// |a c e| +// |b d f| +// and used to scale, rotate, shear and translate the page object. +// +// For page objects outside form objects, the matrix values are relative to the +// page that contains it. +// For page objects inside form objects, the matrix values are relative to the +// form that contains it. +// +// Returns TRUE on success. +var + FPDFPageObj_GetMatrix: function(page_object: FPDF_PAGEOBJECT; matrix: PFS_MATRIX): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the transform matrix of a page object. +// +// page_object - handle to a page object. +// matrix - pointer to struct with the matrix value. +// +// The matrix is composed as: +// |a c e| +// |b d f| +// and can be used to scale, rotate, shear and translate the page object. +// +// Returns TRUE on success. +var + FPDFPageObj_SetMatrix: function(page_object: FPDF_PAGEOBJECT; const matrix: PFS_MATRIX): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Transform all annotations in |page|. +// +// page - handle to a page. +// a - matrix value. +// b - matrix value. +// c - matrix value. +// d - matrix value. +// e - matrix value. +// f - matrix value. +// +// The matrix is composed as: +// |a c e| +// |b d f| +// and can be used to scale, rotate, shear and translate the |page| annotations. +var + FPDFPage_TransformAnnots: procedure(page: FPDF_PAGE; a, b, c, d, e, f: Double); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Create a new image object. +// +// document - handle to a document. +// +// Returns a handle to a new image object. +var + FPDFPageObj_NewImageObj: function(document: FPDF_DOCUMENT): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the marked content ID for the object. +// +// page_object - handle to a page object. +// +// Returns the page object's marked content ID, or -1 on error. +var + FPDFPageObj_GetMarkedContentID: function(page_object: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get number of content marks in |page_object|. +// +// page_object - handle to a page object. +// +// Returns the number of content marks in |page_object|, or -1 in case of +// failure. +var + FPDFPageObj_CountMarks: function(page_object: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get content mark in |page_object| at |index|. +// +// page_object - handle to a page object. +// index - the index of a page object. +// +// Returns the handle to the content mark, or NULL on failure. The handle is +// still owned by the library, and it should not be freed directly. It becomes +// invalid if the page object is destroyed, either directly or indirectly by +// unloading the page. +var + FPDFPageObj_GetMark: function(page_object: FPDF_PAGEOBJECT; index: LongWord): FPDF_PAGEOBJECTMARK; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Add a new content mark to a |page_object|. +// +// page_object - handle to a page object. +// name - the name (tag) of the mark. +// +// Returns the handle to the content mark, or NULL on failure. The handle is +// still owned by the library, and it should not be freed directly. It becomes +// invalid if the page object is destroyed, either directly or indirectly by +// unloading the page. +var + FPDFPageObj_AddMark: function(page_object: FPDF_PAGEOBJECT; name: FPDF_BYTESTRING): FPDF_PAGEOBJECTMARK; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Removes a content |mark| from a |page_object|. +// The mark handle will be invalid after the removal. +// +// page_object - handle to a page object. +// mark - handle to a content mark in that object to remove. +// +// Returns TRUE if the operation succeeded, FALSE if it failed. +var + FPDFPageObj_RemoveMark: function(page_object: FPDF_PAGEOBJECT; mark: FPDF_PAGEOBJECTMARK): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the name of a content mark. +// +// mark - handle to a content mark. +// buffer - buffer for holding the returned name in UTF-16LE. This is only +// modified if |buflen| is longer than the length of the name. +// Optional, pass null to just retrieve the size of the buffer +// needed. +// buflen - length of the buffer. +// out_buflen - pointer to variable that will receive the minimum buffer size +// to contain the name. Not filled if FALSE is returned. +// +// Returns TRUE if the operation succeeded, FALSE if it failed. +var + FPDFPageObjMark_GetName: function(mark: FPDF_PAGEOBJECTMARK; buffer: Pointer; buflen: LongWord; + out_buflen: PLongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the number of key/value pair parameters in |mark|. +// +// mark - handle to a content mark. +// +// Returns the number of key/value pair parameters |mark|, or -1 in case of +// failure. +var + FPDFPageObjMark_CountParams: function(mark: FPDF_PAGEOBJECTMARK): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the key of a property in a content mark. +// +// mark - handle to a content mark. +// index - index of the property. +// buffer - buffer for holding the returned key in UTF-16LE. This is only +// modified if |buflen| is longer than the length of the key. +// Optional, pass null to just retrieve the size of the buffer +// needed. +// buflen - length of the buffer. +// out_buflen - pointer to variable that will receive the minimum buffer size +// to contain the key. Not filled if FALSE is returned. +// +// Returns TRUE if the operation was successful, FALSE otherwise. +var + FPDFPageObjMark_GetParamKey: function(mark: FPDF_PAGEOBJECTMARK; index: LongWord; buffer: Pointer; buflen: LongWord; + out_buflen: PLongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the type of the value of a property in a content mark by key. +// +// mark - handle to a content mark. +// key - string key of the property. +// +// Returns the type of the value, or FPDF_OBJECT_UNKNOWN in case of failure. +var + FPDFPageObjMark_GetParamValueType: function(mark: FPDF_PAGEOBJECTMARK; key: FPDF_BYTESTRING): FPDF_OBJECT_TYPE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// Experimental API. +// Get the value of a number property in a content mark by key as int. +// FPDFPageObjMark_GetParamValueType() should have returned FPDF_OBJECT_NUMBER +// for this property. +// +// mark - handle to a content mark. +// key - string key of the property. +// out_value - pointer to variable that will receive the value. Not filled if +// false is returned. +// +// Returns TRUE if the key maps to a number value, FALSE otherwise. +var + FPDFPageObjMark_GetParamIntValue: function(mark: FPDF_PAGEOBJECTMARK; key: FPDF_BYTESTRING; + out_value: PInteger): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the value of a string property in a content mark by key. +// +// mark - handle to a content mark. +// key - string key of the property. +// buffer - buffer for holding the returned value in UTF-16LE. This is +// only modified if |buflen| is longer than the length of the +// value. +// Optional, pass null to just retrieve the size of the buffer +// needed. +// buflen - length of the buffer. +// out_buflen - pointer to variable that will receive the minimum buffer size +// to contain the value. Not filled if FALSE is returned. +// +// Returns TRUE if the key maps to a string/blob value, FALSE otherwise. +var + FPDFPageObjMark_GetParamStringValue: function(mark: FPDF_PAGEOBJECTMARK; key: FPDF_BYTESTRING; buffer: Pointer; + buflen: LongWord; out_buflen: PLongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the value of a blob property in a content mark by key. +// +// mark - handle to a content mark. +// key - string key of the property. +// buffer - buffer for holding the returned value. This is only modified +// if |buflen| is at least as long as the length of the value. +// Optional, pass null to just retrieve the size of the buffer +// needed. +// buflen - length of the buffer. +// out_buflen - pointer to variable that will receive the minimum buffer size +// to contain the value. Not filled if FALSE is returned. +// +// Returns TRUE if the key maps to a string/blob value, FALSE otherwise. +var + FPDFPageObjMark_GetParamBlobValue: function(mark: FPDF_PAGEOBJECTMARK; key: FPDF_BYTESTRING; buffer: Pointer; + buflen: LongWord; out_buflen: PLongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the value of an int property in a content mark by key. If a parameter +// with key |key| exists, its value is set to |value|. Otherwise, it is added as +// a new parameter. +// +// document - handle to the document. +// page_object - handle to the page object with the mark. +// mark - handle to a content mark. +// key - string key of the property. +// value - int value to set. +// +// Returns TRUE if the operation succeeded, FALSE otherwise. +var + FPDFPageObjMark_SetIntParam: function(document: FPDF_DOCUMENT; page_object: FPDF_PAGEOBJECT; + mark: FPDF_PAGEOBJECTMARK; key: FPDF_BYTESTRING; value: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the value of a string property in a content mark by key. If a parameter +// with key |key| exists, its value is set to |value|. Otherwise, it is added as +// a new parameter. +// +// document - handle to the document. +// page_object - handle to the page object with the mark. +// mark - handle to a content mark. +// key - string key of the property. +// value - string value to set. +// +// Returns TRUE if the operation succeeded, FALSE otherwise. +var + FPDFPageObjMark_SetStringParam: function(document: FPDF_DOCUMENT; page_object: FPDF_PAGEOBJECT; + mark: FPDF_PAGEOBJECTMARK; key: FPDF_BYTESTRING; value: FPDF_BYTESTRING): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the value of a blob property in a content mark by key. If a parameter +// with key |key| exists, its value is set to |value|. Otherwise, it is added as +// a new parameter. +// +// document - handle to the document. +// page_object - handle to the page object with the mark. +// mark - handle to a content mark. +// key - string key of the property. +// value - pointer to blob value to set. +// value_len - size in bytes of |value|. +// +// Returns TRUE if the operation succeeded, FALSE otherwise. +var + FPDFPageObjMark_SetBlobParam: function(document: FPDF_DOCUMENT; page_object: FPDF_PAGEOBJECT; + mark: FPDF_PAGEOBJECTMARK; key: FPDF_BYTESTRING; value: Pointer; value_len: LongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Removes a property from a content mark by key. +// +// page_object - handle to the page object with the mark. +// mark - handle to a content mark. +// key - string key of the property. +// +// Returns TRUE if the operation succeeded, FALSE otherwise. +var + FPDFPageObjMark_RemoveParam: function(page_object: FPDF_PAGEOBJECT; mark: FPDF_PAGEOBJECTMARK; + key: FPDF_BYTESTRING): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Load an image from a JPEG image file and then set it into |image_object|. +// +// pages - pointer to the start of all loaded pages, may be NULL. +// count - number of |pages|, may be 0. +// image_object - handle to an image object. +// file_access - file access handler which specifies the JPEG image file. +// +// Returns TRUE on success. +// +// The image object might already have an associated image, which is shared and +// cached by the loaded pages. In that case, we need to clear the cached image +// for all the loaded pages. Pass |pages| and page count (|count|) to this API +// to clear the image cache. If the image is not previously shared, or NULL is a +// valid |pages| value. +var + FPDFImageObj_LoadJpegFile: function(pages: PFPDF_PAGE; nCount: Integer; image_object: FPDF_PAGEOBJECT; + fileAccess: PFPDF_FILEACCESS): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Load an image from a JPEG image file and then set it into |image_object|. +// +// pages - pointer to the start of all loaded pages, may be NULL. +// count - number of |pages|, may be 0. +// image_object - handle to an image object. +// file_access - file access handler which specifies the JPEG image file. +// +// Returns TRUE on success. +// +// The image object might already have an associated image, which is shared and +// cached by the loaded pages. In that case, we need to clear the cached image +// for all the loaded pages. Pass |pages| and page count (|count|) to this API +// to clear the image cache. If the image is not previously shared, or NULL is a +// valid |pages| value. This function loads the JPEG image inline, so the image +// content is copied to the file. This allows |file_access| and its associated +// data to be deleted after this function returns. +var + FPDFImageObj_LoadJpegFileInline: function(pages: PFPDF_PAGE; count: Integer; image_object: FPDF_PAGEOBJECT; + file_access: PFPDF_FILEACCESS): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// TODO(thestig): Start deprecating this once FPDFPageObj_SetMatrix() is stable. +// Set the transform matrix of |image_object|. +// +// image_object - handle to an image object. +// a - matrix value. +// b - matrix value. +// c - matrix value. +// d - matrix value. +// e - matrix value. +// f - matrix value. +// +// The matrix is composed as: +// |a c e| +// |b d f| +// and can be used to scale, rotate, shear and translate the |image_object|. +// +// Returns TRUE on success. +var + FPDFImageObj_SetMatrix: function(image_object: FPDF_PAGEOBJECT; a, b, c, d, e, f: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set |bitmap| to |image_object|. +// +// pages - pointer to the start of all loaded pages, may be NULL. +// count - number of |pages|, may be 0. +// image_object - handle to an image object. +// bitmap - handle of the bitmap. +// +// Returns TRUE on success. +var + FPDFImageObj_SetBitmap: function(pages: PFPDF_PAGE; nCount: Integer; image_object: FPDF_PAGEOBJECT; + bitmap: FPDF_BITMAP): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get a bitmap rasterization of |image_object|. FPDFImageObj_GetBitmap() only +// operates on |image_object| and does not take the associated image mask into +// account. It also ignores the matrix for |image_object|. +// The returned bitmap will be owned by the caller, and FPDFBitmap_Destroy() +// must be called on the returned bitmap when it is no longer needed. +// +// image_object - handle to an image object. +// +// Returns the bitmap. +var + FPDFImageObj_GetBitmap: function(image_object: FPDF_PAGEOBJECT): FPDF_BITMAP; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get a bitmap rasterization of |image_object| that takes the image mask and +// image matrix into account. To render correctly, the caller must provide the +// |document| associated with |image_object|. If there is a |page| associated +// with |image_object|, the caller should provide that as well. +// The returned bitmap will be owned by the caller, and FPDFBitmap_Destroy() +// must be called on the returned bitmap when it is no longer needed. +// +// document - handle to a document associated with |image_object|. +// page - handle to an optional page associated with |image_object|. +// image_object - handle to an image object. +// +// Returns the bitmap or NULL on failure. +var + FPDFImageObj_GetRenderedBitmap: function(document: FPDF_DOCUMENT; page: FPDF_PAGE; + image_object: FPDF_PAGEOBJECT): FPDF_BITMAP; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the decoded image data of |image_object|. The decoded data is the +// uncompressed image data, i.e. the raw image data after having all filters +// applied. |buffer| is only modified if |buflen| is longer than the length of +// the decoded image data. +// +// image_object - handle to an image object. +// buffer - buffer for holding the decoded image data. +// buflen - length of the buffer in bytes. +// +// Returns the length of the decoded image data. +var + FPDFImageObj_GetImageDataDecoded: function(image_object: FPDF_PAGEOBJECT; buffer: Pointer; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the raw image data of |image_object|. The raw data is the image data as +// stored in the PDF without applying any filters. |buffer| is only modified if +// |buflen| is longer than the length of the raw image data. +// +// image_object - handle to an image object. +// buffer - buffer for holding the raw image data. +// buflen - length of the buffer in bytes. +// +// Returns the length of the raw image data. +var + FPDFImageObj_GetImageDataRaw: function(image_object: FPDF_PAGEOBJECT; buffer: Pointer; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the number of filters (i.e. decoders) of the image in |image_object|. +// +// image_object - handle to an image object. +// +// Returns the number of |image_object|'s filters. +var + FPDFImageObj_GetImageFilterCount: function(image_object: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the filter at |index| of |image_object|'s list of filters. Note that the +// filters need to be applied in order, i.e. the first filter should be applied +// first, then the second, etc. |buffer| is only modified if |buflen| is longer +// than the length of the filter string. +// +// image_object - handle to an image object. +// index - the index of the filter requested. +// buffer - buffer for holding filter string, encoded in UTF-8. +// buflen - length of the buffer. +// +// Returns the length of the filter string. +var + FPDFImageObj_GetImageFilter: function(image_object: FPDF_PAGEOBJECT; index: Integer; buffer: Pointer; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the image metadata of |image_object|, including dimension, DPI, bits per +// pixel, and colorspace. If the |image_object| is not an image object or if it +// does not have an image, then the return value will be false. Otherwise, +// failure to retrieve any specific parameter would result in its value being 0. +// +// image_object - handle to an image object. +// page - handle to the page that |image_object| is on. Required for +// retrieving the image's bits per pixel and colorspace. +// metadata - receives the image metadata; must not be NULL. +// +// Returns true if successful. +var + FPDFImageObj_GetImageMetadata: function(image_object: FPDF_PAGEOBJECT; page: FPDF_PAGE; + metadata: PFPDF_IMAGEOBJ_METADATA): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the image size in pixels. Faster method to get only image size. +// +// image_object - handle to an image object. +// width - receives the image width in pixels; must not be NULL. +// height - receives the image height in pixels; must not be NULL. +// +// Returns true if successful. +var + FPDFImageObj_GetImagePixelSize: function(image_object: FPDF_PAGEOBJECT; var width, height: UInt32): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Create a new path object at an initial position. +// +// x - initial horizontal position. +// y - initial vertical position. +// +// Returns a handle to a new path object. +var + FPDFPageObj_CreateNewPath: function(x, y: Single): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Create a closed path consisting of a rectangle. +// +// x - horizontal position for the left boundary of the rectangle. +// y - vertical position for the bottom boundary of the rectangle. +// w - width of the rectangle. +// h - height of the rectangle. +// +// Returns a handle to the new path object. +var + FPDFPageObj_CreateNewRect: function(x, y, w, h: Single): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the bounding box of |page_object|. +// +// page_object - handle to a page object. +// left - pointer where the left coordinate will be stored +// bottom - pointer where the bottom coordinate will be stored +// right - pointer where the right coordinate will be stored +// top - pointer where the top coordinate will be stored +// +// On success, returns TRUE and fills in the 4 coordinates. +var + FPDFPageObj_GetBounds: function(page_object: FPDF_PAGEOBJECT; var left, bottom, right, top: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the quad points that bounds |page_object|. +// +// page_object - handle to a page object. +// quad_points - pointer where the quadrilateral points will be stored. +// +// On success, returns TRUE and fills in |quad_points|. +// +// Similar to FPDFPageObj_GetBounds(), this returns the bounds of a page +// object. When the object is rotated by a non-multiple of 90 degrees, this API +// returns a tighter bound that cannot be represented with just the 4 sides of +// a rectangle. +// +// Currently only works the following |page_object| types: FPDF_PAGEOBJ_TEXT and +// FPDF_PAGEOBJ_IMAGE. +var + FPDFPageObj_GetRotatedBounds: function(page_object: FPDF_PAGEOBJECT; quad_points: PFS_QUADPOINTSF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set the blend mode of |page_object|. +// +// page_object - handle to a page object. +// blend_mode - string containing the blend mode. +// +// Blend mode can be one of following: Color, ColorBurn, ColorDodge, Darken, +// Difference, Exclusion, HardLight, Hue, Lighten, Luminosity, Multiply, Normal, +// Overlay, Saturation, Screen, SoftLight +var + FPDFPageObj_SetBlendMode: procedure(page_object: FPDF_PAGEOBJECT; blend_mode: FPDF_BYTESTRING); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set the stroke RGBA of a page object. Range of values: 0 - 255. +// +// page_object - the handle to the page object. +// R - the red component for the object's stroke color. +// G - the green component for the object's stroke color. +// B - the blue component for the object's stroke color. +// A - the stroke alpha for the object. +// +// Returns TRUE on success. +var + FPDFPageObj_SetStrokeColor: function(page_object: FPDF_PAGEOBJECT; R, G, B, A: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the stroke RGBA of a page object. Range of values: 0 - 255. +// +// page_object - the handle to the page object. +// R - the red component of the path stroke color. +// G - the green component of the object's stroke color. +// B - the blue component of the object's stroke color. +// A - the stroke alpha of the object. +// +// Returns TRUE on success. +var + FPDFPageObj_GetStrokeColor: function(page_object: FPDF_PAGEOBJECT; var R, G, B, A: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set the stroke width of a page object. +// +// path - the handle to the page object. +// width - the width of the stroke. +// +// Returns TRUE on success +var + FPDFPageObj_SetStrokeWidth: function(page_object: FPDF_PAGEOBJECT; width: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the stroke width of a page object. +// +// path - the handle to the page object. +// width - the width of the stroke. +// +// Returns TRUE on success +var + FPDFPageObj_GetStrokeWidth: function(page_object: FPDF_PAGEOBJECT; var width: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the line join of |page_object|. +// +// page_object - handle to a page object. +// +// Returns the line join, or -1 on failure. +// Line join can be one of following: FPDF_LINEJOIN_MITER, FPDF_LINEJOIN_ROUND, +// FPDF_LINEJOIN_BEVEL +var + FPDFPageObj_GetLineJoin: function(page_object: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set the line join of |page_object|. +// +// page_object - handle to a page object. +// line_join - line join +// +// Line join can be one of following: FPDF_LINEJOIN_MITER, FPDF_LINEJOIN_ROUND, +// FPDF_LINEJOIN_BEVEL +var + FPDFPageObj_SetLineJoin: function(page_object: FPDF_PAGEOBJECT; line_join: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the line cap of |page_object|. +// +// page_object - handle to a page object. +// +// Returns the line cap, or -1 on failure. +// Line cap can be one of following: FPDF_LINECAP_BUTT, FPDF_LINECAP_ROUND, +// FPDF_LINECAP_PROJECTING_SQUARE +var + FPDFPageObj_GetLineCap: function(page_object: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set the line cap of |page_object|. +// +// page_object - handle to a page object. +// line_cap - line cap +// +// Line cap can be one of following: FPDF_LINECAP_BUTT, FPDF_LINECAP_ROUND, +// FPDF_LINECAP_PROJECTING_SQUARE +var + FPDFPageObj_SetLineCap: function(page_object: FPDF_PAGEOBJECT; line_cap: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set the fill RGBA of a page object. Range of values: 0 - 255. +// +// page_object - the handle to the page object. +// R - the red component for the object's fill color. +// G - the green component for the object's fill color. +// B - the blue component for the object's fill color. +// A - the fill alpha for the object. +// +// Returns TRUE on success. +var + FPDFPageObj_SetFillColor: function(page_object: FPDF_PAGEOBJECT; R, G, B, A: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the fill RGBA of a page object. Range of values: 0 - 255. +// +// page_object - the handle to the page object. +// R - the red component of the object's fill color. +// G - the green component of the object's fill color. +// B - the blue component of the object's fill color. +// A - the fill alpha of the object. +// +// Returns TRUE on success. +var + FPDFPageObj_GetFillColor: function(page_object: FPDF_PAGEOBJECT; var R, G, B, A: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the line dash |phase| of |page_object|. +// +// page_object - handle to a page object. +// phase - pointer where the dashing phase will be stored. +// +// Returns TRUE on success. +var + FPDFPageObj_GetDashPhase: function(page_object: FPDF_PAGEOBJECT; var phase: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the line dash phase of |page_object|. +// +// page_object - handle to a page object. +// phase - line dash phase. +// +// Returns TRUE on success. +var + FPDFPageObj_SetDashPhase: function(page_object: FPDF_PAGEOBJECT; phase: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the line dash array of |page_object|. +// +// page_object - handle to a page object. +// +// Returns the line dash array size or -1 on failure. +var + FPDFPageObj_GetDashCount: function(page_object: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the line dash array of |page_object|. +// +// page_object - handle to a page object. +// dash_array - pointer where the dashing array will be stored. +// dash_count - number of elements in |dash_array|. +// +// Returns TRUE on success. +var + FPDFPageObj_GetDashArray: function(page_object: FPDF_PAGEOBJECT; dash_array: PSingle; dash_count: SIZE_T): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the line dash array of |page_object|. +// +// page_object - handle to a page object. +// dash_array - the dash array. +// dash_count - number of elements in |dash_array|. +// phase - the line dash phase. +// +// Returns TRUE on success. +var + FPDFPageObj_SetDashArray: function(page_object: FPDF_PAGEOBJECT; const dash_array: PSingle; dash_count: SIZE_T; + phase: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get number of segments inside |path|. +// +// path - handle to a path. +// +// A segment is a command, created by e.g. FPDFPath_MoveTo(), +// FPDFPath_LineTo() or FPDFPath_BezierTo(). +// +// Returns the number of objects in |path| or -1 on failure. +var + FPDFPath_CountSegments: function(path: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get segment in |path| at |index|. +// +// path - handle to a path. +// index - the index of a segment. +// +// Returns the handle to the segment, or NULL on faiure. +var + FPDFPath_GetPathSegment: function(path: FPDF_PAGEOBJECT; index: Integer): FPDF_PATHSEGMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get coordinates of |segment|. +// +// segment - handle to a segment. +// x - the horizontal position of the segment. +// y - the vertical position of the segment. +// +// Returns TRUE on success, otherwise |x| and |y| is not set. +var + FPDFPathSegment_GetPoint: function(segment: FPDF_PATHSEGMENT; var x, y: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get type of |segment|. +// +// segment - handle to a segment. +// +// Returns one of the FPDF_SEGMENT_* values on success, +// FPDF_SEGMENT_UNKNOWN on error. +var + FPDFPathSegment_GetType: function(segment: FPDF_PATHSEGMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Gets if the |segment| closes the current subpath of a given path. +// +// segment - handle to a segment. +// +// Returns close flag for non-NULL segment, FALSE otherwise. +var + FPDFPathSegment_GetClose: function(segment: FPDF_PATHSEGMENT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Move a path's current point. +// +// path - the handle to the path object. +// x - the horizontal position of the new current point. +// y - the vertical position of the new current point. +// +// Note that no line will be created between the previous current point and the +// new one. +// +// Returns TRUE on success +var + FPDFPath_MoveTo: function(path: FPDF_PAGEOBJECT; x, y: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Add a line between the current point and a new point in the path. +// +// path - the handle to the path object. +// x - the horizontal position of the new point. +// y - the vertical position of the new point. +// +// The path's current point is changed to (x, y). +// +// Returns TRUE on success +var + FPDFPath_LineTo: function(path: FPDF_PAGEOBJECT; x, y: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Add a cubic Bezier curve to the given path, starting at the current point. +// +// path - the handle to the path object. +// x1 - the horizontal position of the first Bezier control point. +// y1 - the vertical position of the first Bezier control point. +// x2 - the horizontal position of the second Bezier control point. +// y2 - the vertical position of the second Bezier control point. +// x3 - the horizontal position of the ending point of the Bezier curve. +// y3 - the vertical position of the ending point of the Bezier curve. +// +// Returns TRUE on success +var + FPDFPath_BezierTo: function(path: FPDF_PAGEOBJECT; x1, y1, x2, y2, x3, y3: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Close the current subpath of a given path. +// +// path - the handle to the path object. +// +// This will add a line between the current point and the initial point of the +// subpath, thus terminating the current subpath. +// +// Returns TRUE on success +var + FPDFPath_Close: function(path: FPDF_PAGEOBJECT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set the drawing mode of a path. +// +// path - the handle to the path object. +// fillmode - the filling mode to be set: one of the FPDF_FILLMODE_* flags. +// stroke - a boolean specifying if the path should be stroked or not. +// +// Returns TRUE on success +var + FPDFPath_SetDrawMode: function(path: FPDF_PAGEOBJECT; fillmode: Integer; stoke: FPDF_BOOL): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the drawing mode of a path. +// +// path - the handle to the path object. +// fillmode - the filling mode of the path: one of the FPDF_FILLMODE_* flags. +// stroke - a boolean specifying if the path is stroked or not. +// +// Returns TRUE on success +var + FPDFPath_GetDrawMode: function(path: FPDF_PAGEOBJECT; var fillmode: Integer; var stoke: FPDF_BOOL): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Create a new text object using one of the standard PDF fonts. +// +// document - handle to the document. +// font - string containing the font name, without spaces. +// font_size - the font size for the new text object. +// +// Returns a handle to a new text object, or NULL on failure +var + FPDFPageObj_NewTextObj: function(document: FPDF_DOCUMENT; font: FPDF_BYTESTRING; font_size: Single): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set the text for a text object. If it had text, it will be replaced. +// +// text_object - handle to the text object. +// text - the UTF-16LE encoded string containing the text to be added. +// +// Returns TRUE on success +var + FPDFText_SetText: function(text_object: FPDF_PAGEOBJECT; text: FPDF_WIDESTRING): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the text using charcodes for a text object. If it had text, it will be +// replaced. +// +// text_object - handle to the text object. +// charcodes - pointer to an array of charcodes to be added. +// count - number of elements in |charcodes|. +// +// Returns TRUE on success +var + FPDFText_SetCharcodes: function(text_object: FPDF_PAGEOBJECT; const charcodes: PUINT; count: SIZE_T): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Returns a font object loaded from a stream of data. The font is loaded +// into the document. Various font data structures, such as the ToUnicode data, +// are auto-generated based on the inputs. +// +// document - handle to the document. +// data - the stream of font data, which will be copied by the font object. +// size - the size of the font data, in bytes. +// font_type - FPDF_FONT_TYPE1 or FPDF_FONT_TRUETYPE depending on the font type. +// cid - a boolean specifying if the font is a CID font or not. +// +// The loaded font can be closed using FPDFFont_Close(). +var + FPDFText_LoadFont: function(document: FPDF_DOCUMENT; data: PByte; size: DWORD; + font_type: Integer; cid: FPDF_BOOL): FPDF_FONT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Loads one of the standard 14 fonts per PDF spec 1.7 page 416. The preferred +// way of using font style is using a dash to separate the name from the style, +// for example 'Helvetica-BoldItalic'. +// +// document - handle to the document. +// font - string containing the font name, without spaces. +// +// The loaded font can be closed using FPDFFont_Close(). +// +// Returns NULL on failure. +var + FPDFText_LoadStandardFont: function(document: FPDF_DOCUMENT; font: FPDF_BYTESTRING): FPDF_FONT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Returns a font object loaded from a stream of data for a type 2 CID font. The +// font is loaded into the document. Unlike FPDFText_LoadFont(), the ToUnicode +// data and the CIDToGIDMap data are caller provided, instead of auto-generated. +// +// document - handle to the document. +// font_data - the stream of font data, which will be copied by +// the font object. +// font_data_size - the size of the font data, in bytes. +// to_unicode_cmap - the ToUnicode data. +// cid_to_gid_map_data - the stream of CIDToGIDMap data. +// cid_to_gid_map_data_size - the size of the CIDToGIDMap data, in bytes. +// +// The loaded font can be closed using FPDFFont_Close(). +// +// Returns NULL on failure. +var + FPDFText_LoadCidType2Font: function(document: FPDF_DOCUMENT; font_data: PByte; font_data_size: DWORD; + to_unicode_cmap: FPDF_BYTESTRING; cid_to_gid_map_data: PByte; cid_to_gid_map_data_size: DWORD): FPDF_FONT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the font size of a text object. +// +// text - handle to a text. +// +// size - pointer to the font size of the text object, measured in points +// (about 1/72 inch) +// +// Returns TRUE on success. +var + FPDFTextObj_GetFontSize: function(text: FPDF_PAGEOBJECT; var size: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Close a loaded PDF font. +// +// font - Handle to the loaded font. +var + FPDFFont_Close: procedure(font: FPDF_FONT); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Create a new text object using a loaded font. +// +// document - handle to the document. +// font - handle to the font object. +// font_size - the font size for the new text object. +// +// Returns a handle to a new text object, or NULL on failure +var + FPDFPageObj_CreateTextObj: function(document: FPDF_DOCUMENT; font: FPDF_FONT; font_size: Single): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the text rendering mode of a text object. +// +// text - the handle to the text object. +// +// Returns one of the known FPDF_TEXT_RENDERMODE enum values on success, +// FPDF_TEXTRENDERMODE_UNKNOWN on error. +var + FPDFTextObj_GetTextRenderMode: function(text: FPDF_PAGEOBJECT): FPDF_TEXT_RENDERMODE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the text rendering mode of a text object. +// +// text - the handle to the text object. +// render_mode - the FPDF_TEXT_RENDERMODE enum value to be set (cannot set to +// FPDF_TEXTRENDERMODE_UNKNOWN). +// +// Returns TRUE on success. +var + FPDFTextObj_SetTextRenderMode: function(text: FPDF_PAGEOBJECT; render_mode: FPDF_TEXT_RENDERMODE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the text of a text object. +// +// text_object - the handle to the text object. +// text_page - the handle to the text page. +// buffer - the address of a buffer that receives the text. +// length - the size, in bytes, of |buffer|. +// +// Returns the number of bytes in the text (including the trailing NUL +// character) on success, 0 on error. +// +// Regardless of the platform, the |buffer| is always in UTF-16LE encoding. +// If |length| is less than the returned length, or |buffer| is NULL, |buffer| +// will not be modified. +var + FPDFTextObj_GetText: function(text_object: FPDF_PAGEOBJECT; text_page: FPDF_TEXTPAGE; buffer: PFPDF_WCHAR; + length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get a bitmap rasterization of |text_object|. To render correctly, the caller +// must provide the |document| associated with |text_object|. If there is a +// |page| associated with |text_object|, the caller should provide that as well. +// The returned bitmap will be owned by the caller, and FPDFBitmap_Destroy() +// must be called on the returned bitmap when it is no longer needed. +// +// document - handle to a document associated with |text_object|. +// page - handle to an optional page associated with |text_object|. +// text_object - handle to a text object. +// scale - the scaling factor, which must be greater than 0. +// +// Returns the bitmap or NULL on failure. +var + FPDFTextObj_GetRenderedBitmap: function(document: FPDF_DOCUMENT; page: FPDF_PAGE; text_object: FPDF_PAGEOBJECT; + scale: Single): FPDF_BITMAP; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the font of a text object. +// +// text - the handle to the text object. +// +// Returns a handle to the font object held by |text| which retains ownership. +var + FPDFTextObj_GetFont: function(text: FPDF_PAGEOBJECT): FPDF_FONT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the family name of a font. +// +// font - the handle to the font object. +// buffer - the address of a buffer that receives the font name. +// length - the size, in bytes, of |buffer|. +// +// Returns the number of bytes in the family name (including the trailing NUL +// character) on success, 0 on error. +// +// Regardless of the platform, the |buffer| is always in UTF-8 encoding. +// If |length| is less than the returned length, or |buffer| is NULL, |buffer| +// will not be modified. +var + FPDFFont_GetFamilyName: function(font: FPDF_FONT; buffer: PAnsiChar; length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the decoded data from the |font| object. +// +// font - The handle to the font object. (Required) +// buffer - The address of a buffer that receives the font data. +// buflen - Length of the buffer. +// out_buflen - Pointer to variable that will receive the minimum buffer size +// to contain the font data. Not filled if the return value is +// FALSE. (Required) +// +// Returns TRUE on success. In which case, |out_buflen| will be filled, and +// |buffer| will be filled if it is large enough. Returns FALSE if any of the +// required parameters are null. +// +// The decoded data is the uncompressed font data. i.e. the raw font data after +// having all stream filters applied, when the data is embedded. +// +// If the font is not embedded, then this API will instead return the data for +// the substitution font it is using. +var + FPDFFont_GetFontData: function(font: FPDF_FONT; buffer: PByte; buflen: SIZE_T; var out_buflen: SIZE_T): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get whether |font| is embedded or not. +// +// font - the handle to the font object. +// +// Returns 1 if the font is embedded, 0 if it not, and -1 on failure. +var + FPDFFont_GetIsEmbedded: function(font: FPDF_FONT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the descriptor flags of a font. +// +// font - the handle to the font object. +// +// Returns the bit flags specifying various characteristics of the font as +// defined in ISO 32000-1:2008, table 123, -1 on failure. +var + FPDFFont_GetFlags: function(font: FPDF_FONT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the font weight of a font. +// +// font - the handle to the font object. +// +// Returns the font weight, -1 on failure. +// Typical values are 400 (normal) and 700 (bold). +var + FPDFFont_GetWeight: function(font: FPDF_FONT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the italic angle of a font. +// +// font - the handle to the font object. +// angle - pointer where the italic angle will be stored +// +// The italic angle of a |font| is defined as degrees counterclockwise +// from vertical. For a font that slopes to the right, this will be negative. +// +// Returns TRUE on success; |angle| unmodified on failure. +var + FPDFFont_GetItalicAngle: function(font: FPDF_FONT; var angle: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get ascent distance of a font. +// +// font - the handle to the font object. +// font_size - the size of the |font|. +// ascent - pointer where the font ascent will be stored +// +// Ascent is the maximum distance in points above the baseline reached by the +// glyphs of the |font|. One point is 1/72 inch (around 0.3528 mm). +// +// Returns TRUE on success; |ascent| unmodified on failure. +var + FPDFFont_GetAscent: function(font: FPDF_FONT; font_size: Single; var ascent: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get descent distance of a font. +// +// font - the handle to the font object. +// font_size - the size of the |font|. +// descent - pointer where the font descent will be stored +// +// Descent is the maximum distance in points below the baseline reached by the +// glyphs of the |font|. One point is 1/72 inch (around 0.3528 mm). +// +// Returns TRUE on success; |descent| unmodified on failure. +var + FPDFFont_GetDescent: function(font: FPDF_FONT; font_size: Single; var descent: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the width of a glyph in a font. +// +// font - the handle to the font object. +// glyph - the glyph. +// font_size - the size of the font. +// width - pointer where the glyph width will be stored +// +// Glyph width is the distance from the end of the prior glyph to the next +// glyph. This will be the vertical distance for vertical writing. +// +// Returns TRUE on success; |width| unmodified on failure. +var + FPDFFont_GetGlyphWidth: function(font: FPDF_FONT; glyph: UINT; font_size: Single; var width: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the glyphpath describing how to draw a font glyph. +// +// font - the handle to the font object. +// glyph - the glyph being drawn. +// font_size - the size of the font. +// +// Returns the handle to the segment, or NULL on faiure. +var + FPDFFont_GetGlyphPath: function(font: FPDF_FONT; glyph: UINT; font_size: Single): FPDF_GLYPHPATH; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get number of segments inside glyphpath. +// +// glyphpath - handle to a glyph path. +// +// Returns the number of objects in |glyphpath| or -1 on failure. +var + FPDFGlyphPath_CountGlyphSegments: function(glyphpath: FPDF_GLYPHPATH): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get segment in glyphpath at index. +// +// glyphpath - handle to a glyph path. +// index - the index of a segment. +// +// Returns the handle to the segment, or NULL on faiure. +var + FPDFGlyphPath_GetGlyphPathSegment: function(glyphpath: FPDF_GLYPHPATH; index: Integer): FPDF_PATHSEGMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get number of page objects inside |form_object|. +// +// form_object - handle to a form object. +// +// Returns the number of objects in |form_object| on success, -1 on error. +var + FPDFFormObj_CountObjects: function(form_object: FPDF_PAGEOBJECT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get page object in |form_object| at |index|. +// +// form_object - handle to a form object. +// index - the 0-based index of a page object. +// +// Returns the handle to the page object, or NULL on error. +var + FPDFFormObj_GetObject: function(form_object: FPDF_PAGEOBJECT; index: LongWord): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// *** _FPDF_PPO_H_ *** + +// Experimental API. +// Import pages to a FPDF_DOCUMENT. +// +// dest_doc - The destination document for the pages. +// src_doc - The document to be imported. +// page_indices - An array of page indices to be imported. The first page is +// zero. If |page_indices| is NULL, all pages from |src_doc| +// are imported. +// length - The length of the |page_indices| array. +// index - The page index at which to insert the first imported page +// into |dest_doc|. The first page is zero. +// +// Returns TRUE on success. Returns FALSE if any pages in |page_indices| is +// invalid. +var + FPDF_ImportPagesByIndex: function(dest_doc, src_doc: FPDF_DOCUMENT; page_indices: PInteger; + length: LongWord; index: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Import pages to a FPDF_DOCUMENT. +// +// dest_doc - The destination document for the pages. +// src_doc - The document to be imported. +// pagerange - A page range string, Such as "1,3,5-7". The first page is one. +// If |pagerange| is NULL, all pages from |src_doc| are imported. +// index - The page index at which to insert the first imported page into +// |dest_doc|. The first page is zero. +// +// Returns TRUE on success. Returns FALSE if any pages in |pagerange| is +// invalid or if |pagerange| cannot be read. +var + FPDF_ImportPages: function(dest_doc, src_doc: FPDF_DOCUMENT; pagerange: FPDF_BYTESTRING; index: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Create a new document from |src_doc|. The pages of |src_doc| will be +// combined to provide |num_pages_on_x_axis x num_pages_on_y_axis| pages per +// |output_doc| page. +// +// src_doc - The document to be imported. +// output_width - The output page width in PDF "user space" units. +// output_height - The output page height in PDF "user space" units. +// num_pages_on_x_axis - The number of pages on X Axis. +// num_pages_on_y_axis - The number of pages on Y Axis. +// +// Return value: +// A handle to the created document, or NULL on failure. +// +// Comments: +// number of pages per page = num_pages_on_x_axis * num_pages_on_y_axis +// +var + FPDF_ImportNPagesToOne: function(src_doc: FPDF_DOCUMENT; output_width, output_height: Single; + num_pages_on_x_axis, num_pages_on_y_axis: SIZE_T): FPDF_DOCUMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Create a template to generate form xobjects from |src_doc|'s page at +// |src_page_index|, for use in |dest_doc|. +// +// Returns a handle on success, or NULL on failure. Caller owns the newly +// created object. +var + FPDF_NewXObjectFromPage: function(dest_doc, src_doc: FPDF_DOCUMENT; src_page_index: Integer): FPDF_XOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Close an FPDF_XOBJECT handle created by FPDF_NewXObjectFromPage(). +// FPDF_PAGEOBJECTs created from the FPDF_XOBJECT handle are not affected. +var + FPDF_CloseXObject: procedure(xobject: FPDF_XOBJECT); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Create a new form object from an FPDF_XOBJECT object. +// +// Returns a new form object on success, or NULL on failure. Caller owns the +// newly created object. +var + FPDF_NewFormObjectFromXObject: function(xobject: FPDF_XOBJECT): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Copy the viewer preferences from |src_doc| into |dest_doc|. +// +// dest_doc - Document to write the viewer preferences into. +// src_doc - Document to read the viewer preferences from. +// +// Returns TRUE on success. +var + FPDF_CopyViewerPreferences: function(dest_doc, src_doc: FPDF_DOCUMENT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_SAVE_H_ *** + +type + // Structure for custom file write + PFPDF_FILEWRITE = ^FPDF_FILEWRITE; + FPDF_FILEWRITE = record + // + // Version number of the interface. Currently must be 1. + // + version: Integer; + + // + // Method: WriteBlock + // Output a block of data in your custom way. + // Interface Version: + // 1 + // Implementation Required: + // Yes + // Comments: + // Called by function FPDF_SaveDocument + // Parameters: + // pThis - Pointer to the structure itself + // pData - Pointer to a buffer to output + // size - The size of the buffer. + // Return value: + // Should be non-zero if successful, zero for error. + // + WriteBlock: function(pThis: PFPDF_FILEWRITE; pData: Pointer; size: LongWord): Integer; cdecl; + end; + PFPdfFileWrite = ^TFPdfFileWrite; + TFPdfFileWrite = FPDF_FILEWRITE; + +const + // Flags for FPDF_SaveAsCopy() + FPDF_INCREMENTAL = 1; + FPDF_NO_INCREMENTAL = 2; + FPDF_REMOVE_SECURITY = 3; + +// Function: FPDF_SaveAsCopy +// Saves the copy of specified document in custom way. +// Parameters: +// document - Handle to document, as returned by +// FPDF_LoadDocument() or FPDF_CreateNewDocument(). +// pFileWrite - A pointer to a custom file write structure. +// flags - The creating flags. +// Return value: +// TRUE for succeed, FALSE for failed. +// +var + FPDF_SaveAsCopy: function(document: FPDF_DOCUMENT; pFileWrite: PFPDF_FILEWRITE; flags: FPDF_DWORD): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_SaveWithVersion +// Same as FPDF_SaveAsCopy(), except the file version of the +// saved document can be specified by the caller. +// Parameters: +// document - Handle to document. +// pFileWrite - A pointer to a custom file write structure. +// flags - The creating flags. +// fileVersion - The PDF file version. File version: 14 for 1.4, 15 for 1.5, ... +// Return value: +// TRUE if succeed, FALSE if failed. +// +var + FPDF_SaveWithVersion: function(document: FPDF_DOCUMENT; pFileWrite: PFPDF_FILEWRITE; + flags: FPDF_DWORD; fileVersion: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_FLATTEN_H_ *** + +const + FLATTEN_FAIL = 0; // Flatten operation failed. + FLATTEN_SUCCESS = 1; // Flatten operation succeed. + FLATTEN_NOTINGTODO = 2; // Nothing to be flattened. + + FLAT_NORMALDISPLAY = 0; // Flatten for normal display. + FLAT_PRINT = 1; // Flatten for print. + +// Flatten annotations and form fields into the page contents. +// +// page - handle to the page. +// nFlag - One of the |FLAT_*| values denoting the page usage. +// +// Returns one of the |FLATTEN_*| values. +// +// Currently, all failures return |FLATTEN_FAIL| with no indication of the +// cause. +var + FPDFPage_Flatten: function(page: FPDF_PAGE; nFlag: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDFTEXT_H_ *** + +// Function: FPDFText_LoadPage +// Prepare information about all characters in a page. +// Parameters: +// page - Handle to the page. Returned by FPDF_LoadPage function (in FPDFVIEW module). +// Return value: +// A handle to the text page information structure. +// NULL if something goes wrong. +// Comments: +// Application must call FPDFText_ClosePage to release the text page +// information. +// +var + FPDFText_LoadPage: function(page: FPDF_PAGE): FPDF_TEXTPAGE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_ClosePage +// Release all resources allocated for a text page information structure. +// Parameters: +// text_page - Handle to a text page information structure. Returned by FPDFText_LoadPage function. +// Return Value: +// None. +// +var + FPDFText_ClosePage: procedure(text_page: FPDF_TEXTPAGE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_CountChars +// Get number of characters in a page. +// Parameters: +// text_page - Handle to a text page information structure. Returned by FPDFText_LoadPage function. +// Return value: +// Number of characters in the page. Return -1 for error. +// Generated characters, like additional space characters, new line +// characters, are also counted. +// Comments: +// Characters in a page form a "stream", inside the stream, each character has an index. +// We will use the index parameters in many of FPDFTEXT functions. The first character in the page +// has an index value of zero. +// +var + FPDFText_CountChars: function(text_page: FPDF_TEXTPAGE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetUnicode +// Get Unicode of a character in a page. +// Parameters: +// text_page - Handle to a text page information structure. Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// Return value: +// The Unicode of the particular character. +// If a character is not encoded in Unicode and Foxit engine can't convert to Unicode, +// the return value will be zero. +// +var + FPDFText_GetUnicode: function(text_page: FPDF_TEXTPAGE; index: Integer): WideChar; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_GetTextObject +// Get the FPDF_PAGEOBJECT associated with a given character. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// Return value: +// The associated text object for the character at |index|, or NULL on +// error. The returned text object, if non-null, is of type +// |FPDF_PAGEOBJ_TEXT|. The caller does not own the returned object. +// +var + FPDFText_GetTextObject: function(text_page: FPDF_TEXTPAGE; index: Integer): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_IsGenerated +// Get if a character in a page is generated by PDFium. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// Return value: +// 1 if the character is generated by PDFium. +// 0 if the character is not generated by PDFium. +// -1 if there was an error. +// +var + FPDFText_IsGenerated: function(text_page: FPDF_TEXTPAGE; index: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_IsHyphen +// Get if a character in a page is a hyphen. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// Return value: +// 1 if the character is a hyphen. +// 0 if the character is not a hyphen. +// -1 if there was an error. +// +var + FPDFText_IsHyphen: function(text_page: FPDF_TEXTPAGE; index: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_HasUnicodeMapError +// Get if a character in a page has an invalid unicode mapping. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// Return value: +// 1 if the character has an invalid unicode mapping. +// 0 if the character has no known unicode mapping issues. +// -1 if there was an error. +// +var + FPDFText_HasUnicodeMapError: function(text_page: FPDF_TEXTPAGE; index: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetFontSize +// Get the font size of a particular character. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// Return value: +// The font size of the particular character, measured in points (about +// 1/72 inch). This is the typographic size of the font (so called +// "em size"). +// +var + FPDFText_GetFontSize: function(text_page: FPDF_TEXTPAGE; index: Integer): Double; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_GetFontInfo +// Get the font name and flags of a particular character. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// buffer - A buffer receiving the font name. +// buflen - The length of |buffer| in bytes. +// flags - Optional pointer to an int receiving the font flags. +// These flags should be interpreted per PDF spec 1.7 +// Section 5.7.1 Font Descriptor Flags. +// Return value: +// On success, return the length of the font name, including the +// trailing NUL character, in bytes. If this length is less than or +// equal to |length|, |buffer| is set to the font name, |flags| is +// set to the font flags. |buffer| is in UTF-8 encoding. Return 0 on +// failure. +// +var + FPDFText_GetFontInfo: function(text_page: FPDF_TEXTPAGE; index: Integer; buffer: Pointer; buflen: LongWord; + flags: PInteger): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_GetFontWeight +// Get the font weight of a particular character. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// Return value: +// On success, return the font weight of the particular character. If +// |text_page| is invalid, if |index| is out of bounds, or if the +// character's text object is undefined, return -1. +// +var + FPDFText_GetFontWeight: function(text_page: FPDF_TEXTPAGE; index: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_GetFillColor +// Get the fill color of a particular character. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// R - Pointer to an unsigned int number receiving the +// red value of the fill color. +// G - Pointer to an unsigned int number receiving the +// green value of the fill color. +// B - Pointer to an unsigned int number receiving the +// blue value of the fill color. +// A - Pointer to an unsigned int number receiving the +// alpha value of the fill color. +// Return value: +// Whether the call succeeded. If false, |R|, |G|, |B| and |A| are +// unchanged. +// +var + FPDFText_GetFillColor: function(text_page: FPDF_TEXTPAGE; index: Integer; var R, G, B, A: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_GetStrokeColor +// Get the stroke color of a particular character. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// R - Pointer to an unsigned int number receiving the +// red value of the stroke color. +// G - Pointer to an unsigned int number receiving the +// green value of the stroke color. +// B - Pointer to an unsigned int number receiving the +// blue value of the stroke color. +// A - Pointer to an unsigned int number receiving the +// alpha value of the stroke color. +// Return value: +// Whether the call succeeded. If false, |R|, |G|, |B| and |A| are +// unchanged. +// +var + FPDFText_GetStrokeColor: function(text_page: FPDF_TEXTPAGE; index: Integer; var R, G, B, A: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_GetCharAngle +// Get character rotation angle. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// Return Value: +// On success, return the angle value in radian. Value will always be +// greater or equal to 0. If |text_page| is invalid, or if |index| is +// out of bounds, then return -1. +// +var + FPDFText_GetCharAngle: function(text_page: FPDF_TEXTPAGE; index: Integer): Single; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetCharBox +// Get bounding box of a particular character. +// Parameters: +// text_page - Handle to a text page information structure. Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// left - Pointer to a double number receiving left position of the character box. +// right - Pointer to a double number receiving right position of the character box. +// bottom - Pointer to a double number receiving bottom position of the character box. +// top - Pointer to a double number receiving top position of the character box. +// Return Value: +// On success, return TRUE and fill in |left|, |right|, |bottom|, and +// |top|. If |text_page| is invalid, or if |index| is out of bounds, +// then return FALSE, and the out parameters remain unmodified. +// Comments: +// All positions are measured in PDF "user space". +// +var + FPDFText_GetCharBox: procedure(text_page: FPDF_TEXTPAGE; index: Integer; var left, right, bottom, top: Double); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_GetLooseCharBox +// Get a "loose" bounding box of a particular character, i.e., covering +// the entire glyph bounds, without taking the actual glyph shape into +// account. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// rect - Pointer to a FS_RECTF receiving the character box. +// Return Value: +// On success, return TRUE and fill in |rect|. If |text_page| is +// invalid, or if |index| is out of bounds, then return FALSE, and the +// |rect| out parameter remains unmodified. +// Comments: +// All positions are measured in PDF "user space". +// +var + FPDFText_GetLooseCharBox: function(text_page: FPDF_TEXTPAGE; index: Integer; rect: PFS_RECTF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFText_GetMatrix +// Get the effective transformation matrix for a particular character. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage(). +// index - Zero-based index of the character. +// matrix - Pointer to a FS_MATRIX receiving the transformation +// matrix. +// Return Value: +// On success, return TRUE and fill in |matrix|. If |text_page| is +// invalid, or if |index| is out of bounds, or if |matrix| is NULL, +// then return FALSE, and |matrix| remains unmodified. +// +var + FPDFText_GetMatrix: function(text_page: FPDF_TEXTPAGE; index: Integer; matrix: PFS_MATRIX): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetCharOrigin +// Get origin of a particular character. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// index - Zero-based index of the character. +// x - Pointer to a double number receiving x coordinate of +// the character origin. +// y - Pointer to a double number receiving y coordinate of +// the character origin. +// Return Value: +// Whether the call succeeded. If false, x and y are unchanged. +// Comments: +// All positions are measured in PDF "user space". +// +var + FPDFText_GetCharOrigin: function(text_page: FPDF_TEXTPAGE; index: Integer; var x, y: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetCharIndexAtPos +// Get the index of a character at or nearby a certain position on the +// page. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// x - X position in PDF "user space". +// y - Y position in PDF "user space". +// xTolerance - An x-axis tolerance value for character hit +// detection, in point units. +// yTolerance - A y-axis tolerance value for character hit +// detection, in point units. +// Return Value: +// The zero-based index of the character at, or nearby the point (x,y). +// If there is no character at or nearby the point, return value will +// be -1. If an error occurs, -3 will be returned. +// +var + FPDFText_GetCharIndexAtPos: function(text_page: FPDF_TEXTPAGE; x, y, xTorelance, yTolerance: Double): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetText +// Extract unicode text string from the page. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// start_index - Index for the start characters. +// count - Number of UCS-2 values to be extracted. +// result - A buffer (allocated by application) receiving the +// extracted UCS-2 values. The buffer must be able to +// hold `count` UCS-2 values plus a terminator. +// Return Value: +// Number of characters written into the result buffer, including the +// trailing terminator. +// Comments: +// This function ignores characters without UCS-2 representations. +// It considers all characters on the page, even those that are not +// visible when the page has a cropbox. To filter out the characters +// outside of the cropbox, use FPDF_GetPageBoundingBox() and +// FPDFText_GetCharBox(). +// +var + FPDFText_GetText: function(text_page: FPDF_TEXTPAGE; start_index, count: Integer; result: PWideChar): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_CountRects +// Counts number of rectangular areas occupied by a segment of text, +// and caches the result for subsequent FPDFText_GetRect() calls. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// start_index - Index for the start character. +// count - Number of characters, or -1 for all remaining. +// Return value: +// Number of rectangles, 0 if text_page is null, or -1 on bad +// start_index. +// Comments: +// This function, along with FPDFText_GetRect can be used by +// applications to detect the position on the page for a text segment, +// so proper areas can be highlighted. The FPDFText_* functions will +// automatically merge small character boxes into bigger one if those +// characters are on the same line and use same font settings. +// +var + FPDFText_CountRects: function(text_page: FPDF_TEXTPAGE; start_index, count: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetRect +// Get a rectangular area from the result generated by +// FPDFText_CountRects. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// rect_index - Zero-based index for the rectangle. +// left - Pointer to a double value receiving the rectangle +// left boundary. +// top - Pointer to a double value receiving the rectangle +// top boundary. +// right - Pointer to a double value receiving the rectangle +// right boundary. +// bottom - Pointer to a double value receiving the rectangle +// bottom boundary. +// Return Value: +// On success, return TRUE and fill in |left|, |top|, |right|, and +// |bottom|. If |text_page| is invalid then return FALSE, and the out +// parameters remain unmodified. If |text_page| is valid but +// |rect_index| is out of bounds, then return FALSE and set the out +// parameters to 0. +// +var + FPDFText_GetRect: procedure(text_page: FPDF_TEXTPAGE; rect_index: Integer; var left, top, right, bottom: Double); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetBoundedText +// Extract unicode text within a rectangular boundary on the page. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// left - Left boundary. +// top - Top boundary. +// right - Right boundary. +// bottom - Bottom boundary. +// buffer - Caller-allocated buffer to receive UTF-16 values. +// buflen - Number of UTF-16 values (not bytes) that `buffer` +// is capable of holding. +// Return Value: +// If buffer is NULL or buflen is zero, return number of UTF-16 +// values (not bytes) of text present within the rectangle, excluding +// a terminating NUL. Generally you should pass a buffer at least one +// larger than this if you want a terminating NUL, which will be +// provided if space is available. Otherwise, return number of UTF-16 +// values copied into the buffer, including the terminating NUL when +// space for it is available. +// Comment: +// If the buffer is too small, as much text as will fit is copied into +// it. May return a split surrogate in that case. +// +var + FPDFText_GetBoundedText: function(text_page: FPDF_TEXTPAGE; left, top, right, bottom: Double; + buffer: PWideChar; buflen: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +const + // Flags used by FPDFText_FindStart function. + FPDF_MATCHCASE = $00000001; // If not set, it will not match case by default. + FPDF_MATCHWHOLEWORD = $00000002; // If not set, it will not match the whole word by default. + FPDF_CONSECUTIVE = $00000004; // If not set, it will skip past the current match to look for the next match. + +// Function: FPDFText_FindStart +// Start a search. +// Parameters: +// text_page - Handle to a text page information structure. Returned by FPDFText_LoadPage function. +// findwhat - A unicode match pattern. +// flags - Option flags. +// start_index - Start from this character. -1 for end of the page. +// Return Value: +// A handle for the search context. FPDFText_FindClose must be called +// to release this handle. +// +var + FPDFText_FindStart: function(text_page: FPDF_TEXTPAGE; findwhat: FPDF_WIDESTRING; flags: LongWord; + start_index: Integer): FPDF_SCHHANDLE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_FindNext +// Search in the direction from page start to end. +// Parameters: +// handle - A search context handle returned by FPDFText_FindStart. +// Return Value: +// Whether a match is found. +// +var + FPDFText_FindNext: function(handle: FPDF_SCHHANDLE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_FindPrev +// Search in the direction from page end to start. +// Parameters: +// handle - A search context handle returned by FPDFText_FindStart. +// Return Value: +// Whether a match is found. +// +var + FPDFText_FindPrev: function(handle: FPDF_SCHHANDLE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetSchResultIndex +// Get the starting character index of the search result. +// Parameters: +// handle - A search context handle returned by FPDFText_FindStart. +// Return Value: +// Index for the starting character. +// +var + FPDFText_GetSchResultIndex: function(handle: FPDF_SCHHANDLE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_GetSchCount +// Get the number of matched characters in the search result. +// Parameters: +// handle - A search context handle returned by FPDFText_FindStart. +// Return Value: +// Number of matched characters. +// +var + FPDFText_GetSchCount: function(handle: FPDF_SCHHANDLE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFText_FindClose +// Release a search context. +// Parameters: +// handle - A search context handle returned by FPDFText_FindStart. +// Return Value: +// None. +// +var + FPDFText_FindClose: procedure(handle: FPDF_SCHHANDLE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFLink_LoadWebLinks +// Prepare information about weblinks in a page. +// Parameters: +// text_page - Handle to a text page information structure. +// Returned by FPDFText_LoadPage function. +// Return Value: +// A handle to the page's links information structure, or +// NULL if something goes wrong. +// Comments: +// Weblinks are those links implicitly embedded in PDF pages. PDF also +// has a type of annotation called "link" (FPDFTEXT doesn't deal with +// that kind of link). FPDFTEXT weblink feature is useful for +// automatically detecting links in the page contents. For example, +// things like "https://www.example.com" will be detected, so +// applications can allow user to click on those characters to activate +// the link, even the PDF doesn't come with link annotations. +// +// FPDFLink_CloseWebLinks must be called to release resources. +// +var + FPDFLink_LoadWebLinks: function(text_page: FPDF_TEXTPAGE): FPDF_PAGELINK; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFLink_CountWebLinks +// Count number of detected web links. +// Parameters: +// link_page - Handle returned by FPDFLink_LoadWebLinks. +// Return Value: +// Number of detected web links. +// +var + FPDFLink_CountWebLinks: function(link_page: FPDF_PAGELINK): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFLink_GetURL +// Fetch the URL information for a detected web link. +// Parameters: +// link_page - Handle returned by FPDFLink_LoadWebLinks. +// link_index - Zero-based index for the link. +// buffer - A unicode buffer for the result. +// buflen - Number of 16-bit code units (not bytes) for the +// buffer, including an additional terminator. +// Return Value: +// If |buffer| is NULL or |buflen| is zero, return the number of 16-bit +// code units (not bytes) needed to buffer the result (an additional +// terminator is included in this count). +// Otherwise, copy the result into |buffer|, truncating at |buflen| if +// the result is too large to fit, and return the number of 16-bit code +// units actually copied into the buffer (the additional terminator is +// also included in this count). +// If |link_index| does not correspond to a valid link, then the result +// is an empty string. +// +var + FPDFLink_GetURL: function(link_page: FPDF_PAGELINK; link_index: Integer; buffer: PWideChar; buflen: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFLink_CountRects +// Count number of rectangular areas for the link. +// Parameters: +// link_page - Handle returned by FPDFLink_LoadWebLinks. +// link_index - Zero-based index for the link. +// Return Value: +// Number of rectangular areas for the link. If |link_index| does +// not correspond to a valid link, then 0 is returned. +// +var + FPDFLink_CountRects: function(link_page: FPDF_PAGELINK; link_index: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFLink_GetRect +// Fetch the boundaries of a rectangle for a link. +// Parameters: +// link_page - Handle returned by FPDFLink_LoadWebLinks. +// link_index - Zero-based index for the link. +// rect_index - Zero-based index for a rectangle. +// left - Pointer to a double value receiving the rectangle +// left boundary. +// top - Pointer to a double value receiving the rectangle +// top boundary. +// right - Pointer to a double value receiving the rectangle +// right boundary. +// bottom - Pointer to a double value receiving the rectangle +// bottom boundary. +// Return Value: +// On success, return TRUE and fill in |left|, |top|, |right|, and +// |bottom|. If |link_page| is invalid or if |link_index| does not +// correspond to a valid link, then return FALSE, and the out +// parameters remain unmodified. +// +var + FPDFLink_GetRect: procedure(link_page: FPDF_PAGELINK; link_index, rect_index: Integer; + var left, top, right, bottom: Double); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFLink_GetTextRange +// Fetch the start char index and char count for a link. +// Parameters: +// link_page - Handle returned by FPDFLink_LoadWebLinks. +// link_index - Zero-based index for the link. +// start_char_index - pointer to int receiving the start char index +// char_count - pointer to int receiving the char count +// Return Value: +// On success, return TRUE and fill in |start_char_index| and +// |char_count|. if |link_page| is invalid or if |link_index| does +// not correspond to a valid link, then return FALSE and the out +// parameters remain unmodified. +// +var + FPDFLink_GetTextRange: function(link_page: FPDF_PAGELINK; link_index: Integer; + start_char_index, char_count: PInteger): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFLink_CloseWebLinks +// Release resources used by weblink feature. +// Parameters: +// link_page - Handle returned by FPDFLink_LoadWebLinks. +// Return Value: +// None. +// +var + FPDFLink_CloseWebLinks: procedure(link_page: FPDF_PAGELINK); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_SEARCH_EX_H *** + +// Get the character index in |text_page| internal character list. +// +// text_page - a text page information structure. +// nTextIndex - index of the text returned from FPDFText_GetText(). +// +// Returns the index of the character in internal character list. -1 for error. +var + FPDFText_GetCharIndexFromTextIndex: function(text_page: FPDF_TEXTPAGE; nTextIndex: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// Get the text index in |text_page| internal character list. +// +// text_page - a text page information structure. +// nCharIndex - index of the character in internal character list. +// +// Returns the index of the text returned from FPDFText_GetText(). -1 for error. +var + FPDFText_GetTextIndexFromCharIndex: function(text_page: FPDF_TEXTPAGE; nCharIndex: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_PROGRESSIVE_H_ *** + +const + //Flags for progressive process status. + FPDF_RENDER_READER = 0; + FPDF_RENDER_TOBECOUNTINUED = 1; + FPDF_RENDER_DONE = 2; + FPDF_RENDER_FAILED = 3; + +// IFPDF_RENDERINFO interface. +type + PIFSDK_PAUSE = ^IFSDK_PAUSE; + IFSDK_PAUSE = record + // Version number of the interface. Currently must be 1. + version: Integer; + + // Method: NeedToPauseNow + // Check if we need to pause a progressive process now. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself + // Return Value: + // Non-zero for pause now, 0 for continue. + NeedToPauseNow: function(pThis: PIFSDK_PAUSE): FPDF_BOOL; cdecl; + + // A user defined data pointer, used by user's application. Can be NULL. + user: Pointer; + end; + PIFSDKPause = ^TIFSDKPause; + TIFSDKPause = IFSDK_PAUSE; + +// Experimental API. +// Function: FPDF_RenderPageBitmapWithColorScheme_Start +// Start to render page contents to a device independent bitmap +// progressively with a specified color scheme for the content. +// Parameters: +// bitmap - Handle to the device independent bitmap (as the +// output buffer). Bitmap handle can be created by +// FPDFBitmap_Create function. +// page - Handle to the page as returned by FPDF_LoadPage +// function. +// start_x - Left pixel position of the display area in the +// bitmap coordinate. +// start_y - Top pixel position of the display area in the +// bitmap coordinate. +// size_x - Horizontal size (in pixels) for displaying the +// page. +// size_y - Vertical size (in pixels) for displaying the page. +// rotate - Page orientation: 0 (normal), 1 (rotated 90 +// degrees clockwise), 2 (rotated 180 degrees), +// 3 (rotated 90 degrees counter-clockwise). +// flags - 0 for normal display, or combination of flags +// defined in fpdfview.h. With FPDF_ANNOT flag, it +// renders all annotations that does not require +// user-interaction, which are all annotations except +// widget and popup annotations. +// color_scheme - Color scheme to be used in rendering the |page|. +// If null, this function will work similar to +// FPDF_RenderPageBitmap_Start(). +// pause - The IFSDK_PAUSE interface. A callback mechanism +// allowing the page rendering process. +// Return value: +// Rendering Status. See flags for progressive process status for the +// details. +var + FPDF_RenderPageBitmapWithColorScheme_Start: function(bitmap: FPDF_BITMAP; page: FPDF_PAGE; + start_x, start_y, size_x, size_y: Integer; rotate: Integer; flags: Integer; + const color_scheme: PFPDF_COLORSCHEME; pause: PIFSDK_PAUSE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_RenderPageBitmap_Start +// Start to render page contents to a device independent bitmap +// progressively. +// Parameters: +// bitmap - Handle to the device independent bitmap (as the +// output buffer). Bitmap handle can be created by +// FPDFBitmap_Create(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// start_x - Left pixel position of the display area in the +// bitmap coordinates. +// start_y - Top pixel position of the display area in the bitmap +// coordinates. +// size_x - Horizontal size (in pixels) for displaying the page. +// size_y - Vertical size (in pixels) for displaying the page. +// rotate - Page orientation: 0 (normal), 1 (rotated 90 degrees +// clockwise), 2 (rotated 180 degrees), 3 (rotated 90 +// degrees counter-clockwise). +// flags - 0 for normal display, or combination of flags +// defined in fpdfview.h. With FPDF_ANNOT flag, it +// renders all annotations that does not require +// user-interaction, which are all annotations except +// widget and popup annotations. +// pause - The IFSDK_PAUSE interface.A callback mechanism +// allowing the page rendering process +// Return value: +// Rendering Status. See flags for progressive process status for the +// details. +var + FPDF_RenderPageBitmap_Start: function(bitmap: FPDF_BITMAP; page: FPDF_PAGE; + start_x, start_y, size_x, size_y: Integer; rotate: Integer; flags: Integer; + pause: PIFSDK_PAUSE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_RenderPage_Continue +// Continue rendering a PDF page. +// Parameters: +// page - Handle to the page, as returned by FPDF_LoadPage(). +// pause - The IFSDK_PAUSE interface (a callback mechanism +// allowing the page rendering process to be paused +// before it's finished). This can be NULL if you +// don't want to pause. +// Return value: +// The rendering status. See flags for progressive process status for +// the details. +var + FPDF_RenderPage_Continue: function(page: FPDF_PAGE; pause: PIFSDK_PAUSE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_RenderPage_Close +// Release the resource allocate during page rendering. Need to be +// called after finishing rendering or +// cancel the rendering. +// Parameters: +// page - Handle to the page, as returned by FPDF_LoadPage(). +// Return value: +// None. +var + FPDF_RenderPage_Close: procedure(page: FPDF_PAGE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_SIGNATURE_H_ *** + +// Experimental API. +// Function: FPDF_GetSignatureCount +// Get total number of signatures in the document. +// Parameters: +// document - Handle to document. Returned by FPDF_LoadDocument(). +// Return value: +// Total number of signatures in the document on success, -1 on error. +var + FPDF_GetSignatureCount: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_GetSignatureObject +// Get the Nth signature of the document. +// Parameters: +// document - Handle to document. Returned by FPDF_LoadDocument(). +// index - Index into the array of signatures of the document. +// Return value: +// Returns the handle to the signature, or NULL on failure. The caller +// does not take ownership of the returned FPDF_SIGNATURE. Instead, it +// remains valid until FPDF_CloseDocument() is called for the document. +var + FPDF_GetSignatureObject: function(document: FPDF_DOCUMENT; index: Integer): FPDF_SIGNATURE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFSignatureObj_GetContents +// Get the contents of a signature object. +// Parameters: +// signature - Handle to the signature object. Returned by +// FPDF_GetSignatureObject(). +// buffer - The address of a buffer that receives the contents. +// length - The size, in bytes, of |buffer|. +// Return value: +// Returns the number of bytes in the contents on success, 0 on error. +// +// For public-key signatures, |buffer| is either a DER-encoded PKCS#1 binary or +// a DER-encoded PKCS#7 binary. If |length| is less than the returned length, or +// |buffer| is NULL, |buffer| will not be modified. +var + FPDFSignatureObj_GetContents: function(signature: FPDF_SIGNATURE; buffer: Pointer; length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFSignatureObj_GetByteRange +// Get the byte range of a signature object. +// Parameters: +// signature - Handle to the signature object. Returned by +// FPDF_GetSignatureObject(). +// buffer - The address of a buffer that receives the +// byte range. +// length - The size, in ints, of |buffer|. +// Return value: +// Returns the number of ints in the byte range on +// success, 0 on error. +// +// |buffer| is an array of pairs of integers (starting byte offset, +// length in bytes) that describes the exact byte range for the digest +// calculation. If |length| is less than the returned length, or +// |buffer| is NULL, |buffer| will not be modified. +var + FPDFSignatureObj_GetByteRange: function(signature: FPDF_SIGNATURE; buffer: PInteger; length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFSignatureObj_GetSubFilter +// Get the encoding of the value of a signature object. +// Parameters: +// signature - Handle to the signature object. Returned by +// FPDF_GetSignatureObject(). +// buffer - The address of a buffer that receives the encoding. +// length - The size, in bytes, of |buffer|. +// Return value: +// Returns the number of bytes in the encoding name (including the +// trailing NUL character) on success, 0 on error. +// +// The |buffer| is always encoded in 7-bit ASCII. If |length| is less than the +// returned length, or |buffer| is NULL, |buffer| will not be modified. +var + FPDFSignatureObj_GetSubFilter: function(signature: FPDF_SIGNATURE; buffer: PAnsiChar; length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFSignatureObj_GetReason +// Get the reason (comment) of the signature object. +// Parameters: +// signature - Handle to the signature object. Returned by +// FPDF_GetSignatureObject(). +// buffer - The address of a buffer that receives the reason. +// length - The size, in bytes, of |buffer|. +// Return value: +// Returns the number of bytes in the reason on success, 0 on error. +// +// Regardless of the platform, the |buffer| is always in UTF-16LE encoding. The +// string is terminated by a UTF16 NUL character. If |length| is less than the +// returned length, or |buffer| is NULL, |buffer| will not be modified. +var + FPDFSignatureObj_GetReason: function(signature: FPDF_SIGNATURE; buffer: Pointer; length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFSignatureObj_GetTime +// Get the time of signing of a signature object. +// Parameters: +// signature - Handle to the signature object. Returned by +// FPDF_GetSignatureObject(). +// buffer - The address of a buffer that receives the time. +// length - The size, in bytes, of |buffer|. +// Return value: +// Returns the number of bytes in the encoding name (including the +// trailing NUL character) on success, 0 on error. +// +// The |buffer| is always encoded in 7-bit ASCII. If |length| is less than the +// returned length, or |buffer| is NULL, |buffer| will not be modified. +// +// The format of time is expected to be D:YYYYMMDDHHMMSS+XX'YY', i.e. it's +// percision is seconds, with timezone information. This value should be used +// only when the time of signing is not available in the (PKCS#7 binary) +// signature. +var + FPDFSignatureObj_GetTime: function(signature: FPDF_SIGNATURE; buffer: PAnsiChar; length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDFSignatureObj_GetDocMDPPermission +// Get the DocMDP permission of a signature object. +// Parameters: +// signature - Handle to the signature object. Returned by +// FPDF_GetSignatureObject(). +// Return value: +// Returns the permission (1, 2 or 3) on success, 0 on error. +var + FPDFSignatureObj_GetDocMDPPermission: function(signature: FPDF_SIGNATURE): UInt32; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// *** _FPDF_DOC_H_ *** + +const + PDFACTION_UNSUPPORTED = 0; // Unsupported action type. + PDFACTION_GOTO = 1; // Go to a destination within current document. + PDFACTION_REMOTEGOTO = 2; // Go to a destination within another document. + PDFACTION_URI = 3; // Universal Resource Identifier, including web pages and + // other Internet based resources. + PDFACTION_LAUNCH = 4; // Launch an application or open a file. + PDFACTION_EMBEDDEDGOTO = 5; // Go to a destination in an embedded file. + +// View destination fit types. See pdfmark reference v9, page 48. + PDFDEST_VIEW_UNKNOWN_MODE = 0; + PDFDEST_VIEW_XYZ = 1; + PDFDEST_VIEW_FIT = 2; + PDFDEST_VIEW_FITH = 3; + PDFDEST_VIEW_FITV = 4; + PDFDEST_VIEW_FITR = 5; + PDFDEST_VIEW_FITB = 6; + PDFDEST_VIEW_FITBH = 7; + PDFDEST_VIEW_FITBV = 8; + +// The file identifier entry type. See section 14.4 "File Identifiers" of the +// ISO 32000-1:2008 spec. +type + FPDF_FILEIDTYPE = ( + FILEIDTYPE_PERMANENT = 0, + FILEIDTYPE_CHANGING = 1 + ); + +// Get the first child of |bookmark|, or the first top-level bookmark item. +// +// document - handle to the document. +// bookmark - handle to the current bookmark. Pass NULL for the first top +// level item. +// +// Returns a handle to the first child of |bookmark| or the first top-level +// bookmark item. NULL if no child or top-level bookmark found. +// Note that another name for the bookmarks is the document outline, as +// described in ISO 32000-1:2008, section 12.3.3. +var + FPDFBookmark_GetFirstChild: function(document: FPDF_DOCUMENT; bookmark: FPDF_BOOKMARK): FPDF_BOOKMARK; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the next sibling of |bookmark|. +// +// document - handle to the document. +// bookmark - handle to the current bookmark. +// +// Returns a handle to the next sibling of |bookmark|, or NULL if this is the +// last bookmark at this level. +// +// Note that the caller is responsible for handling circular bookmark +// references, as may arise from malformed documents. +var + FPDFBookmark_GetNextSibling: function(document: FPDF_DOCUMENT; bookmark: FPDF_BOOKMARK): FPDF_BOOKMARK; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the title of |bookmark|. +// +// bookmark - handle to the bookmark. +// buffer - buffer for the title. May be NULL. +// buflen - the length of the buffer in bytes. May be 0. +// +// Returns the number of bytes in the title, including the terminating NUL +// character. The number of bytes is returned regardless of the |buffer| and +// |buflen| parameters. +// +// Regardless of the platform, the |buffer| is always in UTF-16LE encoding. The +// string is terminated by a UTF16 NUL character. If |buflen| is less than the +// required length, or |buffer| is NULL, |buffer| will not be modified. +var + FPDFBookmark_GetTitle: function(bookmark: FPDF_BOOKMARK; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the number of chlidren of |bookmark|. +// +// bookmark - handle to the bookmark. +// +// Returns a signed integer that represents the number of sub-items the given +// bookmark has. If the value is positive, child items shall be shown by default +// (open state). If the value is negative, child items shall be hidden by +// default (closed state). Please refer to PDF 32000-1:2008, Table 153. +// Returns 0 if the bookmark has no children or is invalid. +var + FPDFBookmark_GetCount: function(bookmark: FPDF_BOOKMARK): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Find the bookmark with |title| in |document|. +// +// document - handle to the document. +// title - the UTF-16LE encoded Unicode title for which to search. +// +// Returns the handle to the bookmark, or NULL if |title| can't be found. +// +// FPDFBookmark_Find() will always return the first bookmark found even if +// multiple bookmarks have the same |title|. +var + FPDFBookmark_Find: function(document: FPDF_DOCUMENT; title: FPDF_WIDESTRING): FPDF_BOOKMARK; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the destination associated with |bookmark|. +// +// document - handle to the document. +// bookmark - handle to the bookmark. +// +// Returns the handle to the destination data, or NULL if no destination is +// associated with |bookmark|. +var + FPDFBookmark_GetDest: function(document: FPDF_DOCUMENT; bookmark: FPDF_BOOKMARK): FPDF_DEST; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the action associated with |bookmark|. +// +// bookmark - handle to the bookmark. +// +// Returns the handle to the action data, or NULL if no action is associated +// with |bookmark|. +// If this function returns a valid handle, it is valid as long as |bookmark| is +// valid. +// If this function returns NULL, FPDFBookmark_GetDest() should be called to get +// the |bookmark| destination data. +var + FPDFBookmark_GetAction: function(bookmark: FPDF_BOOKMARK): FPDF_ACTION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the type of |action|. +// +// action - handle to the action. +// +// Returns one of: +// PDFACTION_UNSUPPORTED +// PDFACTION_GOTO +// PDFACTION_REMOTEGOTO +// PDFACTION_URI +// PDFACTION_LAUNCH +var + FPDFAction_GetType: function(action: FPDF_ACTION): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the destination of |action|. +// +// document - handle to the document. +// action - handle to the action. |action| must be a |PDFACTION_GOTO| or +// |PDFACTION_REMOTEGOTO|. +// +// Returns a handle to the destination data, or NULL on error, typically +// because the arguments were bad or the action was of the wrong type. +// +// In the case of |PDFACTION_REMOTEGOTO|, you must first call +// FPDFAction_GetFilePath(), then load the document at that path, then pass +// the document handle from that document as |document| to FPDFAction_GetDest(). +var + FPDFAction_GetDest: function(document: FPDF_DOCUMENT; action: FPDF_ACTION): FPDF_DEST; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the file path of |action|. +// +// action - handle to the action. |action| must be a |PDFACTION_LAUNCH| or +// |PDFACTION_REMOTEGOTO|. +// buffer - a buffer for output the path string. May be NULL. +// buflen - the length of the buffer, in bytes. May be 0. +// +// Returns the number of bytes in the file path, including the trailing NUL +// character, or 0 on error, typically because the arguments were bad or the +// action was of the wrong type. +// +// Regardless of the platform, the |buffer| is always in UTF-8 encoding. +// If |buflen| is less than the returned length, or |buffer| is NULL, |buffer| +// will not be modified. +var + FPDFAction_GetFilePath: function(action: FPDF_ACTION; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the URI path of |action|. +// +// document - handle to the document. +// action - handle to the action. Must be a |PDFACTION_URI|. +// buffer - a buffer for the path string. May be NULL. +// buflen - the length of the buffer, in bytes. May be 0. +// +// Returns the number of bytes in the URI path, including the trailing NUL +// character, or 0 on error, typically because the arguments were bad or the +// action was of the wrong type. +// +// The |buffer| may contain badly encoded data. The caller should validate the +// output. e.g. Check to see if it is UTF-8. +// +// If |buflen| is less than the returned length, or |buffer| is NULL, |buffer| +// will not be modified. +// +// Historically, the documentation for this API claimed |buffer| is always +// encoded in 7-bit ASCII, but did not actually enforce it. +// https://pdfium.googlesource.com/pdfium.git/+/d609e84cee2e14a18333247485af91df48a40592 +// added that enforcement, but that did not work well for real world PDFs that +// used UTF-8. As of this writing, this API reverted back to its original +// behavior prior to commit d609e84cee. +var + FPDFAction_GetURIPath: function(document: FPDF_DOCUMENT; action: FPDF_ACTION; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the page index of |dest|. +// +// document - handle to the document. +// dest - handle to the destination. +// +// Returns the 0-based page index containing |dest|. Returns -1 on error. +var + FPDFDest_GetDestPageIndex: function(document: FPDF_DOCUMENT; dest: FPDF_DEST): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the view (fit type) specified by |dest|. +// +// dest - handle to the destination. +// pNumParams - receives the number of view parameters, which is at most 4. +// pParams - buffer to write the view parameters. Must be at least 4 +// FS_FLOATs long. +// Returns one of the PDFDEST_VIEW_* constants, PDFDEST_VIEW_UNKNOWN_MODE if +// |dest| does not specify a view. +var + FPDFDest_GetView: function(dest: FPDF_DEST; pNumParams: PLongWord; pParams: PFS_FLOAT): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the (x, y, zoom) location of |dest| in the destination page, if the +// destination is in [page /XYZ x y zoom] syntax. +// +// dest - handle to the destination. +// hasXVal - out parameter; true if the x value is not null +// hasYVal - out parameter; true if the y value is not null +// hasZoomVal - out parameter; true if the zoom value is not null +// x - out parameter; the x coordinate, in page coordinates. +// y - out parameter; the y coordinate, in page coordinates. +// zoom - out parameter; the zoom value. +// Returns TRUE on successfully reading the /XYZ value. +// +// Note the [x, y, zoom] values are only set if the corresponding hasXVal, +// hasYVal or hasZoomVal flags are true. +var + FPDFDest_GetLocationInPage: function(dest: FPDF_DEST; var hasXVal, hasYVal, hasZoomVal: FPDF_BOOL; + var x, y, zoom: FS_FLOAT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Find a link at point (|x|,|y|) on |page|. +// +// page - handle to the document page. +// x - the x coordinate, in the page coordinate system. +// y - the y coordinate, in the page coordinate system. +// +// Returns a handle to the link, or NULL if no link found at the given point. +// +// You can convert coordinates from screen coordinates to page coordinates using +// FPDF_DeviceToPage(). +var + FPDFLink_GetLinkAtPoint: function(page: FPDF_PAGE; x, y: Double): FPDF_LINK; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Find the Z-order of link at point (|x|,|y|) on |page|. +// +// page - handle to the document page. +// x - the x coordinate, in the page coordinate system. +// y - the y coordinate, in the page coordinate system. +// +// Returns the Z-order of the link, or -1 if no link found at the given point. +// Larger Z-order numbers are closer to the front. +// +// You can convert coordinates from screen coordinates to page coordinates using +// FPDF_DeviceToPage(). +var + FPDFLink_GetLinkZOrderAtPoint: function(page: FPDF_PAGE; x, y: Double): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get destination info for |link|. +// +// document - handle to the document. +// link - handle to the link. +// +// Returns a handle to the destination, or NULL if there is no destination +// associated with the link. In this case, you should call FPDFLink_GetAction() +// to retrieve the action associated with |link|. +var + FPDFLink_GetDest: function(document: FPDF_DOCUMENT; link: FPDF_LINK): FPDF_DEST; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get action info for |link|. +// +// link - handle to the link. +// +// Returns a handle to the action associated to |link|, or NULL if no action. +// If this function returns a valid handle, it is valid as long as |link| is +// valid. +var + FPDFLink_GetAction: function(link: FPDF_LINK): FPDF_ACTION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Enumerates all the link annotations in |page|. +// +// page - handle to the page. +// start_pos - the start position, should initially be 0 and is updated with +// the next start position on return. +// link_annot - the link handle for |startPos|. +// +// Returns TRUE on success. +var + FPDFLink_Enumerate: function(page: FPDF_PAGE; var start_pos: Integer; link_annot: PFPDF_LINK): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets FPDF_ANNOTATION object for |link_annot|. +// +// page - handle to the page in which FPDF_LINK object is present. +// link_annot - handle to link annotation. +// +// Returns FPDF_ANNOTATION from the FPDF_LINK and NULL on failure, +// if the input link annot or page is NULL. +var + FPDFLink_GetAnnot: function(page: FPDF_PAGE; link_annot: FPDF_LINK): FPDF_ANNOTATION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the rectangle for |link_annot|. +// +// link_annot - handle to the link annotation. +// rect - the annotation rectangle. +// +// Returns true on success. +var + FPDFLink_GetAnnotRect: function(link_annot: FPDF_LINK; rect: PFS_RECTF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the count of quadrilateral points to the |link_annot|. +// +// link_annot - handle to the link annotation. +// +// Returns the count of quadrilateral points. +var + FPDFLink_CountQuadPoints: function(link_annot: FPDF_LINK): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the quadrilateral points for the specified |quad_index| in |link_annot|. +// +// link_annot - handle to the link annotation. +// quad_index - the specified quad point index. +// quad_points - receives the quadrilateral points. +// +// Returns true on success. +var + FPDFLink_GetQuadPoints: function(link_annot: FPDF_LINK; quad_index: Integer; quad_points: PFS_QUADPOINTSF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets an additional-action from |page|. +// +// page - handle to the page, as returned by FPDF_LoadPage(). +// aa_type - the type of the page object's addtional-action, defined +// in public/fpdf_formfill.h +// +// Returns the handle to the action data, or NULL if there is no +// additional-action of type |aa_type|. +// If this function returns a valid handle, it is valid as long as |page| is +// valid. +var + FPDF_GetPageAAction: function(page: FPDF_PAGE; aa_type: Integer): FPDF_ACTION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the file identifer defined in the trailer of |document|. +// +// document - handle to the document. +// id_type - the file identifier type to retrieve. +// buffer - a buffer for the file identifier. May be NULL. +// buflen - the length of the buffer, in bytes. May be 0. +// +// Returns the number of bytes in the file identifier, including the NUL +// terminator. +// +// The |buffer| is always a byte string. The |buffer| is followed by a NUL +// terminator. If |buflen| is less than the returned length, or |buffer| is +// NULL, |buffer| will not be modified. +var + FPDF_GetFileIdentifier: function(document: FPDF_DOCUMENT; id_type: FPDF_FILEIDTYPE; buffer: Pointer; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get meta-data |tag| content from |document|. +// +// document - handle to the document. +// tag - the tag to retrieve. The tag can be one of: +// Title, Author, Subject, Keywords, Creator, Producer, +// CreationDate, or ModDate. +// For detailed explanations of these tags and their respective +// values, please refer to PDF Reference 1.6, section 10.2.1, +// 'Document Information Dictionary'. +// buffer - a buffer for the tag. May be NULL. +// buflen - the length of the buffer, in bytes. May be 0. +// +// Returns the number of bytes in the tag, including trailing zeros. +// +// The |buffer| is always encoded in UTF-16LE. The |buffer| is followed by two +// bytes of zeros indicating the end of the string. If |buflen| is less than +// the returned length, or |buffer| is NULL, |buffer| will not be modified. +// +// For linearized files, FPDFAvail_IsFormAvail must be called before this, and +// it must have returned PDF_FORM_AVAIL or PDF_FORM_NOTEXIST. Before that, there +// is no guarantee the metadata has been loaded. +var + FPDF_GetMetaText: function(doc: FPDF_DOCUMENT; tag: FPDF_BYTESTRING; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the page label for |page_index| from |document|. +// +// document - handle to the document. +// page_index - the 0-based index of the page. +// buffer - a buffer for the page label. May be NULL. +// buflen - the length of the buffer, in bytes. May be 0. +// +// Returns the number of bytes in the page label, including trailing zeros. +// +// The |buffer| is always encoded in UTF-16LE. The |buffer| is followed by two +// bytes of zeros indicating the end of the string. If |buflen| is less than +// the returned length, or |buffer| is NULL, |buffer| will not be modified. +var + FPDF_GetPageLabel: function(document: FPDF_DOCUMENT; page_index: integer; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_SYSFONTINFO_H_ *** + +const + // Character sets for the font + FXFONT_ANSI_CHARSET = 0; + FXFONT_DEFAULT_CHARSET = 1; + FXFONT_SYMBOL_CHARSET = 2; + FXFONT_SHIFTJIS_CHARSET = 128; + FXFONT_HANGEUL_CHARSET = 129; + FXFONT_GB2312_CHARSET = 134; + FXFONT_CHINESEBIG5_CHARSET = 136; + FXFONT_GREEK_CHARSET = 161; + FXFONT_VIETNAMESE_CHARSET = 163; + FXFONT_HEBREW_CHARSET = 177; + FXFONT_ARABIC_CHARSET = 178; + FXFONT_CYRILLIC_CHARSET = 204; + FXFONT_THAI_CHARSET = 222; + FXFONT_EASTERNEUROPEAN_CHARSET = 238; + + + // Font pitch and family flags + FXFONT_FF_FIXEDPITCH = 1; + FXFONT_FF_ROMAN = 1 shl 4; + FXFONT_FF_SCRIPT = 4 shl 4; + + // Typical weight values + FXFONT_FW_NORMAL = 400; + FXFONT_FW_BOLD = 700; + +// Interface: FPDF_SYSFONTINFO +// Interface for getting system font information and font mapping +type + PFPDF_SYSFONTINFO = ^FPDF_SYSFONTINFO; + FPDF_SYSFONTINFO = record + // Version number of the interface. Currently must be 1. + version: Integer; + + // Method: Release + // Give implementation a chance to release any data after the + // interface is no longer used. + // Interface Version: + // 1 + // Implementation Required: + // No + // Parameters: + // pThis - Pointer to the interface structure itself + // Return Value: + // None + // Comments: + // Called by PDFium during the final cleanup process. + Release: procedure(pThis: PFPDF_SYSFONTINFO); cdecl; + + // Method: EnumFonts + // Enumerate all fonts installed on the system + // Interface Version: + // 1 + // Implementation Required: + // No + // Parameters: + // pThis - Pointer to the interface structure itself + // pMapper - An opaque pointer to internal font mapper, used + // when calling FPDF_AddInstalledFont(). + // Return Value: + // None + // Comments: + // Implementations should call FPDF_AddInstalledFont() function for + // each font found. Only TrueType/OpenType and Type1 fonts are + // accepted by PDFium. + EnumFonts: procedure(pThis: PFPDF_SYSFONTINFO; pMapper: Pointer); cdecl; + + // Method: MapFont + // Use the system font mapper to get a font handle from requested + // parameters. + // Interface Version: + // 1 + // Implementation Required: + // Required if GetFont method is not implemented. + // Parameters: + // pThis - Pointer to the interface structure itself + // weight - Weight of the requested font. 400 is normal and + // 700 is bold. + // bItalic - Italic option of the requested font, TRUE or + // FALSE. + // charset - Character set identifier for the requested font. + // See above defined constants. + // pitch_family - A combination of flags. See above defined + // constants. + // face - Typeface name. Currently use system local encoding + // only. + // bExact - Obsolete: this parameter is now ignored. + // Return Value: + // An opaque pointer for font handle, or NULL if system mapping is + // not supported. + // Comments: + // If the system supports native font mapper (like Windows), + // implementation can implement this method to get a font handle. + // Otherwise, PDFium will do the mapping and then call GetFont + // method. Only TrueType/OpenType and Type1 fonts are accepted + // by PDFium. + MapFont: function(pThis: PFPDF_SYSFONTINFO; weight, bItalic, charset, pitch_family: Integer; + face: PAnsiChar; bExact: PInteger): Pointer; cdecl; + + // Method: GetFont + // Get a handle to a particular font by its internal ID + // Interface Version: + // 1 + // Implementation Required: + // Required if MapFont method is not implemented. + // Return Value: + // An opaque pointer for font handle. + // Parameters: + // pThis - Pointer to the interface structure itself + // face - Typeface name in system local encoding. + // Comments: + // If the system mapping not supported, PDFium will do the font + // mapping and use this method to get a font handle. + GetFont: function(pThis: PFPDF_SYSFONTINFO; face: PAnsiChar): Pointer; cdecl; + + // Method: GetFontData + // Get font data from a font + // Interface Version: + // 1 + // Implementation Required: + // Yes + // Parameters: + // pThis - Pointer to the interface structure itself + // hFont - Font handle returned by MapFont or GetFont method + // table - TrueType/OpenType table identifier (refer to + // TrueType specification), or 0 for the whole file. + // buffer - The buffer receiving the font data. Can be NULL if + // not provided. + // buf_size - Buffer size, can be zero if not provided. + // Return Value: + // Number of bytes needed, if buffer not provided or not large + // enough, or number of bytes written into buffer otherwise. + // Comments: + // Can read either the full font file, or a particular + // TrueType/OpenType table. + GetFontData: function(pThis: PFPDF_SYSFONTINFO; hFont: Pointer; table: LongWord; buffer: PWideChar; + buf_size: LongWord): LongWord; cdecl; + + // Method: GetFaceName + // Get face name from a font handle + // Interface Version: + // 1 + // Implementation Required: + // No + // Parameters: + // pThis - Pointer to the interface structure itself + // hFont - Font handle returned by MapFont or GetFont method + // buffer - The buffer receiving the face name. Can be NULL if + // not provided + // buf_size - Buffer size, can be zero if not provided + // Return Value: + // Number of bytes needed, if buffer not provided or not large + // enough, or number of bytes written into buffer otherwise. + GetFaceName: function(pThis: PFPDF_SYSFONTINFO; hFont: Pointer; buffer: PAnsiChar; buf_size: LongWord): LongWord; cdecl; + + // Method: GetFontCharset + // Get character set information for a font handle + // Interface Version: + // 1 + // Implementation Required: + // No + // Parameters: + // pThis - Pointer to the interface structure itself + // hFont - Font handle returned by MapFont or GetFont method + // Return Value: + // Character set identifier. See defined constants above. + GetFontCharset: function(pThis: PFPDF_SYSFONTINFO; hFont: Pointer): Integer; cdecl; + + // Method: DeleteFont + // Delete a font handle + // Interface Version: + // 1 + // Implementation Required: + // Yes + // Parameters: + // pThis - Pointer to the interface structure itself + // hFont - Font handle returned by MapFont or GetFont method + // Return Value: + // None + DeleteFont: procedure(pThis: PFPDF_SYSFONTINFO; hFont: Pointer); cdecl; + end; + PFPdfSysFontInfo = ^TFPdfSysFontInfo; + TFPdfSysFontInfo = FPDF_SYSFONTINFO; + + // Struct: FPDF_CharsetFontMap + // Provides the name of a font to use for a given charset value. + PFPDF_CharsetFontMap = ^FPDF_CharsetFontMap; + FPDF_CharsetFontMap = record + charset: Integer; // Character Set Enum value, see FXFONT_*_CHARSET above. + fontname: PAnsiChar; // Name of default font to use with that charset. + end; + PFPdfCharsetFontMap = ^TFPdfCharsetFontMap; + TFPdfCharsetFontMap = FPDF_CharsetFontMap; + +// Function: FPDF_GetDefaultTTFMap +// Returns a pointer to the default character set to TT Font name map. The +// map is an array of FPDF_CharsetFontMap structs, with its end indicated +// by a { -1, NULL } entry. +// Parameters: +// None. +// Return Value: +// Pointer to the Charset Font Map. +// Note: +// Once FPDF_GetDefaultTTFMapCount() and FPDF_GetDefaultTTFMapEntry() are no +// longer experimental, this API will be marked as deprecated. +// See https://crbug.com/348468114 +var + FPDF_GetDefaultTTFMap: function: PFPDF_CharsetFontMap; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// +// Function: FPDF_GetDefaultTTFMapCount +// Returns the number of entries in the default character set to TT Font name +// map. +// Parameters: +// None. +// Return Value: +// The number of entries in the map. +var + FPDF_GetDefaultTTFMapCount: function(): SIZE_T; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// +// Function: FPDF_GetDefaultTTFMapEntry +// Returns an entry in the default character set to TT Font name map. +// Parameters: +// index - The index to the entry in the map to retrieve. +// Return Value: +// A pointer to the entry, if it is in the map, or NULL if the index is out +// of bounds. +var + FPDF_GetDefaultTTFMapEntry: function(index: SIZE_T): PFPDF_CharsetFontMap; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_AddInstalledFont +// Add a system font to the list in PDFium. +// Comments: +// This function is only called during the system font list building +// process. +// Parameters: +// mapper - Opaque pointer to Foxit font mapper +// face - The font face name +// charset - Font character set. See above defined constants. +// Return Value: +// None. +var + FPDF_AddInstalledFont: procedure(mapper: Pointer; face: PAnsiChar; charset: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_SetSystemFontInfo +// Set the system font info interface into PDFium +// Parameters: +// pFontInfo - Pointer to a FPDF_SYSFONTINFO structure +// Return Value: +// None +// Comments: +// Platform support implementation should implement required methods of +// FFDF_SYSFONTINFO interface, then call this function during PDFium +// initialization process. +// +// Call this with NULL to tell PDFium to stop using a previously set +// |FPDF_SYSFONTINFO|. +var + FPDF_SetSystemFontInfo: procedure(pFontInfo: PFPDF_SYSFONTINFO); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_GetDefaultSystemFontInfo +// Get default system font info interface for current platform +// Parameters: +// None +// Return Value: +// Pointer to a FPDF_SYSFONTINFO structure describing the default +// interface, or NULL if the platform doesn't have a default interface. +// Application should call FPDF_FreeDefaultSystemFontInfo to free the +// returned pointer. +// Comments: +// For some platforms, PDFium implements a default version of system +// font info interface. The default implementation can be passed to +// FPDF_SetSystemFontInfo(). +var + FPDF_GetDefaultSystemFontInfo: function(): FPDF_SYSFONTINFO; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_FreeDefaultSystemFontInfo +// Free a default system font info interface +// Parameters: +// pFontInfo - Pointer to a FPDF_SYSFONTINFO structure +// Return Value: +// None +// Comments: +// This function should be called on the output from +// FPDF_GetDefaultSystemFontInfo() once it is no longer needed. +var + FPDF_FreeDefaultSystemFontInfo: procedure(pFontInfo: PFPDF_SYSFONTINFO); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_EXT_H_ *** + +const + //flags for type of unsupport object. + FPDF_UNSP_DOC_XFAFORM = 1; // Unsupported XFA form. + FPDF_UNSP_DOC_PORTABLECOLLECTION = 2; // Unsupported portable collection. + FPDF_UNSP_DOC_ATTACHMENT = 3; // Unsupported attachment. + FPDF_UNSP_DOC_SECURITY = 4; // Unsupported security. + FPDF_UNSP_DOC_SHAREDREVIEW = 5; // Unsupported shared review. + FPDF_UNSP_DOC_SHAREDFORM_ACROBAT = 6; // Unsupported shared form, acrobat. + FPDF_UNSP_DOC_SHAREDFORM_FILESYSTEM = 7; // Unsupported shared form, filesystem. + FPDF_UNSP_DOC_SHAREDFORM_EMAIL = 8; // Unsupported shared form, email. + FPDF_UNSP_ANNOT_3DANNOT = 11; // Unsupported 3D annotation. + FPDF_UNSP_ANNOT_MOVIE = 12; // Unsupported movie annotation. + FPDF_UNSP_ANNOT_SOUND = 13; // Unsupported sound annotation. + FPDF_UNSP_ANNOT_SCREEN_MEDIA = 14; // Unsupported screen media annotation. + FPDF_UNSP_ANNOT_SCREEN_RICHMEDIA = 15; // Unsupported screen rich media annotation. + FPDF_UNSP_ANNOT_ATTACHMENT = 16; // Unsupported attachment annotation. + FPDF_UNSP_ANNOT_SIG = 17; // Unsupported signature annotation. + +type + PUNSUPPORT_INFO = ^UNSUPPORT_INFO; + UNSUPPORT_INFO = record + // Version number of the interface. Must be 1. + version: Integer; + + // Unsupported object notification function. + // Interface Version: 1 + // Implementation Required: Yes + // + // pThis - pointer to the interface structure. + // nType - the type of unsupported object. One of the |FPDF_UNSP_*| entries. + FSDK_UnSupport_Handler: procedure(pThis: PUNSUPPORT_INFO; nType: Integer); cdecl; + end; + PUnsupportInfo = ^TUnsupportInfo; + TUnsupportInfo = UNSUPPORT_INFO; + +// Setup an unsupported object handler. +// +// unsp_info - Pointer to an UNSUPPORT_INFO structure. +// +// Returns TRUE on success. +var + FSDK_SetUnSpObjProcessHandler: function(unsp_info: PUNSUPPORT_INFO): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set replacement function for calls to time(). +// +// This API is intended to be used only for testing, thus may cause PDFium to +// behave poorly in production environments. +// +// func - Function pointer to alternate implementation of time(), or +// NULL to restore to actual time() call itself. +type + TFPDFTimeFunction = function: TIME_T; cdecl; +var + FSDK_SetTimeFunction: procedure(func: TFPDFTimeFunction); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set replacement function for calls to localtime(). +// +// This API is intended to be used only for testing, thus may cause PDFium to +// behave poorly in production environments. +// +// func - Function pointer to alternate implementation of localtime(), or +// NULL to restore to actual localtime() call itself. +type + PFPDF_struct_tm = ^FPDF_struct_tm; + FPDF_struct_tm = record + tm_sec: Integer; + tm_min: Integer; + tm_hour: Integer; + tm_mday: Integer; + tm_mon: Integer; + tm_year: Integer; + tm_wday: Integer; + tm_yday: Integer; + tm_isdst: Integer; + end; + +type + TFPDFLocaltimeFunction = function(timer: PTIME_T): PFPDF_struct_tm; cdecl; +var + FSDK_SetLocaltimeFunction: procedure(func: TFPDFLocaltimeFunction); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +const + PAGEMODE_UNKNOWN = -1; // Unknown page mode. + PAGEMODE_USENONE = 0; // Document outline, and thumbnails hidden. + PAGEMODE_USEOUTLINES = 1; // Document outline visible. + PAGEMODE_USETHUMBS = 2; // Thumbnail images visible. + PAGEMODE_FULLSCREEN = 3; // Full-screen mode, no menu bar, window controls, or other decorations visible. + PAGEMODE_USEOC = 4; // Optional content group panel visible. + PAGEMODE_USEATTACHMENTS = 5; // Attachments panel visible. + +// Get the document's PageMode. +// +// doc - Handle to document. +// +// Returns one of the |PAGEMODE_*| flags defined above. +// +// The page mode defines how the document should be initially displayed. +var + FPDFDoc_GetPageMode: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_DATAAVAIL_H_ *** + +const + PDF_LINEARIZATION_UNKNOWN = -1; + PDF_NOT_LINEARIZED = 0; + PDF_LINEARIZED = 1; + + PDF_DATA_ERROR = -1; + PDF_DATA_NOTAVAIL = 0; + PDF_DATA_AVAIL = 1; + + PDF_FORM_ERROR = -1; + PDF_FORM_NOTAVAIL = 0; + PDF_FORM_AVAIL = 1; + PDF_FORM_NOTEXIST = 2; + +type + // Interface for checking whether sections of the file are available. + PFX_FILEAVAIL = ^FX_FILEAVAIL; + FX_FILEAVAIL = record + // Version number of the interface. Must be 1. + version: Integer; + + // Reports if the specified data section is currently available. A section is + // available if all bytes in the section are available. + // + // Interface Version: 1 + // Implementation Required: Yes + // + // pThis - pointer to the interface structure. + // offset - the offset of the data section in the file. + // size - the size of the data section. + // + // Returns true if the specified data section at |offset| of |size| + // is available. + IsDataAvail: function(pThis: PFX_FILEAVAIL; offset, size: SIZE_T): FPDF_BOOL; cdecl; + end; + PFXFileAvail = ^TFXFileAvail; + TFXFileAvail = FX_FILEAVAIL; + +// Create a document availability provider. +// +// file_avail - pointer to file availability interface. +// file - pointer to a file access interface. +// +// Returns a handle to the document availability provider, or NULL on error. +// +// FPDFAvail_Destroy() must be called when done with the availability provider. +var + FPDFAvail_Create: function(file_avail: PFX_FILEAVAIL; file_: PFPDF_FILEACCESS): FPDF_AVAIL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Destroy the |avail| document availability provider. +// +// avail - handle to document availability provider to be destroyed. +var + FPDFAvail_Destroy: procedure(avail: FPDF_AVAIL); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Download hints interface. Used to receive hints for further downloading. +type + PFX_DOWNLOADHINTS = ^FX_DOWNLOADHINTS; + FX_DOWNLOADHINTS = record + // Version number of the interface. Must be 1. + version: Integer; + + // Add a section to be downloaded. + // + // Interface Version: 1 + // Implementation Required: Yes + // + // pThis - pointer to the interface structure. + // offset - the offset of the hint reported to be downloaded. + // size - the size of the hint reported to be downloaded. + // + // The |offset| and |size| of the section may not be unique. Part of the + // section might be already available. The download manager must deal with + // overlapping sections. + AddSegment: procedure(pThis: PFX_DOWNLOADHINTS; offset, size: SIZE_T); cdecl; + end; + PFXDownloadHints = ^TFXDownloadHints; + TFXDownloadHints = FX_DOWNLOADHINTS; + +// Checks if the document is ready for loading, if not, gets download hints. +// +// avail - handle to document availability provider. +// hints - pointer to a download hints interface. +// +// Returns one of: +// PDF_DATA_ERROR: A common error is returned. Data availability unknown. +// PDF_DATA_NOTAVAIL: Data not yet available. +// PDF_DATA_AVAIL: Data available. +// +// Applications should call this function whenever new data arrives, and process +// all the generated download hints, if any, until the function returns +// |PDF_DATA_ERROR| or |PDF_DATA_AVAIL|. +// if hints is nullptr, the function just check current document availability. +// +// Once all data is available, call FPDFAvail_GetDocument() to get a document +// handle. +var + FPDFAvail_IsDocAvail: function(avail: FPDF_AVAIL; hints: PFX_DOWNLOADHINTS): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get document from the availability provider. +// +// avail - handle to document availability provider. +// password - password for decrypting the PDF file. Optional. +// +// Returns a handle to the document. +// +// When FPDFAvail_IsDocAvail() returns TRUE, call FPDFAvail_GetDocument() to +// retrieve the document handle. +// See the comments for FPDF_LoadDocument() regarding the encoding for +// |password|. +var + FPDFAvail_GetDocument: function(avail: FPDF_AVAIL; password: FPDF_BYTESTRING): FPDF_DOCUMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the page number for the first available page in a linearized PDF. +// +// doc - document handle. +// +// Returns the zero-based index for the first available page. +// +// For most linearized PDFs, the first available page will be the first page, +// however, some PDFs might make another page the first available page. +// For non-linearized PDFs, this function will always return zero. +var + FPDFAvail_GetFirstPageNum: function(doc: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Check if |page_index| is ready for loading, if not, get the +// |FX_DOWNLOADHINTS|. +// +// avail - handle to document availability provider. +// page_index - index number of the page. Zero for the first page. +// hints - pointer to a download hints interface. Populated if +// |page_index| is not available. +// +// Returns one of: +// PDF_DATA_ERROR: A common error is returned. Data availability unknown. +// PDF_DATA_NOTAVAIL: Data not yet available. +// PDF_DATA_AVAIL: Data available. +// +// This function can be called only after FPDFAvail_GetDocument() is called. +// Applications should call this function whenever new data arrives and process +// all the generated download |hints|, if any, until this function returns +// |PDF_DATA_ERROR| or |PDF_DATA_AVAIL|. Applications can then perform page +// loading. +// if hints is nullptr, the function just check current availability of +// specified page. +var + FPDFAvail_IsPageAvail: function(avail: FPDF_AVAIL; page_index: Integer; hints: PFX_DOWNLOADHINTS): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Check if form data is ready for initialization, if not, get the +// |FX_DOWNLOADHINTS|. +// +// avail - handle to document availability provider. +// hints - pointer to a download hints interface. Populated if form is not +// ready for initialization. +// +// Returns one of: +// PDF_FORM_ERROR: A common eror, in general incorrect parameters. +// PDF_FORM_NOTAVAIL: Data not available. +// PDF_FORM_AVAIL: Data available. +// PDF_FORM_NOTEXIST: No form data. +// +// This function can be called only after FPDFAvail_GetDocument() is called. +// The application should call this function whenever new data arrives and +// process all the generated download |hints|, if any, until the function +// |PDF_FORM_ERROR|, |PDF_FORM_AVAIL| or |PDF_FORM_NOTEXIST|. +// if hints is nullptr, the function just check current form availability. +// +// Applications can then perform page loading. It is recommend to call +// FPDFDOC_InitFormFillEnvironment() when |PDF_FORM_AVAIL| is returned. +var + FPDFAvail_IsFormAvail: function(avail: FPDF_AVAIL; hints: PFX_DOWNLOADHINTS): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Check whether a document is a linearized PDF. +// +// avail - handle to document availability provider. +// +// Returns one of: +// PDF_LINEARIZED +// PDF_NOT_LINEARIZED +// PDF_LINEARIZATION_UNKNOWN +// +// FPDFAvail_IsLinearized() will return |PDF_LINEARIZED| or |PDF_NOT_LINEARIZED| +// when we have 1k of data. If the files size less than 1k, it returns +// |PDF_LINEARIZATION_UNKNOWN| as there is insufficient information to determine +// if the PDF is linearlized. +var + FPDFAvail_IsLinearized: function(avail: FPDF_AVAIL): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPD_FORMFILL_H *** + +const + // These values are return values for a public API, so should not be changed + // other than the count when adding new values. + FORMTYPE_NONE = 0; // Document contains no forms + FORMTYPE_ACRO_FORM = 1; // Forms are specified using AcroForm spec + FORMTYPE_XFA_FULL = 2; // Forms are specified using the entire XFA spec + FORMTYPE_XFA_FOREGROUND = 3; // Forms are specified using the XFAF subset of XFA spec + FORMTYPE_COUNT = 4; // The number of form types + + JSPLATFORM_ALERT_BUTTON_OK = 0; // OK button + JSPLATFORM_ALERT_BUTTON_OKCANCEL = 1; // OK & Cancel buttons + JSPLATFORM_ALERT_BUTTON_YESNO = 2; // Yes & No buttons + JSPLATFORM_ALERT_BUTTON_YESNOCANCEL = 3; // Yes, No & Cancel buttons + JSPLATFORM_ALERT_BUTTON_DEFAULT = JSPLATFORM_ALERT_BUTTON_OK; + + JSPLATFORM_ALERT_ICON_ERROR = 0; // Error + JSPLATFORM_ALERT_ICON_WARNING = 1; // Warning + JSPLATFORM_ALERT_ICON_QUESTION = 2; // Question + JSPLATFORM_ALERT_ICON_STATUS = 3; // Status + JSPLATFORM_ALERT_ICON_ASTERISK = 4; // Asterisk + JSPLATFORM_ALERT_ICON_DEFAULT = JSPLATFORM_ALERT_ICON_ERROR; + + JSPLATFORM_ALERT_RETURN_OK = 1; // OK + JSPLATFORM_ALERT_RETURN_CANCEL = 2; // Cancel + JSPLATFORM_ALERT_RETURN_NO = 3; // No + JSPLATFORM_ALERT_RETURN_YES = 4; // Yes + + JSPLATFORM_BEEP_ERROR = 0; // Error + JSPLATFORM_BEEP_WARNING = 1; // Warning + JSPLATFORM_BEEP_QUESTION = 2; // Question + JSPLATFORM_BEEP_STATUS = 3; // Status + JSPLATFORM_BEEP_DEFAULT = 4; // Default + +type + PIPDF_JsPlatform = ^IPDF_JsPlatform; + IPDF_JsPlatform = record + // Version number of the interface. Currently must be 2. + version: Integer; + + // Version 1. + + // Method: app_alert + // Pop up a dialog to show warning or hint. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // Msg - A string containing the message to be displayed. + // Title - The title of the dialog. + // Type - The type of button group, one of the + // JSPLATFORM_ALERT_BUTTON_* values above. + // nIcon - The type of the icon, one of the + // JSPLATFORM_ALERT_ICON_* above. + // Return Value: + // Option selected by user in dialogue, one of the + // JSPLATFORM_ALERT_RETURN_* values above. + app_alert: function(pThis: PIPDF_JsPlatform; Msg, Title: FPDF_WIDESTRING; nType: Integer; + Icon: Integer): Integer; cdecl; + + // Method: app_beep + // Causes the system to play a sound. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself + // nType - The sound type, see JSPLATFORM_BEEP_TYPE_* + // above. + // Return Value: + // None + app_beep: procedure(pThis: PIPDF_JsPlatform; nType: Integer); cdecl; + + // Method: app_response + // Displays a dialog box containing a question and an entry field for + // the user to reply to the question. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself + // Question - The question to be posed to the user. + // Title - The title of the dialog box. + // Default - A default value for the answer to the question. If + // not specified, no default value is presented. + // cLabel - A short string to appear in front of and on the + // same line as the edit text field. + // bPassword - If true, indicates that the user's response should + // be shown as asterisks (*) or bullets (?) to mask + // the response, which might be sensitive information. + // response - A string buffer allocated by PDFium, to receive the + // user's response. + // length - The length of the buffer in bytes. Currently, it is + // always 2048. + // Return Value: + // Number of bytes the complete user input would actually require, not + // including trailing zeros, regardless of the value of the length + // parameter or the presence of the response buffer. + // Comments: + // No matter on what platform, the response buffer should be always + // written using UTF-16LE encoding. If a response buffer is + // present and the size of the user input exceeds the capacity of the + // buffer as specified by the length parameter, only the + // first "length" bytes of the user input are to be written to the + // buffer. + app_response: function(pThis: PIPDF_JsPlatform; Question, Title, Default, cLabel: FPDF_WIDESTRING; + bPassword: FPDF_BOOL; response: Pointer; length: Integer): Integer; cdecl; + + // Method: Doc_getFilePath + // Get the file path of the current document. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself + // filePath - The string buffer to receive the file path. Can + // be NULL. + // length - The length of the buffer, number of bytes. Can + // be 0. + // Return Value: + // Number of bytes the filePath consumes, including trailing zeros. + // Comments: + // The filePath should always be provided in the local encoding. + // The return value always indicated number of bytes required for + // the buffer, even when there is no buffer specified, or the buffer + // size is less than required. In this case, the buffer will not + // be modified. + Doc_getFilePath: function(pThis: PIPDF_JsPlatform; filePath: Pointer; length: Integer): Integer; cdecl; + + // Method: Doc_mail + // Mails the data buffer as an attachment to all recipients, with or + // without user interaction. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself + // mailData - Pointer to the data buffer to be sent. Can be NULL. + // length - The size,in bytes, of the buffer pointed by + // mailData parameter. Can be 0. + // bUI - If true, the rest of the parameters are used in a + // compose-new-message window that is displayed to the + // user. If false, the cTo parameter is required and + // all others are optional. + // To - A semicolon-delimited list of recipients for the + // message. + // Subject - The subject of the message. The length limit is + // 64 KB. + // CC - A semicolon-delimited list of CC recipients for + // the message. + // BCC - A semicolon-delimited list of BCC recipients for + // the message. + // Msg - The content of the message. The length limit is + // 64 KB. + // Return Value: + // None. + // Comments: + // If the parameter mailData is NULL or length is 0, the current + // document will be mailed as an attachment to all recipients. + Doc_mail: procedure(pThis: PIPDF_JsPlatform; mailData: Pointer; length: Integer; bUI: FPDF_BOOL; + sTo, subject, CC, BCC, Msg: FPDF_WIDESTRING); cdecl; + + // Method: Doc_print + // Prints all or a specific number of pages of the document. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // bUI - If true, will cause a UI to be presented to the + // user to obtain printing information and confirm + // the action. + // nStart - A 0-based index that defines the start of an + // inclusive range of pages. + // nEnd - A 0-based index that defines the end of an + // inclusive page range. + // bSilent - If true, suppresses the cancel dialog box while + // the document is printing. The default is false. + // bShrinkToFit - If true, the page is shrunk (if necessary) to + // fit within the imageable area of the printed page. + // bPrintAsImage - If true, print pages as an image. + // bReverse - If true, print from nEnd to nStart. + // bAnnotations - If true (the default), annotations are + // printed. + // Return Value: + // None. + Doc_print: procedure(pThis: PIPDF_JsPlatform; bUI: FPDF_BOOKMARK; nStart, nEnd: Integer; + bSilent, bShrinkToFit, bPrintAsImage, bReverse, bAnnotations: FPDF_BOOL); cdecl; + + // Method: Doc_submitForm + // Send the form data to a specified URL. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself + // formData - Pointer to the data buffer to be sent. + // length - The size,in bytes, of the buffer pointed by + // formData parameter. + // URL - The URL to send to. + // Return Value: + // None. + Doc_submitForm: procedure(pThis: PIPDF_JsPlatform; formData: Pointer; length: Integer; URL: FPDF_WIDESTRING); cdecl; + + // Method: Doc_gotoPage + // Jump to a specified page. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself + // nPageNum - The specified page number, zero for the first page. + // Return Value: + // None. + Doc_gotoPage: procedure(pThis: PIPDF_JsPlatform; nPageNum: Integer); cdecl; + + // Method: Field_browse + // Show a file selection dialog, and return the selected file path. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // filePath - Pointer to the data buffer to receive the file + // path. Can be NULL. + // length - The length of the buffer, in bytes. Can be 0. + // Return Value: + // Number of bytes the filePath consumes, including trailing zeros. + // Comments: + // The filePath should always be provided in local encoding. + Field_browse: function(pThis: PIPDF_JsPlatform; filePath: Pointer; length: Integer): Integer; cdecl; + + + // Pointer for embedder-specific data. Unused by PDFium, and despite + // its name, can be any data the embedder desires, though traditionally + // a FPDF_FORMFILLINFO interface. + m_pFormfillinfo: Pointer; + + // Version 2. + + m_isolate: Pointer; // Unused in v3, retain for compatibility. + m_v8EmbedderSlot: DWORD; // Unused in v3, retain for compatibility. + + // Version 3. + // Version 3 moves m_Isolate and m_v8EmbedderSlot to FPDF_LIBRARY_CONFIG. + end; + PIPDFJsPlatform = ^TIPDFJsPlatform; + TIPDFJsPlatform = IPDF_JSPLATFORM; + +// Flags for Cursor type +const + FXCT_ARROW = 0; + FXCT_NESW = 1; + FXCT_NWSE = 2; + FXCT_VBEAM = 3; + FXCT_HBEAM = 4; + FXCT_HAND = 5; + +// Function signature for the callback function passed to the FFI_SetTimer +// method. +// Parameters: +// idEvent - Identifier of the timer. +// Return value: +// None. +type + TFPDFTimerCallback = procedure(idEvent: Integer); cdecl; + +type + // Declares of a struct type to the local system time. + {$IFDEF MSWINDOWS} + PFPDF_SYSTEMTIME = PSystemTime; + FPDF_SYSTEMTIME = TSystemTime; + {$ELSE} + PFPDF_SYSTEMTIME = ^FPDF_SYSTEMTIME; + FPDF_SYSTEMTIME = record + wYear: Word; // years since 1900 + wMonth: Word; // months since January - [0,11] + wDayOfWeek: Word; // days since Sunday - [0,6] + wDay: Word; // day of the month - [1,31] + wHour: Word; // hours since midnight - [0,23] + wMinute: Word; // minutes after the hour - [0,59] + wSecond: Word; // seconds after the minute - [0,59] + wMilliseconds: Word; // milliseconds after the second - [0,999] + end; + {$ENDIF MSWINDOWS} + PFPDFSystemTime = ^TFPDFSystemTime; + TFPDFSystemTime = FPDF_SYSTEMTIME; + +{$IFDEF PDF_ENABLE_XFA} +// XFA +const + // Pageview event flags + FXFA_PAGEVIEWEVENT_POSTADDED = 1; // After a new pageview is added. + FXFA_PAGEVIEWEVENT_POSTREMOVED = 3; // After a pageview is removed. + + // Definitions for Right Context Menu Features Of XFA Fields + FXFA_MENU_COPY = 1; + FXFA_MENU_CUT = 2; + FXFA_MENU_SELECTALL = 4; + FXFA_MENU_UNDO = 8; + FXFA_MENU_REDO = 16; + FXFA_MENU_PASTE = 32; + + // Definitions for File Type. + FXFA_SAVEAS_XML = 1; + FXFA_SAVEAS_XDP = 2; +{$ENDIF PDF_ENABLE_XFA} + +type + PFPDF_FORMFILLINFO = ^FPDF_FORMFILLINFO; + FPDF_FORMFILLINFO = record + // Version number of the interface. + // Version 1 contains stable interfaces. Version 2 has additional + // experimental interfaces. + // When PDFium is built without the XFA module, version can be 1 or 2. + // With version 1, only stable interfaces are called. With version 2, + // additional experimental interfaces are also called. + // When PDFium is built with the XFA module, version must be 2. + // All the XFA related interfaces are experimental. If PDFium is built with + // the XFA module and version 1 then none of the XFA related interfaces + // would be called. When PDFium is built with XFA module then the version + // must be 2. + version: Integer; + + // Version 1. + + // Method: Release + // Give the implementation a chance to release any resources after the + // interface is no longer used. + // Interface Version: + // 1 + // Implementation Required: + // No + // Comments: + // Called by PDFium during the final cleanup process. + // Parameters: + // pThis - Pointer to the interface structure itself + // Return Value: + // None + Release: procedure(pThis: PFPDF_FORMFILLINFO); cdecl; + + // Method: FFI_Invalidate + // Invalidate the client area within the specified rectangle. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // page - Handle to the page. Returned by FPDF_LoadPage(). + // left - Left position of the client area in PDF page + // coordinates. + // top - Top position of the client area in PDF page + // coordinates. + // right - Right position of the client area in PDF page + // coordinates. + // bottom - Bottom position of the client area in PDF page + // coordinates. + // Return Value: + // None. + // Comments: + // All positions are measured in PDF "user space". + // Implementation should call FPDF_RenderPageBitmap() for repainting + // the specified page area. + FFI_Invalidate: procedure(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE; left, top, right, bottom: Double); cdecl; + + // Method: FFI_OutputSelectedRect + // When the user selects text in form fields with the mouse, this + // callback function will be invoked with the selected areas. + // Interface Version: + // 1 + // Implementation Required: + // No + // Parameters: + // pThis - Pointer to the interface structure itself. + // page - Handle to the page. Returned by FPDF_LoadPage()/ + // left - Left position of the client area in PDF page + // coordinates. + // top - Top position of the client area in PDF page + // coordinates. + // right - Right position of the client area in PDF page + // coordinates. + // bottom - Bottom position of the client area in PDF page + // coordinates. + // Return Value: + // None. + // Comments: + // This callback function is useful for implementing special text + // selection effects. An implementation should first record the + // returned rectangles, then draw them one by one during the next + // painting period. Lastly, it should remove all the recorded + // rectangles when finished painting. + FFI_OutputSelectedRect: procedure(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE; left, top, right, bottom: Double); cdecl; + + // Method: FFI_SetCursor + // Set the Cursor shape. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // nCursorType - Cursor type, see Flags for Cursor type for details. + // Return value: + // None. + FFI_SetCursor: procedure(pThis: PFPDF_FORMFILLINFO; nCursorType: Integer); cdecl; + + // Method: FFI_SetTimer + // This method installs a system timer. An interval value is specified, + // and every time that interval elapses, the system must call into the + // callback function with the timer ID as returned by this function. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // uElapse - Specifies the time-out value, in milliseconds. + // lpTimerFunc - A pointer to the callback function-TimerCallback. + // Return value: + // The timer identifier of the new timer if the function is successful. + // An application passes this value to the FFI_KillTimer method to kill + // the timer. Nonzero if it is successful; otherwise, it is zero. + FFI_SetTimer: function(pThis: PFPDF_FORMFILLINFO; uElapse: Integer; lpTimerFunc: TFPDFTimerCallback): Integer; cdecl; + + // Method: FFI_KillTimer + // This method uninstalls a system timer, as set by an earlier call to + // FFI_SetTimer. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // nTimerID - The timer ID returned by FFI_SetTimer function. + // Return value: + // None. + FFI_KillTimer: procedure(pThis: PFPDF_FORMFILLINFO; nTimerID: Integer); cdecl; + + // Method: FFI_GetLocalTime + // This method receives the current local time on the system. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // Return value: + // The local time. See FPDF_SYSTEMTIME above for details. + // Note: Unused. + FFI_GetLocalTime: function(pThis: PFPDF_FORMFILLINFO): FPDF_SYSTEMTIME; cdecl; + + // Method: FFI_OnChange + // This method will be invoked to notify the implementation when the + // value of any FormField on the document had been changed. + // Interface Version: + // 1 + // Implementation Required: + // no + // Parameters: + // pThis - Pointer to the interface structure itself. + // Return value: + // None. + FFI_OnChange: procedure(pThis: PFPDF_FORMFILLINFO); cdecl; + + // Method: FFI_GetPage + // This method receives the page handle associated with a specified + // page index. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // document - Handle to document. Returned by FPDF_LoadDocument(). + // nPageIndex - Index number of the page. 0 for the first page. + // Return value: + // Handle to the page, as previously returned to the implementation by + // FPDF_LoadPage(). + // Comments: + // The implementation is expected to keep track of the page handles it + // receives from PDFium, and their mappings to page numbers. In some + // cases, the document-level JavaScript action may refer to a page + // which hadn't been loaded yet. To successfully run the Javascript + // action, the implementation needs to load the page. + FFI_GetPage: function(pThis: PFPDF_FORMFILLINFO; document: FPDF_DOCUMENT; nPageIndex: Integer): FPDF_PAGE; cdecl; + + // Method: FFI_GetCurrentPage + // This method receives the handle to the current page. + // Interface Version: + // 1 + // Implementation Required: + // Yes when V8 support is present, otherwise unused. + // Parameters: + // pThis - Pointer to the interface structure itself. + // document - Handle to document. Returned by FPDF_LoadDocument(). + // Return value: + // Handle to the page. Returned by FPDF_LoadPage(). + // Comments: + // PDFium doesn't keep keep track of the "current page" (e.g. the one + // that is most visible on screen), so it must ask the embedder for + // this information. + FFI_GetCurrentPage: function(pThis: PFPDF_FORMFILLINFO; document: FPDF_DOCUMENT): FPDF_PAGE; cdecl; + + // Method: FFI_GetRotation + // This method receives currently rotation of the page view. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // page - Handle to page, as returned by FPDF_LoadPage(). + // Return value: + // A number to indicate the page rotation in 90 degree increments + // in a clockwise direction: + // 0 - 0 degrees + // 1 - 90 degrees + // 2 - 180 degrees + // 3 - 270 degrees + // Note: Unused. + FFI_GetRotation: function(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE): Integer; cdecl; + + // Method: FFI_ExecuteNamedAction + // This method will execute a named action. + // Interface Version: + // 1 + // Implementation Required: + // yes + // Parameters: + // pThis - Pointer to the interface structure itself. + // namedAction - A byte string which indicates the named action, + // terminated by 0. + // Return value: + // None. + // Comments: + // See ISO 32000-1:2008, section 12.6.4.11 for descriptions of the + // standard named actions, but note that a document may supply any + // name of its choosing. + FFI_ExecuteNamedAction: procedure(pThis: PFPDF_FORMFILLINFO; namedAction: FPDF_BYTESTRING); cdecl; + + // Method: FFI_SetTextFieldFocus + // Called when a text field is getting or losing focus. + // Interface Version: + // 1 + // Implementation Required: + // no + // Parameters: + // pThis - Pointer to the interface structure itself. + // value - The string value of the form field, in UTF-16LE + // format. + // valueLen - The length of the string value. This is the + // number of characters, not bytes. + // is_focus - True if the form field is getting focus, false + // if the form field is losing focus. + // Return value: + // None. + // Comments: + // Only supports text fields and combobox fields. + FFI_SetTextFieldFocus: procedure(pThis: PFPDF_FORMFILLINFO; value: FPDF_WIDESTRING; valueLen: FPDF_DWORD; is_focus: FPDF_BOOL); cdecl; + + // Method: FFI_DoURIAction + // Ask the implementation to navigate to a uniform resource identifier. + // Interface Version: + // 1 + // Implementation Required: + // No + // Parameters: + // pThis - Pointer to the interface structure itself. + // bsURI - A byte string which indicates the uniform + // resource identifier, terminated by 0. + // Return value: + // None. + // Comments: + // If the embedder is version 2 or higher and have implementation for + // FFI_DoURIActionWithKeyboardModifier, then + // FFI_DoURIActionWithKeyboardModifier takes precedence over + // FFI_DoURIAction. + // See the URI actions description of <<PDF Reference, version 1.7>> + // for more details. + FFI_DoURIAction: procedure(pThis: PFPDF_FORMFILLINFO; bsURI: FPDF_WIDESTRING); cdecl; + + // Method: FFI_DoGoToAction + // This action changes the view to a specified destination. + // Interface Version: + // 1 + // Implementation Required: + // No + // Parameters: + // pThis - Pointer to the interface structure itself. + // nPageIndex - The index of the PDF page. + // zoomMode - The zoom mode for viewing page. See below. + // fPosArray - The float array which carries the position info. + // sizeofArray - The size of float array. + // PDFZoom values: + // - XYZ = 1 + // - FITPAGE = 2 + // - FITHORZ = 3 + // - FITVERT = 4 + // - FITRECT = 5 + // - FITBBOX = 6 + // - FITBHORZ = 7 + // - FITBVERT = 8 + // Return value: + // None. + // Comments: + // See the Destinations description of <<PDF Reference, version 1.7>> + // in 8.2.1 for more details. + FFI_DoGoToAction: procedure(pThis: PFPDF_FORMFILLINFO; nPageIndex, zoomMode: Integer; fPosArray: PSingle; sizeofArray: Integer); cdecl; + + // Pointer to IPDF_JSPLATFORM interface. + // Unused if PDFium is built without V8 support. Otherwise, if NULL, then + // JavaScript will be prevented from executing while rendering the document. + m_pJsPlatform: PIPDF_JSPLATFORM; + + // Version 2 - Experimental. + + // Whether the XFA module is disabled when built with the XFA module. + // Interface Version: + // Ignored if |version| < 2. + xfa_disabled: FPDF_BOOL; + + // Method: FFI_DisplayCaret + // This method will show the caret at specified position. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // page - Handle to page. Returned by FPDF_LoadPage(). + // left - Left position of the client area in PDF page + // coordinates. + // top - Top position of the client area in PDF page + // coordinates. + // right - Right position of the client area in PDF page + // coordinates. + // bottom - Bottom position of the client area in PDF page + // coordinates. + // Return value: + // None. + FFI_DisplayCaret: procedure(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE; bVisible: FPDF_BOOL; + left, top, right, bottom: Double); cdecl; + + // Method: FFI_GetCurrentPageIndex + // This method will get the current page index. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // document - Handle to document from FPDF_LoadDocument(). + // Return value: + // The index of current page. + FFI_GetCurrentPageIndex: function(pThis: PFPDF_FORMFILLINFO; document: FPDF_DOCUMENT): Integer; cdecl; + + // Method: FFI_SetCurrentPage + // This method will set the current page. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // document - Handle to document from FPDF_LoadDocument(). + // iCurPage - The index of the PDF page. + // Return value: + // None. + FFI_SetCurrentPage: procedure(pThis: PFPDF_FORMFILLINFO; document: FPDF_DOCUMENT; iCurPage: Integer); cdecl; + + // Method: FFI_GotoURL + // This method will navigate to the specified URL. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // document - Handle to document from FPDF_LoadDocument(). + // wsURL - The string value of the URL, in UTF-16LE format. + // Return value: + // None. + FFI_GotoURL: procedure(pThis: PFPDF_FORMFILLINFO; document: FPDF_DOCUMENT; wsURL: FPDF_WIDESTRING); cdecl; + + // Method: FFI_GetPageViewRect + // This method will get the current page view rectangle. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // page - Handle to page. Returned by FPDF_LoadPage(). + // left - The pointer to receive left position of the page + // view area in PDF page coordinates. + // top - The pointer to receive top position of the page + // view area in PDF page coordinates. + // right - The pointer to receive right position of the + // page view area in PDF page coordinates. + // bottom - The pointer to receive bottom position of the + // page view area in PDF page coordinates. + // Return value: + // None. + FFI_GetPageViewRect: procedure(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE; var left, top, right, bottom: Double); cdecl; + + // Method: FFI_PageEvent + // This method fires when pages have been added to or deleted from + // the XFA document. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // page_count - The number of pages to be added or deleted. + // event_type - See FXFA_PAGEVIEWEVENT_* above. + // Return value: + // None. + // Comments: + // The pages to be added or deleted always start from the last page + // of document. This means that if parameter page_count is 2 and + // event type is FXFA_PAGEVIEWEVENT_POSTADDED, 2 new pages have been + // appended to the tail of document; If page_count is 2 and + // event type is FXFA_PAGEVIEWEVENT_POSTREMOVED, the last 2 pages + // have been deleted. + FFI_PageEvent: procedure(pThis: PFPDF_FORMFILLINFO; page_count: Integer; event_type: FPDF_DWORD); cdecl; + + // Method: FFI_PopupMenu + // This method will track the right context menu for XFA fields. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // page - Handle to page. Returned by FPDF_LoadPage(). + // hWidget - Always null, exists for compatibility. + // menuFlag - The menu flags. Please refer to macro definition + // of FXFA_MENU_XXX and this can be one or a + // combination of these macros. + // x - X position of the client area in PDF page + // coordinates. + // y - Y position of the client area in PDF page + // coordinates. + // Return value: + // TRUE indicates success; otherwise false. + FFI_PopupMenu: function(pThis: PFPDF_FORMFILLINFO; page: FPDF_PAGE; hWidget: FPDF_WIDGET; + menuFlag: Integer; x, y: Single): FPDF_BOOL; cdecl; + + // Method: FFI_OpenFile + // This method will open the specified file with the specified mode. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // fileFlag - The file flag. Please refer to macro definition + // of FXFA_SAVEAS_XXX and use one of these macros. + // wsURL - The string value of the file URL, in UTF-16LE + // format. + // mode - The mode for open file, e.g. "rb" or "wb". + // Return value: + // The handle to FPDF_FILEHANDLER. + FFI_OpenFile: function(pThis: PFPDF_FORMFILLINFO; fileFlag: Integer; wsURL: FPDF_WIDESTRING; + mode: PAnsiChar): PFPDF_FILEHANDLER; cdecl; + + // Method: FFI_EmailTo + // This method will email the specified file stream to the specified + // contact. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // pFileHandler - Handle to the FPDF_FILEHANDLER. + // pTo - A semicolon-delimited list of recipients for the + // message,in UTF-16LE format. + // pSubject - The subject of the message,in UTF-16LE format. + // pCC - A semicolon-delimited list of CC recipients for + // the message,in UTF-16LE format. + // pBcc - A semicolon-delimited list of BCC recipients for + // the message,in UTF-16LE format. + // pMsg - Pointer to the data buffer to be sent.Can be + // NULL,in UTF-16LE format. + // Return value: + // None. + FFI_EmailTo: procedure(pThis: PFPDF_FORMFILLINFO; fileHandler: PFPDF_FILEHANDLER; + pTo, pSubject, pCC, pBcc, pMsg: FPDF_WIDESTRING); cdecl; + + // Method: FFI_UploadTo + // This method will upload the specified file stream to the + // specified URL. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // pFileHandler - Handle to the FPDF_FILEHANDLER. + // fileFlag - The file flag. Please refer to macro definition + // of FXFA_SAVEAS_XXX and use one of these macros. + // uploadTo - Pointer to the URL path, in UTF-16LE format. + // Return value: + // None. + FFI_UploadTo: procedure(pThis: PFPDF_FORMFILLINFO; fileHandler: PFPDF_FILEHANDLER; fileFlag: Integer; + uploadTo: FPDF_WIDESTRING); cdecl; + + // Method: FFI_GetPlatform + // This method will get the current platform. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // platform - Pointer to the data buffer to receive the + // platform,in UTF-16LE format. Can be NULL. + // length - The length of the buffer in bytes. Can be + // 0 to query the required size. + // Return value: + // The length of the buffer, number of bytes. + FFI_GetPlatform: function(pThis: PFPDF_FORMFILLINFO; platform_: Pointer; length: Integer): Integer; cdecl; + + // Method: FFI_GetLanguage + // This method will get the current language. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // language - Pointer to the data buffer to receive the + // current language. Can be NULL. + // length - The length of the buffer in bytes. Can be + // 0 to query the required size. + // Return value: + // The length of the buffer, number of bytes. + FFI_GetLanguage: function(pThis: PFPDF_FORMFILLINFO; language: Pointer; length: Integer): Integer; cdecl; + + // Method: FFI_DownloadFromURL + // This method will download the specified file from the URL. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // URL - The string value of the file URL, in UTF-16LE + // format. + // Return value: + // The handle to FPDF_FILEHANDLER. + FFI_DownloadFromURL: function(pThis: PFPDF_FORMFILLINFO; URL: FPDF_WIDESTRING): PFPDF_FILEHANDLER; cdecl; + + // Method: FFI_PostRequestURL + // This method will post the request to the server URL. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // wsURL - The string value of the server URL, in UTF-16LE + // format. + // wsData - The post data,in UTF-16LE format. + // wsContentType - The content type of the request data, in + // UTF-16LE format. + // wsEncode - The encode type, in UTF-16LE format. + // wsHeader - The request header,in UTF-16LE format. + // response - Pointer to the FPDF_BSTR to receive the response + // data from the server, in UTF-16LE format. + // Return value: + // TRUE indicates success, otherwise FALSE. + FFI_PostRequestURL: function(pThis: PFPDF_FORMFILLINFO; wsURL, wsData, wsContentType, + wsEncode, wsHeader: FPDF_WIDESTRING; respone: PFPDF_BSTR): FPDF_BOOL; cdecl; + + // Method: FFI_PutRequestURL + // This method will put the request to the server URL. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // Required for XFA, otherwise set to NULL. + // Parameters: + // pThis - Pointer to the interface structure itself. + // wsURL - The string value of the server URL, in UTF-16LE + // format. + // wsData - The put data, in UTF-16LE format. + // wsEncode - The encode type, in UTR-16LE format. + // Return value: + // TRUE indicates success, otherwise FALSE. + FFI_PutRequestURL: function(pThis: PFPDF_FORMFILLINFO; wsURL, wsData, wsEncode: FPDF_WIDESTRING): FPDF_BOOL; cdecl; + + // Method: FFI_OnFocusChange + // Called when the focused annotation is updated. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // No + // Parameters: + // param - Pointer to the interface structure itself. + // annot - The focused annotation. + // page_index - Index number of the page which contains the + // focused annotation. 0 for the first page. + // Return value: + // None. + // Comments: + // This callback function is useful for implementing any view based + // action such as scrolling the annotation rect into view. The + // embedder should not copy and store the annot as its scope is + // limited to this call only. + FFI_OnFocusChange: procedure(param: PFPDF_FORMFILLINFO; annot: FPDF_ANNOTATION; page_index: Integer); cdecl; + + // Method: FFI_DoURIActionWithKeyboardModifier + // Ask the implementation to navigate to a uniform resource identifier + // with the specified modifiers. + // Interface Version: + // Ignored if |version| < 2. + // Implementation Required: + // No + // Parameters: + // param - Pointer to the interface structure itself. + // uri - A byte string which indicates the uniform + // resource identifier, terminated by 0. + // modifiers - Keyboard modifier that indicates which of + // the virtual keys are down, if any. + // Return value: + // None. + // Comments: + // If the embedder who is version 2 and does not implement this API, + // then a call will be redirected to FFI_DoURIAction. + // See the URI actions description of <<PDF Reference, version 1.7>> + // for more details. + FFI_DoURIActionWithKeyboardModifier: procedure(param: PFPDF_FORMFILLINFO; uri: FPDF_BYTESTRING; modifiers: Integer); cdecl; + end; + PFPDFFormFillInfo = ^TFPDFFormFillInfo; + TFPDFFormFillInfo = FPDF_FORMFILLINFO; + +// Function: FPDFDOC_InitFormFillEnvironment +// Initialize form fill environment. +// Parameters: +// document - Handle to document from FPDF_LoadDocument(). +// formInfo - Pointer to a FPDF_FORMFILLINFO structure. +// Return Value: +// Handle to the form fill module, or NULL on failure. +// Comments: +// This function should be called before any form fill operation. +// The FPDF_FORMFILLINFO passed in via |formInfo| must remain valid until +// the returned FPDF_FORMHANDLE is closed. +var + FPDFDOC_InitFormFillEnvironment: function(document: FPDF_DOCUMENT; formInfo: PFPDF_FORMFILLINFO): FPDF_FORMHANDLE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFDOC_ExitFormFillEnvironment +// Take ownership of |hHandle| and exit form fill environment. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// Return Value: +// None. +// Comments: +// This function is a no-op when |hHandle| is null. +var + FPDFDOC_ExitFormFillEnvironment: procedure(hHandle: FPDF_FORMHANDLE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnAfterLoadPage +// This method is required for implementing all the form related +// functions. Should be invoked after user successfully loaded a +// PDF page, and FPDFDOC_InitFormFillEnvironment() has been invoked. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// Return Value: +// None. +var + FORM_OnAfterLoadPage: procedure(page: FPDF_PAGE; hHandle: FPDF_FORMHANDLE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnBeforeClosePage +// This method is required for implementing all the form related +// functions. Should be invoked before user closes the PDF page. +// Parameters: +// page - Handle to the page, as returned by FPDF_LoadPage(). +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// Return Value: +// None. +var + FORM_OnBeforeClosePage: procedure(page: FPDF_PAGE; hHandle: FPDF_FORMHANDLE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_DoDocumentJSAction +// This method is required for performing document-level JavaScript +// actions. It should be invoked after the PDF document has been loaded. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// Return Value: +// None. +// Comments: +// If there is document-level JavaScript action embedded in the +// document, this method will execute the JavaScript action. Otherwise, +// the method will do nothing. +var + FORM_DoDocumentJSAction: procedure(hHandle: FPDF_FORMHANDLE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_DoDocumentOpenAction +// This method is required for performing open-action when the document +// is opened. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// Return Value: +// None. +// Comments: +// This method will do nothing if there are no open-actions embedded +// in the document. +var + FORM_DoDocumentOpenAction: procedure(hHandle: FPDF_FORMHANDLE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +const + // Additional actions type of document: + // WC, before closing document, JavaScript action. + // WS, before saving document, JavaScript action. + // DS, after saving document, JavaScript action. + // WP, before printing document, JavaScript action. + // DP, after printing document, JavaScript action. + FPDFDOC_AACTION_WC = $10; + FPDFDOC_AACTION_WS = $11; + FPDFDOC_AACTION_DS = $12; + FPDFDOC_AACTION_WP = $13; + FPDFDOC_AACTION_DP = $14; + +// Function: FORM_DoDocumentAAction +// This method is required for performing the document's +// additional-action. +// Parameters: +// hHandle - Handle to the form fill module. Returned by +// FPDFDOC_InitFormFillEnvironment. +// aaType - The type of the additional-actions which defined +// above. +// Return Value: +// None. +// Comments: +// This method will do nothing if there is no document +// additional-action corresponding to the specified |aaType|. +var + FORM_DoDocumentAAction: procedure(hHandle: FPDF_FORMHANDLE; aaType: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +const + // Additional-action types of page object: + // OPEN (/O) -- An action to be performed when the page is opened + // CLOSE (/C) -- An action to be performed when the page is closed + FPDFPAGE_AACTION_OPEN = 0; + FPDFPAGE_AACTION_CLOSE = 1; + +// Function: FORM_DoPageAAction +// This method is required for performing the page object's +// additional-action when opened or closed. +// Parameters: +// page - Handle to the page, as returned by FPDF_LoadPage(). +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// aaType - The type of the page object's additional-actions +// which defined above. +// Return Value: +// None. +// Comments: +// This method will do nothing if no additional-action corresponding +// to the specified |aaType| exists. +var + FORM_DoPageAAction: procedure(page: FPDF_PAGE; hHandle: FPDF_FORMHANDLE; aaType: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnMouseMove +// Call this member function when the mouse cursor moves. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// modifier - Indicates whether various virtual keys are down. +// page_x - Specifies the x-coordinate of the cursor in PDF user +// space. +// page_y - Specifies the y-coordinate of the cursor in PDF user +// space. +// Return Value: +// True indicates success; otherwise false. +var + FORM_OnMouseMove: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; modifier: Integer; + page_x, page_y: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API +// Function: FORM_OnMouseWheel +// Call this member function when the user scrolls the mouse wheel. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// modifier - Indicates whether various virtual keys are down. +// page_coord - Specifies the coordinates of the cursor in PDF user +// space. +// delta_x - Specifies the amount of wheel movement on the x-axis, +// in units of platform-agnostic wheel deltas. Negative +// values mean left. +// delta_y - Specifies the amount of wheel movement on the y-axis, +// in units of platform-agnostic wheel deltas. Negative +// values mean down. +// Return Value: +// True indicates success; otherwise false. +// Comments: +// For |delta_x| and |delta_y|, the caller must normalize +// platform-specific wheel deltas. e.g. On Windows, a delta value of 240 +// for a WM_MOUSEWHEEL event normalizes to 2, since Windows defines +// WHEEL_DELTA as 120. +var + FORM_OnMouseWheel: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; modifier: Integer; + const page_coord: PFS_POINTF; delta_x, delta_y: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnFocus +// This function focuses the form annotation at a given point. If the +// annotation at the point already has focus, nothing happens. If there +// is no annotation at the point, removes form focus. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// modifier - Indicates whether various virtual keys are down. +// page_x - Specifies the x-coordinate of the cursor in PDF user +// space. +// page_y - Specifies the y-coordinate of the cursor in PDF user +// space. +// Return Value: +// True if there is an annotation at the given point and it has focus. +var + FORM_OnFocus: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; modifier: Integer; + page_x, page_y: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnLButtonDown +// Call this member function when the user presses the left +// mouse button. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// modifier - Indicates whether various virtual keys are down. +// page_x - Specifies the x-coordinate of the cursor in PDF user +// space. +// page_y - Specifies the y-coordinate of the cursor in PDF user +// space. +// Return Value: +// True indicates success; otherwise false. +var + FORM_OnLButtonDown: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; modifier: Integer; + page_x, page_y: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnRButtonDown +// Same as above, execpt for the right mouse button. +// Comments: +// At the present time, has no effect except in XFA builds, but is +// included for the sake of symmetry. +var + FORM_OnRButtonDown: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; modifier: Integer; + page_x, page_y: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnLButtonUp +// Call this member function when the user releases the left +// mouse button. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// modifier - Indicates whether various virtual keys are down. +// page_x - Specifies the x-coordinate of the cursor in device. +// page_y - Specifies the y-coordinate of the cursor in device. +// Return Value: +// True indicates success; otherwise false. +var + FORM_OnLButtonUp: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; modifier: Integer; + page_x, page_y: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnRButtonUp +// Same as above, execpt for the right mouse button. +// Comments: +// At the present time, has no effect except in XFA builds, but is +// included for the sake of symmetry. +var + FORM_OnRButtonUp: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; modifier: Integer; + page_x, page_y: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnLButtonDoubleClick +// Call this member function when the user double clicks the +// left mouse button. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// modifier - Indicates whether various virtual keys are down. +// page_x - Specifies the x-coordinate of the cursor in PDF user +// space. +// page_y - Specifies the y-coordinate of the cursor in PDF user +// space. +// Return Value: +// True indicates success; otherwise false. +var + FORM_OnLButtonDoubleClick: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; modifier: Integer; + page_x, page_y: Double): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnKeyDown +// Call this member function when a nonsystem key is pressed. +// Parameters: +// hHandle - Handle to the form fill module, aseturned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// nKeyCode - The virtual-key code of the given key (see +// fpdf_fwlevent.h for virtual key codes). +// modifier - Mask of key flags (see fpdf_fwlevent.h for key +// flag values). +// Return Value: +// True indicates success; otherwise false. +var + FORM_OnKeyDown: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; nKeyCode, modifier: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnKeyUp +// Call this member function when a nonsystem key is released. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// nKeyCode - The virtual-key code of the given key (see +// fpdf_fwlevent.h for virtual key codes). +// modifier - Mask of key flags (see fpdf_fwlevent.h for key +// flag values). +// Return Value: +// True indicates success; otherwise false. +// Comments: +// Currently unimplemented and always returns false. PDFium reserves this +// API and may implement it in the future on an as-needed basis. +var + FORM_OnKeyUp: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; nKeyCode, modifier: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_OnChar +// Call this member function when a keystroke translates to a +// nonsystem character. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// nChar - The character code value itself. +// modifier - Mask of key flags (see fpdf_fwlevent.h for key +// flag values). +// Return Value: +// True indicates success; otherwise false. +var + FORM_OnChar: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; nChar, modifier: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API +// Function: FORM_GetFocusedText +// Call this function to obtain the text within the current focused +// field, if any. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// buffer - Buffer for holding the form text, encoded in +// UTF-16LE. If NULL, |buffer| is not modified. +// buflen - Length of |buffer| in bytes. If |buflen| is less +// than the length of the form text string, |buffer| is +// not modified. +// Return Value: +// Length in bytes for the text in the focused field. +var + FORM_GetFocusedText: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_GetSelectedText +// Call this function to obtain selected text within a form text +// field or form combobox text field. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// buffer - Buffer for holding the selected text, encoded in +// UTF-16LE. If NULL, |buffer| is not modified. +// buflen - Length of |buffer| in bytes. If |buflen| is less +// than the length of the selected text string, +// |buffer| is not modified. +// Return Value: +// Length in bytes of selected text in form text field or form combobox +// text field. +var + FORM_GetSelectedText: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API +// Function: FORM_ReplaceAndKeepSelection +// Call this function to replace the selected text in a form +// text field or user-editable form combobox text field with another +// text string (which can be empty or non-empty). If there is no +// selected text, this function will append the replacement text after +// the current caret position. After the insertion, the inserted text +// will be selected. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as Returned by FPDF_LoadPage(). +// wsText - The text to be inserted, in UTF-16LE format. +// Return Value: +// None. +var + FORM_ReplaceAndKeepSelection: procedure(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; wsText: FPDF_WIDESTRING); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_ReplaceSelection +// Call this function to replace the selected text in a form +// text field or user-editable form combobox text field with another +// text string (which can be empty or non-empty). If there is no +// selected text, this function will append the replacement text after +// the current caret position. After the insertion, the selection range +// will be set to empty. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as Returned by FPDF_LoadPage(). +// wsText - The text to be inserted, in UTF-16LE format. +// Return Value: +// None. +var + FORM_ReplaceSelection: procedure(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; wsText: FPDF_WIDESTRING); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API +// Function: FORM_SelectAllText +// Call this function to select all the text within the currently focused +// form text field or form combobox text field. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// Return Value: +// Whether the operation succeeded or not. +var + FORM_SelectAllText: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_CanUndo +// Find out if it is possible for the current focused widget in a given +// form to perform an undo operation. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// Return Value: +// True if it is possible to undo. +var + FORM_CanUndo: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_CanRedo +// Find out if it is possible for the current focused widget in a given +// form to perform a redo operation. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// Return Value: +// True if it is possible to redo. +var + FORM_CanRedo: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_Undo +// Make the current focused widget perform an undo operation. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// Return Value: +// True if the undo operation succeeded. +var + FORM_Undo: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_Redo +// Make the current focused widget perform a redo operation. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// Return Value: +// True if the redo operation succeeded. +var + FORM_Redo: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FORM_ForceToKillFocus. +// Call this member function to force to kill the focus of the form +// field which has focus. If it would kill the focus of a form field, +// save the value of form field if was changed by theuser. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// Return Value: +// True indicates success; otherwise false. +var + FORM_ForceToKillFocus: function(hHandle: FPDF_FORMHANDLE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FORM_GetFocusedAnnot. +// Call this member function to get the currently focused annotation. +// Parameters: +// handle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// page_index - Buffer to hold the index number of the page which +// contains the focused annotation. 0 for the first page. +// Can't be NULL. +// annot - Buffer to hold the focused annotation. Can't be NULL. +// Return Value: +// On success, return true and write to the out parameters. Otherwise +// return false and leave the out parameters unmodified. +// Comments: +// Not currently supported for XFA forms - will report no focused +// annotation. +// Must call FPDFPage_CloseAnnot() when the annotation returned in |annot| +// by this function is no longer needed. +// This will return true and set |page_index| to -1 and |annot| to NULL, +// if there is no focused annotation. +var + FORM_GetFocusedAnnot: function(handle: FPDF_FORMHANDLE; var page_index: Integer; + var annot: FPDF_ANNOTATION): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FORM_SetFocusedAnnot. +// Call this member function to set the currently focused annotation. +// Parameters: +// handle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// annot - Handle to an annotation. +// Return Value: +// True indicates success; otherwise false. +// Comments: +// |annot| can't be NULL. To kill focus, use FORM_ForceToKillFocus() +// instead. +var + FORM_SetFocusedAnnot: function(handle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Form Field Types +// The names of the defines are stable, but the specific values associated with +// them are not, so do not hardcode their values. +const + FPDF_FORMFIELD_UNKNOWN = 0; // Unknown. + FPDF_FORMFIELD_PUSHBUTTON = 1; // push button type. + FPDF_FORMFIELD_CHECKBOX = 2; // check box type. + FPDF_FORMFIELD_RADIOBUTTON = 3; // radio button type. + FPDF_FORMFIELD_COMBOBOX = 4; // combo box type. + FPDF_FORMFIELD_LISTBOX = 5; // list box type. + FPDF_FORMFIELD_TEXTFIELD = 6; // text field type. + FPDF_FORMFIELD_SIGNATURE = 7; // text field type. +{$IFDEF PDF_ENABLE_XFA} + FPDF_FORMFIELD_XFA = 8; // Generic XFA type. + FPDF_FORMFIELD_XFA_CHECKBOX = 9; // XFA check box type. + FPDF_FORMFIELD_XFA_COMBOBOX = 10; // XFA combo box type. + FPDF_FORMFIELD_XFA_IMAGEFIELD = 11; // XFA image field type. + FPDF_FORMFIELD_XFA_LISTBOX = 12; // XFA list box type. + FPDF_FORMFIELD_XFA_PUSHBUTTON = 13; // XFA push button type. + FPDF_FORMFIELD_XFA_SIGNATURE = 14; // XFA signture field type. + FPDF_FORMFIELD_XFA_TEXTFIELD = 15; // XFA text field type. +{$ENDIF PDF_ENABLE_XFA} + +{$IFDEF PDF_ENABLE_XFA} + FPDF_FORMFIELD_COUNT = 16; +{$ELSE} + FPDF_FORMFIELD_COUNT = 8; +{$ENDIF PDF_ENABLE_XFA} + +{$IFDEF PDF_ENABLE_XFA} +function IS_XFA_FORMFIELD(type_: Integer): Boolean; inline; +{$ENDIF PDF_ENABLE_XFA} + + + +// Function: FPDFPage_HasFormFieldAtPoint +// Get the form field type by point. +// Parameters: +// hHandle - Handle to the form fill module. Returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page. Returned by FPDF_LoadPage(). +// page_x - X position in PDF "user space". +// page_y - Y position in PDF "user space". +// Return Value: +// Return the type of the form field; -1 indicates no field. +// See field types above. +var + FPDFPage_HasFormFieldAtPoint: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; page_x, page_y: Double): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDFPage_FormFieldZOrderAtPoint +// Get the form field z-order by point. +// Parameters: +// hHandle - Handle to the form fill module. Returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - Handle to the page. Returned by FPDF_LoadPage(). +// page_x - X position in PDF "user space". +// page_y - Y position in PDF "user space". +// Return Value: +// Return the z-order of the form field; -1 indicates no field. +// Higher numbers are closer to the front. +var + FPDFPage_FormFieldZOrderAtPoint: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; page_x, page_y: Double): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_SetFormFieldHighlightColor +// Set the highlight color of the specified (or all) form fields +// in the document. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// doc - Handle to the document, as returned by +// FPDF_LoadDocument(). +// fieldType - A 32-bit integer indicating the type of a form +// field (defined above). +// color - The highlight color of the form field. Constructed by +// 0xxxrrggbb. +// Return Value: +// None. +// Comments: +// When the parameter fieldType is set to FPDF_FORMFIELD_UNKNOWN, the +// highlight color will be applied to all the form fields in the +// document. +// Please refresh the client window to show the highlight immediately +// if necessary. +var + FPDF_SetFormFieldHighlightColor: procedure(hHandle: FPDF_FORMHANDLE; fieldType: Integer; Color: LongWord); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_SetFormFieldHighlightAlpha +// Set the transparency of the form field highlight color in the +// document. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// doc - Handle to the document, as returaned by +// FPDF_LoadDocument(). +// alpha - The transparency of the form field highlight color, +// between 0-255. +// Return Value: +// None. +var + FPDF_SetFormFieldHighlightAlpha: procedure(hHandle: FPDF_FORMHANDLE; alpha: Byte); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_RemoveFormFieldHighlight +// Remove the form field highlight color in the document. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// Return Value: +// None. +// Comments: +// Please refresh the client window to remove the highlight immediately +// if necessary. +var + FPDF_RemoveFormFieldHighlight: procedure(hHandle: FPDF_FORMHANDLE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_FFLDraw +// Render FormFields and popup window on a page to a device independent +// bitmap. +// Parameters: +// hHandle - Handle to the form fill module, as returned by +// FPDFDOC_InitFormFillEnvironment(). +// bitmap - Handle to the device independent bitmap (as the +// output buffer). Bitmap handles can be created by +// FPDFBitmap_Create(). +// page - Handle to the page, as returned by FPDF_LoadPage(). +// start_x - Left pixel position of the display area in the +// device coordinates. +// start_y - Top pixel position of the display area in the device +// coordinates. +// size_x - Horizontal size (in pixels) for displaying the page. +// size_y - Vertical size (in pixels) for displaying the page. +// rotate - Page orientation: 0 (normal), 1 (rotated 90 degrees +// clockwise), 2 (rotated 180 degrees), 3 (rotated 90 +// degrees counter-clockwise). +// flags - 0 for normal display, or combination of flags +// defined above. +// Return Value: +// None. +// Comments: +// This function is designed to render annotations that are +// user-interactive, which are widget annotations (for FormFields) and +// popup annotations. +// With the FPDF_ANNOT flag, this function will render a popup annotation +// when users mouse-hover on a non-widget annotation. Regardless of +// FPDF_ANNOT flag, this function will always render widget annotations +// for FormFields. +// In order to implement the FormFill functions, implementation should +// call this function after rendering functions, such as +// FPDF_RenderPageBitmap() or FPDF_RenderPageBitmap_Start(), have +// finished rendering the page contents. +var + FPDF_FFLDraw: procedure(hHandle: FPDF_FORMHANDLE; bitmap: FPDF_BITMAP; page: FPDF_PAGE; + start_x, start_y, size_x, size_y, rotate, flags: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +{$IFDEF PDF_USE_SKIA} +var + FPDF_FFLDrawSkia: procedure(hHandle: FPDF_FORMHANDLE; canvas: FPDF_SKIA_CANVAS; page: FPDF_PAGE; + start_x, start_y, size_x, size_y, rotate, flags: Integer); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +{$ENDIF PDF_USE_SKIA} + +// Experimental API +// Function: FPDF_GetFormType +// Returns the type of form contained in the PDF document. +// Parameters: +// document - Handle to document. +// Return Value: +// Integer value representing one of the FORMTYPE_ values. +// Comments: +// If |document| is NULL, then the return value is FORMTYPE_NONE. +var + FPDF_GetFormType: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API +// Function: FORM_SetIndexSelected +// Selects/deselects the value at the given |index| of the focused +// annotation. +// Parameters: +// hHandle - Handle to the form fill module. Returned by +// FPDFDOC_InitFormFillEnvironment. +// page - Handle to the page. Returned by FPDF_LoadPage +// index - 0-based index of value to be set as +// selected/unselected +// selected - true to select, false to deselect +// Return Value: +// TRUE if the operation succeeded. +// FALSE if the operation failed or widget is not a supported type. +// Comments: +// Intended for use with listbox/combobox widget types. Comboboxes +// have at most a single value selected at a time which cannot be +// deselected. Deselect on a combobox is a no-op that returns false. +// Default implementation is a no-op that will return false for +// other types. +// Not currently supported for XFA forms - will return false. +var + FORM_SetIndexSelected: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; index: Integer; + selected: FPDF_BOOL): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API +// Function: FORM_IsIndexSelected +// Returns whether or not the value at |index| of the focused +// annotation is currently selected. +// Parameters: +// hHandle - Handle to the form fill module. Returned by +// FPDFDOC_InitFormFillEnvironment. +// page - Handle to the page. Returned by FPDF_LoadPage +// index - 0-based Index of value to check +// Return Value: +// TRUE if value at |index| is currently selected. +// FALSE if value at |index| is not selected or widget is not a +// supported type. +// Comments: +// Intended for use with listbox/combobox widget types. Default +// implementation is a no-op that will return false for other types. +// Not currently supported for XFA forms - will return false. +var + FORM_IsIndexSelected: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; index: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_LoadXFA +// If the document consists of XFA fields, call this method to +// attempt to load XFA fields. +// Parameters: +// document - Handle to document from FPDF_LoadDocument(). +// Return Value: +// TRUE upon success, otherwise FALSE. If XFA support is not built +// into PDFium, performs no action and always returns FALSE. +var + FPDF_LoadXFA: function(document: FPDF_DOCUMENT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_ANNOT_H_ *** + +const + FPDF_ANNOT_UNKNOWN = 0; + FPDF_ANNOT_TEXT = 1; + FPDF_ANNOT_LINK = 2; + FPDF_ANNOT_FREETEXT = 3; + FPDF_ANNOT_LINE = 4; + FPDF_ANNOT_SQUARE = 5; + FPDF_ANNOT_CIRCLE = 6; + FPDF_ANNOT_POLYGON = 7; + FPDF_ANNOT_POLYLINE = 8; + FPDF_ANNOT_HIGHLIGHT = 9; + FPDF_ANNOT_UNDERLINE = 10; + FPDF_ANNOT_SQUIGGLY = 11; + FPDF_ANNOT_STRIKEOUT = 12; + FPDF_ANNOT_STAMP = 13; + FPDF_ANNOT_CARET = 14; + FPDF_ANNOT_INK = 15; + FPDF_ANNOT_POPUP = 16; + FPDF_ANNOT_FILEATTACHMENT = 17; + FPDF_ANNOT_SOUND = 18; + FPDF_ANNOT_MOVIE = 19; + FPDF_ANNOT_WIDGET = 20; + FPDF_ANNOT_SCREEN = 21; + FPDF_ANNOT_PRINTERMARK = 22; + FPDF_ANNOT_TRAPNET = 23; + FPDF_ANNOT_WATERMARK = 24; + FPDF_ANNOT_THREED = 25; + FPDF_ANNOT_RICHMEDIA = 26; + FPDF_ANNOT_XFAWIDGET = 27; + FPDF_ANNOT_REDACT = 28; + + // Refer to PDF Reference (6th edition) table 8.16 for all annotation flags. + FPDF_ANNOT_FLAG_NONE = 0; + FPDF_ANNOT_FLAG_INVISIBLE = (1 shl 0); + FPDF_ANNOT_FLAG_HIDDEN = (1 shl 1); + FPDF_ANNOT_FLAG_PRINT = (1 shl 2); + FPDF_ANNOT_FLAG_NOZOOM = (1 shl 3); + FPDF_ANNOT_FLAG_NOROTATE = (1 shl 4); + FPDF_ANNOT_FLAG_NOVIEW = (1 shl 5); + FPDF_ANNOT_FLAG_READONLY = (1 shl 6); + FPDF_ANNOT_FLAG_LOCKED = (1 shl 7); + FPDF_ANNOT_FLAG_TOGGLENOVIEW = (1 shl 8); + + FPDF_ANNOT_APPEARANCEMODE_NORMAL = 0; + FPDF_ANNOT_APPEARANCEMODE_ROLLOVER = 1; + FPDF_ANNOT_APPEARANCEMODE_DOWN = 2; + FPDF_ANNOT_APPEARANCEMODE_COUNT = 3; + + // Refer to PDF Reference version 1.7 table 8.70 for field flags common to all + // interactive form field types. + FPDF_FORMFLAG_NONE = 0; + FPDF_FORMFLAG_READONLY = (1 shl 0); + FPDF_FORMFLAG_REQUIRED = (1 shl 1); + FPDF_FORMFLAG_NOEXPORT = (1 shl 2); + + // Refer to PDF Reference version 1.7 table 8.77 for field flags specific to + // interactive form text fields. + FPDF_FORMFLAG_TEXT_MULTILINE = (1 shl 12); + FPDF_FORMFLAG_TEXT_PASSWORD = (1 shl 13); + + // Refer to PDF Reference version 1.7 table 8.79 for field flags specific to + // interactive form choice fields. + FPDF_FORMFLAG_CHOICE_COMBO = (1 shl 17); + FPDF_FORMFLAG_CHOICE_EDIT = (1 shl 18); + FPDF_FORMFLAG_CHOICE_MULTI_SELECT = (1 shl 21); + + // Additional actions type of form field: + // K, on key stroke, JavaScript action. + // F, on format, JavaScript action. + // V, on validate, JavaScript action. + // C, on calculate, JavaScript action. + FPDF_ANNOT_AACTION_KEY_STROKE = 12; + FPDF_ANNOT_AACTION_FORMAT = 13; + FPDF_ANNOT_AACTION_VALIDATE = 14; + FPDF_ANNOT_AACTION_CALCULATE = 15; + +type + FPDFANNOT_COLORTYPE = ( + FPDFANNOT_COLORTYPE_Color = 0, + FPDFANNOT_COLORTYPE_InteriorColor + ); + +// Experimental API. +// Check if an annotation subtype is currently supported for creation. +// Currently supported subtypes: +// - circle +// - fileattachment +// - freetext +// - highlight +// - ink +// - link +// - popup +// - square, +// - squiggly +// - stamp +// - strikeout +// - text +// - underline +// +// subtype - the subtype to be checked. +// +// Returns true if this subtype supported. +var + FPDFAnnot_IsSupportedSubtype: function(subtype: FPDF_ANNOTATION_SUBTYPE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Create an annotation in |page| of the subtype |subtype|. If the specified +// subtype is illegal or unsupported, then a new annotation will not be created. +// Must call FPDFPage_CloseAnnot() when the annotation returned by this +// function is no longer needed. +// +// page - handle to a page. +// subtype - the subtype of the new annotation. +// +// Returns a handle to the new annotation object, or NULL on failure. +var + FPDFPage_CreateAnnot: function(page: FPDF_PAGE; subtype: FPDF_ANNOTATION_SUBTYPE): FPDF_ANNOTATION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the number of annotations in |page|. +// +// page - handle to a page. +// +// Returns the number of annotations in |page|. +var + FPDFPage_GetAnnotCount: function(page: FPDF_PAGE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get annotation in |page| at |index|. Must call FPDFPage_CloseAnnot() when the +// annotation returned by this function is no longer needed. +// +// page - handle to a page. +// index - the index of the annotation. +// +// Returns a handle to the annotation object, or NULL on failure. +var + FPDFPage_GetAnnot: function(page: FPDF_PAGE; index: Integer): FPDF_ANNOTATION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the index of |annot| in |page|. This is the opposite of +// FPDFPage_GetAnnot(). +// +// page - handle to the page that the annotation is on. +// annot - handle to an annotation. +// +// Returns the index of |annot|, or -1 on failure. +var + FPDFPage_GetAnnotIndex: function(page: FPDF_PAGE; annot: FPDF_ANNOTATION): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Close an annotation. Must be called when the annotation returned by +// FPDFPage_CreateAnnot() or FPDFPage_GetAnnot() is no longer needed. This +// function does not remove the annotation from the document. +// +// annot - handle to an annotation. +var + FPDFPage_CloseAnnot: procedure(annot: FPDF_ANNOTATION); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Remove the annotation in |page| at |index|. +// +// page - handle to a page. +// index - the index of the annotation. +// +// Returns true if successful. +var + FPDFPage_RemoveAnnot: function(page: FPDF_PAGE; index: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the subtype of an annotation. +// +// annot - handle to an annotation. +// +// Returns the annotation subtype. +var + FPDFAnnot_GetSubtype: function(annot: FPDF_ANNOTATION): FPDF_ANNOTATION_SUBTYPE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Check if an annotation subtype is currently supported for object extraction, +// update, and removal. +// Currently supported subtypes: ink and stamp. +// +// subtype - the subtype to be checked. +// +// Returns true if this subtype supported. +var + FPDFAnnot_IsObjectSupportedSubtype: function(subtype: FPDF_ANNOTATION_SUBTYPE): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Update |obj| in |annot|. |obj| must be in |annot| already and must have +// been retrieved by FPDFAnnot_GetObject(). Currently, only ink and stamp +// annotations are supported by this API. Also note that only path, image, and +// text objects have APIs for modification; see FPDFPath_*(), FPDFText_*(), and +// FPDFImageObj_*(). +// +// annot - handle to an annotation. +// obj - handle to the object that |annot| needs to update. +// +// Return true if successful. +var + FPDFAnnot_UpdateObject: function(annot: FPDF_ANNOTATION; obj: FPDF_PAGEOBJECT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Add a new InkStroke, represented by an array of points, to the InkList of +// |annot|. The API creates an InkList if one doesn't already exist in |annot|. +// This API works only for ink annotations. Please refer to ISO 32000-1:2008 +// spec, section 12.5.6.13. +// +// annot - handle to an annotation. +// points - pointer to a FS_POINTF array representing input points. +// point_count - number of elements in |points| array. This should not exceed +// the maximum value that can be represented by an int32_t). +// +// Returns the 0-based index at which the new InkStroke is added in the InkList +// of the |annot|. Returns -1 on failure. +var + FPDFAnnot_AddInkStroke: function(annot: FPDF_ANNOTATION; const points: PFS_POINTF; point_count: SIZE_T): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Removes an InkList in |annot|. +// This API works only for ink annotations. +// +// annot - handle to an annotation. +// +// Return true on successful removal of /InkList entry from context of the +// non-null ink |annot|. Returns false on failure. +var + FPDFAnnot_RemoveInkList: function(annot: FPDF_ANNOTATION): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Add |obj| to |annot|. |obj| must have been created by +// FPDFPageObj_CreateNew{Path|Rect}() or FPDFPageObj_New{Text|Image}Obj(), and +// will be owned by |annot|. Note that an |obj| cannot belong to more than one +// |annot|. Currently, only ink and stamp annotations are supported by this API. +// Also note that only path, image, and text objects have APIs for creation. +// +// annot - handle to an annotation. +// obj - handle to the object that is to be added to |annot|. +// +// Return true if successful. +var + FPDFAnnot_AppendObject: function(annot: FPDF_ANNOTATION; obj: FPDF_PAGEOBJECT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the total number of objects in |annot|, including path objects, text +// objects, external objects, image objects, and shading objects. +// +// annot - handle to an annotation. +// +// Returns the number of objects in |annot|. +var + FPDFAnnot_GetObjectCount: function(annot: FPDF_ANNOTATION): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the object in |annot| at |index|. +// +// annot - handle to an annotation. +// index - the index of the object. +// +// Return a handle to the object, or NULL on failure. +var + FPDFAnnot_GetObject: function(annot: FPDF_ANNOTATION; index: Integer): FPDF_PAGEOBJECT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Remove the object in |annot| at |index|. +// +// annot - handle to an annotation. +// index - the index of the object to be removed. +// +// Return true if successful. +var + FPDFAnnot_RemoveObject: function(annot: FPDF_ANNOTATION; index: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the color of an annotation. Fails when called on annotations with +// appearance streams already defined; instead use +// FPDFPath_Set{Stroke|Fill}Color(). +// +// annot - handle to an annotation. +// type - type of the color to be set. +// R, G, B - buffer to hold the RGB value of the color. Ranges from 0 to 255. +// A - buffer to hold the opacity. Ranges from 0 to 255. +// +// Returns true if successful. +var + FPDFAnnot_SetColor: function(annot: FPDF_ANNOTATION; type_: FPDFANNOT_COLORTYPE; R, G, B, A: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the color of an annotation. If no color is specified, default to yellow +// for highlight annotation, black for all else. Fails when called on +// annotations with appearance streams already defined; instead use +// FPDFPath_Get{Stroke|Fill}Color(). +// +// annot - handle to an annotation. +// type - type of the color requested. +// R, G, B - buffer to hold the RGB value of the color. Ranges from 0 to 255. +// A - buffer to hold the opacity. Ranges from 0 to 255. +// +// Returns true if successful. +var + FPDFAnnot_GetColor: function(annot: FPDF_ANNOTATION; type_: FPDFANNOT_COLORTYPE; var R, G, B, A: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Check if the annotation is of a type that has attachment points +// (i.e. quadpoints). Quadpoints are the vertices of the rectangle that +// encompasses the texts affected by the annotation. They provide the +// coordinates in the page where the annotation is attached. Only text markup +// annotations (i.e. highlight, strikeout, squiggly, and underline) and link +// annotations have quadpoints. +// +// annot - handle to an annotation. +// +// Returns true if the annotation is of a type that has quadpoints, false +// otherwise. +var + FPDFAnnot_HasAttachmentPoints: function(annot: FPDF_ANNOTATION): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Replace the attachment points (i.e. quadpoints) set of an annotation at +// |quad_index|. This index needs to be within the result of +// FPDFAnnot_CountAttachmentPoints(). +// If the annotation's appearance stream is defined and this annotation is of a +// type with quadpoints, then update the bounding box too if the new quadpoints +// define a bigger one. +// +// annot - handle to an annotation. +// quad_index - index of the set of quadpoints. +// quad_points - the quadpoints to be set. +// +// Returns true if successful. +var + FPDFAnnot_SetAttachmentPoints: function(annot: FPDF_ANNOTATION; quad_index: SIZE_T; quad_points: PFS_QUADPOINTSF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Append to the list of attachment points (i.e. quadpoints) of an annotation. +// If the annotation's appearance stream is defined and this annotation is of a +// type with quadpoints, then update the bounding box too if the new quadpoints +// define a bigger one. +// +// annot - handle to an annotation. +// quad_points - the quadpoints to be set. +// +// Returns true if successful. +var + FPDFAnnot_AppendAttachmentPoints: function(annot: FPDF_ANNOTATION; quad_points: PFS_QUADPOINTSF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the number of sets of quadpoints of an annotation. +// +// annot - handle to an annotation. +// +// Returns the number of sets of quadpoints, or 0 on failure. +var + FPDFAnnot_CountAttachmentPoints: function(annot: FPDF_ANNOTATION): SIZE_T; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the attachment points (i.e. quadpoints) of an annotation. +// +// annot - handle to an annotation. +// quad_index - index of the set of quadpoints. +// quad_points - receives the quadpoints; must not be NULL. +// +// Returns true if successful. +var + FPDFAnnot_GetAttachmentPoints: function(annot: FPDF_ANNOTATION; quad_index: SIZE_T; quad_points: PFS_QUADPOINTSF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the annotation rectangle defining the location of the annotation. If the +// annotation's appearance stream is defined and this annotation is of a type +// without quadpoints, then update the bounding box too if the new rectangle +// defines a bigger one. +// +// annot - handle to an annotation. +// rect - the annotation rectangle to be set. +// +// Returns true if successful. +var + FPDFAnnot_SetRect: function(annot: FPDF_ANNOTATION; rect: PFS_RECTF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the annotation rectangle defining the location of the annotation. +// +// annot - handle to an annotation. +// rect - receives the rectangle; must not be NULL. +// +// Returns true if successful. +var + FPDFAnnot_GetRect: function(annot: FPDF_ANNOTATION; rect: PFS_RECTF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the vertices of a polygon or polyline annotation. |buffer| is an array of +// points of the annotation. If |length| is less than the returned length, or +// |annot| or |buffer| is NULL, |buffer| will not be modified. +// +// annot - handle to an annotation, as returned by e.g. FPDFPage_GetAnnot() +// buffer - buffer for holding the points. +// length - length of the buffer in points. +// +// Returns the number of points if the annotation is of type polygon or +// polyline, 0 otherwise. +var + FPDFAnnot_GetVertices: function(annot: FPDF_ANNOTATION; buffer: PFS_POINTF; length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the number of paths in the ink list of an ink annotation. +// +// annot - handle to an annotation, as returned by e.g. FPDFPage_GetAnnot() +// +// Returns the number of paths in the ink list if the annotation is of type ink, +// 0 otherwise. +var + FPDFAnnot_GetInkListCount: function(annot: FPDF_ANNOTATION): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get a path in the ink list of an ink annotation. |buffer| is an array of +// points of the path. If |length| is less than the returned length, or |annot| +// or |buffer| is NULL, |buffer| will not be modified. +// +// annot - handle to an annotation, as returned by e.g. FPDFPage_GetAnnot() +// path_index - index of the path +// buffer - buffer for holding the points. +// length - length of the buffer in points. +// +// Returns the number of points of the path if the annotation is of type ink, 0 +// otherwise. +var + FPDFAnnot_GetInkListPath: function(annot: FPDF_ANNOTATION; path_index: LongWord; buffer: PFS_POINTF; + length: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the starting and ending coordinates of a line annotation. +// +// annot - handle to an annotation, as returned by e.g. FPDFPage_GetAnnot() +// start - starting point +// end - ending point +// +// Returns true if the annotation is of type line, |start| and |end| are not +// NULL, false otherwise. +var + FPDFAnnot_GetLine: function(annot: FPDF_ANNOTATION; start, end_: PFS_POINTF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the characteristics of the annotation's border (rounded rectangle). +// +// annot - handle to an annotation +// horizontal_radius - horizontal corner radius, in default user space units +// vertical_radius - vertical corner radius, in default user space units +// border_width - border width, in default user space units +// +// Returns true if setting the border for |annot| succeeds, false otherwise. +// +// If |annot| contains an appearance stream that overrides the border values, +// then the appearance stream will be removed on success. +var + FPDFAnnot_SetBorder: function(annot: FPDF_ANNOTATION; horizontal_radius, vertical_radius, border_width: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the characteristics of the annotation's border (rounded rectangle). +// +// annot - handle to an annotation +// horizontal_radius - horizontal corner radius, in default user space units +// vertical_radius - vertical corner radius, in default user space units +// border_width - border width, in default user space units +// +// Returns true if |horizontal_radius|, |vertical_radius| and |border_width| are +// not NULL, false otherwise. +var + FPDFAnnot_GetBorder: function(annot: FPDF_ANNOTATION; var horizontal_radius, vertical_radius, border_width: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the JavaScript of an event of the annotation's additional actions. +// |buffer| is only modified if |buflen| is large enough to hold the whole +// JavaScript string. If |buflen| is smaller, the total size of the JavaScript +// is still returned, but nothing is copied. If there is no JavaScript for +// |event| in |annot|, an empty string is written to |buf| and 2 is returned, +// denoting the size of the null terminator in the buffer. On other errors, +// nothing is written to |buffer| and 0 is returned. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment(). +// annot - handle to an interactive form annotation. +// event - event type, one of the FPDF_ANNOT_AACTION_* values. +// buffer - buffer for holding the value string, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the string value in bytes, including the 2-byte +// null terminator. +var + FPDFAnnot_GetFormAdditionalActionJavaScript: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; + event: Integer; buffer: PFPDF_WCHAR; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Check if |annot|'s dictionary has |key| as a key. +// +// annot - handle to an annotation. +// key - the key to look for, encoded in UTF-8. +// +// Returns true if |key| exists. +var + FPDFAnnot_HasKey: function(annot: FPDF_ANNOTATION; key: FPDF_BYTESTRING): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the type of the value corresponding to |key| in |annot|'s dictionary. +// +// annot - handle to an annotation. +// key - the key to look for, encoded in UTF-8. +// +// Returns the type of the dictionary value. +var + FPDFAnnot_GetValueType: function(annot: FPDF_ANNOTATION; key: FPDF_BYTESTRING): FPDF_OBJECT_TYPE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the string value corresponding to |key| in |annot|'s dictionary, +// overwriting the existing value if any. The value type would be +// FPDF_OBJECT_STRING after this function call succeeds. +// +// annot - handle to an annotation. +// key - the key to the dictionary entry to be set, encoded in UTF-8. +// value - the string value to be set, encoded in UTF-16LE. +// +// Returns true if successful. +var + FPDFAnnot_SetStringValue: function(annot: FPDF_ANNOTATION; key: FPDF_BYTESTRING; value: FPDF_WIDESTRING): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the string value corresponding to |key| in |annot|'s dictionary. |buffer| +// is only modified if |buflen| is longer than the length of contents. Note that +// if |key| does not exist in the dictionary or if |key|'s corresponding value +// in the dictionary is not a string (i.e. the value is not of type +// FPDF_OBJECT_STRING or FPDF_OBJECT_NAME), then an empty string would be copied +// to |buffer| and the return value would be 2. On other errors, nothing would +// be added to |buffer| and the return value would be 0. +// +// annot - handle to an annotation. +// key - the key to the requested dictionary entry, encoded in UTF-8. +// buffer - buffer for holding the value string, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the string value in bytes. +var + FPDFAnnot_GetStringValue: function(annot: FPDF_ANNOTATION; key: FPDF_BYTESTRING; buffer: PFPDF_WCHAR; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the float value corresponding to |key| in |annot|'s dictionary. Writes +// value to |value| and returns True if |key| exists in the dictionary and +// |key|'s corresponding value is a number (FPDF_OBJECT_NUMBER), False +// otherwise. +// +// annot - handle to an annotation. +// key - the key to the requested dictionary entry, encoded in UTF-8. +// value - receives the value, must not be NULL. +// +// Returns True if value found, False otherwise. +var + FPDFAnnot_GetNumberValue: function(annot: FPDF_ANNOTATION; key: FPDF_BYTESTRING; value: PSingle): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the AP (appearance string) in |annot|'s dictionary for a given +// |appearanceMode|. +// +// annot - handle to an annotation. +// appearanceMode - the appearance mode (normal, rollover or down) for which +// to get the AP. +// value - the string value to be set, encoded in UTF-16LE. If +// nullptr is passed, the AP is cleared for that mode. If the +// mode is Normal, APs for all modes are cleared. +// +// Returns true if successful. +var + FPDFAnnot_SetAP: function(annot: FPDF_ANNOTATION; appearanceMode: FPDF_ANNOT_APPEARANCEMODE; + value: FPDF_WIDESTRING): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the AP (appearance string) from |annot|'s dictionary for a given +// |appearanceMode|. +// |buffer| is only modified if |buflen| is large enough to hold the whole AP +// string. If |buflen| is smaller, the total size of the AP is still returned, +// but nothing is copied. +// If there is no appearance stream for |annot| in |appearanceMode|, an empty +// string is written to |buf| and 2 is returned. +// On other errors, nothing is written to |buffer| and 0 is returned. +// +// annot - handle to an annotation. +// appearanceMode - the appearance mode (normal, rollover or down) for which +// to get the AP. +// buffer - buffer for holding the value string, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the string value in bytes. +var + FPDFAnnot_GetAP: function(annot: FPDF_ANNOTATION; appearanceMode: FPDF_ANNOT_APPEARANCEMODE; buffer: PFPDF_WCHAR; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the annotation corresponding to |key| in |annot|'s dictionary. Common +// keys for linking annotations include "IRT" and "Popup". Must call +// FPDFPage_CloseAnnot() when the annotation returned by this function is no +// longer needed. +// +// annot - handle to an annotation. +// key - the key to the requested dictionary entry, encoded in UTF-8. +// +// Returns a handle to the linked annotation object, or NULL on failure. +var + FPDFAnnot_GetLinkedAnnot: function(annot: FPDF_ANNOTATION; key: FPDF_BYTESTRING): FPDF_ANNOTATION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the annotation flags of |annot|. +// +// annot - handle to an annotation. +// +// Returns the annotation flags. +var + FPDFAnnot_GetFlags: function(annot: FPDF_ANNOTATION): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the |annot|'s flags to be of the value |flags|. +// +// annot - handle to an annotation. +// flags - the flag values to be set. +// +// Returns true if successful. +var + FPDFAnnot_SetFlags: function(annot: FPDF_ANNOTATION; flags: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the annotation flags of |annot|. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment(). +// annot - handle to an interactive form annotation. +// +// Returns the annotation flags specific to interactive forms. +var + FPDFAnnot_GetFormFieldFlags: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Retrieves an interactive form annotation whose rectangle contains a given +// point on a page. Must call FPDFPage_CloseAnnot() when the annotation returned +// is no longer needed. +// +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment(). +// page - handle to the page, returned by FPDF_LoadPage function. +// point - position in PDF "user space". +// +// Returns the interactive form annotation whose rectangle contains the given +// coordinates on the page. If there is no such annotation, return NULL. +var + FPDFAnnot_GetFormFieldAtPoint: function(hHandle: FPDF_FORMHANDLE; page: FPDF_PAGE; + const point: PFS_POINTF): FPDF_ANNOTATION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets the name of |annot|, which is an interactive form annotation. +// |buffer| is only modified if |buflen| is longer than the length of contents. +// In case of error, nothing will be added to |buffer| and the return value will +// be 0. Note that return value of empty string is 2 for "\0\0". +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment(). +// annot - handle to an interactive form annotation. +// buffer - buffer for holding the name string, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the string value in bytes. +var + FPDFAnnot_GetFormFieldName: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; buffer: PFPDF_WCHAR; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets the alternate name of |annot|, which is an interactive form annotation. +// |buffer| is only modified if |buflen| is longer than the length of contents. +// In case of error, nothing will be added to |buffer| and the return value will +// be 0. Note that return value of empty string is 2 for "\0\0". +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment(). +// annot - handle to an interactive form annotation. +// buffer - buffer for holding the alternate name string, encoded in +// UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the string value in bytes. +var + FPDFAnnot_GetFormFieldAlternateName: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; buffer: PFPDF_WCHAR; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets the form field type of |annot|, which is an interactive form annotation. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment(). +// annot - handle to an interactive form annotation. +// +// Returns the type of the form field (one of the FPDF_FORMFIELD_* values) on +// success. Returns -1 on error. +// See field types in fpdf_formfill.h. +var + FPDFAnnot_GetFormFieldType: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets the value of |annot|, which is an interactive form annotation. +// |buffer| is only modified if |buflen| is longer than the length of contents. +// In case of error, nothing will be added to |buffer| and the return value will +// be 0. Note that return value of empty string is 2 for "\0\0". +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment(). +// annot - handle to an interactive form annotation. +// buffer - buffer for holding the value string, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the string value in bytes. +var + FPDFAnnot_GetFormFieldValue: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; buffer: PFPDF_WCHAR; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the number of options in the |annot|'s "Opt" dictionary. Intended for +// use with listbox and combobox widget annotations. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// annot - handle to an annotation. +// +// Returns the number of options in "Opt" dictionary on success. Return value +// will be -1 if annotation does not have an "Opt" dictionary or other error. +var + FPDFAnnot_GetOptionCount: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the string value for the label of the option at |index| in |annot|'s +// "Opt" dictionary. Intended for use with listbox and combobox widget +// annotations. |buffer| is only modified if |buflen| is longer than the length +// of contents. If index is out of range or in case of other error, nothing +// will be added to |buffer| and the return value will be 0. Note that +// return value of empty string is 2 for "\0\0". +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// annot - handle to an annotation. +// index - numeric index of the option in the "Opt" array +// buffer - buffer for holding the value string, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the string value in bytes. +// If |annot| does not have an "Opt" array, |index| is out of range or if any +// other error occurs, returns 0. +var + FPDFAnnot_GetOptionLabel: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; index: Integer; + buffer: PFPDF_WCHAR; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Determine whether or not the option at |index| in |annot|'s "Opt" dictionary +// is selected. Intended for use with listbox and combobox widget annotations. +// +// handle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// annot - handle to an annotation. +// index - numeric index of the option in the "Opt" array. +// +// Returns true if the option at |index| in |annot|'s "Opt" dictionary is +// selected, false otherwise. +var + FPDFAnnot_IsOptionSelected: function(handle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; index: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the float value of the font size for an |annot| with variable text. +// If 0, the font is to be auto-sized: its size is computed as a function of +// the height of the annotation rectangle. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// annot - handle to an annotation. +// value - Required. Float which will be set to font size on success. +// +// Returns true if the font size was set in |value|, false on error or if +// |value| not provided. +var + FPDFAnnot_GetFontSize: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; var value: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get the RGB value of the font color for an |annot| with variable text. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// annot - handle to an annotation. +// R, G, B - buffer to hold the RGB value of the color. Ranges from 0 to 255. +// +// Returns true if the font color was set, false on error or if the font +// color was not provided. +var + FPDFAnnot_GetFontColor: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; var R, G, B: Cardinal): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Determine if |annot| is a form widget that is checked. Intended for use with +// checkbox and radio button widgets. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// annot - handle to an annotation. +// +// Returns true if |annot| is a form widget and is checked, false otherwise. +var + FPDFAnnot_IsChecked: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the list of focusable annotation subtypes. Annotations of subtype +// FPDF_ANNOT_WIDGET are by default focusable. New subtypes set using this API +// will override the existing subtypes. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// subtypes - list of annotation subtype which can be tabbed over. +// count - total number of annotation subtype in list. +// Returns true if list of annotation subtype is set successfully, false +// otherwise. +var + FPDFAnnot_SetFocusableSubtypes: function(hHandle: FPDF_FORMHANDLE; const subtypes: PFPDF_ANNOTATION_SUBTYPE; + count: SIZE_T): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the count of focusable annotation subtypes as set by host +// for a |hHandle|. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// Returns the count of focusable annotation subtypes or -1 on error. +// Note : Annotations of type FPDF_ANNOT_WIDGET are by default focusable. +var + FPDFAnnot_GetFocusableSubtypesCount: function(hHandle: FPDF_FORMHANDLE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the list of focusable annotation subtype as set by host. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// subtypes - receives the list of annotation subtype which can be tabbed +// over. Caller must have allocated |subtypes| more than or +// equal to the count obtained from +// FPDFAnnot_GetFocusableSubtypesCount() API. +// count - size of |subtypes|. +// Returns true on success and set list of annotation subtype to |subtypes|, +// false otherwise. +// Note : Annotations of type FPDF_ANNOT_WIDGET are by default focusable. +var + FPDFAnnot_GetFocusableSubtypes: function(hHandle: FPDF_FORMHANDLE; subtypes: PFPDF_ANNOTATION_SUBTYPE; + count: SIZE_T): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets FPDF_LINK object for |annot|. Intended to use for link annotations. +// +// annot - handle to an annotation. +// +// Returns FPDF_LINK from the FPDF_ANNOTATION and NULL on failure, +// if the input annot is NULL or input annot's subtype is not link. +var + FPDFAnnot_GetLink: function(annot: FPDF_ANNOTATION): FPDF_LINK; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets the count of annotations in the |annot|'s control group. +// A group of interactive form annotations is collectively called a form +// control group. Here, |annot|, an interactive form annotation, should be +// either a radio button or a checkbox. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// annot - handle to an annotation. +// +// Returns number of controls in its control group or -1 on error. +var + FPDFAnnot_GetFormControlCount: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets the index of |annot| in |annot|'s control group. +// A group of interactive form annotations is collectively called a form +// control group. Here, |annot|, an interactive form annotation, should be +// either a radio button or a checkbox. +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment. +// annot - handle to an annotation. +// +// Returns index of a given |annot| in its control group or -1 on error. +var + FPDFAnnot_GetFormControlIndex: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets the export value of |annot| which is an interactive form annotation. +// Intended for use with radio button and checkbox widget annotations. +// |buffer| is only modified if |buflen| is longer than the length of contents. +// In case of error, nothing will be added to |buffer| and the return value +// will be 0. Note that return value of empty string is 2 for "\0\0". +// +// hHandle - handle to the form fill module, returned by +// FPDFDOC_InitFormFillEnvironment(). +// annot - handle to an interactive form annotation. +// buffer - buffer for holding the value string, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the string value in bytes. +var + FPDFAnnot_GetFormFieldExportValue: function(hHandle: FPDF_FORMHANDLE; annot: FPDF_ANNOTATION; + buffer: PFPDF_WCHAR; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Add a URI action to |annot|, overwriting the existing action, if any. +// +// annot - handle to a link annotation. +// uri - the URI to be set, encoded in 7-bit ASCII. +// +// Returns true if successful. +var + FPDFAnnot_SetURI: function(annot: FPDF_ANNOTATION; uri: PAnsiChar): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the attachment from |annot|. +// +// annot - handle to a file annotation. +// +// Returns the handle to the attachment object, or NULL on failure. +var + FPDFAnnot_GetFileAttachment: function(annot: FPDF_ANNOTATION): FPDF_ATTACHMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Add an embedded file with |name| to |annot|. +// +// annot - handle to a file annotation. +// name - name of the new attachment. +// +// Returns a handle to the new attachment object, or NULL on failure. +var + FPDFAnnot_AddFileAttachment: function(annot: FPDF_ANNOTATION; name: FPDF_WIDESTRING): FPDF_ATTACHMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// *** _FPDF_CATALOG_H_ *** + +// Experimental API. +// +// Determine if |document| represents a tagged PDF. +// +// For the definition of tagged PDF, See (see 10.7 "Tagged PDF" in PDF +// Reference 1.7). +// +// document - handle to a document. +// +// Returns |true| iff |document| is a tagged PDF. +var + FPDFCatalog_IsTagged: function(document: FPDF_DOCUMENT): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_ATTACHMENT_H_ *** + +// Experimental API. +// Get the number of embedded files in |document|. +// +// document - handle to a document. +// +// Returns the number of embedded files in |document|. +var + FPDFDoc_GetAttachmentCount: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Add an embedded file with |name| in |document|. If |name| is empty, or if +// |name| is the name of a existing embedded file in |document|, or if +// |document|'s embedded file name tree is too deep (i.e. |document| has too +// many embedded files already), then a new attachment will not be added. +// +// document - handle to a document. +// name - name of the new attachment. +// +// Returns a handle to the new attachment object, or NULL on failure. +var + FPDFDoc_AddAttachment: function(document: FPDF_DOCUMENT; name: FPDF_WIDESTRING): FPDF_ATTACHMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the embedded attachment at |index| in |document|. Note that the returned +// attachment handle is only valid while |document| is open. +// +// document - handle to a document. +// index - the index of the requested embedded file. +// +// Returns the handle to the attachment object, or NULL on failure. +var + FPDFDoc_GetAttachment: function(document: FPDF_DOCUMENT; index: Integer): FPDF_ATTACHMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Delete the embedded attachment at |index| in |document|. Note that this does +// not remove the attachment data from the PDF file; it simply removes the +// file's entry in the embedded files name tree so that it does not appear in +// the attachment list. This behavior may change in the future. +// +// document - handle to a document. +// index - the index of the embedded file to be deleted. +// +// Returns true if successful. +var + FPDFDoc_DeleteAttachment: function(document: FPDF_DOCUMENT; index: Integer): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the name of the |attachment| file. |buffer| is only modified if |buflen| +// is longer than the length of the file name. On errors, |buffer| is unmodified +// and the returned length is 0. +// +// attachment - handle to an attachment. +// buffer - buffer for holding the file name, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the file name in bytes. +var + FPDFAttachment_GetName: function(attachment: FPDF_ATTACHMENT; buffer: PFPDF_WCHAR; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Check if the params dictionary of |attachment| has |key| as a key. +// +// attachment - handle to an attachment. +// key - the key to look for, encoded in UTF-8. +// +// Returns true if |key| exists. +var + FPDFAttachment_HasKey: function(attachment: FPDF_ATTACHMENT; key: FPDF_BYTESTRING): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the type of the value corresponding to |key| in the params dictionary of +// the embedded |attachment|. +// +// attachment - handle to an attachment. +// key - the key to look for, encoded in UTF-8. +// +// Returns the type of the dictionary value. +var + FPDFAttachment_GetValueType: function(attachment: FPDF_ATTACHMENT; key: FPDF_BYTESTRING): FPDF_OBJECT_TYPE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the string value corresponding to |key| in the params dictionary of the +// embedded file |attachment|, overwriting the existing value if any. The value +// type should be FPDF_OBJECT_STRING after this function call succeeds. +// +// attachment - handle to an attachment. +// key - the key to the dictionary entry, encoded in UTF-8. +// value - the string value to be set, encoded in UTF-16LE. +// +// Returns true if successful. +var + FPDFAttachment_SetStringValue: function(attachment: FPDF_ATTACHMENT; key: FPDF_BYTESTRING; + value: FPDF_WIDESTRING): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the string value corresponding to |key| in the params dictionary of the +// embedded file |attachment|. |buffer| is only modified if |buflen| is longer +// than the length of the string value. Note that if |key| does not exist in the +// dictionary or if |key|'s corresponding value in the dictionary is not a +// string (i.e. the value is not of type FPDF_OBJECT_STRING or +// FPDF_OBJECT_NAME), then an empty string would be copied to |buffer| and the +// return value would be 2. On other errors, nothing would be added to |buffer| +// and the return value would be 0. +// +// attachment - handle to an attachment. +// key - the key to the requested string value, encoded in UTF-8. +// buffer - buffer for holding the string value encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the dictionary value string in bytes. +var + FPDFAttachment_GetStringValue: function(attachment: FPDF_ATTACHMENT; key: FPDF_BYTESTRING; buffer: PFPDF_WCHAR; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Set the file data of |attachment|, overwriting the existing file data if any. +// The creation date and checksum will be updated, while all other dictionary +// entries will be deleted. Note that only contents with |len| smaller than +// INT_MAX is supported. +// +// attachment - handle to an attachment. +// contents - buffer holding the file data to write to |attachment|. +// len - length of file data in bytes. +// +// Returns true if successful. +var + FPDFAttachment_SetFile: function(attachment: FPDF_ATTACHMENT; document: FPDF_DOCUMENT; + contents: Pointer; len: LongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the file data of |attachment|. +// When the attachment file data is readable, true is returned, and |out_buflen| +// is updated to indicate the file data size. |buffer| is only modified if +// |buflen| is non-null and long enough to contain the entire file data. Callers +// must check both the return value and the input |buflen| is no less than the +// returned |out_buflen| before using the data. +// +// Otherwise, when the attachment file data is unreadable or when |out_buflen| +// is null, false is returned and |buffer| and |out_buflen| remain unmodified. +// +// attachment - handle to an attachment. +// buffer - buffer for holding the file data from |attachment|. +// buflen - length of the buffer in bytes. +// out_buflen - pointer to the variable that will receive the minimum buffer +// size to contain the file data of |attachment|. +// +// Returns true on success, false otherwise. +var + FPDFAttachment_GetFile: function(attachment: FPDF_ATTACHMENT; buffer: Pointer; buflen: LongWord; + var out_buflen: LongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_FWLEVENT_H_ *** + +// Key flags. +type + FWL_EVENTFLAG = Integer; +const + FWL_EVENTFLAG_ShiftKey = 1 shl 0; + FWL_EVENTFLAG_ControlKey = 1 shl 1; + FWL_EVENTFLAG_AltKey = 1 shl 2; + FWL_EVENTFLAG_MetaKey = 1 shl 3; + FWL_EVENTFLAG_KeyPad = 1 shl 4; + FWL_EVENTFLAG_AutoRepeat = 1 shl 5; + FWL_EVENTFLAG_LeftButtonDown = 1 shl 6; + FWL_EVENTFLAG_MiddleButtonDown = 1 shl 7; + FWL_EVENTFLAG_RightButtonDown = 1 shl 8; + +type + FWL_VKEYCODE = Integer; // note: FWL_VKEY_* equals Windows.VK_* + + +// *** _FPDF_TRANSFORMPAGE_H_ *** + +// Set "MediaBox" entry to the page dictionary. +// +// page - Handle to a page. +// left - The left of the rectangle. +// bottom - The bottom of the rectangle. +// right - The right of the rectangle. +// top - The top of the rectangle. +var + FPDFPage_SetMediaBox: procedure(page: FPDF_PAGE; left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set "CropBox" entry to the page dictionary. +// +// page - Handle to a page. +// left - The left of the rectangle. +// bottom - The bottom of the rectangle. +// right - The right of the rectangle. +// top - The top of the rectangle. +var + FPDFPage_SetCropBox: procedure(page: FPDF_PAGE; left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set "BleedBox" entry to the page dictionary. +// +// page - Handle to a page. +// left - The left of the rectangle. +// bottom - The bottom of the rectangle. +// right - The right of the rectangle. +// top - The top of the rectangle. +var + FPDFPage_SetBleedBox: procedure(page: FPDF_PAGE; left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set "TrimBox" entry to the page dictionary. +// +// page - Handle to a page. +// left - The left of the rectangle. +// bottom - The bottom of the rectangle. +// right - The right of the rectangle. +// top - The top of the rectangle. +var + FPDFPage_SetTrimBox: procedure(page: FPDF_PAGE; left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Set "ArtBox" entry to the page dictionary. +// +// page - Handle to a page. +// left - The left of the rectangle. +// bottom - The bottom of the rectangle. +// right - The right of the rectangle. +// top - The top of the rectangle. +var + FPDFPage_SetArtBox: procedure(page: FPDF_PAGE; left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get "MediaBox" entry from the page dictionary. +// +// page - Handle to a page. +// left - Pointer to a float value receiving the left of the rectangle. +// bottom - Pointer to a float value receiving the bottom of the rectangle. +// right - Pointer to a float value receiving the right of the rectangle. +// top - Pointer to a float value receiving the top of the rectangle. +// +// On success, return true and write to the out parameters. Otherwise return +// false and leave the out parameters unmodified. +var + FPDFPage_GetMediaBox: procedure(page: FPDF_PAGE; var left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get "CropBox" entry from the page dictionary. +// +// page - Handle to a page. +// left - Pointer to a float value receiving the left of the rectangle. +// bottom - Pointer to a float value receiving the bottom of the rectangle. +// right - Pointer to a float value receiving the right of the rectangle. +// top - Pointer to a float value receiving the top of the rectangle. +// +// On success, return true and write to the out parameters. Otherwise return +// false and leave the out parameters unmodified. +var + FPDFPage_GetCropBox: procedure(page: FPDF_PAGE; var left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get "BleedBox" entry from the page dictionary. +// +// page - Handle to a page. +// left - Pointer to a float value receiving the left of the rectangle. +// bottom - Pointer to a float value receiving the bottom of the rectangle. +// right - Pointer to a float value receiving the right of the rectangle. +// top - Pointer to a float value receiving the top of the rectangle. +// +// On success, return true and write to the out parameters. Otherwise return +// false and leave the out parameters unmodified. +var + FPDFPage_GetBleedBox: procedure(page: FPDF_PAGE; var left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get "TrimBox" entry from the page dictionary. +// +// page - Handle to a page. +// left - Pointer to a float value receiving the left of the rectangle. +// bottom - Pointer to a float value receiving the bottom of the rectangle. +// right - Pointer to a float value receiving the right of the rectangle. +// top - Pointer to a float value receiving the top of the rectangle. +// +// On success, return true and write to the out parameters. Otherwise return +// false and leave the out parameters unmodified. +var + FPDFPage_GetTrimBox: procedure(page: FPDF_PAGE; var left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Get "ArtBox" entry from the page dictionary. +// +// page - Handle to a page. +// left - Pointer to a float value receiving the left of the rectangle. +// bottom - Pointer to a float value receiving the bottom of the rectangle. +// right - Pointer to a float value receiving the right of the rectangle. +// top - Pointer to a float value receiving the top of the rectangle. +// +// On success, return true and write to the out parameters. Otherwise return +// false and leave the out parameters unmodified. +var + FPDFPage_GetArtBox: procedure(page: FPDF_PAGE; var left, bottom, right, top: Single); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Apply transforms to |page|. +// +// If |matrix| is provided it will be applied to transform the page. +// If |clipRect| is provided it will be used to clip the resulting page. +// If neither |matrix| or |clipRect| are provided this method returns |false|. +// Returns |true| if transforms are applied. +// +// This function will transform the whole page, and would take effect to all the +// objects in the page. +// +// page - Page handle. +// matrix - Transform matrix. +// clipRect - Clipping rectangle. +var + FPDFPage_TransFormWithClip: function(page: FPDF_PAGE; matrix: PFS_MATRIX; clipRect: PFS_RECTF): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Transform (scale, rotate, shear, move) the clip path of page object. +// page_object - Handle to a page object. Returned by +// FPDFPageObj_NewImageObj(). +// +// a - The coefficient "a" of the matrix. +// b - The coefficient "b" of the matrix. +// c - The coefficient "c" of the matrix. +// d - The coefficient "d" of the matrix. +// e - The coefficient "e" of the matrix. +// f - The coefficient "f" of the matrix. +var + FPDFPageObj_TransformClipPath: procedure(page_object: FPDF_PAGEOBJECT; a, b, c, d, e, f: Double); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the clip path of the page object. +// +// page object - Handle to a page object. Returned by e.g. +// FPDFPage_GetObject(). +// +// Returns the handle to the clip path, or NULL on failure. The caller does not +// take ownership of the returned FPDF_CLIPPATH. Instead, it remains valid until +// FPDF_ClosePage() is called for the page containing |page_object|. +var + FPDFPageObj_GetClipPath: function(page_object: FPDF_PAGEOBJECT): FPDF_CLIPPATH; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get number of paths inside |clip_path|. +// +// clip_path - handle to a clip_path. +// +// Returns the number of objects in |clip_path| or -1 on failure. +var + FPDFClipPath_CountPaths: function(clip_path: FPDF_CLIPPATH): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get number of segments inside one path of |clip_path|. +// +// clip_path - handle to a clip_path. +// path_index - index into the array of paths of the clip path. +// +// Returns the number of segments or -1 on failure. +var + FPDFClipPath_CountPathSegments: function(clip_path: FPDF_CLIPPATH; path_index: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get segment in one specific path of |clip_path| at index. +// +// clip_path - handle to a clip_path. +// path_index - the index of a path. +// segment_index - the index of a segment. +// +// Returns the handle to the segment, or NULL on failure. The caller does not +// take ownership of the returned FPDF_PATHSEGMENT. Instead, it remains valid +// until FPDF_ClosePage() is called for the page containing |clip_path|. +var + FPDFClipPath_GetPathSegment: function(clip_path: FPDF_CLIPPATH; path_index, segment_index: Integer): FPDF_PATHSEGMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Create a new clip path, with a rectangle inserted. +// +// Caller takes ownership of the returned FPDF_CLIPPATH. It should be freed with +// FPDF_DestroyClipPath(). +// +// left - The left of the clip box. +// bottom - The bottom of the clip box. +// right - The right of the clip box. +// top - The top of the clip box. +var + FPDF_CreateClipPath: function(page_object: FPDF_PAGEOBJECT; left, bottom, right, top: Single): FPDF_CLIPPATH; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Destroy the clip path. +// +// clipPath - A handle to the clip path. It will be invalid after this call. +var + FPDF_DestroyClipPath: procedure(clipPath: FPDF_CLIPPATH); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Clip the page content, the page content that outside the clipping region +// become invisible. +// +// A clip path will be inserted before the page content stream or content array. +// In this way, the page content will be clipped by this clip path. +// +// page - A page handle. +// clipPath - A handle to the clip path. (Does not take ownership.) +var + FPDFPage_InsertClipPath: procedure(page: FPDF_PAGE; clipPath: FPDF_CLIPPATH); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_STRUCTTREE_H_ *** + +// Function: FPDF_StructTree_GetForPage +// Get the structure tree for a page. +// Parameters: +// page - Handle to the page, as returned by FPDF_LoadPage(). +// Return value: +// A handle to the structure tree or NULL on error. The caller owns the +// returned handle and must use FPDF_StructTree_Close() to release it. +// The handle should be released before |page| gets released. +var + FPDF_StructTree_GetForPage: function(page: FPDF_PAGE): FPDF_STRUCTTREE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructTree_Close +// Release a resource allocated by FPDF_StructTree_GetForPage(). +// Parameters: +// struct_tree - Handle to the structure tree, as returned by +// FPDF_StructTree_LoadPage(). +// Return value: +// None. +var + FPDF_StructTree_Close: procedure(struct_tree: FPDF_STRUCTTREE); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructTree_CountChildren +// Count the number of children for the structure tree. +// Parameters: +// struct_tree - Handle to the structure tree, as returned by +// FPDF_StructTree_LoadPage(). +// Return value: +// The number of children, or -1 on error. +var + FPDF_StructTree_CountChildren: function(struct_tree: FPDF_STRUCTTREE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructTree_GetChildAtIndex +// Get a child in the structure tree. +// Parameters: +// struct_tree - Handle to the structure tree, as returned by +// FPDF_StructTree_LoadPage(). +// index - The index for the child, 0-based. +// Return value: +// The child at the n-th index or NULL on error. The caller does not +// own the handle. The handle remains valid as long as |struct_tree| +// remains valid. +// Comments: +// The |index| must be less than the FPDF_StructTree_CountChildren() +// return value. +var + FPDF_StructTree_GetChildAtIndex: function(struct_tree: FPDF_STRUCTTREE; index: Integer): FPDF_STRUCTELEMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructElement_GetAltText +// Get the alt text for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// buffer - A buffer for output the alt text. May be NULL. +// buflen - The length of the buffer, in bytes. May be 0. +// Return value: +// The number of bytes in the alt text, including the terminating NUL +// character. The number of bytes is returned regardless of the +// |buffer| and |buflen| parameters. +// Comments: +// Regardless of the platform, the |buffer| is always in UTF-16LE +// encoding. The string is terminated by a UTF16 NUL character. If +// |buflen| is less than the required length, or |buffer| is NULL, +// |buffer| will not be modified. +var + FPDF_StructElement_GetAltText: function(struct_element: FPDF_STRUCTELEMENT; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetActualText +// Get the actual text for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// buffer - A buffer for output the actual text. May be NULL. +// buflen - The length of the buffer, in bytes. May be 0. +// Return value: +// The number of bytes in the actual text, including the terminating +// NUL character. The number of bytes is returned regardless of the +// |buffer| and |buflen| parameters. +// Comments: +// Regardless of the platform, the |buffer| is always in UTF-16LE +// encoding. The string is terminated by a UTF16 NUL character. If +// |buflen| is less than the required length, or |buffer| is NULL, +// |buffer| will not be modified. +var + FPDF_StructElement_GetActualText: function(struct_element: FPDF_STRUCTELEMENT; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructElement_GetID +// Get the ID for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// buffer - A buffer for output the ID string. May be NULL. +// buflen - The length of the buffer, in bytes. May be 0. +// Return value: +// The number of bytes in the ID string, including the terminating NUL +// character. The number of bytes is returned regardless of the +// |buffer| and |buflen| parameters. +// Comments: +// Regardless of the platform, the |buffer| is always in UTF-16LE +// encoding. The string is terminated by a UTF16 NUL character. If +// |buflen| is less than the required length, or |buffer| is NULL, +// |buffer| will not be modified. +var + FPDF_StructElement_GetID: function(struct_element: FPDF_STRUCTELEMENT; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetLang +// Get the case-insensitive IETF BCP 47 language code for an element. +// Parameters: +// struct_element - Handle to the struct element. +// buffer - A buffer for output the lang string. May be NULL. +// buflen - The length of the buffer, in bytes. May be 0. +// Return value: +// The number of bytes in the ID string, including the terminating NUL +// character. The number of bytes is returned regardless of the +// |buffer| and |buflen| parameters. +// Comments: +// Regardless of the platform, the |buffer| is always in UTF-16LE +// encoding. The string is terminated by a UTF16 NUL character. If +// |buflen| is less than the required length, or |buffer| is NULL, +// |buffer| will not be modified. +var + FPDF_StructElement_GetLang: function(struct_element: FPDF_STRUCTELEMENT; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetStringAttribute +// Get a struct element attribute of type "name" or "string". +// Parameters: +// struct_element - Handle to the struct element. +// attr_name - The name of the attribute to retrieve. +// buffer - A buffer for output. May be NULL. +// buflen - The length of the buffer, in bytes. May be 0. +// Return value: +// The number of bytes in the attribute value, including the +// terminating NUL character. The number of bytes is returned +// regardless of the |buffer| and |buflen| parameters. +// Comments: +// Regardless of the platform, the |buffer| is always in UTF-16LE +// encoding. The string is terminated by a UTF16 NUL character. If +// |buflen| is less than the required length, or |buffer| is NULL, +// |buffer| will not be modified. +var + FPDF_StructElement_GetStringAttribute: function(struct_element: FPDF_STRUCTELEMENT; + attr_name: FPDF_BYTESTRING; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructElement_GetMarkedContentID +// Get the marked content ID for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// Return value: +// The marked content ID of the element. If no ID exists, returns +// -1. +// Comments: +// FPDF_StructElement_GetMarkedContentIdAtIndex() may be able to +// extract more marked content IDs out of |struct_element|. This API +// may be deprecated in the future. +var + FPDF_StructElement_GetMarkedContentID: function(struct_element: FPDF_STRUCTELEMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructElement_GetType +// Get the type (/S) for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// buffer - A buffer for output. May be NULL. +// buflen - The length of the buffer, in bytes. May be 0. +// Return value: +// The number of bytes in the type, including the terminating NUL +// character. The number of bytes is returned regardless of the +// |buffer| and |buflen| parameters. +// Comments: +// Regardless of the platform, the |buffer| is always in UTF-16LE +// encoding. The string is terminated by a UTF16 NUL character. If +// |buflen| is less than the required length, or |buffer| is NULL, +// |buffer| will not be modified. +var + FPDF_StructElement_GetType: function(struct_element: FPDF_STRUCTELEMENT; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetObjType +// Get the object type (/Type) for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// buffer - A buffer for output. May be NULL. +// buflen - The length of the buffer, in bytes. May be 0. +// Return value: +// The number of bytes in the object type, including the terminating +// NUL character. The number of bytes is returned regardless of the +// |buffer| and |buflen| parameters. +// Comments: +// Regardless of the platform, the |buffer| is always in UTF-16LE +// encoding. The string is terminated by a UTF16 NUL character. If +// |buflen| is less than the required length, or |buffer| is NULL, +// |buffer| will not be modified. +var + FPDF_StructElement_GetObjType: function(struct_element: FPDF_STRUCTELEMENT; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructElement_GetTitle +// Get the title (/T) for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// buffer - A buffer for output. May be NULL. +// buflen - The length of the buffer, in bytes. May be 0. +// Return value: +// The number of bytes in the title, including the terminating NUL +// character. The number of bytes is returned regardless of the +// |buffer| and |buflen| parameters. +// Comments: +// Regardless of the platform, the |buffer| is always in UTF-16LE +// encoding. The string is terminated by a UTF16 NUL character. If +// |buflen| is less than the required length, or |buffer| is NULL, +// |buffer| will not be modified. +var + FPDF_StructElement_GetTitle: function(struct_element: FPDF_STRUCTELEMENT; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructElement_CountChildren +// Count the number of children for the structure element. +// Parameters: +// struct_element - Handle to the struct element. +// Return value: +// The number of children, or -1 on error. +var + FPDF_StructElement_CountChildren: function(struct_element: FPDF_STRUCTELEMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructElement_GetChildAtIndex +// Get a child in the structure element. +// Parameters: +// struct_element - Handle to the struct element. +// index - The index for the child, 0-based. +// Return value: +// The child at the n-th index or NULL on error. +// Comments: +// If the child exists but is not an element, then this function will +// return NULL. This will also return NULL for out of bounds indices. +// The |index| must be less than the FPDF_StructElement_CountChildren() +// return value. +var + FPDF_StructElement_GetChildAtIndex: function(struct_element: FPDF_STRUCTELEMENT; index: Integer): FPDF_STRUCTELEMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetChildMarkedContentID +// Get the child's content id +// Parameters: +// struct_element - Handle to the struct element. +// index - The index for the child, 0-based. +// Return value: +// The marked content ID of the child. If no ID exists, returns -1. +// Comments: +// If the child exists but is not a stream or object, then this +// function will return -1. This will also return -1 for out of bounds +// indices. Compared to FPDF_StructElement_GetMarkedContentIdAtIndex, +// it is scoped to the current page. +// The |index| must be less than the FPDF_StructElement_CountChildren() +// return value. +var + FPDF_StructElement_GetChildMarkedContentID: function(struct_element: FPDF_STRUCTELEMENT; index: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetParent +// Get the parent of the structure element. +// Parameters: +// struct_element - Handle to the struct element. +// Return value: +// The parent structure element or NULL on error. +// Comments: +// If structure element is StructTreeRoot, then this function will +// return NULL. +var + FPDF_StructElement_GetParent: function(struct_element: FPDF_STRUCTELEMENT): FPDF_STRUCTELEMENT; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Function: FPDF_StructElement_GetAttributeCount +// Count the number of attributes for the structure element. +// Parameters: +// struct_element - Handle to the struct element. +// Return value: +// The number of attributes, or -1 on error. +var + FPDF_StructElement_GetAttributeCount: function(struct_element: FPDF_STRUCTELEMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetAttributeAtIndex +// Get an attribute object in the structure element. +// Parameters: +// struct_element - Handle to the struct element. +// index - The index for the attribute object, 0-based. +// Return value: +// The attribute object at the n-th index or NULL on error. +// Comments: +// If the attribute object exists but is not a dict, then this +// function will return NULL. This will also return NULL for out of +// bounds indices. The caller does not own the handle. The handle +// remains valid as long as |struct_element| remains valid. +// The |index| must be less than the +// FPDF_StructElement_GetAttributeCount() return value. +var + FPDF_StructElement_GetAttributeAtIndex: function(struct_element: FPDF_STRUCTELEMENT; index: Integer): FPDF_STRUCTELEMENT_ATTR; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetCount +// Count the number of attributes in a structure element attribute map. +// Parameters: +// struct_attribute - Handle to the struct element attribute. +// Return value: +// The number of attributes, or -1 on error. +var + FPDF_StructElement_Attr_GetCount: function(struct_attribute: FPDF_STRUCTELEMENT_ATTR): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetName +// Get the name of an attribute in a structure element attribute map. +// Parameters: +// struct_attribute - Handle to the struct element attribute. +// index - The index of attribute in the map. +// buffer - A buffer for output. May be NULL. This is only +// modified if |buflen| is longer than the length +// of the key. Optional, pass null to just +// retrieve the size of the buffer needed. +// buflen - The length of the buffer. +// out_buflen - A pointer to variable that will receive the +// minimum buffer size to contain the key. Not +// filled if FALSE is returned. +// Return value: +// TRUE if the operation was successful, FALSE otherwise. +var + FPDF_StructElement_Attr_GetName: function(struct_attribute: FPDF_STRUCTELEMENT_ATTR; index: Integer; buffer: Pointer; + buflen: LongWord; var out_buflen: LongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetValue +// Get a handle to a value for an attribute in a structure element +// attribute map. +// Parameters: +// struct_attribute - Handle to the struct element attribute. +// name - The attribute name. +// Return value: +// Returns a handle to the value associated with the input, if any. +// Returns NULL on failure. The caller does not own the handle. +// The handle remains valid as long as |struct_attribute| remains +// valid. +var + FPDF_StructElement_Attr_GetValue: function(struct_attribute: FPDF_STRUCTELEMENT_ATTR; + name: FPDF_BYTESTRING): FPDF_STRUCTELEMENT_ATTR_VALUE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetType +// Get the type of an attribute in a structure element attribute map. +// Parameters: +// value - Handle to the value. +// Return value: +// Returns the type of the value, or FPDF_OBJECT_UNKNOWN in case of +// failure. Note that this will never return FPDF_OBJECT_REFERENCE, as +// references are always dereferenced. +var + FPDF_StructElement_Attr_GetType: function(struct_attribute: FPDF_STRUCTELEMENT_ATTR_VALUE): FPDF_OBJECT_TYPE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetBooleanValue +// Get the value of a boolean attribute in an attribute map as +// FPDF_BOOL. FPDF_StructElement_Attr_GetType() should have returned +// FPDF_OBJECT_BOOLEAN for this property. +// Parameters: +// value - Handle to the value. +// out_value - A pointer to variable that will receive the value. Not +// filled if false is returned. +// Return value: +// Returns TRUE if the attribute maps to a boolean value, FALSE +// otherwise. +var + FPDF_StructElement_Attr_GetBooleanValue: function(value: FPDF_STRUCTELEMENT_ATTR_VALUE; + var out_value: FPDF_BOOL): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetNumberValue +// Get the value of a number attribute in an attribute map as float. +// FPDF_StructElement_Attr_GetType() should have returned +// FPDF_OBJECT_NUMBER for this property. +// Parameters: +// value - Handle to the value. +// out_value - A pointer to variable that will receive the value. Not +// filled if false is returned. +// Return value: +// Returns TRUE if the attribute maps to a number value, FALSE +// otherwise. +var + FPDF_StructElement_Attr_GetNumberValue: function(value: FPDF_STRUCTELEMENT_ATTR_VALUE; + var out_value: Single): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetStringValue +// Get the value of a string attribute in an attribute map as string. +// FPDF_StructElement_Attr_GetType() should have returned +// FPDF_OBJECT_STRING or FPDF_OBJECT_NAME for this property. +// Parameters: +// value - Handle to the value. +// buffer - A buffer for holding the returned key in UTF-16LE. +// This is only modified if |buflen| is longer than the +// length of the key. Optional, pass null to just +// retrieve the size of the buffer needed. +// buflen - The length of the buffer. +// out_buflen - A pointer to variable that will receive the minimum +// buffer size to contain the key. Not filled if FALSE is +// returned. +// Return value: +// Returns TRUE if the attribute maps to a string value, FALSE +// otherwise. +var + FPDF_StructElement_Attr_GetStringValue: function(value: FPDF_STRUCTELEMENT_ATTR; buffer: Pointer; buflen: LongWord; + var out_buflen: LongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetBlobValue +// Get the value of a blob attribute in an attribute map as string. +// Parameters: +// value - Handle to the value. +// buffer - A buffer for holding the returned value. This is only +// modified if |buflen| is at least as long as the length +// of the value. Optional, pass null to just retrieve the +// size of the buffer needed. +// buflen - The length of the buffer. +// out_buflen - A pointer to variable that will receive the minimum +// buffer size to contain the key. Not filled if FALSE is +// returned. +// Return value: +// Returns TRUE if the attribute maps to a string value, FALSE +// otherwise. +var + FPDF_StructElement_Attr_GetBlobValue: function(value: FPDF_STRUCTELEMENT_ATTR; buffer: Pointer; buflen: LongWord; + var out_buflen: LongWord): FPDF_BOOL; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_CountChildren +// Count the number of children values in an attribute. +// Parameters: +// value - Handle to the value. +// Return value: +// The number of children, or -1 on error. +var + FPDF_StructElement_Attr_CountChildren: function(value: FPDF_STRUCTELEMENT_ATTR_VALUE): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_Attr_GetChildAtIndex +// Get a child from an attribute. +// Parameters: +// value - Handle to the value. +// index - The index for the child, 0-based. +// Return value: +// The child at the n-th index or NULL on error. +// Comments: +// The |index| must be less than the +// FPDF_StructElement_Attr_CountChildren() return value. +var + FPDF_StructElement_Attr_GetChildAtIndex: function(value: FPDF_STRUCTELEMENT_ATTR_VALUE; + index: Integer): FPDF_STRUCTELEMENT_ATTR_VALUE; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetMarkedContentIdCount +// Get the count of marked content ids for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// Return value: +// The count of marked content ids or -1 if none exists. +var + FPDF_StructElement_GetMarkedContentIdCount: function(struct_element: FPDF_STRUCTELEMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Function: FPDF_StructElement_GetMarkedContentIdAtIndex +// Get the marked content id at a given index for a given element. +// Parameters: +// struct_element - Handle to the struct element. +// index - The index of the marked content id, 0-based. +// Return value: +// The marked content ID of the element. If no ID exists, returns +// -1. +// Comments: +// The |index| must be less than the +// FPDF_StructElement_GetMarkedContentIdCount() return value. +// This will likely supersede FPDF_StructElement_GetMarkedContentID(). +var + FPDF_StructElement_GetMarkedContentIdAtIndex: function(struct_element: FPDF_STRUCTELEMENT; index: Integer): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_LIBS_H_ *** + +{$IFDEF PDF_ENABLE_V8} + +// Function: FPDF_InitEmbeddedLibraries +// Initialize embedded libraries (v8, iuctl) included in pdfium +// Parameters: +// resourcePath - a path to v8 resources (snapshot_blob.bin, icudtl.dat, ...) +// Return value: +// None. +// Comments: +// This function must be called before calling FPDF_InitLibrary() +// if v8 suppport is enabled +var + FPDF_InitEmbeddedLibraries: procedure(const resourcePath: PAnsiChar); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +{$ENDIF PDF_ENABLE_V8} + + +// *** _FPDF_JAVASCRIPT_H_ *** + +// Experimental API. +// Get the number of JavaScript actions in |document|. +// +// document - handle to a document. +// +// Returns the number of JavaScript actions in |document| or -1 on error. +var + FPDFDoc_GetJavaScriptActionCount: function(document: FPDF_DOCUMENT): Integer; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the JavaScript action at |index| in |document|. +// +// document - handle to a document. +// index - the index of the requested JavaScript action. +// +// Returns the handle to the JavaScript action, or NULL on failure. +// Caller owns the returned handle and must close it with +// FPDFDoc_CloseJavaScriptAction(). +var + FPDFDoc_GetJavaScriptAction: function(document: FPDF_DOCUMENT; index: Integer): FPDF_JAVASCRIPT_ACTION; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Close a loaded FPDF_JAVASCRIPT_ACTION object. + +// javascript - Handle to a JavaScript action. +var + FPDFDoc_CloseJavaScriptAction: procedure(javascript: FPDF_JAVASCRIPT_ACTION); {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the name from the |javascript| handle. |buffer| is only modified if +// |buflen| is longer than the length of the name. On errors, |buffer| is +// unmodified and the returned length is 0. +// +// javascript - handle to an JavaScript action. +// buffer - buffer for holding the name, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the JavaScript action name in bytes. +var + FPDFJavaScriptAction_GetName: function(javascript: FPDF_JAVASCRIPT_ACTION; buffer: PFPDF_WCHAR; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Get the script from the |javascript| handle. |buffer| is only modified if +// |buflen| is longer than the length of the script. On errors, |buffer| is +// unmodified and the returned length is 0. +// +// javascript - handle to an JavaScript action. +// buffer - buffer for holding the name, encoded in UTF-16LE. +// buflen - length of the buffer in bytes. +// +// Returns the length of the JavaScript action name in bytes. +var + FPDFJavaScriptAction_GetScript: function(javascript: FPDF_JAVASCRIPT_ACTION; buffer: PFPDF_WCHAR; + buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *** _FPDF_THUMBNAIL_H_ *** + +// Experimental API. +// Gets the decoded data from the thumbnail of |page| if it exists. +// This only modifies |buffer| if |buflen| less than or equal to the +// size of the decoded data. Returns the size of the decoded +// data or 0 if thumbnail DNE. Optional, pass null to just retrieve +// the size of the buffer needed. +// +// page - handle to a page. +// buffer - buffer for holding the decoded image data. +// buflen - length of the buffer in bytes. +var + FPDFPage_GetDecodedThumbnailData: function(page: FPDF_PAGE; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Gets the raw data from the thumbnail of |page| if it exists. +// This only modifies |buffer| if |buflen| is less than or equal to +// the size of the raw data. Returns the size of the raw data or 0 +// if thumbnail DNE. Optional, pass null to just retrieve the size +// of the buffer needed. +// +// page - handle to a page. +// buffer - buffer for holding the raw image data. +// buflen - length of the buffer in bytes. +var + FPDFPage_GetRawThumbnailData: function(page: FPDF_PAGE; buffer: Pointer; buflen: LongWord): LongWord; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + +// Experimental API. +// Returns the thumbnail of |page| as a FPDF_BITMAP. Returns a nullptr +// if unable to access the thumbnail's stream. +// +// page - handle to a page. +var + FPDFPage_GetThumbnailAsBitmap: function(page: FPDF_PAGE): FPDF_BITMAP; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; + + +// *********************************************************************** + +procedure InitPDFium(const DllPath: string = '' {$IFDEF PDF_ENABLE_V8}; const ResPath: string = ''{$ENDIF}); +procedure InitPDFiumEx(const DllFileName: string{$IFDEF PDF_ENABLE_V8}; const ResPath: string{$ENDIF}); + +implementation + +uses + {$IFDEF CPUX64} + Math, + {$ENDIF CPUX64} + SysUtils; + +resourcestring + RsFailedToLoadProc = 'Symbol "%s" was not found in pdfium.dll'; + RsPdfiumNotLoaded = 'pdfium.dll is not loaded'; + RsFunctionNotSupported = 'PDFium function is not supported'; + +function FPDF_ARGB(a, r, g, b: Byte): DWORD; inline; +begin + Result := DWORD(b) or (DWORD(g) shl 8) or (DWORD(r) shl 16) or (DWORD(a) shl 24); +end; + +function FPDF_GetBValue(argb: DWORD): Byte; inline; +begin + Result := Byte(argb); +end; + +function FPDF_GetGValue(argb: DWORD): Byte; inline; +begin + Result := Byte(argb shr 8); +end; + +function FPDF_GetRValue(argb: DWORD): Byte; inline; +begin + Result := Byte(argb shr 16); +end; + +function FPDF_GetAValue(argb: DWORD): Byte; inline; +begin + Result := Byte(argb shr 24); +end; + +{$IFDEF PDF_ENABLE_XFA} +function IS_XFA_FORMFIELD(type_: Integer): Boolean; inline; +begin + case type_ of + FPDF_FORMFIELD_XFA, + FPDF_FORMFIELD_XFA_CHECKBOX, + FPDF_FORMFIELD_XFA_COMBOBOX, + FPDF_FORMFIELD_XFA_IMAGEFIELD, + FPDF_FORMFIELD_XFA_LISTBOX, + FPDF_FORMFIELD_XFA_PUSHBUTTON, + FPDF_FORMFIELD_XFA_SIGNATURE, + FPDF_FORMFIELD_XFA_TEXTFIELD: + Result := True; + else + Result := False; + end; +end; +{$ENDIF PDF_ENABLE_XFA} + + +type + TImportFuncRec = record + P: PPointer; + {$IF defined(FPC) and not defined(MSWINDOWS)} + N: AnsiString; // The "dynlibs" unit's GetProcAddress uses an AnsiString instead of PAnsiChar + {$ELSE} + N: PAnsiChar; + {$IFEND} + Quirk: Boolean; // True: if the symbol can't be found, no exception is raised. If both Quirk + // and Optional are True and the symbol can't be found, it will be mapped + // to FunctionNotSupported. + // (used if the symbol's name has changed and both DLL versions should be supported) + Optional: Boolean; // True: If the symbol can't be found, it is set to nil. + // (used for optional exported features like V8 and XFA) + end; + +const + {$IFDEF FPC} + {$WARN 3175 off : Some fields coming before "$1" were not initialized} + {$WARN 3177 off : Some fields coming after "$1" were not initialized} + {$ENDIF FPC} + ImportFuncs: array[0..438 + {$IFDEF MSWINDOWS } + 2 {$ENDIF} + {$IFDEF PDF_USE_SKIA } + 2 {$ENDIF} + {$IFDEF PDF_ENABLE_V8 } + 3 {$ENDIF} + {$IFDEF PDF_ENABLE_XFA} + 3 {$ENDIF} + ] of TImportFuncRec = ( + + // *** _FPDFVIEW_H_ *** + (P: @@FPDF_InitLibraryWithConfig; N: 'FPDF_InitLibraryWithConfig'), + (P: @@FPDF_InitLibrary; N: 'FPDF_InitLibrary'), + (P: @@FPDF_DestroyLibrary; N: 'FPDF_DestroyLibrary'), + (P: @@FPDF_SetSandBoxPolicy; N: 'FPDF_SetSandBoxPolicy'), + {$IFDEF MSWINDOWS} + (P: @@FPDF_SetPrintMode; N: 'FPDF_SetPrintMode'), + {$ENDIF MSWINDOWS} + (P: @@FPDF_LoadDocument; N: 'FPDF_LoadDocument'), + (P: @@FPDF_LoadMemDocument; N: 'FPDF_LoadMemDocument'), + (P: @@FPDF_LoadMemDocument64; N: 'FPDF_LoadMemDocument64'), + (P: @@FPDF_LoadCustomDocument; N: 'FPDF_LoadCustomDocument'), + (P: @@FPDF_GetFileVersion; N: 'FPDF_GetFileVersion'), + (P: @@FPDF_GetLastError; N: 'FPDF_GetLastError'), + (P: @@FPDF_DocumentHasValidCrossReferenceTable; N: 'FPDF_DocumentHasValidCrossReferenceTable'), + (P: @@FPDF_GetTrailerEnds; N: 'FPDF_GetTrailerEnds'), + (P: @@FPDF_GetDocPermissions; N: 'FPDF_GetDocPermissions'), + (P: @@FPDF_GetDocUserPermissions; N: 'FPDF_GetDocUserPermissions'), + (P: @@FPDF_GetSecurityHandlerRevision; N: 'FPDF_GetSecurityHandlerRevision'), + (P: @@FPDF_GetPageCount; N: 'FPDF_GetPageCount'), + (P: @@FPDF_LoadPage; N: 'FPDF_LoadPage'), + (P: @@FPDF_GetPageWidthF; N: 'FPDF_GetPageWidthF'), + (P: @@FPDF_GetPageWidth; N: 'FPDF_GetPageWidth'), + (P: @@FPDF_GetPageHeightF; N: 'FPDF_GetPageHeightF'), + (P: @@FPDF_GetPageHeight; N: 'FPDF_GetPageHeight'), + (P: @@FPDF_GetPageBoundingBox; N: 'FPDF_GetPageBoundingBox'), + (P: @@FPDF_GetPageSizeByIndexF; N: 'FPDF_GetPageSizeByIndexF'), + (P: @@FPDF_GetPageSizeByIndex; N: 'FPDF_GetPageSizeByIndex'), + {$IFDEF MSWINDOWS} + (P: @@FPDF_RenderPage; N: 'FPDF_RenderPage'), + {$ENDIF MSWINDOWS} + (P: @@FPDF_RenderPageBitmap; N: 'FPDF_RenderPageBitmap'), + (P: @@FPDF_RenderPageBitmapWithMatrix; N: 'FPDF_RenderPageBitmapWithMatrix'), + {$IFDEF PDF_USE_SKIA} + (P: @@FPDF_RenderPageSkia; N: 'FPDF_RenderPageSkia'; Quirk: True; Optional: True), + {$ENDIF PDF_USE_SKIA} + (P: @@FPDF_ClosePage; N: 'FPDF_ClosePage'), + (P: @@FPDF_CloseDocument; N: 'FPDF_CloseDocument'), + (P: @@FPDF_DeviceToPage; N: 'FPDF_DeviceToPage'), + (P: @@FPDF_PageToDevice; N: 'FPDF_PageToDevice'), + (P: @@FPDFBitmap_Create; N: 'FPDFBitmap_Create'), + (P: @@FPDFBitmap_CreateEx; N: 'FPDFBitmap_CreateEx'), + (P: @@FPDFBitmap_GetFormat; N: 'FPDFBitmap_GetFormat'), + (P: @@FPDFBitmap_FillRect; N: 'FPDFBitmap_FillRect'), + (P: @@FPDFBitmap_GetBuffer; N: 'FPDFBitmap_GetBuffer'), + (P: @@FPDFBitmap_GetWidth; N: 'FPDFBitmap_GetWidth'), + (P: @@FPDFBitmap_GetHeight; N: 'FPDFBitmap_GetHeight'), + (P: @@FPDFBitmap_GetStride; N: 'FPDFBitmap_GetStride'), + (P: @@FPDFBitmap_Destroy; N: 'FPDFBitmap_Destroy'), + (P: @@FPDF_VIEWERREF_GetPrintScaling; N: 'FPDF_VIEWERREF_GetPrintScaling'), + (P: @@FPDF_VIEWERREF_GetNumCopies; N: 'FPDF_VIEWERREF_GetNumCopies'), + (P: @@FPDF_VIEWERREF_GetPrintPageRange; N: 'FPDF_VIEWERREF_GetPrintPageRange'), + (P: @@FPDF_VIEWERREF_GetPrintPageRangeCount; N: 'FPDF_VIEWERREF_GetPrintPageRangeCount'), + (P: @@FPDF_VIEWERREF_GetPrintPageRangeElement; N: 'FPDF_VIEWERREF_GetPrintPageRangeElement'), + (P: @@FPDF_VIEWERREF_GetDuplex; N: 'FPDF_VIEWERREF_GetDuplex'), + (P: @@FPDF_VIEWERREF_GetName; N: 'FPDF_VIEWERREF_GetName'), + (P: @@FPDF_CountNamedDests; N: 'FPDF_CountNamedDests'), + (P: @@FPDF_GetNamedDestByName; N: 'FPDF_GetNamedDestByName'), + (P: @@FPDF_GetNamedDest; N: 'FPDF_GetNamedDest'), + (P: @@FPDF_GetXFAPacketCount; N: 'FPDF_GetXFAPacketCount'), + (P: @@FPDF_GetXFAPacketName; N: 'FPDF_GetXFAPacketName'), + (P: @@FPDF_GetXFAPacketContent; N: 'FPDF_GetXFAPacketContent'), + {$IFDEF PDF_ENABLE_V8} + (P: @@FPDF_GetRecommendedV8Flags; N: 'FPDF_GetRecommendedV8Flags'; Quirk: True; Optional: True), + (P: @@FPDF_GetArrayBufferAllocatorSharedInstance; N: 'FPDF_GetArrayBufferAllocatorSharedInstance'; Quirk: True; Optional: True), + {$ENDIF PDF_ENABLE_V8} + {$IFDEF PDF_ENABLE_XFA} + (P: @@FPDF_BStr_Init; N: 'FPDF_BStr_Init'; Quirk: True; Optional: True), + (P: @@FPDF_BStr_Set; N: 'FPDF_BStr_Set'; Quirk: True; Optional: True), + (P: @@FPDF_BStr_Clear; N: 'FPDF_BStr_Clear'; Quirk: True; Optional: True), + {$ENDIF PDF_ENABLE_XFA} + + // *** _FPDF_EDIT_H_ *** + (P: @@FPDF_CreateNewDocument; N: 'FPDF_CreateNewDocument'), + (P: @@FPDFPage_New; N: 'FPDFPage_New'), + (P: @@FPDFPage_Delete; N: 'FPDFPage_Delete'), + (P: @@FPDF_MovePages; N: 'FPDF_MovePages'), + (P: @@FPDFPage_GetRotation; N: 'FPDFPage_GetRotation'), + (P: @@FPDFPage_SetRotation; N: 'FPDFPage_SetRotation'), + (P: @@FPDFPage_InsertObject; N: 'FPDFPage_InsertObject'), + (P: @@FPDFPage_RemoveObject; N: 'FPDFPage_RemoveObject'), + (P: @@FPDFPage_CountObjects; N: 'FPDFPage_CountObjects'), + (P: @@FPDFPage_GetObject; N: 'FPDFPage_GetObject'), + (P: @@FPDFPage_HasTransparency; N: 'FPDFPage_HasTransparency'), + (P: @@FPDFPage_GenerateContent; N: 'FPDFPage_GenerateContent'), + (P: @@FPDFPageObj_Destroy; N: 'FPDFPageObj_Destroy'), + (P: @@FPDFPageObj_HasTransparency; N: 'FPDFPageObj_HasTransparency'), + (P: @@FPDFPageObj_GetType; N: 'FPDFPageObj_GetType'), + (P: @@FPDFPageObj_Transform; N: 'FPDFPageObj_Transform'), + (P: @@FPDFPageObj_TransformF; N: 'FPDFPageObj_TransformF'), + (P: @@FPDFPageObj_GetMatrix; N: 'FPDFPageObj_GetMatrix'), + (P: @@FPDFPageObj_SetMatrix; N: 'FPDFPageObj_SetMatrix'), + (P: @@FPDFPage_TransformAnnots; N: 'FPDFPage_TransformAnnots'), + (P: @@FPDFPageObj_NewImageObj; N: 'FPDFPageObj_NewImageObj'), + (P: @@FPDFPageObj_GetMarkedContentID; N: 'FPDFPageObj_GetMarkedContentID'), + (P: @@FPDFPageObj_CountMarks; N: 'FPDFPageObj_CountMarks'), + (P: @@FPDFPageObj_GetMark; N: 'FPDFPageObj_GetMark'), + (P: @@FPDFPageObj_AddMark; N: 'FPDFPageObj_AddMark'), + (P: @@FPDFPageObj_RemoveMark; N: 'FPDFPageObj_RemoveMark'), + (P: @@FPDFPageObjMark_GetName; N: 'FPDFPageObjMark_GetName'), + (P: @@FPDFPageObjMark_CountParams; N: 'FPDFPageObjMark_CountParams'), + (P: @@FPDFPageObjMark_GetParamKey; N: 'FPDFPageObjMark_GetParamKey'), + (P: @@FPDFPageObjMark_GetParamValueType; N: 'FPDFPageObjMark_GetParamValueType'), + (P: @@FPDFPageObjMark_GetParamIntValue; N: 'FPDFPageObjMark_GetParamIntValue'), + (P: @@FPDFPageObjMark_GetParamStringValue; N: 'FPDFPageObjMark_GetParamStringValue'), + (P: @@FPDFPageObjMark_GetParamBlobValue; N: 'FPDFPageObjMark_GetParamBlobValue'), + (P: @@FPDFPageObjMark_SetIntParam; N: 'FPDFPageObjMark_SetIntParam'), + (P: @@FPDFPageObjMark_SetStringParam; N: 'FPDFPageObjMark_SetStringParam'), + (P: @@FPDFPageObjMark_SetBlobParam; N: 'FPDFPageObjMark_SetBlobParam'), + (P: @@FPDFPageObjMark_RemoveParam; N: 'FPDFPageObjMark_RemoveParam'), + (P: @@FPDFImageObj_LoadJpegFile; N: 'FPDFImageObj_LoadJpegFile'), + (P: @@FPDFImageObj_LoadJpegFileInline; N: 'FPDFImageObj_LoadJpegFileInline'), + (P: @@FPDFImageObj_SetMatrix; N: 'FPDFImageObj_SetMatrix'), + (P: @@FPDFImageObj_SetBitmap; N: 'FPDFImageObj_SetBitmap'), + (P: @@FPDFImageObj_GetBitmap; N: 'FPDFImageObj_GetBitmap'), + (P: @@FPDFImageObj_GetRenderedBitmap; N: 'FPDFImageObj_GetRenderedBitmap'), + (P: @@FPDFImageObj_GetImageDataDecoded; N: 'FPDFImageObj_GetImageDataDecoded'), + (P: @@FPDFImageObj_GetImageDataRaw; N: 'FPDFImageObj_GetImageDataRaw'), + (P: @@FPDFImageObj_GetImageFilterCount; N: 'FPDFImageObj_GetImageFilterCount'), + (P: @@FPDFImageObj_GetImageFilter; N: 'FPDFImageObj_GetImageFilter'), + (P: @@FPDFImageObj_GetImageMetadata; N: 'FPDFImageObj_GetImageMetadata'), + (P: @@FPDFImageObj_GetImagePixelSize; N: 'FPDFImageObj_GetImagePixelSize'), + (P: @@FPDFPageObj_CreateNewPath; N: 'FPDFPageObj_CreateNewPath'), + (P: @@FPDFPageObj_CreateNewRect; N: 'FPDFPageObj_CreateNewRect'), + (P: @@FPDFPageObj_GetBounds; N: 'FPDFPageObj_GetBounds'), + (P: @@FPDFPageObj_GetRotatedBounds; N: 'FPDFPageObj_GetRotatedBounds'), + (P: @@FPDFPageObj_SetBlendMode; N: 'FPDFPageObj_SetBlendMode'), + (P: @@FPDFPageObj_SetStrokeColor; N: 'FPDFPageObj_SetStrokeColor'), + (P: @@FPDFPageObj_GetStrokeColor; N: 'FPDFPageObj_GetStrokeColor'), + (P: @@FPDFPageObj_SetStrokeWidth; N: 'FPDFPageObj_SetStrokeWidth'), + (P: @@FPDFPageObj_GetStrokeWidth; N: 'FPDFPageObj_GetStrokeWidth'), + (P: @@FPDFPageObj_GetLineJoin; N: 'FPDFPageObj_GetLineJoin'), + (P: @@FPDFPageObj_SetLineJoin; N: 'FPDFPageObj_SetLineJoin'), + (P: @@FPDFPageObj_GetLineCap; N: 'FPDFPageObj_GetLineCap'), + (P: @@FPDFPageObj_SetLineCap; N: 'FPDFPageObj_SetLineCap'), + (P: @@FPDFPageObj_SetFillColor; N: 'FPDFPageObj_SetFillColor'), + (P: @@FPDFPageObj_GetFillColor; N: 'FPDFPageObj_GetFillColor'), + (P: @@FPDFPageObj_GetDashPhase; N: 'FPDFPageObj_GetDashPhase'), + (P: @@FPDFPageObj_SetDashPhase; N: 'FPDFPageObj_SetDashPhase'), + (P: @@FPDFPageObj_GetDashCount; N: 'FPDFPageObj_GetDashCount'), + (P: @@FPDFPageObj_GetDashArray; N: 'FPDFPageObj_GetDashArray'), + (P: @@FPDFPageObj_SetDashArray; N: 'FPDFPageObj_SetDashArray'), + (P: @@FPDFPath_CountSegments; N: 'FPDFPath_CountSegments'), + (P: @@FPDFPath_GetPathSegment; N: 'FPDFPath_GetPathSegment'), + (P: @@FPDFPathSegment_GetPoint; N: 'FPDFPathSegment_GetPoint'), + (P: @@FPDFPathSegment_GetType; N: 'FPDFPathSegment_GetType'), + (P: @@FPDFPathSegment_GetClose; N: 'FPDFPathSegment_GetClose'), + (P: @@FPDFPath_MoveTo; N: 'FPDFPath_MoveTo'), + (P: @@FPDFPath_LineTo; N: 'FPDFPath_LineTo'), + (P: @@FPDFPath_BezierTo; N: 'FPDFPath_BezierTo'), + (P: @@FPDFPath_Close; N: 'FPDFPath_Close'), + (P: @@FPDFPath_SetDrawMode; N: 'FPDFPath_SetDrawMode'), + (P: @@FPDFPath_GetDrawMode; N: 'FPDFPath_GetDrawMode'), + (P: @@FPDFPageObj_NewTextObj; N: 'FPDFPageObj_NewTextObj'), + (P: @@FPDFText_SetText; N: 'FPDFText_SetText'), + (P: @@FPDFText_SetCharcodes; N: 'FPDFText_SetCharcodes'), + (P: @@FPDFText_LoadFont; N: 'FPDFText_LoadFont'), + (P: @@FPDFText_LoadStandardFont; N: 'FPDFText_LoadStandardFont'), + (P: @@FPDFText_LoadCidType2Font; N: 'FPDFText_LoadCidType2Font'), + (P: @@FPDFTextObj_GetFontSize; N: 'FPDFTextObj_GetFontSize'), + (P: @@FPDFFont_Close; N: 'FPDFFont_Close'), + (P: @@FPDFPageObj_CreateTextObj; N: 'FPDFPageObj_CreateTextObj'), + (P: @@FPDFTextObj_GetTextRenderMode; N: 'FPDFTextObj_GetTextRenderMode'), + (P: @@FPDFTextObj_SetTextRenderMode; N: 'FPDFTextObj_SetTextRenderMode'), + (P: @@FPDFTextObj_GetText; N: 'FPDFTextObj_GetText'), + (P: @@FPDFTextObj_GetRenderedBitmap; N: 'FPDFTextObj_GetRenderedBitmap'), + (P: @@FPDFTextObj_GetFont; N: 'FPDFTextObj_GetFont'), + (P: @@FPDFFont_GetFamilyName; N: 'FPDFFont_GetFamilyName'), + (P: @@FPDFFont_GetFontData; N: 'FPDFFont_GetFontData'), + (P: @@FPDFFont_GetIsEmbedded; N: 'FPDFFont_GetIsEmbedded'), + (P: @@FPDFFont_GetFlags; N: 'FPDFFont_GetFlags'), + (P: @@FPDFFont_GetWeight; N: 'FPDFFont_GetWeight'), + (P: @@FPDFFont_GetItalicAngle; N: 'FPDFFont_GetItalicAngle'), + (P: @@FPDFFont_GetAscent; N: 'FPDFFont_GetAscent'), + (P: @@FPDFFont_GetDescent; N: 'FPDFFont_GetDescent'), + (P: @@FPDFFont_GetGlyphWidth; N: 'FPDFFont_GetGlyphWidth'), + (P: @@FPDFFont_GetGlyphPath; N: 'FPDFFont_GetGlyphPath'), + (P: @@FPDFGlyphPath_CountGlyphSegments; N: 'FPDFGlyphPath_CountGlyphSegments'), + (P: @@FPDFGlyphPath_GetGlyphPathSegment; N: 'FPDFGlyphPath_GetGlyphPathSegment'), + (P: @@FPDFFormObj_CountObjects; N: 'FPDFFormObj_CountObjects'), + (P: @@FPDFFormObj_GetObject; N: 'FPDFFormObj_GetObject'), + + // *** _FPDF_PPO_H_ *** + (P: @@FPDF_ImportPagesByIndex; N: 'FPDF_ImportPagesByIndex'), + (P: @@FPDF_ImportPages; N: 'FPDF_ImportPages'), + (P: @@FPDF_ImportNPagesToOne; N: 'FPDF_ImportNPagesToOne'), + (P: @@FPDF_NewXObjectFromPage; N: 'FPDF_NewXObjectFromPage'), + (P: @@FPDF_CloseXObject; N: 'FPDF_CloseXObject'), + (P: @@FPDF_NewFormObjectFromXObject; N: 'FPDF_NewFormObjectFromXObject'), + (P: @@FPDF_CopyViewerPreferences; N: 'FPDF_CopyViewerPreferences'), + + // *** _FPDF_SAVE_H_ *** + (P: @@FPDF_SaveAsCopy; N: 'FPDF_SaveAsCopy'), + (P: @@FPDF_SaveWithVersion; N: 'FPDF_SaveWithVersion'), + + // *** _FPDFTEXT_H_ *** + (P: @@FPDFText_LoadPage; N: 'FPDFText_LoadPage'), + (P: @@FPDFText_ClosePage; N: 'FPDFText_ClosePage'), + (P: @@FPDFText_CountChars; N: 'FPDFText_CountChars'), + (P: @@FPDFText_GetUnicode; N: 'FPDFText_GetUnicode'), + (P: @@FPDFText_GetTextObject; N: 'FPDFText_GetTextObject'), + (P: @@FPDFText_IsGenerated; N: 'FPDFText_IsGenerated'), + (P: @@FPDFText_IsHyphen; N: 'FPDFText_IsHyphen'), + (P: @@FPDFText_HasUnicodeMapError; N: 'FPDFText_HasUnicodeMapError'), + (P: @@FPDFText_GetFontSize; N: 'FPDFText_GetFontSize'), + (P: @@FPDFText_GetFontInfo; N: 'FPDFText_GetFontInfo'), + (P: @@FPDFText_GetFontWeight; N: 'FPDFText_GetFontWeight'), + (P: @@FPDFText_GetFillColor; N: 'FPDFText_GetFillColor'), + (P: @@FPDFText_GetStrokeColor; N: 'FPDFText_GetStrokeColor'), + (P: @@FPDFText_GetCharAngle; N: 'FPDFText_GetCharAngle'), + (P: @@FPDFText_GetCharBox; N: 'FPDFText_GetCharBox'), + (P: @@FPDFText_GetLooseCharBox; N: 'FPDFText_GetLooseCharBox'), + (P: @@FPDFText_GetMatrix; N: 'FPDFText_GetMatrix'), + (P: @@FPDFText_GetCharOrigin; N: 'FPDFText_GetCharOrigin'), + (P: @@FPDFText_GetCharIndexAtPos; N: 'FPDFText_GetCharIndexAtPos'), + (P: @@FPDFText_GetText; N: 'FPDFText_GetText'), + (P: @@FPDFText_CountRects; N: 'FPDFText_CountRects'), + (P: @@FPDFText_GetRect; N: 'FPDFText_GetRect'), + (P: @@FPDFText_GetBoundedText; N: 'FPDFText_GetBoundedText'), + (P: @@FPDFText_FindStart; N: 'FPDFText_FindStart'), + (P: @@FPDFText_FindNext; N: 'FPDFText_FindNext'), + (P: @@FPDFText_FindPrev; N: 'FPDFText_FindPrev'), + (P: @@FPDFText_GetSchResultIndex; N: 'FPDFText_GetSchResultIndex'), + (P: @@FPDFText_GetSchCount; N: 'FPDFText_GetSchCount'), + (P: @@FPDFText_FindClose; N: 'FPDFText_FindClose'), + (P: @@FPDFLink_LoadWebLinks; N: 'FPDFLink_LoadWebLinks'), + (P: @@FPDFLink_CountWebLinks; N: 'FPDFLink_CountWebLinks'), + (P: @@FPDFLink_GetURL; N: 'FPDFLink_GetURL'), + (P: @@FPDFLink_CountRects; N: 'FPDFLink_CountRects'), + (P: @@FPDFLink_GetRect; N: 'FPDFLink_GetRect'), + (P: @@FPDFLink_GetTextRange; N: 'FPDFLink_GetTextRange'), + (P: @@FPDFLink_CloseWebLinks; N: 'FPDFLink_CloseWebLinks'), + + // *** _FPDF_SEARCHEX_H_ *** + (P: @@FPDFText_GetCharIndexFromTextIndex; N: 'FPDFText_GetCharIndexFromTextIndex'), + (P: @@FPDFText_GetTextIndexFromCharIndex; N: 'FPDFText_GetTextIndexFromCharIndex'), + + // *** _FPDF_PROGRESSIVE_H_ *** + (P: @@FPDF_RenderPageBitmapWithColorScheme_Start; N: 'FPDF_RenderPageBitmapWithColorScheme_Start'), + (P: @@FPDF_RenderPageBitmap_Start; N: 'FPDF_RenderPageBitmap_Start'), + (P: @@FPDF_RenderPage_Continue; N: 'FPDF_RenderPage_Continue'), + (P: @@FPDF_RenderPage_Close; N: 'FPDF_RenderPage_Close'), + + // *** _FPDF_SIGNATURE_H_ *** + (P: @@FPDF_GetSignatureCount; N: 'FPDF_GetSignatureCount'), + (P: @@FPDF_GetSignatureObject; N: 'FPDF_GetSignatureObject'), + (P: @@FPDFSignatureObj_GetContents; N: 'FPDFSignatureObj_GetContents'), + (P: @@FPDFSignatureObj_GetByteRange; N: 'FPDFSignatureObj_GetByteRange'), + (P: @@FPDFSignatureObj_GetSubFilter; N: 'FPDFSignatureObj_GetSubFilter'), + (P: @@FPDFSignatureObj_GetReason; N: 'FPDFSignatureObj_GetReason'), + (P: @@FPDFSignatureObj_GetTime; N: 'FPDFSignatureObj_GetTime'), + (P: @@FPDFSignatureObj_GetDocMDPPermission; N: 'FPDFSignatureObj_GetDocMDPPermission'), + + // *** _FPDF_FLATTEN_H_ *** + (P: @@FPDFPage_Flatten; N: 'FPDFPage_Flatten'), + + // *** _FPDF_DOC_H_ *** + (P: @@FPDFBookmark_GetFirstChild; N: 'FPDFBookmark_GetFirstChild'), + (P: @@FPDFBookmark_GetNextSibling; N: 'FPDFBookmark_GetNextSibling'), + (P: @@FPDFBookmark_GetTitle; N: 'FPDFBookmark_GetTitle'), + (P: @@FPDFBookmark_GetCount; N: 'FPDFBookmark_GetCount'), + (P: @@FPDFBookmark_Find; N: 'FPDFBookmark_Find'), + (P: @@FPDFBookmark_GetDest; N: 'FPDFBookmark_GetDest'), + (P: @@FPDFBookmark_GetAction; N: 'FPDFBookmark_GetAction'), + (P: @@FPDFAction_GetDest; N: 'FPDFAction_GetDest'), + (P: @@FPDFAction_GetType; N: 'FPDFAction_GetType'), + (P: @@FPDFAction_GetFilePath; N: 'FPDFAction_GetFilePath'), + (P: @@FPDFAction_GetURIPath; N: 'FPDFAction_GetURIPath'), + (P: @@FPDFDest_GetDestPageIndex; N: 'FPDFDest_GetDestPageIndex'), + (P: @@FPDFDest_GetView; N: 'FPDFDest_GetView'), + (P: @@FPDFDest_GetLocationInPage; N: 'FPDFDest_GetLocationInPage'), + (P: @@FPDFLink_GetLinkAtPoint; N: 'FPDFLink_GetLinkAtPoint'), + (P: @@FPDFLink_GetLinkZOrderAtPoint; N: 'FPDFLink_GetLinkZOrderAtPoint'), + (P: @@FPDFLink_GetDest; N: 'FPDFLink_GetDest'), + (P: @@FPDFLink_GetAction; N: 'FPDFLink_GetAction'), + (P: @@FPDFLink_Enumerate; N: 'FPDFLink_Enumerate'), + (P: @@FPDFLink_GetAnnot; N: 'FPDFLink_GetAnnot'), + (P: @@FPDFLink_GetAnnotRect; N: 'FPDFLink_GetAnnotRect'), + (P: @@FPDFLink_CountQuadPoints; N: 'FPDFLink_CountQuadPoints'), + (P: @@FPDFLink_GetQuadPoints; N: 'FPDFLink_GetQuadPoints'), + (P: @@FPDF_GetPageAAction; N: 'FPDF_GetPageAAction'), + (P: @@FPDF_GetFileIdentifier; N: 'FPDF_GetFileIdentifier'), + (P: @@FPDF_GetMetaText; N: 'FPDF_GetMetaText'), + (P: @@FPDF_GetPageLabel; N: 'FPDF_GetPageLabel'), + + // *** _FPDF_SYSFONTINFO_H_ *** + (P: @@FPDF_GetDefaultTTFMap; N: 'FPDF_GetDefaultTTFMap'), + (P: @@FPDF_GetDefaultTTFMapCount; N: 'FPDF_GetDefaultTTFMapCount'), + (P: @@FPDF_GetDefaultTTFMapEntry; N: 'FPDF_GetDefaultTTFMapEntry'), + (P: @@FPDF_AddInstalledFont; N: 'FPDF_AddInstalledFont'), + (P: @@FPDF_SetSystemFontInfo; N: 'FPDF_SetSystemFontInfo'), + (P: @@FPDF_GetDefaultSystemFontInfo; N: 'FPDF_GetDefaultSystemFontInfo'), + (P: @@FPDFDoc_GetPageMode; N: 'FPDFDoc_GetPageMode'), + + // *** _FPDF_EXT_H_ *** + (P: @@FSDK_SetUnSpObjProcessHandler; N: 'FSDK_SetUnSpObjProcessHandler'), + (P: @@FSDK_SetTimeFunction; N: 'FSDK_SetTimeFunction'), + (P: @@FSDK_SetLocaltimeFunction; N: 'FSDK_SetLocaltimeFunction'), + + // *** _FPDF_DATAAVAIL_H_ *** + (P: @@FPDFAvail_Create; N: 'FPDFAvail_Create'), + (P: @@FPDFAvail_Destroy; N: 'FPDFAvail_Destroy'), + (P: @@FPDFAvail_IsDocAvail; N: 'FPDFAvail_IsDocAvail'), + (P: @@FPDFAvail_GetDocument; N: 'FPDFAvail_GetDocument'), + (P: @@FPDFAvail_GetFirstPageNum; N: 'FPDFAvail_GetFirstPageNum'), + (P: @@FPDFAvail_IsPageAvail; N: 'FPDFAvail_IsPageAvail'), + (P: @@FPDFAvail_IsFormAvail; N: 'FPDFAvail_IsFormAvail'), + (P: @@FPDFAvail_IsLinearized; N: 'FPDFAvail_IsLinearized'), + + // *** _FPD_FORMFILL_H *** + (P: @@FPDFDOC_InitFormFillEnvironment; N: 'FPDFDOC_InitFormFillEnvironment'), + (P: @@FPDFDOC_ExitFormFillEnvironment; N: 'FPDFDOC_ExitFormFillEnvironment'), + (P: @@FORM_OnAfterLoadPage; N: 'FORM_OnAfterLoadPage'), + (P: @@FORM_OnBeforeClosePage; N: 'FORM_OnBeforeClosePage'), + (P: @@FORM_DoDocumentJSAction; N: 'FORM_DoDocumentJSAction'), + (P: @@FORM_DoDocumentOpenAction; N: 'FORM_DoDocumentOpenAction'), + (P: @@FORM_DoDocumentAAction; N: 'FORM_DoDocumentAAction'), + (P: @@FORM_DoPageAAction; N: 'FORM_DoPageAAction'), + (P: @@FORM_OnMouseMove; N: 'FORM_OnMouseMove'), + (P: @@FORM_OnMouseWheel; N: 'FORM_OnMouseWheel'), + (P: @@FORM_OnFocus; N: 'FORM_OnFocus'), + (P: @@FORM_OnLButtonDown; N: 'FORM_OnLButtonDown'), + (P: @@FORM_OnRButtonDown; N: 'FORM_OnRButtonDown'), + (P: @@FORM_OnLButtonUp; N: 'FORM_OnLButtonUp'), + (P: @@FORM_OnRButtonUp; N: 'FORM_OnRButtonUp'), + (P: @@FORM_OnLButtonDoubleClick; N: 'FORM_OnLButtonDoubleClick'), + (P: @@FORM_OnKeyDown; N: 'FORM_OnKeyDown'), + (P: @@FORM_OnKeyUp; N: 'FORM_OnKeyUp'), + (P: @@FORM_OnChar; N: 'FORM_OnChar'), + (P: @@FORM_GetFocusedText; N: 'FORM_GetFocusedText'), + (P: @@FORM_GetSelectedText; N: 'FORM_GetSelectedText'), + (P: @@FORM_ReplaceAndKeepSelection; N: 'FORM_ReplaceAndKeepSelection'), + (P: @@FORM_ReplaceSelection; N: 'FORM_ReplaceSelection'), + (P: @@FORM_SelectAllText; N: 'FORM_SelectAllText'), + (P: @@FORM_CanUndo; N: 'FORM_CanUndo'), + (P: @@FORM_CanRedo; N: 'FORM_CanRedo'), + (P: @@FORM_Undo; N: 'FORM_Undo'), + (P: @@FORM_Redo; N: 'FORM_Redo'), + (P: @@FORM_ForceToKillFocus; N: 'FORM_ForceToKillFocus'), + (P: @@FORM_GetFocusedAnnot; N: 'FORM_GetFocusedAnnot'), + (P: @@FORM_SetFocusedAnnot; N: 'FORM_SetFocusedAnnot'), + (P: @@FPDFPage_HasFormFieldAtPoint; N: 'FPDFPage_HasFormFieldAtPoint'), + (P: @@FPDFPage_FormFieldZOrderAtPoint; N: 'FPDFPage_FormFieldZOrderAtPoint'), + (P: @@FPDF_SetFormFieldHighlightColor; N: 'FPDF_SetFormFieldHighlightColor'), + (P: @@FPDF_SetFormFieldHighlightAlpha; N: 'FPDF_SetFormFieldHighlightAlpha'), + (P: @@FPDF_RemoveFormFieldHighlight; N: 'FPDF_RemoveFormFieldHighlight'), + (P: @@FPDF_FFLDraw; N: 'FPDF_FFLDraw'), + {$IFDEF PDF_USE_SKIA} + (P: @@FPDF_FFLDrawSkia; N: 'FPDF_FFLDrawSkia'; Quirk: True; Optional: True), + {$ENDIF PDF_USE_SKIA} + + (P: @@FPDF_GetFormType; N: 'FPDF_GetFormType'), + (P: @@FORM_SetIndexSelected; N: 'FORM_SetIndexSelected'), + (P: @@FORM_IsIndexSelected; N: 'FORM_IsIndexSelected'), + (P: @@FPDF_LoadXFA; N: 'FPDF_LoadXFA'), + + // *** _FPDF_CATALOG_H_ *** + (P: @@FPDFCatalog_IsTagged; N: 'FPDFCatalog_IsTagged'), + + // *** _FPDF_ATTACHMENT_H_ *** + (P: @@FPDFDoc_GetAttachmentCount; N: 'FPDFDoc_GetAttachmentCount'), + (P: @@FPDFDoc_AddAttachment; N: 'FPDFDoc_AddAttachment'), + (P: @@FPDFDoc_GetAttachment; N: 'FPDFDoc_GetAttachment'), + (P: @@FPDFDoc_DeleteAttachment; N: 'FPDFDoc_DeleteAttachment'), + (P: @@FPDFAttachment_GetName; N: 'FPDFAttachment_GetName'), + (P: @@FPDFAttachment_HasKey; N: 'FPDFAttachment_HasKey'), + (P: @@FPDFAttachment_GetValueType; N: 'FPDFAttachment_GetValueType'), + (P: @@FPDFAttachment_SetStringValue; N: 'FPDFAttachment_SetStringValue'), + (P: @@FPDFAttachment_GetStringValue; N: 'FPDFAttachment_GetStringValue'), + (P: @@FPDFAttachment_SetFile; N: 'FPDFAttachment_SetFile'), + (P: @@FPDFAttachment_GetFile; N: 'FPDFAttachment_GetFile'), + + // *** _FPDF_TRANSFORMPAGE_H_ *** + (P: @@FPDFPage_SetMediaBox; N: 'FPDFPage_SetMediaBox'), + (P: @@FPDFPage_SetCropBox; N: 'FPDFPage_SetCropBox'), + (P: @@FPDFPage_SetBleedBox; N: 'FPDFPage_SetBleedBox'), + (P: @@FPDFPage_SetTrimBox; N: 'FPDFPage_SetTrimBox'), + (P: @@FPDFPage_SetArtBox; N: 'FPDFPage_SetArtBox'), + (P: @@FPDFPage_GetMediaBox; N: 'FPDFPage_GetMediaBox'), + (P: @@FPDFPage_GetCropBox; N: 'FPDFPage_GetCropBox'), + (P: @@FPDFPage_GetBleedBox; N: 'FPDFPage_GetBleedBox'), + (P: @@FPDFPage_GetTrimBox; N: 'FPDFPage_GetTrimBox'), + (P: @@FPDFPage_GetArtBox; N: 'FPDFPage_GetArtBox'), + (P: @@FPDFPage_TransFormWithClip; N: 'FPDFPage_TransFormWithClip'), + (P: @@FPDFPageObj_TransformClipPath; N: 'FPDFPageObj_TransformClipPath'), + (P: @@FPDFPageObj_GetClipPath; N: 'FPDFPageObj_GetClipPath'), + (P: @@FPDFClipPath_CountPaths; N: 'FPDFClipPath_CountPaths'), + (P: @@FPDFClipPath_CountPathSegments; N: 'FPDFClipPath_CountPathSegments'), + (P: @@FPDFClipPath_GetPathSegment; N: 'FPDFClipPath_GetPathSegment'), + (P: @@FPDF_CreateClipPath; N: 'FPDF_CreateClipPath'), + (P: @@FPDF_DestroyClipPath; N: 'FPDF_DestroyClipPath'), + (P: @@FPDFPage_InsertClipPath; N: 'FPDFPage_InsertClipPath'), + + // *** _FPDF_STRUCTTREE_H_ *** + (P: @@FPDF_StructTree_GetForPage; N: 'FPDF_StructTree_GetForPage'), + (P: @@FPDF_StructTree_Close; N: 'FPDF_StructTree_Close'), + (P: @@FPDF_StructTree_CountChildren; N: 'FPDF_StructTree_CountChildren'), + (P: @@FPDF_StructTree_GetChildAtIndex; N: 'FPDF_StructTree_GetChildAtIndex'), + (P: @@FPDF_StructElement_GetAltText; N: 'FPDF_StructElement_GetAltText'), + (P: @@FPDF_StructElement_GetActualText; N: 'FPDF_StructElement_GetActualText'), + (P: @@FPDF_StructElement_GetID; N: 'FPDF_StructElement_GetID'), + (P: @@FPDF_StructElement_GetLang; N: 'FPDF_StructElement_GetLang'), + (P: @@FPDF_StructElement_GetStringAttribute; N: 'FPDF_StructElement_GetStringAttribute'), + (P: @@FPDF_StructElement_GetMarkedContentID; N: 'FPDF_StructElement_GetMarkedContentID'), + (P: @@FPDF_StructElement_GetType; N: 'FPDF_StructElement_GetType'), + (P: @@FPDF_StructElement_GetObjType; N: 'FPDF_StructElement_GetObjType'), + (P: @@FPDF_StructElement_GetTitle; N: 'FPDF_StructElement_GetTitle'), + (P: @@FPDF_StructElement_CountChildren; N: 'FPDF_StructElement_CountChildren'), + (P: @@FPDF_StructElement_GetChildAtIndex; N: 'FPDF_StructElement_GetChildAtIndex'), + (P: @@FPDF_StructElement_GetChildMarkedContentID; N: 'FPDF_StructElement_GetChildMarkedContentID'), + (P: @@FPDF_StructElement_GetParent; N: 'FPDF_StructElement_GetParent'), + (P: @@FPDF_StructElement_GetAttributeCount; N: 'FPDF_StructElement_GetAttributeCount'), + (P: @@FPDF_StructElement_GetAttributeAtIndex; N: 'FPDF_StructElement_GetAttributeAtIndex'), + (P: @@FPDF_StructElement_Attr_GetCount; N: 'FPDF_StructElement_Attr_GetCount'), + (P: @@FPDF_StructElement_Attr_GetName; N: 'FPDF_StructElement_Attr_GetName'), + (P: @@FPDF_StructElement_Attr_GetType; N: 'FPDF_StructElement_Attr_GetType'), + (P: @@FPDF_StructElement_Attr_GetBooleanValue; N: 'FPDF_StructElement_Attr_GetBooleanValue'), + (P: @@FPDF_StructElement_Attr_GetNumberValue; N: 'FPDF_StructElement_Attr_GetNumberValue'), + (P: @@FPDF_StructElement_Attr_GetStringValue; N: 'FPDF_StructElement_Attr_GetStringValue'), + (P: @@FPDF_StructElement_Attr_GetBlobValue; N: 'FPDF_StructElement_Attr_GetBlobValue'), + (P: @@FPDF_StructElement_Attr_CountChildren; N: 'FPDF_StructElement_Attr_CountChildren'), + (P: @@FPDF_StructElement_Attr_GetChildAtIndex; N: 'FPDF_StructElement_Attr_GetChildAtIndex'), + (P: @@FPDF_StructElement_GetMarkedContentIdCount; N: 'FPDF_StructElement_GetMarkedContentIdCount'), + (P: @@FPDF_StructElement_GetMarkedContentIdAtIndex; N: 'FPDF_StructElement_GetMarkedContentIdAtIndex'), + + (P: @@FPDFAnnot_IsSupportedSubtype; N: 'FPDFAnnot_IsSupportedSubtype'), + (P: @@FPDFPage_CreateAnnot; N: 'FPDFPage_CreateAnnot'), + (P: @@FPDFPage_GetAnnotCount; N: 'FPDFPage_GetAnnotCount'), + (P: @@FPDFPage_GetAnnot; N: 'FPDFPage_GetAnnot'), + (P: @@FPDFPage_GetAnnotIndex; N: 'FPDFPage_GetAnnotIndex'), + (P: @@FPDFPage_CloseAnnot; N: 'FPDFPage_CloseAnnot'), + (P: @@FPDFPage_RemoveAnnot; N: 'FPDFPage_RemoveAnnot'), + (P: @@FPDFAnnot_GetSubtype; N: 'FPDFAnnot_GetSubtype'), + (P: @@FPDFAnnot_IsObjectSupportedSubtype; N: 'FPDFAnnot_IsObjectSupportedSubtype'), + (P: @@FPDFAnnot_UpdateObject; N: 'FPDFAnnot_UpdateObject'), + (P: @@FPDFAnnot_AddInkStroke; N: 'FPDFAnnot_AddInkStroke'), + (P: @@FPDFAnnot_RemoveInkList; N: 'FPDFAnnot_RemoveInkList'), + (P: @@FPDFAnnot_AppendObject; N: 'FPDFAnnot_AppendObject'), + (P: @@FPDFAnnot_GetObjectCount; N: 'FPDFAnnot_GetObjectCount'), + (P: @@FPDFAnnot_GetObject; N: 'FPDFAnnot_GetObject'), + (P: @@FPDFAnnot_RemoveObject; N: 'FPDFAnnot_RemoveObject'), + (P: @@FPDFAnnot_SetColor; N: 'FPDFAnnot_SetColor'), + (P: @@FPDFAnnot_GetColor; N: 'FPDFAnnot_GetColor'), + (P: @@FPDFAnnot_HasAttachmentPoints; N: 'FPDFAnnot_HasAttachmentPoints'), + (P: @@FPDFAnnot_SetAttachmentPoints; N: 'FPDFAnnot_SetAttachmentPoints'), + (P: @@FPDFAnnot_AppendAttachmentPoints; N: 'FPDFAnnot_AppendAttachmentPoints'), + (P: @@FPDFAnnot_CountAttachmentPoints; N: 'FPDFAnnot_CountAttachmentPoints'), + (P: @@FPDFAnnot_GetAttachmentPoints; N: 'FPDFAnnot_GetAttachmentPoints'), + (P: @@FPDFAnnot_SetRect; N: 'FPDFAnnot_SetRect'), + (P: @@FPDFAnnot_GetRect; N: 'FPDFAnnot_GetRect'), + (P: @@FPDFAnnot_GetVertices; N: 'FPDFAnnot_GetVertices'), + (P: @@FPDFAnnot_GetInkListCount; N: 'FPDFAnnot_GetInkListCount'), + (P: @@FPDFAnnot_GetInkListPath; N: 'FPDFAnnot_GetInkListPath'), + (P: @@FPDFAnnot_GetLine; N: 'FPDFAnnot_GetLine'), + (P: @@FPDFAnnot_SetBorder; N: 'FPDFAnnot_SetBorder'), + (P: @@FPDFAnnot_GetBorder; N: 'FPDFAnnot_GetBorder'), + (P: @@FPDFAnnot_GetFormAdditionalActionJavaScript; N: 'FPDFAnnot_GetFormAdditionalActionJavaScript'), + (P: @@FPDFAnnot_HasKey; N: 'FPDFAnnot_HasKey'), + (P: @@FPDFAnnot_GetValueType; N: 'FPDFAnnot_GetValueType'), + (P: @@FPDFAnnot_SetStringValue; N: 'FPDFAnnot_SetStringValue'), + (P: @@FPDFAnnot_GetStringValue; N: 'FPDFAnnot_GetStringValue'), + (P: @@FPDFAnnot_GetNumberValue; N: 'FPDFAnnot_GetNumberValue'), + (P: @@FPDFAnnot_SetAP; N: 'FPDFAnnot_SetAP'), + (P: @@FPDFAnnot_GetAP; N: 'FPDFAnnot_GetAP'), + (P: @@FPDFAnnot_GetLinkedAnnot; N: 'FPDFAnnot_GetLinkedAnnot'), + (P: @@FPDFAnnot_GetFlags; N: 'FPDFAnnot_GetFlags'), + (P: @@FPDFAnnot_SetFlags; N: 'FPDFAnnot_SetFlags'), + (P: @@FPDFAnnot_GetFormFieldFlags; N: 'FPDFAnnot_GetFormFieldFlags'), + (P: @@FPDFAnnot_GetFormFieldAtPoint; N: 'FPDFAnnot_GetFormFieldAtPoint'), + (P: @@FPDFAnnot_GetFormFieldName; N: 'FPDFAnnot_GetFormFieldName'), + (P: @@FPDFAnnot_GetFormFieldAlternateName; N: 'FPDFAnnot_GetFormFieldAlternateName'), + (P: @@FPDFAnnot_GetFormFieldType; N: 'FPDFAnnot_GetFormFieldType'), + (P: @@FPDFAnnot_GetFormFieldValue; N: 'FPDFAnnot_GetFormFieldValue'), + (P: @@FPDFAnnot_GetOptionCount; N: 'FPDFAnnot_GetOptionCount'), + (P: @@FPDFAnnot_GetOptionLabel; N: 'FPDFAnnot_GetOptionLabel'), + (P: @@FPDFAnnot_IsOptionSelected; N: 'FPDFAnnot_IsOptionSelected'), + (P: @@FPDFAnnot_GetFontSize; N: 'FPDFAnnot_GetFontSize'), + (P: @@FPDFAnnot_GetFontColor; N: 'FPDFAnnot_GetFontColor'), + (P: @@FPDFAnnot_IsChecked; N: 'FPDFAnnot_IsChecked'), + + (P: @@FPDFAnnot_SetFocusableSubtypes; N: 'FPDFAnnot_SetFocusableSubtypes'), + (P: @@FPDFAnnot_GetFocusableSubtypesCount; N: 'FPDFAnnot_GetFocusableSubtypesCount'), + (P: @@FPDFAnnot_GetFocusableSubtypes; N: 'FPDFAnnot_GetFocusableSubtypes'), + (P: @@FPDFAnnot_GetLink; N: 'FPDFAnnot_GetLink'), + (P: @@FPDFAnnot_GetFormControlCount; N: 'FPDFAnnot_GetFormControlCount'), + (P: @@FPDFAnnot_GetFormControlIndex; N: 'FPDFAnnot_GetFormControlIndex'), + (P: @@FPDFAnnot_GetFormFieldExportValue; N: 'FPDFAnnot_GetFormFieldExportValue'), + (P: @@FPDFAnnot_SetURI; N: 'FPDFAnnot_SetURI'), + (P: @@FPDFAnnot_GetFileAttachment; N: 'FPDFAnnot_GetFileAttachment'), + (P: @@FPDFAnnot_AddFileAttachment; N: 'FPDFAnnot_AddFileAttachment'), + + {$IFDEF PDF_ENABLE_V8} + // *** _FPDF_LIBS_H_ *** + (P: @@FPDF_InitEmbeddedLibraries; N: 'FPDF_InitEmbeddedLibraries'; Optional: True), + {$ENDIF PDF_ENABLE_V8} + + // *** _FPDF_JAVASCRIPT_H_ *** + (P: @@FPDFDoc_GetJavaScriptActionCount; N: 'FPDFDoc_GetJavaScriptActionCount'), + (P: @@FPDFDoc_GetJavaScriptAction; N: 'FPDFDoc_GetJavaScriptAction'), + (P: @@FPDFDoc_CloseJavaScriptAction; N: 'FPDFDoc_CloseJavaScriptAction'), + (P: @@FPDFJavaScriptAction_GetName; N: 'FPDFJavaScriptAction_GetName'), + (P: @@FPDFJavaScriptAction_GetScript; N: 'FPDFJavaScriptAction_GetScript'), + + // *** _FPDF_THUMBNAIL_H_ *** + (P: @@FPDFPage_GetDecodedThumbnailData; N: 'FPDFPage_GetDecodedThumbnailData'), + (P: @@FPDFPage_GetRawThumbnailData; N: 'FPDFPage_GetRawThumbnailData'), + (P: @@FPDFPage_GetThumbnailAsBitmap; N: 'FPDFPage_GetThumbnailAsBitmap') + ); + {$IFDEF FPC} + {$WARN 3175 on : Some fields coming before "$1" were not initialized} + {$WARN 3177 on : Some fields coming after "$1" were not initialized} + {$ENDIF FPC} + +const + pdfium_dll = 'pdfium.dll'; + +var + PdfiumModule: HMODULE; + +procedure NotLoaded; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +begin + raise Exception.CreateRes(@RsPdfiumNotLoaded); +end; + +procedure FunctionNotSupported; {$IFDEF DLLEXPORT}stdcall{$ELSE}cdecl{$ENDIF}; +begin + raise Exception.CreateRes(@RsFunctionNotSupported); +end; + +function PDF_USE_XFA: Boolean; +begin + {$IFDEF PDF_ENABLE_XFA} + Result := Assigned(FPDF_BStr_Init) and (@FPDF_BStr_Init <> @NotLoaded) and (@FPDF_BStr_Init <> @FunctionNotSupported); + {$ELSE} + Result := False; + {$ENDIF PDF_ENABLE_XFA} +end; + +function PDF_IsSkiaAvailable: Boolean; +begin + {$IFDEF PDF_USE_SKIA} + Result := Assigned(FPDF_RenderPageSkia) and (@FPDF_RenderPageSkia <> @NotLoaded) and (@FPDF_RenderPageSkia <> @FunctionNotSupported) + and Assigned(FPDF_FFLDrawSkia) and (@FPDF_FFLDrawSkia <> @NotLoaded) and (@FPDF_FFLDrawSkia <> @FunctionNotSupported); + {$ELSE} + Result := False; + {$ENDIF PDF_USE_SKIA} +end; + +procedure Init; +var + I: Integer; +begin + for I := 0 to Length(ImportFuncs) - 1 do + ImportFuncs[I].P^ := @NotLoaded; +end; + +procedure InitPDFium(const DllPath: string{$IFDEF PDF_ENABLE_V8}; const ResPath: string{$ENDIF}); +begin + if DllPath <> '' then + InitPDFiumEx(IncludeTrailingPathDelimiter(DllPath) + pdfium_dll{$IFDEF PDF_ENABLE_V8}, ResPath{$ENDIF}) + else + InitPDFiumEx(''{$IFDEF PDF_ENABLE_V8}, ResPath{$ENDIF}); +end; + +procedure InitPDFiumEx(const DllFileName: string{$IFDEF PDF_ENABLE_V8}; const ResPath: string{$ENDIF}); +var + I: Integer; + Path: string; + LibraryConfig: FPDF_LIBRARY_CONFIG; +begin + if PdfiumModule <> 0 then + Exit; + + {$IFDEF CPUX64} + {$IFDEF FPC} + SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]); + {$ELSE} + // Pdfium requires all arithmetic exceptions to be masked in 64bit mode + if GetExceptionMask <> exAllArithmeticExceptions then + SetExceptionMask(exAllArithmeticExceptions); + {$ENDIF FPC} + {$ENDIF CPUX64} + + if DllFileName <> '' then + PdfiumModule := SafeLoadLibrary(DllFileName) + else + PdfiumModule := SafeLoadLibrary(pdfium_dll); + + if PdfiumModule = 0 then + begin + {$IF not defined(FPC) and (CompilerVersion >= 24.0)} // XE3+ + if DllFileName <> '' then + RaiseLastOSError(GetLastError, '.'#10#10 + DllFileName) + else + RaiseLastOSError(GetLastError, '.'#10#10 + pdfium_dll); + {$ELSE} + RaiseLastOSError; + {$IFEND} + end; + + // Import the pdfium.dll functions + for I := 0 to Length(ImportFuncs) - 1 do + begin + if ImportFuncs[I].P^ = @NotLoaded then + begin + ImportFuncs[I].P^ := GetProcAddress(PdfiumModule, ImportFuncs[I].N); + if ImportFuncs[I].P^ = nil then + begin + if ImportFuncs[I].Optional then + begin + if ImportFuncs[I].Quirk then + ImportFuncs[I].P^ := @FunctionNotSupported; + end + else + begin + ImportFuncs[I].P^ := @NotLoaded; + if not ImportFuncs[I].Quirk then + begin + FreeLibrary(PdfiumModule); + PdfiumModule := 0; + Init; // reset all functions to @NotLoaded + raise Exception.CreateResFmt(@RsFailedToLoadProc, [ImportFuncs[I].N]); + end; + end; + end; + end; + end; + + {$IFDEF PDF_ENABLE_V8} + // Initialize the V8 engine if available + if Assigned(FPDF_InitEmbeddedLibraries) then + begin + if ResPath <> '' then + Path := IncludeTrailingPathDelimiter(ResPath) + else if DllFileName <> '' then + begin + Path := ExtractFileDir(DllFileName); + if Path <> '' then + Path := IncludeTrailingPathDelimiter(Path); + end; + + if Path = '' then + begin + // If the DLL was already loaded we can use its path + Path := GetModuleName(PdfiumModule); + if Path <> '' then + Path := IncludeTrailingPathDelimiter(ExtractFilePath(Path)); + end; + + FPDF_InitEmbeddedLibraries(PAnsiChar(AnsiString(Path))); // requires trailing path delimiter + end + else + @FPDF_InitEmbeddedLibraries := @FunctionNotSupported; + {$ENDIF PDF_ENABLE_V8} + + // Initialize the pdfium library + {$IFDEF FPC} {$WARN 5057 off : Local variable "$1" does not seem to be initialized} {$ENDIF FPC} + FillChar(LibraryConfig, SizeOf(LibraryConfig), 0); + {$IFDEF FPC} {$WARN 5057 on} {$ENDIF FPC} + LibraryConfig.version := 2; + LibraryConfig.m_RendererType := FPDF_RENDERERTYPE_AGG; + {if IsSkiaAvailable and SkiaRendererEnabled then + LibraryConfig.m_RendererType := FPDF_RENDERERTYPE_SKIA;} + FPDF_InitLibraryWithConfig(@LibraryConfig); +end; + +initialization + Init; + +finalization + if PdfiumModule <> 0 then + begin + FPDF_DestroyLibrary; + FreeLibrary(PdfiumModule); + end; + +end. + diff --git a/Tocsg.Lib/VCL/Other/EM.WbemScripting_TLB.pas b/Tocsg.Lib/VCL/Other/EM.WbemScripting_TLB.pas new file mode 100644 index 00000000..cd96ff81 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.WbemScripting_TLB.pas @@ -0,0 +1,4630 @@ +unit EM.WbemScripting_TLB; + +// ************************************************************************ // +// WARNING +// ------- +// The types declared in this file were generated from data read from a +// Type Library. If this type library is explicitly or indirectly (via +// another type library referring to this type library) re-imported, or the +// 'Refresh' command of the Type Library Editor activated while editing the +// Type Library, the contents of this file will be regenerated and all +// manual modifications will be lost. +// ************************************************************************ // + +// PASTLWTR : 1.2 +// File generated on 5/6/2005 5:57:20 PM from Type Library described below. + +// ************************************************************************ // +// Type Lib: C:\WINDOWS\System32\wbem\wbemdisp.TLB (1) +// LIBID: {565783C6-CB41-11D1-8B02-00600806D9B6} +// LCID: 0 +// Helpfile: +// HelpString: Microsoft WMI Scripting V1.2 Library +// DepndLst: +// (1) v2.0 stdole, (C:\WINDOWS\System32\stdole2.tlb) +// Errors: +// Hint: Member 'Class' of 'ISWbemObjectPath' changed to 'Class_' +// Hint: Member 'Object' of 'ISWbemRefreshableItem' changed to 'Object_' +// Error creating palette bitmap of (TSWbemLocator) : Server C:\WINDOWS\System32\wbem\wbemdisp.dll contains no icons +// Error creating palette bitmap of (TSWbemNamedValueSet) : Server C:\WINDOWS\System32\wbem\wbemdisp.dll contains no icons +// Error creating palette bitmap of (TSWbemObjectPath) : Server C:\WINDOWS\System32\wbem\wbemdisp.dll contains no icons +// Error creating palette bitmap of (TSWbemLastError) : Server C:\WINDOWS\System32\wbem\wbemdisp.dll contains no icons +// Error creating palette bitmap of (TSWbemSink) : Server C:\WINDOWS\System32\wbem\wbemdisp.dll contains no icons +// Error creating palette bitmap of (TSWbemDateTime) : Server C:\WINDOWS\System32\wbem\wbemdisp.dll contains no icons +// Error creating palette bitmap of (TSWbemRefresher) : Server C:\WINDOWS\System32\wbem\wbemdisp.dll contains no icons +// ************************************************************************ // +// *************************************************************************// +// NOTE: +// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties +// which return objects that may need to be explicitly created via a function +// call prior to any access via the property. These items have been disabled +// in order to prevent accidental use from within the object inspector. You +// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively +// removing them from the $IFDEF blocks. However, such items must still be +// programmatically created via a method of the appropriate CoClass before +// they can be used. +{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. +{$WARN SYMBOL_PLATFORM OFF} +{$WRITEABLECONST ON} +{$VARPROPSETTER ON} +interface + +uses WinApi.Windows, WinApi.ActiveX, Classes, Graphics, OleServer, StdVCL, Variants; + + +// *********************************************************************// +// GUIDS declared in the TypeLibrary. Following prefixes are used: +// Type Libraries : LIBID_xxxx +// CoClasses : CLASS_xxxx +// DISPInterfaces : DIID_xxxx +// Non-DISP interfaces: IID_xxxx +// *********************************************************************// +const + // TypeLibrary Major and minor versions + WbemScriptingMajorVersion = 1; + WbemScriptingMinorVersion = 2; + + LIBID_WbemScripting: TGUID = '{565783C6-CB41-11D1-8B02-00600806D9B6}'; + + IID_ISWbemServices: TGUID = '{76A6415C-CB41-11D1-8B02-00600806D9B6}'; + IID_ISWbemObject: TGUID = '{76A6415A-CB41-11D1-8B02-00600806D9B6}'; + IID_ISWbemObjectPath: TGUID = '{5791BC27-CE9C-11D1-97BF-0000F81E849C}'; + IID_ISWbemNamedValueSet: TGUID = '{CF2376EA-CE8C-11D1-8B05-00600806D9B6}'; + IID_ISWbemNamedValue: TGUID = '{76A64164-CB41-11D1-8B02-00600806D9B6}'; + IID_ISWbemSecurity: TGUID = '{B54D66E6-2287-11D2-8B33-00600806D9B6}'; + IID_ISWbemPrivilegeSet: TGUID = '{26EE67BF-5804-11D2-8B4A-00600806D9B6}'; + IID_ISWbemPrivilege: TGUID = '{26EE67BD-5804-11D2-8B4A-00600806D9B6}'; + IID_ISWbemObjectSet: TGUID = '{76A6415F-CB41-11D1-8B02-00600806D9B6}'; + IID_ISWbemQualifierSet: TGUID = '{9B16ED16-D3DF-11D1-8B08-00600806D9B6}'; + IID_ISWbemQualifier: TGUID = '{79B05932-D3B7-11D1-8B06-00600806D9B6}'; + IID_ISWbemPropertySet: TGUID = '{DEA0A7B2-D4BA-11D1-8B09-00600806D9B6}'; + IID_ISWbemProperty: TGUID = '{1A388F98-D4BA-11D1-8B09-00600806D9B6}'; + IID_ISWbemMethodSet: TGUID = '{C93BA292-D955-11D1-8B09-00600806D9B6}'; + IID_ISWbemMethod: TGUID = '{422E8E90-D955-11D1-8B09-00600806D9B6}'; + IID_ISWbemEventSource: TGUID = '{27D54D92-0EBE-11D2-8B22-00600806D9B6}'; + IID_ISWbemLocator: TGUID = '{76A6415B-CB41-11D1-8B02-00600806D9B6}'; + IID_ISWbemLastError: TGUID = '{D962DB84-D4BB-11D1-8B09-00600806D9B6}'; + DIID_ISWbemSinkEvents: TGUID = '{75718CA0-F029-11D1-A1AC-00C04FB6C223}'; + IID_ISWbemSink: TGUID = '{75718C9F-F029-11D1-A1AC-00C04FB6C223}'; + IID_ISWbemServicesEx: TGUID = '{D2F68443-85DC-427E-91D8-366554CC754C}'; + IID_ISWbemObjectEx: TGUID = '{269AD56A-8A67-4129-BC8C-0506DCFE9880}'; + IID_ISWbemDateTime: TGUID = '{5E97458A-CF77-11D3-B38F-00105A1F473A}'; + IID_ISWbemRefresher: TGUID = '{14D8250E-D9C2-11D3-B38F-00105A1F473A}'; + IID_ISWbemRefreshableItem: TGUID = '{5AD4BF92-DAAB-11D3-B38F-00105A1F473A}'; + CLASS_SWbemLocator: TGUID = '{76A64158-CB41-11D1-8B02-00600806D9B6}'; + CLASS_SWbemNamedValueSet: TGUID = '{9AED384E-CE8B-11D1-8B05-00600806D9B6}'; + CLASS_SWbemObjectPath: TGUID = '{5791BC26-CE9C-11D1-97BF-0000F81E849C}'; + CLASS_SWbemLastError: TGUID = '{C2FEEEAC-CFCD-11D1-8B05-00600806D9B6}'; + CLASS_SWbemSink: TGUID = '{75718C9A-F029-11D1-A1AC-00C04FB6C223}'; + CLASS_SWbemDateTime: TGUID = '{47DFBE54-CF76-11D3-B38F-00105A1F473A}'; + CLASS_SWbemRefresher: TGUID = '{D269BF5C-D9C1-11D3-B38F-00105A1F473A}'; + CLASS_SWbemServices: TGUID = '{04B83D63-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemServicesEx: TGUID = '{62E522DC-8CF3-40A8-8B2E-37D595651E40}'; + CLASS_SWbemObject: TGUID = '{04B83D62-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemObjectEx: TGUID = '{D6BDAFB2-9435-491F-BB87-6AA0F0BC31A2}'; + CLASS_SWbemObjectSet: TGUID = '{04B83D61-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemNamedValue: TGUID = '{04B83D60-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemQualifier: TGUID = '{04B83D5F-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemQualifierSet: TGUID = '{04B83D5E-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemProperty: TGUID = '{04B83D5D-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemPropertySet: TGUID = '{04B83D5C-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemMethod: TGUID = '{04B83D5B-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemMethodSet: TGUID = '{04B83D5A-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemEventSource: TGUID = '{04B83D58-21AE-11D2-8B33-00600806D9B6}'; + CLASS_SWbemSecurity: TGUID = '{B54D66E9-2287-11D2-8B33-00600806D9B6}'; + CLASS_SWbemPrivilege: TGUID = '{26EE67BC-5804-11D2-8B4A-00600806D9B6}'; + CLASS_SWbemPrivilegeSet: TGUID = '{26EE67BE-5804-11D2-8B4A-00600806D9B6}'; + CLASS_SWbemRefreshableItem: TGUID = '{8C6854BC-DE4B-11D3-B390-00105A1F473A}'; + +// *********************************************************************// +// Declaration of Enumerations defined in Type Library +// *********************************************************************// +// Constants for enum WbemImpersonationLevelEnum +type + WbemImpersonationLevelEnum = TOleEnum; +const + wbemImpersonationLevelAnonymous = $00000001; + wbemImpersonationLevelIdentify = $00000002; + wbemImpersonationLevelImpersonate = $00000003; + wbemImpersonationLevelDelegate = $00000004; + +// Constants for enum WbemAuthenticationLevelEnum +type + WbemAuthenticationLevelEnum = TOleEnum; +const + wbemAuthenticationLevelDefault = $00000000; + wbemAuthenticationLevelNone = $00000001; + wbemAuthenticationLevelConnect = $00000002; + wbemAuthenticationLevelCall = $00000003; + wbemAuthenticationLevelPkt = $00000004; + wbemAuthenticationLevelPktIntegrity = $00000005; + wbemAuthenticationLevelPktPrivacy = $00000006; + +// Constants for enum WbemPrivilegeEnum +type + WbemPrivilegeEnum = TOleEnum; +const + wbemPrivilegeCreateToken = $00000001; + wbemPrivilegePrimaryToken = $00000002; + wbemPrivilegeLockMemory = $00000003; + wbemPrivilegeIncreaseQuota = $00000004; + wbemPrivilegeMachineAccount = $00000005; + wbemPrivilegeTcb = $00000006; + wbemPrivilegeSecurity = $00000007; + wbemPrivilegeTakeOwnership = $00000008; + wbemPrivilegeLoadDriver = $00000009; + wbemPrivilegeSystemProfile = $0000000A; + wbemPrivilegeSystemtime = $0000000B; + wbemPrivilegeProfileSingleProcess = $0000000C; + wbemPrivilegeIncreaseBasePriority = $0000000D; + wbemPrivilegeCreatePagefile = $0000000E; + wbemPrivilegeCreatePermanent = $0000000F; + wbemPrivilegeBackup = $00000010; + wbemPrivilegeRestore = $00000011; + wbemPrivilegeShutdown = $00000012; + wbemPrivilegeDebug = $00000013; + wbemPrivilegeAudit = $00000014; + wbemPrivilegeSystemEnvironment = $00000015; + wbemPrivilegeChangeNotify = $00000016; + wbemPrivilegeRemoteShutdown = $00000017; + wbemPrivilegeUndock = $00000018; + wbemPrivilegeSyncAgent = $00000019; + wbemPrivilegeEnableDelegation = $0000001A; + wbemPrivilegeManageVolume = $0000001B; + +// Constants for enum WbemCimtypeEnum +type + WbemCimtypeEnum = TOleEnum; +const + wbemCimtypeSint8 = $00000010; + wbemCimtypeUint8 = $00000011; + wbemCimtypeSint16 = $00000002; + wbemCimtypeUint16 = $00000012; + wbemCimtypeSint32 = $00000003; + wbemCimtypeUint32 = $00000013; + wbemCimtypeSint64 = $00000014; + wbemCimtypeUint64 = $00000015; + wbemCimtypeReal32 = $00000004; + wbemCimtypeReal64 = $00000005; + wbemCimtypeBoolean = $0000000B; + wbemCimtypeString = $00000008; + wbemCimtypeDatetime = $00000065; + wbemCimtypeReference = $00000066; + wbemCimtypeChar16 = $00000067; + wbemCimtypeObject = $0000000D; + +// Constants for enum WbemErrorEnum +type + WbemErrorEnum = TOleEnum; +const + wbemNoErr = $00000000; + wbemErrFailed = $80041001; + wbemErrNotFound = $80041002; + wbemErrAccessDenied = $80041003; + wbemErrProviderFailure = $80041004; + wbemErrTypeMismatch = $80041005; + wbemErrOutOfMemory = $80041006; + wbemErrInvalidContext = $80041007; + wbemErrInvalidParameter = $80041008; + wbemErrNotAvailable = $80041009; + wbemErrCriticalError = $8004100A; + wbemErrInvalidStream = $8004100B; + wbemErrNotSupported = $8004100C; + wbemErrInvalidSuperclass = $8004100D; + wbemErrInvalidNamespace = $8004100E; + wbemErrInvalidObject = $8004100F; + wbemErrInvalidClass = $80041010; + wbemErrProviderNotFound = $80041011; + wbemErrInvalidProviderRegistration = $80041012; + wbemErrProviderLoadFailure = $80041013; + wbemErrInitializationFailure = $80041014; + wbemErrTransportFailure = $80041015; + wbemErrInvalidOperation = $80041016; + wbemErrInvalidQuery = $80041017; + wbemErrInvalidQueryType = $80041018; + wbemErrAlreadyExists = $80041019; + wbemErrOverrideNotAllowed = $8004101A; + wbemErrPropagatedQualifier = $8004101B; + wbemErrPropagatedProperty = $8004101C; + wbemErrUnexpected = $8004101D; + wbemErrIllegalOperation = $8004101E; + wbemErrCannotBeKey = $8004101F; + wbemErrIncompleteClass = $80041020; + wbemErrInvalidSyntax = $80041021; + wbemErrNondecoratedObject = $80041022; + wbemErrReadOnly = $80041023; + wbemErrProviderNotCapable = $80041024; + wbemErrClassHasChildren = $80041025; + wbemErrClassHasInstances = $80041026; + wbemErrQueryNotImplemented = $80041027; + wbemErrIllegalNull = $80041028; + wbemErrInvalidQualifierType = $80041029; + wbemErrInvalidPropertyType = $8004102A; + wbemErrValueOutOfRange = $8004102B; + wbemErrCannotBeSingleton = $8004102C; + wbemErrInvalidCimType = $8004102D; + wbemErrInvalidMethod = $8004102E; + wbemErrInvalidMethodParameters = $8004102F; + wbemErrSystemProperty = $80041030; + wbemErrInvalidProperty = $80041031; + wbemErrCallCancelled = $80041032; + wbemErrShuttingDown = $80041033; + wbemErrPropagatedMethod = $80041034; + wbemErrUnsupportedParameter = $80041035; + wbemErrMissingParameter = $80041036; + wbemErrInvalidParameterId = $80041037; + wbemErrNonConsecutiveParameterIds = $80041038; + wbemErrParameterIdOnRetval = $80041039; + wbemErrInvalidObjectPath = $8004103A; + wbemErrOutOfDiskSpace = $8004103B; + wbemErrBufferTooSmall = $8004103C; + wbemErrUnsupportedPutExtension = $8004103D; + wbemErrUnknownObjectType = $8004103E; + wbemErrUnknownPacketType = $8004103F; + wbemErrMarshalVersionMismatch = $80041040; + wbemErrMarshalInvalidSignature = $80041041; + wbemErrInvalidQualifier = $80041042; + wbemErrInvalidDuplicateParameter = $80041043; + wbemErrTooMuchData = $80041044; + wbemErrServerTooBusy = $80041045; + wbemErrInvalidFlavor = $80041046; + wbemErrCircularReference = $80041047; + wbemErrUnsupportedClassUpdate = $80041048; + wbemErrCannotChangeKeyInheritance = $80041049; + wbemErrCannotChangeIndexInheritance = $80041050; + wbemErrTooManyProperties = $80041051; + wbemErrUpdateTypeMismatch = $80041052; + wbemErrUpdateOverrideNotAllowed = $80041053; + wbemErrUpdatePropagatedMethod = $80041054; + wbemErrMethodNotImplemented = $80041055; + wbemErrMethodDisabled = $80041056; + wbemErrRefresherBusy = $80041057; + wbemErrUnparsableQuery = $80041058; + wbemErrNotEventClass = $80041059; + wbemErrMissingGroupWithin = $8004105A; + wbemErrMissingAggregationList = $8004105B; + wbemErrPropertyNotAnObject = $8004105C; + wbemErrAggregatingByObject = $8004105D; + wbemErrUninterpretableProviderQuery = $8004105F; + wbemErrBackupRestoreWinmgmtRunning = $80041060; + wbemErrQueueOverflow = $80041061; + wbemErrPrivilegeNotHeld = $80041062; + wbemErrInvalidOperator = $80041063; + wbemErrLocalCredentials = $80041064; + wbemErrCannotBeAbstract = $80041065; + wbemErrAmendedObject = $80041066; + wbemErrClientTooSlow = $80041067; + wbemErrNullSecurityDescriptor = $80041068; + wbemErrTimeout = $80041069; + wbemErrInvalidAssociation = $8004106A; + wbemErrAmbiguousOperation = $8004106B; + wbemErrQuotaViolation = $8004106C; + wbemErrTransactionConflict = $8004106D; + wbemErrForcedRollback = $8004106E; + wbemErrUnsupportedLocale = $8004106F; + wbemErrHandleOutOfDate = $80041070; + wbemErrConnectionFailed = $80041071; + wbemErrInvalidHandleRequest = $80041072; + wbemErrPropertyNameTooWide = $80041073; + wbemErrClassNameTooWide = $80041074; + wbemErrMethodNameTooWide = $80041075; + wbemErrQualifierNameTooWide = $80041076; + wbemErrRerunCommand = $80041077; + wbemErrDatabaseVerMismatch = $80041078; + wbemErrVetoPut = $80041079; + wbemErrVetoDelete = $8004107A; + wbemErrInvalidLocale = $80041080; + wbemErrProviderSuspended = $80041081; + wbemErrSynchronizationRequired = $80041082; + wbemErrNoSchema = $80041083; + wbemErrProviderAlreadyRegistered = $80041084; + wbemErrProviderNotRegistered = $80041085; + wbemErrFatalTransportError = $80041086; + wbemErrEncryptedConnectionRequired = $80041087; + wbemErrRegistrationTooBroad = $80042001; + wbemErrRegistrationTooPrecise = $80042002; + wbemErrTimedout = $80043001; + wbemErrResetToDefault = $80043002; + +// Constants for enum WbemObjectTextFormatEnum +type + WbemObjectTextFormatEnum = TOleEnum; +const + wbemObjectTextFormatCIMDTD20 = $00000001; + wbemObjectTextFormatWMIDTD20 = $00000002; + +// Constants for enum WbemChangeFlagEnum +type + WbemChangeFlagEnum = TOleEnum; +const + wbemChangeFlagCreateOrUpdate = $00000000; + wbemChangeFlagUpdateOnly = $00000001; + wbemChangeFlagCreateOnly = $00000002; + wbemChangeFlagUpdateCompatible = $00000000; + wbemChangeFlagUpdateSafeMode = $00000020; + wbemChangeFlagUpdateForceMode = $00000040; + wbemChangeFlagStrongValidation = $00000080; + wbemChangeFlagAdvisory = $00010000; + +// Constants for enum WbemFlagEnum +type + WbemFlagEnum = TOleEnum; +const + wbemFlagReturnImmediately = $00000010; + wbemFlagReturnWhenComplete = $00000000; + wbemFlagBidirectional = $00000000; + wbemFlagForwardOnly = $00000020; + wbemFlagNoErrorObject = $00000040; + wbemFlagReturnErrorObject = $00000000; + wbemFlagSendStatus = $00000080; + wbemFlagDontSendStatus = $00000000; + wbemFlagEnsureLocatable = $00000100; + wbemFlagDirectRead = $00000200; + wbemFlagSendOnlySelected = $00000000; + wbemFlagUseAmendedQualifiers = $00020000; + wbemFlagGetDefault = $00000000; + wbemFlagSpawnInstance = $00000001; + wbemFlagUseCurrentTime = $00000001; + +// Constants for enum WbemQueryFlagEnum +type + WbemQueryFlagEnum = TOleEnum; +const + wbemQueryFlagDeep = $00000000; + wbemQueryFlagShallow = $00000001; + wbemQueryFlagPrototype = $00000002; + +// Constants for enum WbemTextFlagEnum +type + WbemTextFlagEnum = TOleEnum; +const + wbemTextFlagNoFlavors = $00000001; + +// Constants for enum WbemTimeout +type + WbemTimeout = TOleEnum; +const + wbemTimeoutInfinite = $FFFFFFFF; + +// Constants for enum WbemComparisonFlagEnum +type + WbemComparisonFlagEnum = TOleEnum; +const + wbemComparisonFlagIncludeAll = $00000000; + wbemComparisonFlagIgnoreQualifiers = $00000001; + wbemComparisonFlagIgnoreObjectSource = $00000002; + wbemComparisonFlagIgnoreDefaultValues = $00000004; + wbemComparisonFlagIgnoreClass = $00000008; + wbemComparisonFlagIgnoreCase = $00000010; + wbemComparisonFlagIgnoreFlavor = $00000020; + +// Constants for enum WbemConnectOptionsEnum +type + WbemConnectOptionsEnum = TOleEnum; +const + wbemConnectFlagUseMaxWait = $00000080; + +type + +// *********************************************************************// +// Forward declaration of types defined in TypeLibrary +// *********************************************************************// + ISWbemServices = interface; + ISWbemServicesDisp = dispinterface; + ISWbemObject = interface; + ISWbemObjectDisp = dispinterface; + ISWbemObjectPath = interface; + ISWbemObjectPathDisp = dispinterface; + ISWbemNamedValueSet = interface; + ISWbemNamedValueSetDisp = dispinterface; + ISWbemNamedValue = interface; + ISWbemNamedValueDisp = dispinterface; + ISWbemSecurity = interface; + ISWbemSecurityDisp = dispinterface; + ISWbemPrivilegeSet = interface; + ISWbemPrivilegeSetDisp = dispinterface; + ISWbemPrivilege = interface; + ISWbemPrivilegeDisp = dispinterface; + ISWbemObjectSet = interface; + ISWbemObjectSetDisp = dispinterface; + ISWbemQualifierSet = interface; + ISWbemQualifierSetDisp = dispinterface; + ISWbemQualifier = interface; + ISWbemQualifierDisp = dispinterface; + ISWbemPropertySet = interface; + ISWbemPropertySetDisp = dispinterface; + ISWbemProperty = interface; + ISWbemPropertyDisp = dispinterface; + ISWbemMethodSet = interface; + ISWbemMethodSetDisp = dispinterface; + ISWbemMethod = interface; + ISWbemMethodDisp = dispinterface; + ISWbemEventSource = interface; + ISWbemEventSourceDisp = dispinterface; + ISWbemLocator = interface; + ISWbemLocatorDisp = dispinterface; + ISWbemLastError = interface; + ISWbemLastErrorDisp = dispinterface; + ISWbemSinkEvents = dispinterface; + ISWbemSink = interface; + ISWbemSinkDisp = dispinterface; + ISWbemServicesEx = interface; + ISWbemServicesExDisp = dispinterface; + ISWbemObjectEx = interface; + ISWbemObjectExDisp = dispinterface; + ISWbemDateTime = interface; + ISWbemDateTimeDisp = dispinterface; + ISWbemRefresher = interface; + ISWbemRefresherDisp = dispinterface; + ISWbemRefreshableItem = interface; + ISWbemRefreshableItemDisp = dispinterface; + +// *********************************************************************// +// Declaration of CoClasses defined in Type Library +// (NOTE: Here we map each CoClass to its Default Interface) +// *********************************************************************// + SWbemLocator = ISWbemLocator; + SWbemNamedValueSet = ISWbemNamedValueSet; + SWbemObjectPath = ISWbemObjectPath; + SWbemLastError = ISWbemLastError; + SWbemSink = ISWbemSink; + SWbemDateTime = ISWbemDateTime; + SWbemRefresher = ISWbemRefresher; + SWbemServices = ISWbemServices; + SWbemServicesEx = ISWbemServicesEx; + SWbemObject = ISWbemObject; + SWbemObjectEx = ISWbemObjectEx; + SWbemObjectSet = ISWbemObjectSet; + SWbemNamedValue = ISWbemNamedValue; + SWbemQualifier = ISWbemQualifier; + SWbemQualifierSet = ISWbemQualifierSet; + SWbemProperty = ISWbemProperty; + SWbemPropertySet = ISWbemPropertySet; + SWbemMethod = ISWbemMethod; + SWbemMethodSet = ISWbemMethodSet; + SWbemEventSource = ISWbemEventSource; + SWbemSecurity = ISWbemSecurity; + SWbemPrivilege = ISWbemPrivilege; + SWbemPrivilegeSet = ISWbemPrivilegeSet; + SWbemRefreshableItem = ISWbemRefreshableItem; + + +// *********************************************************************// +// Declaration of structures, unions and aliases. +// *********************************************************************// + POleVariant1 = ^OleVariant; {*} + + +// *********************************************************************// +// Interface: ISWbemServices +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {76A6415C-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemServices = interface(IDispatch) + ['{76A6415C-CB41-11D1-8B02-00600806D9B6}'] + function Get(const strObjectPath: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObject; safecall; + procedure GetAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + procedure Delete(const strObjectPath: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch); safecall; + procedure DeleteAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function InstancesOf(const strClass: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure InstancesOfAsync(const objWbemSink: IDispatch; const strClass: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function SubclassesOf(const strSuperclass: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure SubclassesOfAsync(const objWbemSink: IDispatch; const strSuperclass: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function ExecQuery(const strQuery: WideString; const strQueryLanguage: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure ExecQueryAsync(const objWbemSink: IDispatch; const strQuery: WideString; + const strQueryLanguage: WideString; lFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function AssociatorsOf(const strObjectPath: WideString; const strAssocClass: WideString; + const strResultClass: WideString; const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure AssociatorsOfAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strAssocClass: WideString; const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function ReferencesTo(const strObjectPath: WideString; const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure ReferencesToAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function ExecNotificationQuery(const strQuery: WideString; const strQueryLanguage: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemEventSource; safecall; + procedure ExecNotificationQueryAsync(const objWbemSink: IDispatch; const strQuery: WideString; + const strQueryLanguage: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function ExecMethod(const strObjectPath: WideString; const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObject; safecall; + procedure ExecMethodAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function Get_Security_: ISWbemSecurity; safecall; + property Security_: ISWbemSecurity read Get_Security_; + end; + +// *********************************************************************// +// DispIntf: ISWbemServicesDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {76A6415C-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemServicesDisp = dispinterface + ['{76A6415C-CB41-11D1-8B02-00600806D9B6}'] + function Get(const strObjectPath: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObject; dispid 1; + procedure GetAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 2; + procedure Delete(const strObjectPath: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch); dispid 3; + procedure DeleteAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 4; + function InstancesOf(const strClass: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 5; + procedure InstancesOfAsync(const objWbemSink: IDispatch; const strClass: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 6; + function SubclassesOf(const strSuperclass: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 7; + procedure SubclassesOfAsync(const objWbemSink: IDispatch; const strSuperclass: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 8; + function ExecQuery(const strQuery: WideString; const strQueryLanguage: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 9; + procedure ExecQueryAsync(const objWbemSink: IDispatch; const strQuery: WideString; + const strQueryLanguage: WideString; lFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 10; + function AssociatorsOf(const strObjectPath: WideString; const strAssocClass: WideString; + const strResultClass: WideString; const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 11; + procedure AssociatorsOfAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strAssocClass: WideString; const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 12; + function ReferencesTo(const strObjectPath: WideString; const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 13; + procedure ReferencesToAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 14; + function ExecNotificationQuery(const strQuery: WideString; const strQueryLanguage: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemEventSource; dispid 15; + procedure ExecNotificationQueryAsync(const objWbemSink: IDispatch; const strQuery: WideString; + const strQueryLanguage: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 16; + function ExecMethod(const strObjectPath: WideString; const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObject; dispid 17; + procedure ExecMethodAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 18; + property Security_: ISWbemSecurity readonly dispid 19; + end; + +// *********************************************************************// +// Interface: ISWbemObject +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {76A6415A-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemObject = interface(IDispatch) + ['{76A6415A-CB41-11D1-8B02-00600806D9B6}'] + function Put_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectPath; safecall; + procedure PutAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; const objWbemAsyncContext: IDispatch); safecall; + procedure Delete_(iFlags: Integer; const objWbemNamedValueSet: IDispatch); safecall; + procedure DeleteAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function Instances_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure InstancesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function Subclasses_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure SubclassesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function Associators_(const strAssocClass: WideString; const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure AssociatorsAsync_(const objWbemSink: IDispatch; const strAssocClass: WideString; + const strResultClass: WideString; const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function References_(const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall; + procedure ReferencesAsync_(const objWbemSink: IDispatch; const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredQualifier: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function ExecMethod_(const strMethodName: WideString; const objWbemInParameters: IDispatch; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObject; safecall; + procedure ExecMethodAsync_(const objWbemSink: IDispatch; const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + function Clone_: ISWbemObject; safecall; + function GetObjectText_(iFlags: Integer): WideString; safecall; + function SpawnDerivedClass_(iFlags: Integer): ISWbemObject; safecall; + function SpawnInstance_(iFlags: Integer): ISWbemObject; safecall; + function CompareTo_(const objWbemObject: IDispatch; iFlags: Integer): WordBool; safecall; + function Get_Qualifiers_: ISWbemQualifierSet; safecall; + function Get_Properties_: ISWbemPropertySet; safecall; + function Get_Methods_: ISWbemMethodSet; safecall; + function Get_Derivation_: OleVariant; safecall; + function Get_Path_: ISWbemObjectPath; safecall; + function Get_Security_: ISWbemSecurity; safecall; + property Qualifiers_: ISWbemQualifierSet read Get_Qualifiers_; + property Properties_: ISWbemPropertySet read Get_Properties_; + property Methods_: ISWbemMethodSet read Get_Methods_; + property Derivation_: OleVariant read Get_Derivation_; + property Path_: ISWbemObjectPath read Get_Path_; + property Security_: ISWbemSecurity read Get_Security_; + end; + +// *********************************************************************// +// DispIntf: ISWbemObjectDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {76A6415A-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemObjectDisp = dispinterface + ['{76A6415A-CB41-11D1-8B02-00600806D9B6}'] + function Put_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectPath; dispid 1; + procedure PutAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; const objWbemAsyncContext: IDispatch); dispid 2; + procedure Delete_(iFlags: Integer; const objWbemNamedValueSet: IDispatch); dispid 3; + procedure DeleteAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 4; + function Instances_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 5; + procedure InstancesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 6; + function Subclasses_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 7; + procedure SubclassesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 8; + function Associators_(const strAssocClass: WideString; const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 9; + procedure AssociatorsAsync_(const objWbemSink: IDispatch; const strAssocClass: WideString; + const strResultClass: WideString; const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 10; + function References_(const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 11; + procedure ReferencesAsync_(const objWbemSink: IDispatch; const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredQualifier: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 12; + function ExecMethod_(const strMethodName: WideString; const objWbemInParameters: IDispatch; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObject; dispid 13; + procedure ExecMethodAsync_(const objWbemSink: IDispatch; const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 14; + function Clone_: ISWbemObject; dispid 15; + function GetObjectText_(iFlags: Integer): WideString; dispid 16; + function SpawnDerivedClass_(iFlags: Integer): ISWbemObject; dispid 17; + function SpawnInstance_(iFlags: Integer): ISWbemObject; dispid 18; + function CompareTo_(const objWbemObject: IDispatch; iFlags: Integer): WordBool; dispid 19; + property Qualifiers_: ISWbemQualifierSet readonly dispid 20; + property Properties_: ISWbemPropertySet readonly dispid 21; + property Methods_: ISWbemMethodSet readonly dispid 22; + property Derivation_: OleVariant readonly dispid 23; + property Path_: ISWbemObjectPath readonly dispid 24; + property Security_: ISWbemSecurity readonly dispid 25; + end; + +// *********************************************************************// +// Interface: ISWbemObjectPath +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {5791BC27-CE9C-11D1-97BF-0000F81E849C} +// *********************************************************************// + ISWbemObjectPath = interface(IDispatch) + ['{5791BC27-CE9C-11D1-97BF-0000F81E849C}'] + function Get_Path: WideString; safecall; + procedure Set_Path(const strPath: WideString); safecall; + function Get_RelPath: WideString; safecall; + procedure Set_RelPath(const strRelPath: WideString); safecall; + function Get_Server: WideString; safecall; + procedure Set_Server(const strServer: WideString); safecall; + function Get_Namespace: WideString; safecall; + procedure Set_Namespace(const strNamespace: WideString); safecall; + function Get_ParentNamespace: WideString; safecall; + function Get_DisplayName: WideString; safecall; + procedure Set_DisplayName(const strDisplayName: WideString); safecall; + function Get_Class_: WideString; safecall; + procedure Set_Class_(const strClass: WideString); safecall; + function Get_IsClass: WordBool; safecall; + procedure SetAsClass; safecall; + function Get_IsSingleton: WordBool; safecall; + procedure SetAsSingleton; safecall; + function Get_Keys: ISWbemNamedValueSet; safecall; + function Get_Security_: ISWbemSecurity; safecall; + function Get_Locale: WideString; safecall; + procedure Set_Locale(const strLocale: WideString); safecall; + function Get_Authority: WideString; safecall; + procedure Set_Authority(const strAuthority: WideString); safecall; + property Path: WideString read Get_Path write Set_Path; + property RelPath: WideString read Get_RelPath write Set_RelPath; + property Server: WideString read Get_Server write Set_Server; + property Namespace: WideString read Get_Namespace write Set_Namespace; + property ParentNamespace: WideString read Get_ParentNamespace; + property DisplayName: WideString read Get_DisplayName write Set_DisplayName; + property Class_: WideString read Get_Class_ write Set_Class_; + property IsClass: WordBool read Get_IsClass; + property IsSingleton: WordBool read Get_IsSingleton; + property Keys: ISWbemNamedValueSet read Get_Keys; + property Security_: ISWbemSecurity read Get_Security_; + property Locale: WideString read Get_Locale write Set_Locale; + property Authority: WideString read Get_Authority write Set_Authority; + end; + +// *********************************************************************// +// DispIntf: ISWbemObjectPathDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {5791BC27-CE9C-11D1-97BF-0000F81E849C} +// *********************************************************************// + ISWbemObjectPathDisp = dispinterface + ['{5791BC27-CE9C-11D1-97BF-0000F81E849C}'] + property Path: WideString dispid 0; + property RelPath: WideString dispid 1; + property Server: WideString dispid 2; + property Namespace: WideString dispid 3; + property ParentNamespace: WideString readonly dispid 4; + property DisplayName: WideString dispid 5; + property Class_: WideString dispid 6; + property IsClass: WordBool readonly dispid 7; + procedure SetAsClass; dispid 8; + property IsSingleton: WordBool readonly dispid 9; + procedure SetAsSingleton; dispid 10; + property Keys: ISWbemNamedValueSet readonly dispid 11; + property Security_: ISWbemSecurity readonly dispid 12; + property Locale: WideString dispid 13; + property Authority: WideString dispid 14; + end; + +// *********************************************************************// +// Interface: ISWbemNamedValueSet +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {CF2376EA-CE8C-11D1-8B05-00600806D9B6} +// *********************************************************************// + ISWbemNamedValueSet = interface(IDispatch) + ['{CF2376EA-CE8C-11D1-8B05-00600806D9B6}'] + function Get__NewEnum: IUnknown; safecall; + function Item(const strName: WideString; iFlags: Integer): ISWbemNamedValue; safecall; + function Get_Count: Integer; safecall; + function Add(const strName: WideString; var varValue: OleVariant; iFlags: Integer): ISWbemNamedValue; safecall; + procedure Remove(const strName: WideString; iFlags: Integer); safecall; + function Clone: ISWbemNamedValueSet; safecall; + procedure DeleteAll; safecall; + property _NewEnum: IUnknown read Get__NewEnum; + property Count: Integer read Get_Count; + end; + +// *********************************************************************// +// DispIntf: ISWbemNamedValueSetDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {CF2376EA-CE8C-11D1-8B05-00600806D9B6} +// *********************************************************************// + ISWbemNamedValueSetDisp = dispinterface + ['{CF2376EA-CE8C-11D1-8B05-00600806D9B6}'] + property _NewEnum: IUnknown readonly dispid -4; + function Item(const strName: WideString; iFlags: Integer): ISWbemNamedValue; dispid 0; + property Count: Integer readonly dispid 1; + function Add(const strName: WideString; var varValue: OleVariant; iFlags: Integer): ISWbemNamedValue; dispid 2; + procedure Remove(const strName: WideString; iFlags: Integer); dispid 3; + function Clone: ISWbemNamedValueSet; dispid 4; + procedure DeleteAll; dispid 5; + end; + +// *********************************************************************// +// Interface: ISWbemNamedValue +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {76A64164-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemNamedValue = interface(IDispatch) + ['{76A64164-CB41-11D1-8B02-00600806D9B6}'] + function Get_Value: OleVariant; safecall; + procedure Set_Value(var varValue: OleVariant); safecall; + function Get_Name: WideString; safecall; + property Name: WideString read Get_Name; + end; + +// *********************************************************************// +// DispIntf: ISWbemNamedValueDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {76A64164-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemNamedValueDisp = dispinterface + ['{76A64164-CB41-11D1-8B02-00600806D9B6}'] + function Value: OleVariant; dispid 0; + property Name: WideString readonly dispid 2; + end; + +// *********************************************************************// +// Interface: ISWbemSecurity +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {B54D66E6-2287-11D2-8B33-00600806D9B6} +// *********************************************************************// + ISWbemSecurity = interface(IDispatch) + ['{B54D66E6-2287-11D2-8B33-00600806D9B6}'] + function Get_ImpersonationLevel: WbemImpersonationLevelEnum; safecall; + procedure Set_ImpersonationLevel(iImpersonationLevel: WbemImpersonationLevelEnum); safecall; + function Get_AuthenticationLevel: WbemAuthenticationLevelEnum; safecall; + procedure Set_AuthenticationLevel(iAuthenticationLevel: WbemAuthenticationLevelEnum); safecall; + function Get_Privileges: ISWbemPrivilegeSet; safecall; + property ImpersonationLevel: WbemImpersonationLevelEnum read Get_ImpersonationLevel write Set_ImpersonationLevel; + property AuthenticationLevel: WbemAuthenticationLevelEnum read Get_AuthenticationLevel write Set_AuthenticationLevel; + property Privileges: ISWbemPrivilegeSet read Get_Privileges; + end; + +// *********************************************************************// +// DispIntf: ISWbemSecurityDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {B54D66E6-2287-11D2-8B33-00600806D9B6} +// *********************************************************************// + ISWbemSecurityDisp = dispinterface + ['{B54D66E6-2287-11D2-8B33-00600806D9B6}'] + property ImpersonationLevel: WbemImpersonationLevelEnum dispid 1; + property AuthenticationLevel: WbemAuthenticationLevelEnum dispid 2; + property Privileges: ISWbemPrivilegeSet readonly dispid 3; + end; + +// *********************************************************************// +// Interface: ISWbemPrivilegeSet +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {26EE67BF-5804-11D2-8B4A-00600806D9B6} +// *********************************************************************// + ISWbemPrivilegeSet = interface(IDispatch) + ['{26EE67BF-5804-11D2-8B4A-00600806D9B6}'] + function Get__NewEnum: IUnknown; safecall; + function Item(iPrivilege: WbemPrivilegeEnum): ISWbemPrivilege; safecall; + function Get_Count: Integer; safecall; + function Add(iPrivilege: WbemPrivilegeEnum; bIsEnabled: WordBool): ISWbemPrivilege; safecall; + procedure Remove(iPrivilege: WbemPrivilegeEnum); safecall; + procedure DeleteAll; safecall; + function AddAsString(const strPrivilege: WideString; bIsEnabled: WordBool): ISWbemPrivilege; safecall; + property _NewEnum: IUnknown read Get__NewEnum; + property Count: Integer read Get_Count; + end; + +// *********************************************************************// +// DispIntf: ISWbemPrivilegeSetDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {26EE67BF-5804-11D2-8B4A-00600806D9B6} +// *********************************************************************// + ISWbemPrivilegeSetDisp = dispinterface + ['{26EE67BF-5804-11D2-8B4A-00600806D9B6}'] + property _NewEnum: IUnknown readonly dispid -4; + function Item(iPrivilege: WbemPrivilegeEnum): ISWbemPrivilege; dispid 0; + property Count: Integer readonly dispid 1; + function Add(iPrivilege: WbemPrivilegeEnum; bIsEnabled: WordBool): ISWbemPrivilege; dispid 2; + procedure Remove(iPrivilege: WbemPrivilegeEnum); dispid 3; + procedure DeleteAll; dispid 4; + function AddAsString(const strPrivilege: WideString; bIsEnabled: WordBool): ISWbemPrivilege; dispid 5; + end; + +// *********************************************************************// +// Interface: ISWbemPrivilege +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {26EE67BD-5804-11D2-8B4A-00600806D9B6} +// *********************************************************************// + ISWbemPrivilege = interface(IDispatch) + ['{26EE67BD-5804-11D2-8B4A-00600806D9B6}'] + function Get_IsEnabled: WordBool; safecall; + procedure Set_IsEnabled(bIsEnabled: WordBool); safecall; + function Get_Name: WideString; safecall; + function Get_DisplayName: WideString; safecall; + function Get_Identifier: WbemPrivilegeEnum; safecall; + property IsEnabled: WordBool read Get_IsEnabled write Set_IsEnabled; + property Name: WideString read Get_Name; + property DisplayName: WideString read Get_DisplayName; + property Identifier: WbemPrivilegeEnum read Get_Identifier; + end; + +// *********************************************************************// +// DispIntf: ISWbemPrivilegeDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {26EE67BD-5804-11D2-8B4A-00600806D9B6} +// *********************************************************************// + ISWbemPrivilegeDisp = dispinterface + ['{26EE67BD-5804-11D2-8B4A-00600806D9B6}'] + property IsEnabled: WordBool dispid 0; + property Name: WideString readonly dispid 1; + property DisplayName: WideString readonly dispid 2; + property Identifier: WbemPrivilegeEnum readonly dispid 3; + end; + +// *********************************************************************// +// Interface: ISWbemObjectSet +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {76A6415F-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemObjectSet = interface(IDispatch) + ['{76A6415F-CB41-11D1-8B02-00600806D9B6}'] + function Get__NewEnum: IUnknown; safecall; + function Item(const strObjectPath: WideString; iFlags: Integer): ISWbemObject; safecall; + function Get_Count: Integer; safecall; + function Get_Security_: ISWbemSecurity; safecall; + property _NewEnum: IUnknown read Get__NewEnum; + property Count: Integer read Get_Count; + property Security_: ISWbemSecurity read Get_Security_; + end; + +// *********************************************************************// +// DispIntf: ISWbemObjectSetDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {76A6415F-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemObjectSetDisp = dispinterface + ['{76A6415F-CB41-11D1-8B02-00600806D9B6}'] + property _NewEnum: IUnknown readonly dispid -4; + function Item(const strObjectPath: WideString; iFlags: Integer): ISWbemObject; dispid 0; + property Count: Integer readonly dispid 1; + property Security_: ISWbemSecurity readonly dispid 4; + end; + +// *********************************************************************// +// Interface: ISWbemQualifierSet +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {9B16ED16-D3DF-11D1-8B08-00600806D9B6} +// *********************************************************************// + ISWbemQualifierSet = interface(IDispatch) + ['{9B16ED16-D3DF-11D1-8B08-00600806D9B6}'] + function Get__NewEnum: IUnknown; safecall; + function Item(const Name: WideString; iFlags: Integer): ISWbemQualifier; safecall; + function Get_Count: Integer; safecall; + function Add(const strName: WideString; var varVal: OleVariant; + bPropagatesToSubclass: WordBool; bPropagatesToInstance: WordBool; + bIsOverridable: WordBool; iFlags: Integer): ISWbemQualifier; safecall; + procedure Remove(const strName: WideString; iFlags: Integer); safecall; + property _NewEnum: IUnknown read Get__NewEnum; + property Count: Integer read Get_Count; + end; + +// *********************************************************************// +// DispIntf: ISWbemQualifierSetDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {9B16ED16-D3DF-11D1-8B08-00600806D9B6} +// *********************************************************************// + ISWbemQualifierSetDisp = dispinterface + ['{9B16ED16-D3DF-11D1-8B08-00600806D9B6}'] + property _NewEnum: IUnknown readonly dispid -4; + function Item(const Name: WideString; iFlags: Integer): ISWbemQualifier; dispid 0; + property Count: Integer readonly dispid 1; + function Add(const strName: WideString; var varVal: OleVariant; + bPropagatesToSubclass: WordBool; bPropagatesToInstance: WordBool; + bIsOverridable: WordBool; iFlags: Integer): ISWbemQualifier; dispid 2; + procedure Remove(const strName: WideString; iFlags: Integer); dispid 3; + end; + +// *********************************************************************// +// Interface: ISWbemQualifier +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {79B05932-D3B7-11D1-8B06-00600806D9B6} +// *********************************************************************// + ISWbemQualifier = interface(IDispatch) + ['{79B05932-D3B7-11D1-8B06-00600806D9B6}'] + function Get_Value: OleVariant; safecall; + procedure Set_Value(var varValue: OleVariant); safecall; + function Get_Name: WideString; safecall; + function Get_IsLocal: WordBool; safecall; + function Get_PropagatesToSubclass: WordBool; safecall; + procedure Set_PropagatesToSubclass(bPropagatesToSubclass: WordBool); safecall; + function Get_PropagatesToInstance: WordBool; safecall; + procedure Set_PropagatesToInstance(bPropagatesToInstance: WordBool); safecall; + function Get_IsOverridable: WordBool; safecall; + procedure Set_IsOverridable(bIsOverridable: WordBool); safecall; + function Get_IsAmended: WordBool; safecall; + property Name: WideString read Get_Name; + property IsLocal: WordBool read Get_IsLocal; + property PropagatesToSubclass: WordBool read Get_PropagatesToSubclass write Set_PropagatesToSubclass; + property PropagatesToInstance: WordBool read Get_PropagatesToInstance write Set_PropagatesToInstance; + property IsOverridable: WordBool read Get_IsOverridable write Set_IsOverridable; + property IsAmended: WordBool read Get_IsAmended; + end; + +// *********************************************************************// +// DispIntf: ISWbemQualifierDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {79B05932-D3B7-11D1-8B06-00600806D9B6} +// *********************************************************************// + ISWbemQualifierDisp = dispinterface + ['{79B05932-D3B7-11D1-8B06-00600806D9B6}'] + function Value: OleVariant; dispid 0; + property Name: WideString readonly dispid 1; + property IsLocal: WordBool readonly dispid 2; + property PropagatesToSubclass: WordBool dispid 3; + property PropagatesToInstance: WordBool dispid 4; + property IsOverridable: WordBool dispid 5; + property IsAmended: WordBool readonly dispid 6; + end; + +// *********************************************************************// +// Interface: ISWbemPropertySet +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {DEA0A7B2-D4BA-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemPropertySet = interface(IDispatch) + ['{DEA0A7B2-D4BA-11D1-8B09-00600806D9B6}'] + function Get__NewEnum: IUnknown; safecall; + function Item(const strName: WideString; iFlags: Integer): ISWbemProperty; safecall; + function Get_Count: Integer; safecall; + function Add(const strName: WideString; iCimType: WbemCimtypeEnum; bIsArray: WordBool; + iFlags: Integer): ISWbemProperty; safecall; + procedure Remove(const strName: WideString; iFlags: Integer); safecall; + property _NewEnum: IUnknown read Get__NewEnum; + property Count: Integer read Get_Count; + end; + +// *********************************************************************// +// DispIntf: ISWbemPropertySetDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {DEA0A7B2-D4BA-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemPropertySetDisp = dispinterface + ['{DEA0A7B2-D4BA-11D1-8B09-00600806D9B6}'] + property _NewEnum: IUnknown readonly dispid -4; + function Item(const strName: WideString; iFlags: Integer): ISWbemProperty; dispid 0; + property Count: Integer readonly dispid 1; + function Add(const strName: WideString; iCimType: WbemCimtypeEnum; bIsArray: WordBool; + iFlags: Integer): ISWbemProperty; dispid 2; + procedure Remove(const strName: WideString; iFlags: Integer); dispid 3; + end; + +// *********************************************************************// +// Interface: ISWbemProperty +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {1A388F98-D4BA-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemProperty = interface(IDispatch) + ['{1A388F98-D4BA-11D1-8B09-00600806D9B6}'] + function Get_Value: OleVariant; safecall; + procedure Set_Value(var varValue: OleVariant); safecall; + function Get_Name: WideString; safecall; + function Get_IsLocal: WordBool; safecall; + function Get_Origin: WideString; safecall; + function Get_CIMType: WbemCimtypeEnum; safecall; + function Get_Qualifiers_: ISWbemQualifierSet; safecall; + function Get_IsArray: WordBool; safecall; + property Name: WideString read Get_Name; + property IsLocal: WordBool read Get_IsLocal; + property Origin: WideString read Get_Origin; + property CIMType: WbemCimtypeEnum read Get_CIMType; + property Qualifiers_: ISWbemQualifierSet read Get_Qualifiers_; + property IsArray: WordBool read Get_IsArray; + end; + +// *********************************************************************// +// DispIntf: ISWbemPropertyDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {1A388F98-D4BA-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemPropertyDisp = dispinterface + ['{1A388F98-D4BA-11D1-8B09-00600806D9B6}'] + function Value: OleVariant; dispid 0; + property Name: WideString readonly dispid 1; + property IsLocal: WordBool readonly dispid 2; + property Origin: WideString readonly dispid 3; + property CIMType: WbemCimtypeEnum readonly dispid 4; + property Qualifiers_: ISWbemQualifierSet readonly dispid 5; + property IsArray: WordBool readonly dispid 6; + end; + +// *********************************************************************// +// Interface: ISWbemMethodSet +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {C93BA292-D955-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemMethodSet = interface(IDispatch) + ['{C93BA292-D955-11D1-8B09-00600806D9B6}'] + function Get__NewEnum: IUnknown; safecall; + function Item(const strName: WideString; iFlags: Integer): ISWbemMethod; safecall; + function Get_Count: Integer; safecall; + property _NewEnum: IUnknown read Get__NewEnum; + property Count: Integer read Get_Count; + end; + +// *********************************************************************// +// DispIntf: ISWbemMethodSetDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {C93BA292-D955-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemMethodSetDisp = dispinterface + ['{C93BA292-D955-11D1-8B09-00600806D9B6}'] + property _NewEnum: IUnknown readonly dispid -4; + function Item(const strName: WideString; iFlags: Integer): ISWbemMethod; dispid 0; + property Count: Integer readonly dispid 1; + end; + +// *********************************************************************// +// Interface: ISWbemMethod +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {422E8E90-D955-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemMethod = interface(IDispatch) + ['{422E8E90-D955-11D1-8B09-00600806D9B6}'] + function Get_Name: WideString; safecall; + function Get_Origin: WideString; safecall; + function Get_InParameters: ISWbemObject; safecall; + function Get_OutParameters: ISWbemObject; safecall; + function Get_Qualifiers_: ISWbemQualifierSet; safecall; + property Name: WideString read Get_Name; + property Origin: WideString read Get_Origin; + property InParameters: ISWbemObject read Get_InParameters; + property OutParameters: ISWbemObject read Get_OutParameters; + property Qualifiers_: ISWbemQualifierSet read Get_Qualifiers_; + end; + +// *********************************************************************// +// DispIntf: ISWbemMethodDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {422E8E90-D955-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemMethodDisp = dispinterface + ['{422E8E90-D955-11D1-8B09-00600806D9B6}'] + property Name: WideString readonly dispid 1; + property Origin: WideString readonly dispid 2; + property InParameters: ISWbemObject readonly dispid 3; + property OutParameters: ISWbemObject readonly dispid 4; + property Qualifiers_: ISWbemQualifierSet readonly dispid 5; + end; + +// *********************************************************************// +// Interface: ISWbemEventSource +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {27D54D92-0EBE-11D2-8B22-00600806D9B6} +// *********************************************************************// + ISWbemEventSource = interface(IDispatch) + ['{27D54D92-0EBE-11D2-8B22-00600806D9B6}'] + function NextEvent(iTimeoutMs: Integer): ISWbemObject; safecall; + function Get_Security_: ISWbemSecurity; safecall; + property Security_: ISWbemSecurity read Get_Security_; + end; + +// *********************************************************************// +// DispIntf: ISWbemEventSourceDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {27D54D92-0EBE-11D2-8B22-00600806D9B6} +// *********************************************************************// + ISWbemEventSourceDisp = dispinterface + ['{27D54D92-0EBE-11D2-8B22-00600806D9B6}'] + function NextEvent(iTimeoutMs: Integer): ISWbemObject; dispid 1; + property Security_: ISWbemSecurity readonly dispid 2; + end; + +// *********************************************************************// +// Interface: ISWbemLocator +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {76A6415B-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemLocator = interface(IDispatch) + ['{76A6415B-CB41-11D1-8B02-00600806D9B6}'] + function ConnectServer(const strServer: WideString; const strNamespace: WideString; + const strUser: WideString; const strPassword: WideString; + const strLocale: WideString; const strAuthority: WideString; + iSecurityFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemServices; safecall; + function Get_Security_: ISWbemSecurity; safecall; + property Security_: ISWbemSecurity read Get_Security_; + end; + +// *********************************************************************// +// DispIntf: ISWbemLocatorDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {76A6415B-CB41-11D1-8B02-00600806D9B6} +// *********************************************************************// + ISWbemLocatorDisp = dispinterface + ['{76A6415B-CB41-11D1-8B02-00600806D9B6}'] + function ConnectServer(const strServer: WideString; const strNamespace: WideString; + const strUser: WideString; const strPassword: WideString; + const strLocale: WideString; const strAuthority: WideString; + iSecurityFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemServices; dispid 1; + property Security_: ISWbemSecurity readonly dispid 2; + end; + +// *********************************************************************// +// Interface: ISWbemLastError +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {D962DB84-D4BB-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemLastError = interface(ISWbemObject) + ['{D962DB84-D4BB-11D1-8B09-00600806D9B6}'] + end; + +// *********************************************************************// +// DispIntf: ISWbemLastErrorDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {D962DB84-D4BB-11D1-8B09-00600806D9B6} +// *********************************************************************// + ISWbemLastErrorDisp = dispinterface + ['{D962DB84-D4BB-11D1-8B09-00600806D9B6}'] + function Put_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectPath; dispid 1; + procedure PutAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; const objWbemAsyncContext: IDispatch); dispid 2; + procedure Delete_(iFlags: Integer; const objWbemNamedValueSet: IDispatch); dispid 3; + procedure DeleteAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 4; + function Instances_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 5; + procedure InstancesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 6; + function Subclasses_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 7; + procedure SubclassesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 8; + function Associators_(const strAssocClass: WideString; const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 9; + procedure AssociatorsAsync_(const objWbemSink: IDispatch; const strAssocClass: WideString; + const strResultClass: WideString; const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 10; + function References_(const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 11; + procedure ReferencesAsync_(const objWbemSink: IDispatch; const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredQualifier: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 12; + function ExecMethod_(const strMethodName: WideString; const objWbemInParameters: IDispatch; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObject; dispid 13; + procedure ExecMethodAsync_(const objWbemSink: IDispatch; const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 14; + function Clone_: ISWbemObject; dispid 15; + function GetObjectText_(iFlags: Integer): WideString; dispid 16; + function SpawnDerivedClass_(iFlags: Integer): ISWbemObject; dispid 17; + function SpawnInstance_(iFlags: Integer): ISWbemObject; dispid 18; + function CompareTo_(const objWbemObject: IDispatch; iFlags: Integer): WordBool; dispid 19; + property Qualifiers_: ISWbemQualifierSet readonly dispid 20; + property Properties_: ISWbemPropertySet readonly dispid 21; + property Methods_: ISWbemMethodSet readonly dispid 22; + property Derivation_: OleVariant readonly dispid 23; + property Path_: ISWbemObjectPath readonly dispid 24; + property Security_: ISWbemSecurity readonly dispid 25; + end; + +// *********************************************************************// +// DispIntf: ISWbemSinkEvents +// Flags: (4240) Hidden NonExtensible Dispatchable +// GUID: {75718CA0-F029-11D1-A1AC-00C04FB6C223} +// *********************************************************************// + ISWbemSinkEvents = dispinterface + ['{75718CA0-F029-11D1-A1AC-00C04FB6C223}'] + procedure OnObjectReady(const objWbemObject: ISWbemObject; + const objWbemAsyncContext: ISWbemNamedValueSet); dispid 1; + procedure OnCompleted(iHResult: WbemErrorEnum; const objWbemErrorObject: ISWbemObject; + const objWbemAsyncContext: ISWbemNamedValueSet); dispid 2; + procedure OnProgress(iUpperBound: Integer; iCurrent: Integer; const strMessage: WideString; + const objWbemAsyncContext: ISWbemNamedValueSet); dispid 3; + procedure OnObjectPut(const objWbemObjectPath: ISWbemObjectPath; + const objWbemAsyncContext: ISWbemNamedValueSet); dispid 4; + end; + +// *********************************************************************// +// Interface: ISWbemSink +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {75718C9F-F029-11D1-A1AC-00C04FB6C223} +// *********************************************************************// + ISWbemSink = interface(IDispatch) + ['{75718C9F-F029-11D1-A1AC-00C04FB6C223}'] + procedure Cancel; safecall; + end; + +// *********************************************************************// +// DispIntf: ISWbemSinkDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {75718C9F-F029-11D1-A1AC-00C04FB6C223} +// *********************************************************************// + ISWbemSinkDisp = dispinterface + ['{75718C9F-F029-11D1-A1AC-00C04FB6C223}'] + procedure Cancel; dispid 1; + end; + +// *********************************************************************// +// Interface: ISWbemServicesEx +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {D2F68443-85DC-427E-91D8-366554CC754C} +// *********************************************************************// + ISWbemServicesEx = interface(ISWbemServices) + ['{D2F68443-85DC-427E-91D8-366554CC754C}'] + function Put(const objWbemObject: ISWbemObjectEx; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectPath; safecall; + procedure PutAsync(const objWbemSink: ISWbemSink; const objWbemObject: ISWbemObjectEx; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); safecall; + end; + +// *********************************************************************// +// DispIntf: ISWbemServicesExDisp +// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable +// GUID: {D2F68443-85DC-427E-91D8-366554CC754C} +// *********************************************************************// + ISWbemServicesExDisp = dispinterface + ['{D2F68443-85DC-427E-91D8-366554CC754C}'] + function Put(const objWbemObject: ISWbemObjectEx; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectPath; dispid 20; + procedure PutAsync(const objWbemSink: ISWbemSink; const objWbemObject: ISWbemObjectEx; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 21; + function Get(const strObjectPath: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObject; dispid 1; + procedure GetAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 2; + procedure Delete(const strObjectPath: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch); dispid 3; + procedure DeleteAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 4; + function InstancesOf(const strClass: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 5; + procedure InstancesOfAsync(const objWbemSink: IDispatch; const strClass: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 6; + function SubclassesOf(const strSuperclass: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 7; + procedure SubclassesOfAsync(const objWbemSink: IDispatch; const strSuperclass: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 8; + function ExecQuery(const strQuery: WideString; const strQueryLanguage: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 9; + procedure ExecQueryAsync(const objWbemSink: IDispatch; const strQuery: WideString; + const strQueryLanguage: WideString; lFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 10; + function AssociatorsOf(const strObjectPath: WideString; const strAssocClass: WideString; + const strResultClass: WideString; const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 11; + procedure AssociatorsOfAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strAssocClass: WideString; const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 12; + function ReferencesTo(const strObjectPath: WideString; const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 13; + procedure ReferencesToAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 14; + function ExecNotificationQuery(const strQuery: WideString; const strQueryLanguage: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemEventSource; dispid 15; + procedure ExecNotificationQueryAsync(const objWbemSink: IDispatch; const strQuery: WideString; + const strQueryLanguage: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 16; + function ExecMethod(const strObjectPath: WideString; const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObject; dispid 17; + procedure ExecMethodAsync(const objWbemSink: IDispatch; const strObjectPath: WideString; + const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 18; + property Security_: ISWbemSecurity readonly dispid 19; + end; + +// *********************************************************************// +// Interface: ISWbemObjectEx +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {269AD56A-8A67-4129-BC8C-0506DCFE9880} +// *********************************************************************// + ISWbemObjectEx = interface(ISWbemObject) + ['{269AD56A-8A67-4129-BC8C-0506DCFE9880}'] + procedure Refresh_(iFlags: Integer; const objWbemNamedValueSet: IDispatch); safecall; + function Get_SystemProperties_: ISWbemPropertySet; safecall; + function GetText_(iObjectTextFormat: WbemObjectTextFormatEnum; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): WideString; safecall; + procedure SetFromText_(const bsText: WideString; iObjectTextFormat: WbemObjectTextFormatEnum; + iFlags: Integer; const objWbemNamedValueSet: IDispatch); safecall; + property SystemProperties_: ISWbemPropertySet read Get_SystemProperties_; + end; + +// *********************************************************************// +// DispIntf: ISWbemObjectExDisp +// Flags: (4432) Hidden Dual OleAutomation Dispatchable +// GUID: {269AD56A-8A67-4129-BC8C-0506DCFE9880} +// *********************************************************************// + ISWbemObjectExDisp = dispinterface + ['{269AD56A-8A67-4129-BC8C-0506DCFE9880}'] + procedure Refresh_(iFlags: Integer; const objWbemNamedValueSet: IDispatch); dispid 26; + property SystemProperties_: ISWbemPropertySet readonly dispid 27; + function GetText_(iObjectTextFormat: WbemObjectTextFormatEnum; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): WideString; dispid 28; + procedure SetFromText_(const bsText: WideString; iObjectTextFormat: WbemObjectTextFormatEnum; + iFlags: Integer; const objWbemNamedValueSet: IDispatch); dispid 29; + function Put_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectPath; dispid 1; + procedure PutAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; const objWbemAsyncContext: IDispatch); dispid 2; + procedure Delete_(iFlags: Integer; const objWbemNamedValueSet: IDispatch); dispid 3; + procedure DeleteAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 4; + function Instances_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 5; + procedure InstancesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 6; + function Subclasses_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 7; + procedure SubclassesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 8; + function Associators_(const strAssocClass: WideString; const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 9; + procedure AssociatorsAsync_(const objWbemSink: IDispatch; const strAssocClass: WideString; + const strResultClass: WideString; const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 10; + function References_(const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; dispid 11; + procedure ReferencesAsync_(const objWbemSink: IDispatch; const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredQualifier: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 12; + function ExecMethod_(const strMethodName: WideString; const objWbemInParameters: IDispatch; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObject; dispid 13; + procedure ExecMethodAsync_(const objWbemSink: IDispatch; const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); dispid 14; + function Clone_: ISWbemObject; dispid 15; + function GetObjectText_(iFlags: Integer): WideString; dispid 16; + function SpawnDerivedClass_(iFlags: Integer): ISWbemObject; dispid 17; + function SpawnInstance_(iFlags: Integer): ISWbemObject; dispid 18; + function CompareTo_(const objWbemObject: IDispatch; iFlags: Integer): WordBool; dispid 19; + property Qualifiers_: ISWbemQualifierSet readonly dispid 20; + property Properties_: ISWbemPropertySet readonly dispid 21; + property Methods_: ISWbemMethodSet readonly dispid 22; + property Derivation_: OleVariant readonly dispid 23; + property Path_: ISWbemObjectPath readonly dispid 24; + property Security_: ISWbemSecurity readonly dispid 25; + end; + +// *********************************************************************// +// Interface: ISWbemDateTime +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {5E97458A-CF77-11D3-B38F-00105A1F473A} +// *********************************************************************// + ISWbemDateTime = interface(IDispatch) + ['{5E97458A-CF77-11D3-B38F-00105A1F473A}'] + function Get_Value: WideString; safecall; + procedure Set_Value(const strValue: WideString); safecall; + function Get_Year: Integer; safecall; + procedure Set_Year(iYear: Integer); safecall; + function Get_YearSpecified: WordBool; safecall; + procedure Set_YearSpecified(bYearSpecified: WordBool); safecall; + function Get_Month: Integer; safecall; + procedure Set_Month(iMonth: Integer); safecall; + function Get_MonthSpecified: WordBool; safecall; + procedure Set_MonthSpecified(bMonthSpecified: WordBool); safecall; + function Get_Day: Integer; safecall; + procedure Set_Day(iDay: Integer); safecall; + function Get_DaySpecified: WordBool; safecall; + procedure Set_DaySpecified(bDaySpecified: WordBool); safecall; + function Get_Hours: Integer; safecall; + procedure Set_Hours(iHours: Integer); safecall; + function Get_HoursSpecified: WordBool; safecall; + procedure Set_HoursSpecified(bHoursSpecified: WordBool); safecall; + function Get_Minutes: Integer; safecall; + procedure Set_Minutes(iMinutes: Integer); safecall; + function Get_MinutesSpecified: WordBool; safecall; + procedure Set_MinutesSpecified(bMinutesSpecified: WordBool); safecall; + function Get_Seconds: Integer; safecall; + procedure Set_Seconds(iSeconds: Integer); safecall; + function Get_SecondsSpecified: WordBool; safecall; + procedure Set_SecondsSpecified(bSecondsSpecified: WordBool); safecall; + function Get_Microseconds: Integer; safecall; + procedure Set_Microseconds(iMicroseconds: Integer); safecall; + function Get_MicrosecondsSpecified: WordBool; safecall; + procedure Set_MicrosecondsSpecified(bMicrosecondsSpecified: WordBool); safecall; + function Get_UTC: Integer; safecall; + procedure Set_UTC(iUTC: Integer); safecall; + function Get_UTCSpecified: WordBool; safecall; + procedure Set_UTCSpecified(bUTCSpecified: WordBool); safecall; + function Get_IsInterval: WordBool; safecall; + procedure Set_IsInterval(bIsInterval: WordBool); safecall; + function GetVarDate(bIsLocal: WordBool): TDateTime; safecall; + procedure SetVarDate(dVarDate: TDateTime; bIsLocal: WordBool); safecall; + function GetFileTime(bIsLocal: WordBool): WideString; safecall; + procedure SetFileTime(const strFileTime: WideString; bIsLocal: WordBool); safecall; + property Value: WideString read Get_Value write Set_Value; + property Year: Integer read Get_Year write Set_Year; + property YearSpecified: WordBool read Get_YearSpecified write Set_YearSpecified; + property Month: Integer read Get_Month write Set_Month; + property MonthSpecified: WordBool read Get_MonthSpecified write Set_MonthSpecified; + property Day: Integer read Get_Day write Set_Day; + property DaySpecified: WordBool read Get_DaySpecified write Set_DaySpecified; + property Hours: Integer read Get_Hours write Set_Hours; + property HoursSpecified: WordBool read Get_HoursSpecified write Set_HoursSpecified; + property Minutes: Integer read Get_Minutes write Set_Minutes; + property MinutesSpecified: WordBool read Get_MinutesSpecified write Set_MinutesSpecified; + property Seconds: Integer read Get_Seconds write Set_Seconds; + property SecondsSpecified: WordBool read Get_SecondsSpecified write Set_SecondsSpecified; + property Microseconds: Integer read Get_Microseconds write Set_Microseconds; + property MicrosecondsSpecified: WordBool read Get_MicrosecondsSpecified write Set_MicrosecondsSpecified; + property UTC: Integer read Get_UTC write Set_UTC; + property UTCSpecified: WordBool read Get_UTCSpecified write Set_UTCSpecified; + property IsInterval: WordBool read Get_IsInterval write Set_IsInterval; + end; + +// *********************************************************************// +// DispIntf: ISWbemDateTimeDisp +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {5E97458A-CF77-11D3-B38F-00105A1F473A} +// *********************************************************************// + ISWbemDateTimeDisp = dispinterface + ['{5E97458A-CF77-11D3-B38F-00105A1F473A}'] + property Value: WideString dispid 0; + property Year: Integer dispid 1; + property YearSpecified: WordBool dispid 2; + property Month: Integer dispid 3; + property MonthSpecified: WordBool dispid 4; + property Day: Integer dispid 5; + property DaySpecified: WordBool dispid 6; + property Hours: Integer dispid 7; + property HoursSpecified: WordBool dispid 8; + property Minutes: Integer dispid 9; + property MinutesSpecified: WordBool dispid 10; + property Seconds: Integer dispid 11; + property SecondsSpecified: WordBool dispid 12; + property Microseconds: Integer dispid 13; + property MicrosecondsSpecified: WordBool dispid 14; + property UTC: Integer dispid 15; + property UTCSpecified: WordBool dispid 16; + property IsInterval: WordBool dispid 17; + function GetVarDate(bIsLocal: WordBool): TDateTime; dispid 18; + procedure SetVarDate(dVarDate: TDateTime; bIsLocal: WordBool); dispid 19; + function GetFileTime(bIsLocal: WordBool): WideString; dispid 20; + procedure SetFileTime(const strFileTime: WideString; bIsLocal: WordBool); dispid 21; + end; + +// *********************************************************************// +// Interface: ISWbemRefresher +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {14D8250E-D9C2-11D3-B38F-00105A1F473A} +// *********************************************************************// + ISWbemRefresher = interface(IDispatch) + ['{14D8250E-D9C2-11D3-B38F-00105A1F473A}'] + function Get__NewEnum: IUnknown; safecall; + function Item(iIndex: Integer): ISWbemRefreshableItem; safecall; + function Get_Count: Integer; safecall; + function Add(const objWbemServices: ISWbemServicesEx; const bsInstancePath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemRefreshableItem; safecall; + function AddEnum(const objWbemServices: ISWbemServicesEx; const bsClassName: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemRefreshableItem; safecall; + procedure Remove(iIndex: Integer; iFlags: Integer); safecall; + procedure Refresh(iFlags: Integer); safecall; + function Get_AutoReconnect: WordBool; safecall; + procedure Set_AutoReconnect(bCount: WordBool); safecall; + procedure DeleteAll; safecall; + property _NewEnum: IUnknown read Get__NewEnum; + property Count: Integer read Get_Count; + property AutoReconnect: WordBool read Get_AutoReconnect write Set_AutoReconnect; + end; + +// *********************************************************************// +// DispIntf: ISWbemRefresherDisp +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {14D8250E-D9C2-11D3-B38F-00105A1F473A} +// *********************************************************************// + ISWbemRefresherDisp = dispinterface + ['{14D8250E-D9C2-11D3-B38F-00105A1F473A}'] + property _NewEnum: IUnknown readonly dispid -4; + function Item(iIndex: Integer): ISWbemRefreshableItem; dispid 0; + property Count: Integer readonly dispid 1; + function Add(const objWbemServices: ISWbemServicesEx; const bsInstancePath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemRefreshableItem; dispid 2; + function AddEnum(const objWbemServices: ISWbemServicesEx; const bsClassName: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemRefreshableItem; dispid 3; + procedure Remove(iIndex: Integer; iFlags: Integer); dispid 4; + procedure Refresh(iFlags: Integer); dispid 5; + property AutoReconnect: WordBool dispid 6; + procedure DeleteAll; dispid 7; + end; + +// *********************************************************************// +// Interface: ISWbemRefreshableItem +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {5AD4BF92-DAAB-11D3-B38F-00105A1F473A} +// *********************************************************************// + ISWbemRefreshableItem = interface(IDispatch) + ['{5AD4BF92-DAAB-11D3-B38F-00105A1F473A}'] + function Get_Index: Integer; safecall; + function Get_Refresher: ISWbemRefresher; safecall; + function Get_IsSet: WordBool; safecall; + function Get_Object_: ISWbemObjectEx; safecall; + function Get_ObjectSet: ISWbemObjectSet; safecall; + procedure Remove(iFlags: Integer); safecall; + property Index: Integer read Get_Index; + property Refresher: ISWbemRefresher read Get_Refresher; + property IsSet: WordBool read Get_IsSet; + property Object_: ISWbemObjectEx read Get_Object_; + property ObjectSet: ISWbemObjectSet read Get_ObjectSet; + end; + +// *********************************************************************// +// DispIntf: ISWbemRefreshableItemDisp +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {5AD4BF92-DAAB-11D3-B38F-00105A1F473A} +// *********************************************************************// + ISWbemRefreshableItemDisp = dispinterface + ['{5AD4BF92-DAAB-11D3-B38F-00105A1F473A}'] + property Index: Integer readonly dispid 1; + property Refresher: ISWbemRefresher readonly dispid 2; + property IsSet: WordBool readonly dispid 3; + property Object_: ISWbemObjectEx readonly dispid 4; + property ObjectSet: ISWbemObjectSet readonly dispid 5; + procedure Remove(iFlags: Integer); dispid 6; + end; + +// *********************************************************************// +// The Class CoSWbemLocator provides a Create and CreateRemote method to +// create instances of the default interface ISWbemLocator exposed by +// the CoClass SWbemLocator. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemLocator = class + class function Create: ISWbemLocator; + class function CreateRemote(const MachineName: string): ISWbemLocator; + end; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TSWbemLocator +// Help String : Used to obtain Namespace connections +// Default Interface: ISWbemLocator +// Def. Intf. DISP? : No +// Event Interface: +// TypeFlags : (2) CanCreate +// *********************************************************************// +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + TSWbemLocatorProperties= class; +{$ENDIF} + TSWbemLocator = class(TOleServer) + private + FIntf: ISWbemLocator; +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps: TSWbemLocatorProperties; + function GetServerProperties: TSWbemLocatorProperties; +{$ENDIF} + function GetDefaultInterface: ISWbemLocator; + protected + procedure InitServerData; override; + function Get_Security_: ISWbemSecurity; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: ISWbemLocator); + procedure Disconnect; override; + function ConnectServer(const strServer: WideString; const strNamespace: WideString; + const strUser: WideString; const strPassword: WideString; + const strLocale: WideString; const strAuthority: WideString; + iSecurityFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemServices; + property DefaultInterface: ISWbemLocator read GetDefaultInterface; + property Security_: ISWbemSecurity read Get_Security_; + published +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + property Server: TSWbemLocatorProperties read GetServerProperties; +{$ENDIF} + end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +// *********************************************************************// +// OLE Server Properties Proxy Class +// Server Object : TSWbemLocator +// (This object is used by the IDE's Property Inspector to allow editing +// of the properties of this server) +// *********************************************************************// + TSWbemLocatorProperties = class(TPersistent) + private + FServer: TSWbemLocator; + function GetDefaultInterface: ISWbemLocator; + constructor Create(AServer: TSWbemLocator); + protected + function Get_Security_: ISWbemSecurity; + public + property DefaultInterface: ISWbemLocator read GetDefaultInterface; + published + end; +{$ENDIF} + + +// *********************************************************************// +// The Class CoSWbemNamedValueSet provides a Create and CreateRemote method to +// create instances of the default interface ISWbemNamedValueSet exposed by +// the CoClass SWbemNamedValueSet. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemNamedValueSet = class + class function Create: ISWbemNamedValueSet; + class function CreateRemote(const MachineName: string): ISWbemNamedValueSet; + end; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TSWbemNamedValueSet +// Help String : A collection of Named Values +// Default Interface: ISWbemNamedValueSet +// Def. Intf. DISP? : No +// Event Interface: +// TypeFlags : (2) CanCreate +// *********************************************************************// +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + TSWbemNamedValueSetProperties= class; +{$ENDIF} + TSWbemNamedValueSet = class(TOleServer) + private + FIntf: ISWbemNamedValueSet; +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps: TSWbemNamedValueSetProperties; + function GetServerProperties: TSWbemNamedValueSetProperties; +{$ENDIF} + function GetDefaultInterface: ISWbemNamedValueSet; + protected + procedure InitServerData; override; + function Get_Count: Integer; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: ISWbemNamedValueSet); + procedure Disconnect; override; + function Item(const strName: WideString; iFlags: Integer): ISWbemNamedValue; + function Add(const strName: WideString; var varValue: OleVariant; iFlags: Integer): ISWbemNamedValue; + procedure Remove(const strName: WideString; iFlags: Integer); + function Clone: ISWbemNamedValueSet; + procedure DeleteAll; + property DefaultInterface: ISWbemNamedValueSet read GetDefaultInterface; + property Count: Integer read Get_Count; + published +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + property Server: TSWbemNamedValueSetProperties read GetServerProperties; +{$ENDIF} + end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +// *********************************************************************// +// OLE Server Properties Proxy Class +// Server Object : TSWbemNamedValueSet +// (This object is used by the IDE's Property Inspector to allow editing +// of the properties of this server) +// *********************************************************************// + TSWbemNamedValueSetProperties = class(TPersistent) + private + FServer: TSWbemNamedValueSet; + function GetDefaultInterface: ISWbemNamedValueSet; + constructor Create(AServer: TSWbemNamedValueSet); + protected + function Get_Count: Integer; + public + property DefaultInterface: ISWbemNamedValueSet read GetDefaultInterface; + published + end; +{$ENDIF} + + +// *********************************************************************// +// The Class CoSWbemObjectPath provides a Create and CreateRemote method to +// create instances of the default interface ISWbemObjectPath exposed by +// the CoClass SWbemObjectPath. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemObjectPath = class + class function Create: ISWbemObjectPath; + class function CreateRemote(const MachineName: string): ISWbemObjectPath; + end; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TSWbemObjectPath +// Help String : Object Path +// Default Interface: ISWbemObjectPath +// Def. Intf. DISP? : No +// Event Interface: +// TypeFlags : (2) CanCreate +// *********************************************************************// +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + TSWbemObjectPathProperties= class; +{$ENDIF} + TSWbemObjectPath = class(TOleServer) + private + FIntf: ISWbemObjectPath; +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps: TSWbemObjectPathProperties; + function GetServerProperties: TSWbemObjectPathProperties; +{$ENDIF} + function GetDefaultInterface: ISWbemObjectPath; + protected + procedure InitServerData; override; + function Get_Path: WideString; + procedure Set_Path(const strPath: WideString); + function Get_RelPath: WideString; + procedure Set_RelPath(const strRelPath: WideString); + function Get_Server: WideString; + procedure Set_Server(const strServer: WideString); + function Get_Namespace: WideString; + procedure Set_Namespace(const strNamespace: WideString); + function Get_ParentNamespace: WideString; + function Get_DisplayName: WideString; + procedure Set_DisplayName(const strDisplayName: WideString); + function Get_Class_: WideString; + procedure Set_Class_(const strClass: WideString); + function Get_IsClass: WordBool; + function Get_IsSingleton: WordBool; + function Get_Keys: ISWbemNamedValueSet; + function Get_Security_: ISWbemSecurity; + function Get_Locale: WideString; + procedure Set_Locale(const strLocale: WideString); + function Get_Authority: WideString; + procedure Set_Authority(const strAuthority: WideString); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: ISWbemObjectPath); + procedure Disconnect; override; + procedure SetAsClass; + procedure SetAsSingleton; + property DefaultInterface: ISWbemObjectPath read GetDefaultInterface; + property ParentNamespace: WideString read Get_ParentNamespace; + property IsClass: WordBool read Get_IsClass; + property IsSingleton: WordBool read Get_IsSingleton; + property Keys: ISWbemNamedValueSet read Get_Keys; + property Security_: ISWbemSecurity read Get_Security_; + property Path: WideString read Get_Path write Set_Path; + property RelPath: WideString read Get_RelPath write Set_RelPath; + property Server: WideString read Get_Server write Set_Server; + property Namespace: WideString read Get_Namespace write Set_Namespace; + property DisplayName: WideString read Get_DisplayName write Set_DisplayName; + property Class_: WideString read Get_Class_ write Set_Class_; + property Locale: WideString read Get_Locale write Set_Locale; + property Authority: WideString read Get_Authority write Set_Authority; + published +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + property Server: TSWbemObjectPathProperties read GetServerProperties; +{$ENDIF} + end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +// *********************************************************************// +// OLE Server Properties Proxy Class +// Server Object : TSWbemObjectPath +// (This object is used by the IDE's Property Inspector to allow editing +// of the properties of this server) +// *********************************************************************// + TSWbemObjectPathProperties = class(TPersistent) + private + FServer: TSWbemObjectPath; + function GetDefaultInterface: ISWbemObjectPath; + constructor Create(AServer: TSWbemObjectPath); + protected + function Get_Path: WideString; + procedure Set_Path(const strPath: WideString); + function Get_RelPath: WideString; + procedure Set_RelPath(const strRelPath: WideString); + function Get_Server: WideString; + procedure Set_Server(const strServer: WideString); + function Get_Namespace: WideString; + procedure Set_Namespace(const strNamespace: WideString); + function Get_ParentNamespace: WideString; + function Get_DisplayName: WideString; + procedure Set_DisplayName(const strDisplayName: WideString); + function Get_Class_: WideString; + procedure Set_Class_(const strClass: WideString); + function Get_IsClass: WordBool; + function Get_IsSingleton: WordBool; + function Get_Keys: ISWbemNamedValueSet; + function Get_Security_: ISWbemSecurity; + function Get_Locale: WideString; + procedure Set_Locale(const strLocale: WideString); + function Get_Authority: WideString; + procedure Set_Authority(const strAuthority: WideString); + public + property DefaultInterface: ISWbemObjectPath read GetDefaultInterface; + published + property Path: WideString read Get_Path write Set_Path; + property RelPath: WideString read Get_RelPath write Set_RelPath; + property Server: WideString read Get_Server write Set_Server; + property Namespace: WideString read Get_Namespace write Set_Namespace; + property DisplayName: WideString read Get_DisplayName write Set_DisplayName; + property Class_: WideString read Get_Class_ write Set_Class_; + property Locale: WideString read Get_Locale write Set_Locale; + property Authority: WideString read Get_Authority write Set_Authority; + end; +{$ENDIF} + + +// *********************************************************************// +// The Class CoSWbemLastError provides a Create and CreateRemote method to +// create instances of the default interface ISWbemLastError exposed by +// the CoClass SWbemLastError. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemLastError = class + class function Create: ISWbemLastError; + class function CreateRemote(const MachineName: string): ISWbemLastError; + end; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TSWbemLastError +// Help String : The last error on the current thread +// Default Interface: ISWbemLastError +// Def. Intf. DISP? : No +// Event Interface: +// TypeFlags : (2) CanCreate +// *********************************************************************// +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + TSWbemLastErrorProperties= class; +{$ENDIF} + TSWbemLastError = class(TOleServer) + private + FIntf: ISWbemLastError; +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps: TSWbemLastErrorProperties; + function GetServerProperties: TSWbemLastErrorProperties; +{$ENDIF} + function GetDefaultInterface: ISWbemLastError; + protected + procedure InitServerData; override; + function Get_Qualifiers_: ISWbemQualifierSet; + function Get_Properties_: ISWbemPropertySet; + function Get_Methods_: ISWbemMethodSet; + function Get_Derivation_: OleVariant; + function Get_Path_: ISWbemObjectPath; + function Get_Security_: ISWbemSecurity; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: ISWbemLastError); + procedure Disconnect; override; + function Put_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectPath; + procedure PutAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; const objWbemAsyncContext: IDispatch); + procedure Delete_(iFlags: Integer; const objWbemNamedValueSet: IDispatch); + procedure DeleteAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); + function Instances_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; + procedure InstancesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); + function Subclasses_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; + procedure SubclassesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); + function Associators_(const strAssocClass: WideString; const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; + procedure AssociatorsAsync_(const objWbemSink: IDispatch; const strAssocClass: WideString; + const strResultClass: WideString; const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); + function References_(const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; + procedure ReferencesAsync_(const objWbemSink: IDispatch; const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; const strRequiredQualifier: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); + function ExecMethod_(const strMethodName: WideString; const objWbemInParameters: IDispatch; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObject; + procedure ExecMethodAsync_(const objWbemSink: IDispatch; const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); + function Clone_: ISWbemObject; + function GetObjectText_(iFlags: Integer): WideString; + function SpawnDerivedClass_(iFlags: Integer): ISWbemObject; + function SpawnInstance_(iFlags: Integer): ISWbemObject; + function CompareTo_(const objWbemObject: IDispatch; iFlags: Integer): WordBool; + property DefaultInterface: ISWbemLastError read GetDefaultInterface; + property Qualifiers_: ISWbemQualifierSet read Get_Qualifiers_; + property Properties_: ISWbemPropertySet read Get_Properties_; + property Methods_: ISWbemMethodSet read Get_Methods_; + property Derivation_: OleVariant read Get_Derivation_; + property Path_: ISWbemObjectPath read Get_Path_; + property Security_: ISWbemSecurity read Get_Security_; + published +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + property Server: TSWbemLastErrorProperties read GetServerProperties; +{$ENDIF} + end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +// *********************************************************************// +// OLE Server Properties Proxy Class +// Server Object : TSWbemLastError +// (This object is used by the IDE's Property Inspector to allow editing +// of the properties of this server) +// *********************************************************************// + TSWbemLastErrorProperties = class(TPersistent) + private + FServer: TSWbemLastError; + function GetDefaultInterface: ISWbemLastError; + constructor Create(AServer: TSWbemLastError); + protected + function Get_Qualifiers_: ISWbemQualifierSet; + function Get_Properties_: ISWbemPropertySet; + function Get_Methods_: ISWbemMethodSet; + function Get_Derivation_: OleVariant; + function Get_Path_: ISWbemObjectPath; + function Get_Security_: ISWbemSecurity; + public + property DefaultInterface: ISWbemLastError read GetDefaultInterface; + published + end; +{$ENDIF} + + +// *********************************************************************// +// The Class CoSWbemSink provides a Create and CreateRemote method to +// create instances of the default interface ISWbemSink exposed by +// the CoClass SWbemSink. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemSink = class + class function Create: ISWbemSink; + class function CreateRemote(const MachineName: string): ISWbemSink; + end; + + TSWbemSinkOnObjectReady = procedure(ASender: TObject; const objWbemObject: ISWbemObject; + const objWbemAsyncContext: ISWbemNamedValueSet) of object; + TSWbemSinkOnCompleted = procedure(ASender: TObject; iHResult: WbemErrorEnum; + const objWbemErrorObject: ISWbemObject; + const objWbemAsyncContext: ISWbemNamedValueSet) of object; + TSWbemSinkOnProgress = procedure(ASender: TObject; iUpperBound: Integer; iCurrent: Integer; + const strMessage: WideString; + const objWbemAsyncContext: ISWbemNamedValueSet) of object; + TSWbemSinkOnObjectPut = procedure(ASender: TObject; const objWbemObjectPath: ISWbemObjectPath; + const objWbemAsyncContext: ISWbemNamedValueSet) of object; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TSWbemSink +// Help String : A sink for events arising from asynchronous operations +// Default Interface: ISWbemSink +// Def. Intf. DISP? : No +// Event Interface: ISWbemSinkEvents +// TypeFlags : (2) CanCreate +// *********************************************************************// +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + TSWbemSinkProperties= class; +{$ENDIF} + TSWbemSink = class(TOleServer) + private + FOnObjectReady: TSWbemSinkOnObjectReady; + FOnCompleted: TSWbemSinkOnCompleted; + FOnProgress: TSWbemSinkOnProgress; + FOnObjectPut: TSWbemSinkOnObjectPut; + FIntf: ISWbemSink; +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps: TSWbemSinkProperties; + function GetServerProperties: TSWbemSinkProperties; +{$ENDIF} + function GetDefaultInterface: ISWbemSink; + protected + procedure InitServerData; override; + procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: ISWbemSink); + procedure Disconnect; override; + procedure Cancel; + property DefaultInterface: ISWbemSink read GetDefaultInterface; + published +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + property Server: TSWbemSinkProperties read GetServerProperties; +{$ENDIF} + property OnObjectReady: TSWbemSinkOnObjectReady read FOnObjectReady write FOnObjectReady; + property OnCompleted: TSWbemSinkOnCompleted read FOnCompleted write FOnCompleted; + property OnProgress: TSWbemSinkOnProgress read FOnProgress write FOnProgress; + property OnObjectPut: TSWbemSinkOnObjectPut read FOnObjectPut write FOnObjectPut; + end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +// *********************************************************************// +// OLE Server Properties Proxy Class +// Server Object : TSWbemSink +// (This object is used by the IDE's Property Inspector to allow editing +// of the properties of this server) +// *********************************************************************// + TSWbemSinkProperties = class(TPersistent) + private + FServer: TSWbemSink; + function GetDefaultInterface: ISWbemSink; + constructor Create(AServer: TSWbemSink); + protected + public + property DefaultInterface: ISWbemSink read GetDefaultInterface; + published + end; +{$ENDIF} + + +// *********************************************************************// +// The Class CoSWbemDateTime provides a Create and CreateRemote method to +// create instances of the default interface ISWbemDateTime exposed by +// the CoClass SWbemDateTime. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemDateTime = class + class function Create: ISWbemDateTime; + class function CreateRemote(const MachineName: string): ISWbemDateTime; + end; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TSWbemDateTime +// Help String : Date & Time +// Default Interface: ISWbemDateTime +// Def. Intf. DISP? : No +// Event Interface: +// TypeFlags : (2) CanCreate +// *********************************************************************// +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + TSWbemDateTimeProperties= class; +{$ENDIF} + TSWbemDateTime = class(TOleServer) + private + FIntf: ISWbemDateTime; +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps: TSWbemDateTimeProperties; + function GetServerProperties: TSWbemDateTimeProperties; +{$ENDIF} + function GetDefaultInterface: ISWbemDateTime; + protected + procedure InitServerData; override; + function Get_Value: WideString; + procedure Set_Value(const strValue: WideString); + function Get_Year: Integer; + procedure Set_Year(iYear: Integer); + function Get_YearSpecified: WordBool; + procedure Set_YearSpecified(bYearSpecified: WordBool); + function Get_Month: Integer; + procedure Set_Month(iMonth: Integer); + function Get_MonthSpecified: WordBool; + procedure Set_MonthSpecified(bMonthSpecified: WordBool); + function Get_Day: Integer; + procedure Set_Day(iDay: Integer); + function Get_DaySpecified: WordBool; + procedure Set_DaySpecified(bDaySpecified: WordBool); + function Get_Hours: Integer; + procedure Set_Hours(iHours: Integer); + function Get_HoursSpecified: WordBool; + procedure Set_HoursSpecified(bHoursSpecified: WordBool); + function Get_Minutes: Integer; + procedure Set_Minutes(iMinutes: Integer); + function Get_MinutesSpecified: WordBool; + procedure Set_MinutesSpecified(bMinutesSpecified: WordBool); + function Get_Seconds: Integer; + procedure Set_Seconds(iSeconds: Integer); + function Get_SecondsSpecified: WordBool; + procedure Set_SecondsSpecified(bSecondsSpecified: WordBool); + function Get_Microseconds: Integer; + procedure Set_Microseconds(iMicroseconds: Integer); + function Get_MicrosecondsSpecified: WordBool; + procedure Set_MicrosecondsSpecified(bMicrosecondsSpecified: WordBool); + function Get_UTC: Integer; + procedure Set_UTC(iUTC: Integer); + function Get_UTCSpecified: WordBool; + procedure Set_UTCSpecified(bUTCSpecified: WordBool); + function Get_IsInterval: WordBool; + procedure Set_IsInterval(bIsInterval: WordBool); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: ISWbemDateTime); + procedure Disconnect; override; + function GetVarDate(bIsLocal: WordBool): TDateTime; + procedure SetVarDate(dVarDate: TDateTime; bIsLocal: WordBool); + function GetFileTime(bIsLocal: WordBool): WideString; + procedure SetFileTime(const strFileTime: WideString; bIsLocal: WordBool); + property DefaultInterface: ISWbemDateTime read GetDefaultInterface; + property Value: WideString read Get_Value write Set_Value; + property Year: Integer read Get_Year write Set_Year; + property YearSpecified: WordBool read Get_YearSpecified write Set_YearSpecified; + property Month: Integer read Get_Month write Set_Month; + property MonthSpecified: WordBool read Get_MonthSpecified write Set_MonthSpecified; + property Day: Integer read Get_Day write Set_Day; + property DaySpecified: WordBool read Get_DaySpecified write Set_DaySpecified; + property Hours: Integer read Get_Hours write Set_Hours; + property HoursSpecified: WordBool read Get_HoursSpecified write Set_HoursSpecified; + property Minutes: Integer read Get_Minutes write Set_Minutes; + property MinutesSpecified: WordBool read Get_MinutesSpecified write Set_MinutesSpecified; + property Seconds: Integer read Get_Seconds write Set_Seconds; + property SecondsSpecified: WordBool read Get_SecondsSpecified write Set_SecondsSpecified; + property Microseconds: Integer read Get_Microseconds write Set_Microseconds; + property MicrosecondsSpecified: WordBool read Get_MicrosecondsSpecified write Set_MicrosecondsSpecified; + property UTC: Integer read Get_UTC write Set_UTC; + property UTCSpecified: WordBool read Get_UTCSpecified write Set_UTCSpecified; + property IsInterval: WordBool read Get_IsInterval write Set_IsInterval; + published +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + property Server: TSWbemDateTimeProperties read GetServerProperties; +{$ENDIF} + end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +// *********************************************************************// +// OLE Server Properties Proxy Class +// Server Object : TSWbemDateTime +// (This object is used by the IDE's Property Inspector to allow editing +// of the properties of this server) +// *********************************************************************// + TSWbemDateTimeProperties = class(TPersistent) + private + FServer: TSWbemDateTime; + function GetDefaultInterface: ISWbemDateTime; + constructor Create(AServer: TSWbemDateTime); + protected + function Get_Value: WideString; + procedure Set_Value(const strValue: WideString); + function Get_Year: Integer; + procedure Set_Year(iYear: Integer); + function Get_YearSpecified: WordBool; + procedure Set_YearSpecified(bYearSpecified: WordBool); + function Get_Month: Integer; + procedure Set_Month(iMonth: Integer); + function Get_MonthSpecified: WordBool; + procedure Set_MonthSpecified(bMonthSpecified: WordBool); + function Get_Day: Integer; + procedure Set_Day(iDay: Integer); + function Get_DaySpecified: WordBool; + procedure Set_DaySpecified(bDaySpecified: WordBool); + function Get_Hours: Integer; + procedure Set_Hours(iHours: Integer); + function Get_HoursSpecified: WordBool; + procedure Set_HoursSpecified(bHoursSpecified: WordBool); + function Get_Minutes: Integer; + procedure Set_Minutes(iMinutes: Integer); + function Get_MinutesSpecified: WordBool; + procedure Set_MinutesSpecified(bMinutesSpecified: WordBool); + function Get_Seconds: Integer; + procedure Set_Seconds(iSeconds: Integer); + function Get_SecondsSpecified: WordBool; + procedure Set_SecondsSpecified(bSecondsSpecified: WordBool); + function Get_Microseconds: Integer; + procedure Set_Microseconds(iMicroseconds: Integer); + function Get_MicrosecondsSpecified: WordBool; + procedure Set_MicrosecondsSpecified(bMicrosecondsSpecified: WordBool); + function Get_UTC: Integer; + procedure Set_UTC(iUTC: Integer); + function Get_UTCSpecified: WordBool; + procedure Set_UTCSpecified(bUTCSpecified: WordBool); + function Get_IsInterval: WordBool; + procedure Set_IsInterval(bIsInterval: WordBool); + public + property DefaultInterface: ISWbemDateTime read GetDefaultInterface; + published + property Value: WideString read Get_Value write Set_Value; + property Year: Integer read Get_Year write Set_Year; + property YearSpecified: WordBool read Get_YearSpecified write Set_YearSpecified; + property Month: Integer read Get_Month write Set_Month; + property MonthSpecified: WordBool read Get_MonthSpecified write Set_MonthSpecified; + property Day: Integer read Get_Day write Set_Day; + property DaySpecified: WordBool read Get_DaySpecified write Set_DaySpecified; + property Hours: Integer read Get_Hours write Set_Hours; + property HoursSpecified: WordBool read Get_HoursSpecified write Set_HoursSpecified; + property Minutes: Integer read Get_Minutes write Set_Minutes; + property MinutesSpecified: WordBool read Get_MinutesSpecified write Set_MinutesSpecified; + property Seconds: Integer read Get_Seconds write Set_Seconds; + property SecondsSpecified: WordBool read Get_SecondsSpecified write Set_SecondsSpecified; + property Microseconds: Integer read Get_Microseconds write Set_Microseconds; + property MicrosecondsSpecified: WordBool read Get_MicrosecondsSpecified write Set_MicrosecondsSpecified; + property UTC: Integer read Get_UTC write Set_UTC; + property UTCSpecified: WordBool read Get_UTCSpecified write Set_UTCSpecified; + property IsInterval: WordBool read Get_IsInterval write Set_IsInterval; + end; +{$ENDIF} + + +// *********************************************************************// +// The Class CoSWbemRefresher provides a Create and CreateRemote method to +// create instances of the default interface ISWbemRefresher exposed by +// the CoClass SWbemRefresher. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemRefresher = class + class function Create: ISWbemRefresher; + class function CreateRemote(const MachineName: string): ISWbemRefresher; + end; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TSWbemRefresher +// Help String : Refresher +// Default Interface: ISWbemRefresher +// Def. Intf. DISP? : No +// Event Interface: +// TypeFlags : (2) CanCreate +// *********************************************************************// +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + TSWbemRefresherProperties= class; +{$ENDIF} + TSWbemRefresher = class(TOleServer) + private + FIntf: ISWbemRefresher; +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps: TSWbemRefresherProperties; + function GetServerProperties: TSWbemRefresherProperties; +{$ENDIF} + function GetDefaultInterface: ISWbemRefresher; + protected + procedure InitServerData; override; + function Get_Count: Integer; + function Get_AutoReconnect: WordBool; + procedure Set_AutoReconnect(bCount: WordBool); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: ISWbemRefresher); + procedure Disconnect; override; + function Item(iIndex: Integer): ISWbemRefreshableItem; + function Add(const objWbemServices: ISWbemServicesEx; const bsInstancePath: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemRefreshableItem; + function AddEnum(const objWbemServices: ISWbemServicesEx; const bsClassName: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemRefreshableItem; + procedure Remove(iIndex: Integer; iFlags: Integer); + procedure Refresh(iFlags: Integer); + procedure DeleteAll; + property DefaultInterface: ISWbemRefresher read GetDefaultInterface; + property Count: Integer read Get_Count; + property AutoReconnect: WordBool read Get_AutoReconnect write Set_AutoReconnect; + published +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + property Server: TSWbemRefresherProperties read GetServerProperties; +{$ENDIF} + end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +// *********************************************************************// +// OLE Server Properties Proxy Class +// Server Object : TSWbemRefresher +// (This object is used by the IDE's Property Inspector to allow editing +// of the properties of this server) +// *********************************************************************// + TSWbemRefresherProperties = class(TPersistent) + private + FServer: TSWbemRefresher; + function GetDefaultInterface: ISWbemRefresher; + constructor Create(AServer: TSWbemRefresher); + protected + function Get_Count: Integer; + function Get_AutoReconnect: WordBool; + procedure Set_AutoReconnect(bCount: WordBool); + public + property DefaultInterface: ISWbemRefresher read GetDefaultInterface; + published + property AutoReconnect: WordBool read Get_AutoReconnect write Set_AutoReconnect; + end; +{$ENDIF} + + +// *********************************************************************// +// The Class CoSWbemServices provides a Create and CreateRemote method to +// create instances of the default interface ISWbemServices exposed by +// the CoClass SWbemServices. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemServices = class + class function Create: ISWbemServices; + class function CreateRemote(const MachineName: string): ISWbemServices; + end; + +// *********************************************************************// +// The Class CoSWbemServicesEx provides a Create and CreateRemote method to +// create instances of the default interface ISWbemServicesEx exposed by +// the CoClass SWbemServicesEx. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemServicesEx = class + class function Create: ISWbemServicesEx; + class function CreateRemote(const MachineName: string): ISWbemServicesEx; + end; + +// *********************************************************************// +// The Class CoSWbemObject provides a Create and CreateRemote method to +// create instances of the default interface ISWbemObject exposed by +// the CoClass SWbemObject. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemObject = class + class function Create: ISWbemObject; + class function CreateRemote(const MachineName: string): ISWbemObject; + end; + +// *********************************************************************// +// The Class CoSWbemObjectEx provides a Create and CreateRemote method to +// create instances of the default interface ISWbemObjectEx exposed by +// the CoClass SWbemObjectEx. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemObjectEx = class + class function Create: ISWbemObjectEx; + class function CreateRemote(const MachineName: string): ISWbemObjectEx; + end; + +// *********************************************************************// +// The Class CoSWbemObjectSet provides a Create and CreateRemote method to +// create instances of the default interface ISWbemObjectSet exposed by +// the CoClass SWbemObjectSet. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemObjectSet = class + class function Create: ISWbemObjectSet; + class function CreateRemote(const MachineName: string): ISWbemObjectSet; + end; + +// *********************************************************************// +// The Class CoSWbemNamedValue provides a Create and CreateRemote method to +// create instances of the default interface ISWbemNamedValue exposed by +// the CoClass SWbemNamedValue. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemNamedValue = class + class function Create: ISWbemNamedValue; + class function CreateRemote(const MachineName: string): ISWbemNamedValue; + end; + +// *********************************************************************// +// The Class CoSWbemQualifier provides a Create and CreateRemote method to +// create instances of the default interface ISWbemQualifier exposed by +// the CoClass SWbemQualifier. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemQualifier = class + class function Create: ISWbemQualifier; + class function CreateRemote(const MachineName: string): ISWbemQualifier; + end; + +// *********************************************************************// +// The Class CoSWbemQualifierSet provides a Create and CreateRemote method to +// create instances of the default interface ISWbemQualifierSet exposed by +// the CoClass SWbemQualifierSet. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemQualifierSet = class + class function Create: ISWbemQualifierSet; + class function CreateRemote(const MachineName: string): ISWbemQualifierSet; + end; + +// *********************************************************************// +// The Class CoSWbemProperty provides a Create and CreateRemote method to +// create instances of the default interface ISWbemProperty exposed by +// the CoClass SWbemProperty. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemProperty = class + class function Create: ISWbemProperty; + class function CreateRemote(const MachineName: string): ISWbemProperty; + end; + +// *********************************************************************// +// The Class CoSWbemPropertySet provides a Create and CreateRemote method to +// create instances of the default interface ISWbemPropertySet exposed by +// the CoClass SWbemPropertySet. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemPropertySet = class + class function Create: ISWbemPropertySet; + class function CreateRemote(const MachineName: string): ISWbemPropertySet; + end; + +// *********************************************************************// +// The Class CoSWbemMethod provides a Create and CreateRemote method to +// create instances of the default interface ISWbemMethod exposed by +// the CoClass SWbemMethod. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemMethod = class + class function Create: ISWbemMethod; + class function CreateRemote(const MachineName: string): ISWbemMethod; + end; + +// *********************************************************************// +// The Class CoSWbemMethodSet provides a Create and CreateRemote method to +// create instances of the default interface ISWbemMethodSet exposed by +// the CoClass SWbemMethodSet. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemMethodSet = class + class function Create: ISWbemMethodSet; + class function CreateRemote(const MachineName: string): ISWbemMethodSet; + end; + +// *********************************************************************// +// The Class CoSWbemEventSource provides a Create and CreateRemote method to +// create instances of the default interface ISWbemEventSource exposed by +// the CoClass SWbemEventSource. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemEventSource = class + class function Create: ISWbemEventSource; + class function CreateRemote(const MachineName: string): ISWbemEventSource; + end; + +// *********************************************************************// +// The Class CoSWbemSecurity provides a Create and CreateRemote method to +// create instances of the default interface ISWbemSecurity exposed by +// the CoClass SWbemSecurity. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemSecurity = class + class function Create: ISWbemSecurity; + class function CreateRemote(const MachineName: string): ISWbemSecurity; + end; + +// *********************************************************************// +// The Class CoSWbemPrivilege provides a Create and CreateRemote method to +// create instances of the default interface ISWbemPrivilege exposed by +// the CoClass SWbemPrivilege. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemPrivilege = class + class function Create: ISWbemPrivilege; + class function CreateRemote(const MachineName: string): ISWbemPrivilege; + end; + +// *********************************************************************// +// The Class CoSWbemPrivilegeSet provides a Create and CreateRemote method to +// create instances of the default interface ISWbemPrivilegeSet exposed by +// the CoClass SWbemPrivilegeSet. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemPrivilegeSet = class + class function Create: ISWbemPrivilegeSet; + class function CreateRemote(const MachineName: string): ISWbemPrivilegeSet; + end; + +// *********************************************************************// +// The Class CoSWbemRefreshableItem provides a Create and CreateRemote method to +// create instances of the default interface ISWbemRefreshableItem exposed by +// the CoClass SWbemRefreshableItem. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoSWbemRefreshableItem = class + class function Create: ISWbemRefreshableItem; + class function CreateRemote(const MachineName: string): ISWbemRefreshableItem; + end; + +procedure Register; + +resourcestring + dtlServerPage = '(none)'; + + dtlOcxPage = '(none)'; + +implementation + +uses ComObj; + +class function CoSWbemLocator.Create: ISWbemLocator; +begin + Result := CreateComObject(CLASS_SWbemLocator) as ISWbemLocator; +end; + +class function CoSWbemLocator.CreateRemote(const MachineName: string): ISWbemLocator; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemLocator) as ISWbemLocator; +end; + +procedure TSWbemLocator.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{76A64158-CB41-11D1-8B02-00600806D9B6}'; + IntfIID: '{76A6415B-CB41-11D1-8B02-00600806D9B6}'; + EventIID: ''; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TSWbemLocator.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + Fintf:= punk as ISWbemLocator; + end; +end; + +procedure TSWbemLocator.ConnectTo(svrIntf: ISWbemLocator); +begin + Disconnect; + FIntf := svrIntf; +end; + +procedure TSWbemLocator.DisConnect; +begin + if Fintf <> nil then + begin + FIntf := nil; + end; +end; + +function TSWbemLocator.GetDefaultInterface: ISWbemLocator; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); + Result := FIntf; +end; + +constructor TSWbemLocator.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps := TSWbemLocatorProperties.Create(Self); +{$ENDIF} +end; + +destructor TSWbemLocator.Destroy; +begin +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps.Free; +{$ENDIF} + inherited Destroy; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +function TSWbemLocator.GetServerProperties: TSWbemLocatorProperties; +begin + Result := FProps; +end; +{$ENDIF} + +function TSWbemLocator.Get_Security_: ISWbemSecurity; +begin + Result := DefaultInterface.Security_; +end; + +function TSWbemLocator.ConnectServer(const strServer: WideString; const strNamespace: WideString; + const strUser: WideString; const strPassword: WideString; + const strLocale: WideString; const strAuthority: WideString; + iSecurityFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemServices; +begin + Result := DefaultInterface.ConnectServer(strServer, strNamespace, strUser, strPassword, + strLocale, strAuthority, iSecurityFlags, + objWbemNamedValueSet); +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +constructor TSWbemLocatorProperties.Create(AServer: TSWbemLocator); +begin + inherited Create; + FServer := AServer; +end; + +function TSWbemLocatorProperties.GetDefaultInterface: ISWbemLocator; +begin + Result := FServer.DefaultInterface; +end; + +function TSWbemLocatorProperties.Get_Security_: ISWbemSecurity; +begin + Result := DefaultInterface.Security_; +end; + +{$ENDIF} + +class function CoSWbemNamedValueSet.Create: ISWbemNamedValueSet; +begin + Result := CreateComObject(CLASS_SWbemNamedValueSet) as ISWbemNamedValueSet; +end; + +class function CoSWbemNamedValueSet.CreateRemote(const MachineName: string): ISWbemNamedValueSet; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemNamedValueSet) as ISWbemNamedValueSet; +end; + +procedure TSWbemNamedValueSet.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{9AED384E-CE8B-11D1-8B05-00600806D9B6}'; + IntfIID: '{CF2376EA-CE8C-11D1-8B05-00600806D9B6}'; + EventIID: ''; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TSWbemNamedValueSet.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + Fintf:= punk as ISWbemNamedValueSet; + end; +end; + +procedure TSWbemNamedValueSet.ConnectTo(svrIntf: ISWbemNamedValueSet); +begin + Disconnect; + FIntf := svrIntf; +end; + +procedure TSWbemNamedValueSet.DisConnect; +begin + if Fintf <> nil then + begin + FIntf := nil; + end; +end; + +function TSWbemNamedValueSet.GetDefaultInterface: ISWbemNamedValueSet; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); + Result := FIntf; +end; + +constructor TSWbemNamedValueSet.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps := TSWbemNamedValueSetProperties.Create(Self); +{$ENDIF} +end; + +destructor TSWbemNamedValueSet.Destroy; +begin +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps.Free; +{$ENDIF} + inherited Destroy; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +function TSWbemNamedValueSet.GetServerProperties: TSWbemNamedValueSetProperties; +begin + Result := FProps; +end; +{$ENDIF} + +function TSWbemNamedValueSet.Get_Count: Integer; +begin + Result := DefaultInterface.Count; +end; + +function TSWbemNamedValueSet.Item(const strName: WideString; iFlags: Integer): ISWbemNamedValue; +begin + Result := DefaultInterface.Item(strName, iFlags); +end; + +function TSWbemNamedValueSet.Add(const strName: WideString; var varValue: OleVariant; + iFlags: Integer): ISWbemNamedValue; +begin + Result := DefaultInterface.Add(strName, varValue, iFlags); +end; + +procedure TSWbemNamedValueSet.Remove(const strName: WideString; iFlags: Integer); +begin + DefaultInterface.Remove(strName, iFlags); +end; + +function TSWbemNamedValueSet.Clone: ISWbemNamedValueSet; +begin + Result := DefaultInterface.Clone; +end; + +procedure TSWbemNamedValueSet.DeleteAll; +begin + DefaultInterface.DeleteAll; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +constructor TSWbemNamedValueSetProperties.Create(AServer: TSWbemNamedValueSet); +begin + inherited Create; + FServer := AServer; +end; + +function TSWbemNamedValueSetProperties.GetDefaultInterface: ISWbemNamedValueSet; +begin + Result := FServer.DefaultInterface; +end; + +function TSWbemNamedValueSetProperties.Get_Count: Integer; +begin + Result := DefaultInterface.Count; +end; + +{$ENDIF} + +class function CoSWbemObjectPath.Create: ISWbemObjectPath; +begin + Result := CreateComObject(CLASS_SWbemObjectPath) as ISWbemObjectPath; +end; + +class function CoSWbemObjectPath.CreateRemote(const MachineName: string): ISWbemObjectPath; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemObjectPath) as ISWbemObjectPath; +end; + +procedure TSWbemObjectPath.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{5791BC26-CE9C-11D1-97BF-0000F81E849C}'; + IntfIID: '{5791BC27-CE9C-11D1-97BF-0000F81E849C}'; + EventIID: ''; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TSWbemObjectPath.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + Fintf:= punk as ISWbemObjectPath; + end; +end; + +procedure TSWbemObjectPath.ConnectTo(svrIntf: ISWbemObjectPath); +begin + Disconnect; + FIntf := svrIntf; +end; + +procedure TSWbemObjectPath.DisConnect; +begin + if Fintf <> nil then + begin + FIntf := nil; + end; +end; + +function TSWbemObjectPath.GetDefaultInterface: ISWbemObjectPath; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); + Result := FIntf; +end; + +constructor TSWbemObjectPath.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps := TSWbemObjectPathProperties.Create(Self); +{$ENDIF} +end; + +destructor TSWbemObjectPath.Destroy; +begin +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps.Free; +{$ENDIF} + inherited Destroy; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +function TSWbemObjectPath.GetServerProperties: TSWbemObjectPathProperties; +begin + Result := FProps; +end; +{$ENDIF} + +function TSWbemObjectPath.Get_Path: WideString; +begin + Result := DefaultInterface.Path; +end; + +procedure TSWbemObjectPath.Set_Path(const strPath: WideString); + { Warning: The property Path has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Path := strPath; +end; + +function TSWbemObjectPath.Get_RelPath: WideString; +begin + Result := DefaultInterface.RelPath; +end; + +procedure TSWbemObjectPath.Set_RelPath(const strRelPath: WideString); + { Warning: The property RelPath has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.RelPath := strRelPath; +end; + +function TSWbemObjectPath.Get_Server: WideString; +begin + Result := DefaultInterface.Server; +end; + +procedure TSWbemObjectPath.Set_Server(const strServer: WideString); + { Warning: The property Server has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Server := strServer; +end; + +function TSWbemObjectPath.Get_Namespace: WideString; +begin + Result := DefaultInterface.Namespace; +end; + +procedure TSWbemObjectPath.Set_Namespace(const strNamespace: WideString); + { Warning: The property Namespace has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Namespace := strNamespace; +end; + +function TSWbemObjectPath.Get_ParentNamespace: WideString; +begin + Result := DefaultInterface.ParentNamespace; +end; + +function TSWbemObjectPath.Get_DisplayName: WideString; +begin + Result := DefaultInterface.DisplayName; +end; + +procedure TSWbemObjectPath.Set_DisplayName(const strDisplayName: WideString); + { Warning: The property DisplayName has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.DisplayName := strDisplayName; +end; + +function TSWbemObjectPath.Get_Class_: WideString; +begin + Result := DefaultInterface.Class_; +end; + +procedure TSWbemObjectPath.Set_Class_(const strClass: WideString); + { Warning: The property Class_ has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Class_ := strClass; +end; + +function TSWbemObjectPath.Get_IsClass: WordBool; +begin + Result := DefaultInterface.IsClass; +end; + +function TSWbemObjectPath.Get_IsSingleton: WordBool; +begin + Result := DefaultInterface.IsSingleton; +end; + +function TSWbemObjectPath.Get_Keys: ISWbemNamedValueSet; +begin + Result := DefaultInterface.Keys; +end; + +function TSWbemObjectPath.Get_Security_: ISWbemSecurity; +begin + Result := DefaultInterface.Security_; +end; + +function TSWbemObjectPath.Get_Locale: WideString; +begin + Result := DefaultInterface.Locale; +end; + +procedure TSWbemObjectPath.Set_Locale(const strLocale: WideString); + { Warning: The property Locale has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Locale := strLocale; +end; + +function TSWbemObjectPath.Get_Authority: WideString; +begin + Result := DefaultInterface.Authority; +end; + +procedure TSWbemObjectPath.Set_Authority(const strAuthority: WideString); + { Warning: The property Authority has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Authority := strAuthority; +end; + +procedure TSWbemObjectPath.SetAsClass; +begin + DefaultInterface.SetAsClass; +end; + +procedure TSWbemObjectPath.SetAsSingleton; +begin + DefaultInterface.SetAsSingleton; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +constructor TSWbemObjectPathProperties.Create(AServer: TSWbemObjectPath); +begin + inherited Create; + FServer := AServer; +end; + +function TSWbemObjectPathProperties.GetDefaultInterface: ISWbemObjectPath; +begin + Result := FServer.DefaultInterface; +end; + +function TSWbemObjectPathProperties.Get_Path: WideString; +begin + Result := DefaultInterface.Path; +end; + +procedure TSWbemObjectPathProperties.Set_Path(const strPath: WideString); + { Warning: The property Path has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Path := strPath; +end; + +function TSWbemObjectPathProperties.Get_RelPath: WideString; +begin + Result := DefaultInterface.RelPath; +end; + +procedure TSWbemObjectPathProperties.Set_RelPath(const strRelPath: WideString); + { Warning: The property RelPath has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.RelPath := strRelPath; +end; + +function TSWbemObjectPathProperties.Get_Server: WideString; +begin + Result := DefaultInterface.Server; +end; + +procedure TSWbemObjectPathProperties.Set_Server(const strServer: WideString); + { Warning: The property Server has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Server := strServer; +end; + +function TSWbemObjectPathProperties.Get_Namespace: WideString; +begin + Result := DefaultInterface.Namespace; +end; + +procedure TSWbemObjectPathProperties.Set_Namespace(const strNamespace: WideString); + { Warning: The property Namespace has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Namespace := strNamespace; +end; + +function TSWbemObjectPathProperties.Get_ParentNamespace: WideString; +begin + Result := DefaultInterface.ParentNamespace; +end; + +function TSWbemObjectPathProperties.Get_DisplayName: WideString; +begin + Result := DefaultInterface.DisplayName; +end; + +procedure TSWbemObjectPathProperties.Set_DisplayName(const strDisplayName: WideString); + { Warning: The property DisplayName has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.DisplayName := strDisplayName; +end; + +function TSWbemObjectPathProperties.Get_Class_: WideString; +begin + Result := DefaultInterface.Class_; +end; + +procedure TSWbemObjectPathProperties.Set_Class_(const strClass: WideString); + { Warning: The property Class_ has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Class_ := strClass; +end; + +function TSWbemObjectPathProperties.Get_IsClass: WordBool; +begin + Result := DefaultInterface.IsClass; +end; + +function TSWbemObjectPathProperties.Get_IsSingleton: WordBool; +begin + Result := DefaultInterface.IsSingleton; +end; + +function TSWbemObjectPathProperties.Get_Keys: ISWbemNamedValueSet; +begin + Result := DefaultInterface.Keys; +end; + +function TSWbemObjectPathProperties.Get_Security_: ISWbemSecurity; +begin + Result := DefaultInterface.Security_; +end; + +function TSWbemObjectPathProperties.Get_Locale: WideString; +begin + Result := DefaultInterface.Locale; +end; + +procedure TSWbemObjectPathProperties.Set_Locale(const strLocale: WideString); + { Warning: The property Locale has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Locale := strLocale; +end; + +function TSWbemObjectPathProperties.Get_Authority: WideString; +begin + Result := DefaultInterface.Authority; +end; + +procedure TSWbemObjectPathProperties.Set_Authority(const strAuthority: WideString); + { Warning: The property Authority has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Authority := strAuthority; +end; + +{$ENDIF} + +class function CoSWbemLastError.Create: ISWbemLastError; +begin + Result := CreateComObject(CLASS_SWbemLastError) as ISWbemLastError; +end; + +class function CoSWbemLastError.CreateRemote(const MachineName: string): ISWbemLastError; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemLastError) as ISWbemLastError; +end; + +procedure TSWbemLastError.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{C2FEEEAC-CFCD-11D1-8B05-00600806D9B6}'; + IntfIID: '{D962DB84-D4BB-11D1-8B09-00600806D9B6}'; + EventIID: ''; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TSWbemLastError.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + Fintf:= punk as ISWbemLastError; + end; +end; + +procedure TSWbemLastError.ConnectTo(svrIntf: ISWbemLastError); +begin + Disconnect; + FIntf := svrIntf; +end; + +procedure TSWbemLastError.DisConnect; +begin + if Fintf <> nil then + begin + FIntf := nil; + end; +end; + +function TSWbemLastError.GetDefaultInterface: ISWbemLastError; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); + Result := FIntf; +end; + +constructor TSWbemLastError.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps := TSWbemLastErrorProperties.Create(Self); +{$ENDIF} +end; + +destructor TSWbemLastError.Destroy; +begin +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps.Free; +{$ENDIF} + inherited Destroy; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +function TSWbemLastError.GetServerProperties: TSWbemLastErrorProperties; +begin + Result := FProps; +end; +{$ENDIF} + +function TSWbemLastError.Get_Qualifiers_: ISWbemQualifierSet; +begin + Result := DefaultInterface.Qualifiers_; +end; + +function TSWbemLastError.Get_Properties_: ISWbemPropertySet; +begin + Result := DefaultInterface.Properties_; +end; + +function TSWbemLastError.Get_Methods_: ISWbemMethodSet; +begin + Result := DefaultInterface.Methods_; +end; + +function TSWbemLastError.Get_Derivation_: OleVariant; +var + InterfaceVariant : OleVariant; +begin + InterfaceVariant := DefaultInterface; + Result := InterfaceVariant.Derivation_; +end; + +function TSWbemLastError.Get_Path_: ISWbemObjectPath; +begin + Result := DefaultInterface.Path_; +end; + +function TSWbemLastError.Get_Security_: ISWbemSecurity; +begin + Result := DefaultInterface.Security_; +end; + +function TSWbemLastError.Put_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectPath; +begin + Result := DefaultInterface.Put_(iFlags, objWbemNamedValueSet); +end; + +procedure TSWbemLastError.PutAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); +begin + DefaultInterface.PutAsync_(objWbemSink, iFlags, objWbemNamedValueSet, objWbemAsyncContext); +end; + +procedure TSWbemLastError.Delete_(iFlags: Integer; const objWbemNamedValueSet: IDispatch); +begin + DefaultInterface.Delete_(iFlags, objWbemNamedValueSet); +end; + +procedure TSWbemLastError.DeleteAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); +begin + DefaultInterface.DeleteAsync_(objWbemSink, iFlags, objWbemNamedValueSet, objWbemAsyncContext); +end; + +function TSWbemLastError.Instances_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; +begin + Result := DefaultInterface.Instances_(iFlags, objWbemNamedValueSet); +end; + +procedure TSWbemLastError.InstancesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); +begin + DefaultInterface.InstancesAsync_(objWbemSink, iFlags, objWbemNamedValueSet, objWbemAsyncContext); +end; + +function TSWbemLastError.Subclasses_(iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; +begin + Result := DefaultInterface.Subclasses_(iFlags, objWbemNamedValueSet); +end; + +procedure TSWbemLastError.SubclassesAsync_(const objWbemSink: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); +begin + DefaultInterface.SubclassesAsync_(objWbemSink, iFlags, objWbemNamedValueSet, objWbemAsyncContext); +end; + +function TSWbemLastError.Associators_(const strAssocClass: WideString; + const strResultClass: WideString; + const strResultRole: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; +begin + Result := DefaultInterface.Associators_(strAssocClass, strResultClass, strResultRole, strRole, + bClassesOnly, bSchemaOnly, strRequiredAssocQualifier, + strRequiredQualifier, iFlags, objWbemNamedValueSet); +end; + +procedure TSWbemLastError.AssociatorsAsync_(const objWbemSink: IDispatch; + const strAssocClass: WideString; + const strResultClass: WideString; + const strResultRole: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; + const strRequiredAssocQualifier: WideString; + const strRequiredQualifier: WideString; + iFlags: Integer; const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); +begin + DefaultInterface.AssociatorsAsync_(objWbemSink, strAssocClass, strResultClass, strResultRole, + strRole, bClassesOnly, bSchemaOnly, strRequiredAssocQualifier, + strRequiredQualifier, iFlags, objWbemNamedValueSet, + objWbemAsyncContext); +end; + +function TSWbemLastError.References_(const strResultClass: WideString; const strRole: WideString; + bClassesOnly: WordBool; bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; +begin + Result := DefaultInterface.References_(strResultClass, strRole, bClassesOnly, bSchemaOnly, + strRequiredQualifier, iFlags, objWbemNamedValueSet); +end; + +procedure TSWbemLastError.ReferencesAsync_(const objWbemSink: IDispatch; + const strResultClass: WideString; + const strRole: WideString; bClassesOnly: WordBool; + bSchemaOnly: WordBool; + const strRequiredQualifier: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); +begin + DefaultInterface.ReferencesAsync_(objWbemSink, strResultClass, strRole, bClassesOnly, + bSchemaOnly, strRequiredQualifier, iFlags, + objWbemNamedValueSet, objWbemAsyncContext); +end; + +function TSWbemLastError.ExecMethod_(const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemObject; +begin + Result := DefaultInterface.ExecMethod_(strMethodName, objWbemInParameters, iFlags, + objWbemNamedValueSet); +end; + +procedure TSWbemLastError.ExecMethodAsync_(const objWbemSink: IDispatch; + const strMethodName: WideString; + const objWbemInParameters: IDispatch; iFlags: Integer; + const objWbemNamedValueSet: IDispatch; + const objWbemAsyncContext: IDispatch); +begin + DefaultInterface.ExecMethodAsync_(objWbemSink, strMethodName, objWbemInParameters, iFlags, + objWbemNamedValueSet, objWbemAsyncContext); +end; + +function TSWbemLastError.Clone_: ISWbemObject; +begin + Result := DefaultInterface.Clone_; +end; + +function TSWbemLastError.GetObjectText_(iFlags: Integer): WideString; +begin + Result := DefaultInterface.GetObjectText_(iFlags); +end; + +function TSWbemLastError.SpawnDerivedClass_(iFlags: Integer): ISWbemObject; +begin + Result := DefaultInterface.SpawnDerivedClass_(iFlags); +end; + +function TSWbemLastError.SpawnInstance_(iFlags: Integer): ISWbemObject; +begin + Result := DefaultInterface.SpawnInstance_(iFlags); +end; + +function TSWbemLastError.CompareTo_(const objWbemObject: IDispatch; iFlags: Integer): WordBool; +begin + Result := DefaultInterface.CompareTo_(objWbemObject, iFlags); +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +constructor TSWbemLastErrorProperties.Create(AServer: TSWbemLastError); +begin + inherited Create; + FServer := AServer; +end; + +function TSWbemLastErrorProperties.GetDefaultInterface: ISWbemLastError; +begin + Result := FServer.DefaultInterface; +end; + +function TSWbemLastErrorProperties.Get_Qualifiers_: ISWbemQualifierSet; +begin + Result := DefaultInterface.Qualifiers_; +end; + +function TSWbemLastErrorProperties.Get_Properties_: ISWbemPropertySet; +begin + Result := DefaultInterface.Properties_; +end; + +function TSWbemLastErrorProperties.Get_Methods_: ISWbemMethodSet; +begin + Result := DefaultInterface.Methods_; +end; + +function TSWbemLastErrorProperties.Get_Derivation_: OleVariant; +var + InterfaceVariant : OleVariant; +begin + InterfaceVariant := DefaultInterface; + Result := InterfaceVariant.Derivation_; +end; + +function TSWbemLastErrorProperties.Get_Path_: ISWbemObjectPath; +begin + Result := DefaultInterface.Path_; +end; + +function TSWbemLastErrorProperties.Get_Security_: ISWbemSecurity; +begin + Result := DefaultInterface.Security_; +end; + +{$ENDIF} + +class function CoSWbemSink.Create: ISWbemSink; +begin + Result := CreateComObject(CLASS_SWbemSink) as ISWbemSink; +end; + +class function CoSWbemSink.CreateRemote(const MachineName: string): ISWbemSink; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemSink) as ISWbemSink; +end; + +procedure TSWbemSink.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{75718C9A-F029-11D1-A1AC-00C04FB6C223}'; + IntfIID: '{75718C9F-F029-11D1-A1AC-00C04FB6C223}'; + EventIID: '{75718CA0-F029-11D1-A1AC-00C04FB6C223}'; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TSWbemSink.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + ConnectEvents(punk); + Fintf:= punk as ISWbemSink; + end; +end; + +procedure TSWbemSink.ConnectTo(svrIntf: ISWbemSink); +begin + Disconnect; + FIntf := svrIntf; + ConnectEvents(FIntf); +end; + +procedure TSWbemSink.DisConnect; +begin + if Fintf <> nil then + begin + DisconnectEvents(FIntf); + FIntf := nil; + end; +end; + +function TSWbemSink.GetDefaultInterface: ISWbemSink; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); + Result := FIntf; +end; + +constructor TSWbemSink.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps := TSWbemSinkProperties.Create(Self); +{$ENDIF} +end; + +destructor TSWbemSink.Destroy; +begin +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps.Free; +{$ENDIF} + inherited Destroy; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +function TSWbemSink.GetServerProperties: TSWbemSinkProperties; +begin + Result := FProps; +end; +{$ENDIF} + +procedure TSWbemSink.InvokeEvent(DispID: TDispID; var Params: TVariantArray); +begin + case DispID of + -1: Exit; // DISPID_UNKNOWN + 1: if Assigned(FOnObjectReady) then + FOnObjectReady(Self, + IUnknown(TVarData(Params[0]).VPointer) as ISWbemObject {const ISWbemObject}, + IUnknown(TVarData(Params[1]).VPointer) as ISWbemNamedValueSet {const ISWbemNamedValueSet}); + 2: if Assigned(FOnCompleted) then + FOnCompleted(Self, + Params[0] {WbemErrorEnum}, + IUnknown(TVarData(Params[1]).VPointer) as ISWbemObject {const ISWbemObject}, + IUnknown(TVarData(Params[2]).VPointer) as ISWbemNamedValueSet {const ISWbemNamedValueSet}); + 3: if Assigned(FOnProgress) then + FOnProgress(Self, + Params[0] {Integer}, + Params[1] {Integer}, + Params[2] {const WideString}, + IUnknown(TVarData(Params[3]).VPointer) as ISWbemNamedValueSet {const ISWbemNamedValueSet}); + 4: if Assigned(FOnObjectPut) then + FOnObjectPut(Self, + IUnknown(TVarData(Params[0]).VPointer) as ISWbemObjectPath {const ISWbemObjectPath}, + IUnknown(TVarData(Params[1]).VPointer) as ISWbemNamedValueSet {const ISWbemNamedValueSet}); + end; {case DispID} +end; + +procedure TSWbemSink.Cancel; +begin + DefaultInterface.Cancel; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +constructor TSWbemSinkProperties.Create(AServer: TSWbemSink); +begin + inherited Create; + FServer := AServer; +end; + +function TSWbemSinkProperties.GetDefaultInterface: ISWbemSink; +begin + Result := FServer.DefaultInterface; +end; + +{$ENDIF} + +class function CoSWbemDateTime.Create: ISWbemDateTime; +begin + Result := CreateComObject(CLASS_SWbemDateTime) as ISWbemDateTime; +end; + +class function CoSWbemDateTime.CreateRemote(const MachineName: string): ISWbemDateTime; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemDateTime) as ISWbemDateTime; +end; + +procedure TSWbemDateTime.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{47DFBE54-CF76-11D3-B38F-00105A1F473A}'; + IntfIID: '{5E97458A-CF77-11D3-B38F-00105A1F473A}'; + EventIID: ''; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TSWbemDateTime.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + Fintf:= punk as ISWbemDateTime; + end; +end; + +procedure TSWbemDateTime.ConnectTo(svrIntf: ISWbemDateTime); +begin + Disconnect; + FIntf := svrIntf; +end; + +procedure TSWbemDateTime.DisConnect; +begin + if Fintf <> nil then + begin + FIntf := nil; + end; +end; + +function TSWbemDateTime.GetDefaultInterface: ISWbemDateTime; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); + Result := FIntf; +end; + +constructor TSWbemDateTime.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps := TSWbemDateTimeProperties.Create(Self); +{$ENDIF} +end; + +destructor TSWbemDateTime.Destroy; +begin +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps.Free; +{$ENDIF} + inherited Destroy; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +function TSWbemDateTime.GetServerProperties: TSWbemDateTimeProperties; +begin + Result := FProps; +end; +{$ENDIF} + +function TSWbemDateTime.Get_Value: WideString; +begin + Result := DefaultInterface.Value; +end; + +procedure TSWbemDateTime.Set_Value(const strValue: WideString); + { Warning: The property Value has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Value := strValue; +end; + +function TSWbemDateTime.Get_Year: Integer; +begin + Result := DefaultInterface.Year; +end; + +procedure TSWbemDateTime.Set_Year(iYear: Integer); +begin + DefaultInterface.Set_Year(iYear); +end; + +function TSWbemDateTime.Get_YearSpecified: WordBool; +begin + Result := DefaultInterface.YearSpecified; +end; + +procedure TSWbemDateTime.Set_YearSpecified(bYearSpecified: WordBool); +begin + DefaultInterface.Set_YearSpecified(bYearSpecified); +end; + +function TSWbemDateTime.Get_Month: Integer; +begin + Result := DefaultInterface.Month; +end; + +procedure TSWbemDateTime.Set_Month(iMonth: Integer); +begin + DefaultInterface.Set_Month(iMonth); +end; + +function TSWbemDateTime.Get_MonthSpecified: WordBool; +begin + Result := DefaultInterface.MonthSpecified; +end; + +procedure TSWbemDateTime.Set_MonthSpecified(bMonthSpecified: WordBool); +begin + DefaultInterface.Set_MonthSpecified(bMonthSpecified); +end; + +function TSWbemDateTime.Get_Day: Integer; +begin + Result := DefaultInterface.Day; +end; + +procedure TSWbemDateTime.Set_Day(iDay: Integer); +begin + DefaultInterface.Set_Day(iDay); +end; + +function TSWbemDateTime.Get_DaySpecified: WordBool; +begin + Result := DefaultInterface.DaySpecified; +end; + +procedure TSWbemDateTime.Set_DaySpecified(bDaySpecified: WordBool); +begin + DefaultInterface.Set_DaySpecified(bDaySpecified); +end; + +function TSWbemDateTime.Get_Hours: Integer; +begin + Result := DefaultInterface.Hours; +end; + +procedure TSWbemDateTime.Set_Hours(iHours: Integer); +begin + DefaultInterface.Set_Hours(iHours); +end; + +function TSWbemDateTime.Get_HoursSpecified: WordBool; +begin + Result := DefaultInterface.HoursSpecified; +end; + +procedure TSWbemDateTime.Set_HoursSpecified(bHoursSpecified: WordBool); +begin + DefaultInterface.Set_HoursSpecified(bHoursSpecified); +end; + +function TSWbemDateTime.Get_Minutes: Integer; +begin + Result := DefaultInterface.Minutes; +end; + +procedure TSWbemDateTime.Set_Minutes(iMinutes: Integer); +begin + DefaultInterface.Set_Minutes(iMinutes); +end; + +function TSWbemDateTime.Get_MinutesSpecified: WordBool; +begin + Result := DefaultInterface.MinutesSpecified; +end; + +procedure TSWbemDateTime.Set_MinutesSpecified(bMinutesSpecified: WordBool); +begin + DefaultInterface.Set_MinutesSpecified(bMinutesSpecified); +end; + +function TSWbemDateTime.Get_Seconds: Integer; +begin + Result := DefaultInterface.Seconds; +end; + +procedure TSWbemDateTime.Set_Seconds(iSeconds: Integer); +begin + DefaultInterface.Set_Seconds(iSeconds); +end; + +function TSWbemDateTime.Get_SecondsSpecified: WordBool; +begin + Result := DefaultInterface.SecondsSpecified; +end; + +procedure TSWbemDateTime.Set_SecondsSpecified(bSecondsSpecified: WordBool); +begin + DefaultInterface.Set_SecondsSpecified(bSecondsSpecified); +end; + +function TSWbemDateTime.Get_Microseconds: Integer; +begin + Result := DefaultInterface.Microseconds; +end; + +procedure TSWbemDateTime.Set_Microseconds(iMicroseconds: Integer); +begin + DefaultInterface.Set_Microseconds(iMicroseconds); +end; + +function TSWbemDateTime.Get_MicrosecondsSpecified: WordBool; +begin + Result := DefaultInterface.MicrosecondsSpecified; +end; + +procedure TSWbemDateTime.Set_MicrosecondsSpecified(bMicrosecondsSpecified: WordBool); +begin + DefaultInterface.Set_MicrosecondsSpecified(bMicrosecondsSpecified); +end; + +function TSWbemDateTime.Get_UTC: Integer; +begin + Result := DefaultInterface.UTC; +end; + +procedure TSWbemDateTime.Set_UTC(iUTC: Integer); +begin + DefaultInterface.Set_UTC(iUTC); +end; + +function TSWbemDateTime.Get_UTCSpecified: WordBool; +begin + Result := DefaultInterface.UTCSpecified; +end; + +procedure TSWbemDateTime.Set_UTCSpecified(bUTCSpecified: WordBool); +begin + DefaultInterface.Set_UTCSpecified(bUTCSpecified); +end; + +function TSWbemDateTime.Get_IsInterval: WordBool; +begin + Result := DefaultInterface.IsInterval; +end; + +procedure TSWbemDateTime.Set_IsInterval(bIsInterval: WordBool); +begin + DefaultInterface.Set_IsInterval(bIsInterval); +end; + +function TSWbemDateTime.GetVarDate(bIsLocal: WordBool): TDateTime; +begin + Result := DefaultInterface.GetVarDate(bIsLocal); +end; + +procedure TSWbemDateTime.SetVarDate(dVarDate: TDateTime; bIsLocal: WordBool); +begin + DefaultInterface.SetVarDate(dVarDate, bIsLocal); +end; + +function TSWbemDateTime.GetFileTime(bIsLocal: WordBool): WideString; +begin + Result := DefaultInterface.GetFileTime(bIsLocal); +end; + +procedure TSWbemDateTime.SetFileTime(const strFileTime: WideString; bIsLocal: WordBool); +begin + DefaultInterface.SetFileTime(strFileTime, bIsLocal); +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +constructor TSWbemDateTimeProperties.Create(AServer: TSWbemDateTime); +begin + inherited Create; + FServer := AServer; +end; + +function TSWbemDateTimeProperties.GetDefaultInterface: ISWbemDateTime; +begin + Result := FServer.DefaultInterface; +end; + +function TSWbemDateTimeProperties.Get_Value: WideString; +begin + Result := DefaultInterface.Value; +end; + +procedure TSWbemDateTimeProperties.Set_Value(const strValue: WideString); + { Warning: The property Value has a setter and a getter whose + types do not match. Delphi was unable to generate a property of + this sort and so is using a Variant as a passthrough. } +var + InterfaceVariant: OleVariant; +begin + InterfaceVariant := DefaultInterface; + InterfaceVariant.Value := strValue; +end; + +function TSWbemDateTimeProperties.Get_Year: Integer; +begin + Result := DefaultInterface.Year; +end; + +procedure TSWbemDateTimeProperties.Set_Year(iYear: Integer); +begin + DefaultInterface.Set_Year(iYear); +end; + +function TSWbemDateTimeProperties.Get_YearSpecified: WordBool; +begin + Result := DefaultInterface.YearSpecified; +end; + +procedure TSWbemDateTimeProperties.Set_YearSpecified(bYearSpecified: WordBool); +begin + DefaultInterface.Set_YearSpecified(bYearSpecified); +end; + +function TSWbemDateTimeProperties.Get_Month: Integer; +begin + Result := DefaultInterface.Month; +end; + +procedure TSWbemDateTimeProperties.Set_Month(iMonth: Integer); +begin + DefaultInterface.Set_Month(iMonth); +end; + +function TSWbemDateTimeProperties.Get_MonthSpecified: WordBool; +begin + Result := DefaultInterface.MonthSpecified; +end; + +procedure TSWbemDateTimeProperties.Set_MonthSpecified(bMonthSpecified: WordBool); +begin + DefaultInterface.Set_MonthSpecified(bMonthSpecified); +end; + +function TSWbemDateTimeProperties.Get_Day: Integer; +begin + Result := DefaultInterface.Day; +end; + +procedure TSWbemDateTimeProperties.Set_Day(iDay: Integer); +begin + DefaultInterface.Set_Day(iDay); +end; + +function TSWbemDateTimeProperties.Get_DaySpecified: WordBool; +begin + Result := DefaultInterface.DaySpecified; +end; + +procedure TSWbemDateTimeProperties.Set_DaySpecified(bDaySpecified: WordBool); +begin + DefaultInterface.Set_DaySpecified(bDaySpecified); +end; + +function TSWbemDateTimeProperties.Get_Hours: Integer; +begin + Result := DefaultInterface.Hours; +end; + +procedure TSWbemDateTimeProperties.Set_Hours(iHours: Integer); +begin + DefaultInterface.Set_Hours(iHours); +end; + +function TSWbemDateTimeProperties.Get_HoursSpecified: WordBool; +begin + Result := DefaultInterface.HoursSpecified; +end; + +procedure TSWbemDateTimeProperties.Set_HoursSpecified(bHoursSpecified: WordBool); +begin + DefaultInterface.Set_HoursSpecified(bHoursSpecified); +end; + +function TSWbemDateTimeProperties.Get_Minutes: Integer; +begin + Result := DefaultInterface.Minutes; +end; + +procedure TSWbemDateTimeProperties.Set_Minutes(iMinutes: Integer); +begin + DefaultInterface.Set_Minutes(iMinutes); +end; + +function TSWbemDateTimeProperties.Get_MinutesSpecified: WordBool; +begin + Result := DefaultInterface.MinutesSpecified; +end; + +procedure TSWbemDateTimeProperties.Set_MinutesSpecified(bMinutesSpecified: WordBool); +begin + DefaultInterface.Set_MinutesSpecified(bMinutesSpecified); +end; + +function TSWbemDateTimeProperties.Get_Seconds: Integer; +begin + Result := DefaultInterface.Seconds; +end; + +procedure TSWbemDateTimeProperties.Set_Seconds(iSeconds: Integer); +begin + DefaultInterface.Set_Seconds(iSeconds); +end; + +function TSWbemDateTimeProperties.Get_SecondsSpecified: WordBool; +begin + Result := DefaultInterface.SecondsSpecified; +end; + +procedure TSWbemDateTimeProperties.Set_SecondsSpecified(bSecondsSpecified: WordBool); +begin + DefaultInterface.Set_SecondsSpecified(bSecondsSpecified); +end; + +function TSWbemDateTimeProperties.Get_Microseconds: Integer; +begin + Result := DefaultInterface.Microseconds; +end; + +procedure TSWbemDateTimeProperties.Set_Microseconds(iMicroseconds: Integer); +begin + DefaultInterface.Set_Microseconds(iMicroseconds); +end; + +function TSWbemDateTimeProperties.Get_MicrosecondsSpecified: WordBool; +begin + Result := DefaultInterface.MicrosecondsSpecified; +end; + +procedure TSWbemDateTimeProperties.Set_MicrosecondsSpecified(bMicrosecondsSpecified: WordBool); +begin + DefaultInterface.Set_MicrosecondsSpecified(bMicrosecondsSpecified); +end; + +function TSWbemDateTimeProperties.Get_UTC: Integer; +begin + Result := DefaultInterface.UTC; +end; + +procedure TSWbemDateTimeProperties.Set_UTC(iUTC: Integer); +begin + DefaultInterface.Set_UTC(iUTC); +end; + +function TSWbemDateTimeProperties.Get_UTCSpecified: WordBool; +begin + Result := DefaultInterface.UTCSpecified; +end; + +procedure TSWbemDateTimeProperties.Set_UTCSpecified(bUTCSpecified: WordBool); +begin + DefaultInterface.Set_UTCSpecified(bUTCSpecified); +end; + +function TSWbemDateTimeProperties.Get_IsInterval: WordBool; +begin + Result := DefaultInterface.IsInterval; +end; + +procedure TSWbemDateTimeProperties.Set_IsInterval(bIsInterval: WordBool); +begin + DefaultInterface.Set_IsInterval(bIsInterval); +end; + +{$ENDIF} + +class function CoSWbemRefresher.Create: ISWbemRefresher; +begin + Result := CreateComObject(CLASS_SWbemRefresher) as ISWbemRefresher; +end; + +class function CoSWbemRefresher.CreateRemote(const MachineName: string): ISWbemRefresher; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemRefresher) as ISWbemRefresher; +end; + +procedure TSWbemRefresher.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{D269BF5C-D9C1-11D3-B38F-00105A1F473A}'; + IntfIID: '{14D8250E-D9C2-11D3-B38F-00105A1F473A}'; + EventIID: ''; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TSWbemRefresher.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + Fintf:= punk as ISWbemRefresher; + end; +end; + +procedure TSWbemRefresher.ConnectTo(svrIntf: ISWbemRefresher); +begin + Disconnect; + FIntf := svrIntf; +end; + +procedure TSWbemRefresher.DisConnect; +begin + if Fintf <> nil then + begin + FIntf := nil; + end; +end; + +function TSWbemRefresher.GetDefaultInterface: ISWbemRefresher; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); + Result := FIntf; +end; + +constructor TSWbemRefresher.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps := TSWbemRefresherProperties.Create(Self); +{$ENDIF} +end; + +destructor TSWbemRefresher.Destroy; +begin +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps.Free; +{$ENDIF} + inherited Destroy; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +function TSWbemRefresher.GetServerProperties: TSWbemRefresherProperties; +begin + Result := FProps; +end; +{$ENDIF} + +function TSWbemRefresher.Get_Count: Integer; +begin + Result := DefaultInterface.Count; +end; + +function TSWbemRefresher.Get_AutoReconnect: WordBool; +begin + Result := DefaultInterface.AutoReconnect; +end; + +procedure TSWbemRefresher.Set_AutoReconnect(bCount: WordBool); +begin + DefaultInterface.Set_AutoReconnect(bCount); +end; + +function TSWbemRefresher.Item(iIndex: Integer): ISWbemRefreshableItem; +begin + Result := DefaultInterface.Item(iIndex); +end; + +function TSWbemRefresher.Add(const objWbemServices: ISWbemServicesEx; + const bsInstancePath: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemRefreshableItem; +begin + Result := DefaultInterface.Add(objWbemServices, bsInstancePath, iFlags, objWbemNamedValueSet); +end; + +function TSWbemRefresher.AddEnum(const objWbemServices: ISWbemServicesEx; + const bsClassName: WideString; iFlags: Integer; + const objWbemNamedValueSet: IDispatch): ISWbemRefreshableItem; +begin + Result := DefaultInterface.AddEnum(objWbemServices, bsClassName, iFlags, objWbemNamedValueSet); +end; + +procedure TSWbemRefresher.Remove(iIndex: Integer; iFlags: Integer); +begin + DefaultInterface.Remove(iIndex, iFlags); +end; + +procedure TSWbemRefresher.Refresh(iFlags: Integer); +begin + DefaultInterface.Refresh(iFlags); +end; + +procedure TSWbemRefresher.DeleteAll; +begin + DefaultInterface.DeleteAll; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +constructor TSWbemRefresherProperties.Create(AServer: TSWbemRefresher); +begin + inherited Create; + FServer := AServer; +end; + +function TSWbemRefresherProperties.GetDefaultInterface: ISWbemRefresher; +begin + Result := FServer.DefaultInterface; +end; + +function TSWbemRefresherProperties.Get_Count: Integer; +begin + Result := DefaultInterface.Count; +end; + +function TSWbemRefresherProperties.Get_AutoReconnect: WordBool; +begin + Result := DefaultInterface.AutoReconnect; +end; + +procedure TSWbemRefresherProperties.Set_AutoReconnect(bCount: WordBool); +begin + DefaultInterface.Set_AutoReconnect(bCount); +end; + +{$ENDIF} + +class function CoSWbemServices.Create: ISWbemServices; +begin + Result := CreateComObject(CLASS_SWbemServices) as ISWbemServices; +end; + +class function CoSWbemServices.CreateRemote(const MachineName: string): ISWbemServices; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemServices) as ISWbemServices; +end; + +class function CoSWbemServicesEx.Create: ISWbemServicesEx; +begin + Result := CreateComObject(CLASS_SWbemServicesEx) as ISWbemServicesEx; +end; + +class function CoSWbemServicesEx.CreateRemote(const MachineName: string): ISWbemServicesEx; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemServicesEx) as ISWbemServicesEx; +end; + +class function CoSWbemObject.Create: ISWbemObject; +begin + Result := CreateComObject(CLASS_SWbemObject) as ISWbemObject; +end; + +class function CoSWbemObject.CreateRemote(const MachineName: string): ISWbemObject; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemObject) as ISWbemObject; +end; + +class function CoSWbemObjectEx.Create: ISWbemObjectEx; +begin + Result := CreateComObject(CLASS_SWbemObjectEx) as ISWbemObjectEx; +end; + +class function CoSWbemObjectEx.CreateRemote(const MachineName: string): ISWbemObjectEx; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemObjectEx) as ISWbemObjectEx; +end; + +class function CoSWbemObjectSet.Create: ISWbemObjectSet; +begin + Result := CreateComObject(CLASS_SWbemObjectSet) as ISWbemObjectSet; +end; + +class function CoSWbemObjectSet.CreateRemote(const MachineName: string): ISWbemObjectSet; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemObjectSet) as ISWbemObjectSet; +end; + +class function CoSWbemNamedValue.Create: ISWbemNamedValue; +begin + Result := CreateComObject(CLASS_SWbemNamedValue) as ISWbemNamedValue; +end; + +class function CoSWbemNamedValue.CreateRemote(const MachineName: string): ISWbemNamedValue; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemNamedValue) as ISWbemNamedValue; +end; + +class function CoSWbemQualifier.Create: ISWbemQualifier; +begin + Result := CreateComObject(CLASS_SWbemQualifier) as ISWbemQualifier; +end; + +class function CoSWbemQualifier.CreateRemote(const MachineName: string): ISWbemQualifier; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemQualifier) as ISWbemQualifier; +end; + +class function CoSWbemQualifierSet.Create: ISWbemQualifierSet; +begin + Result := CreateComObject(CLASS_SWbemQualifierSet) as ISWbemQualifierSet; +end; + +class function CoSWbemQualifierSet.CreateRemote(const MachineName: string): ISWbemQualifierSet; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemQualifierSet) as ISWbemQualifierSet; +end; + +class function CoSWbemProperty.Create: ISWbemProperty; +begin + Result := CreateComObject(CLASS_SWbemProperty) as ISWbemProperty; +end; + +class function CoSWbemProperty.CreateRemote(const MachineName: string): ISWbemProperty; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemProperty) as ISWbemProperty; +end; + +class function CoSWbemPropertySet.Create: ISWbemPropertySet; +begin + Result := CreateComObject(CLASS_SWbemPropertySet) as ISWbemPropertySet; +end; + +class function CoSWbemPropertySet.CreateRemote(const MachineName: string): ISWbemPropertySet; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemPropertySet) as ISWbemPropertySet; +end; + +class function CoSWbemMethod.Create: ISWbemMethod; +begin + Result := CreateComObject(CLASS_SWbemMethod) as ISWbemMethod; +end; + +class function CoSWbemMethod.CreateRemote(const MachineName: string): ISWbemMethod; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemMethod) as ISWbemMethod; +end; + +class function CoSWbemMethodSet.Create: ISWbemMethodSet; +begin + Result := CreateComObject(CLASS_SWbemMethodSet) as ISWbemMethodSet; +end; + +class function CoSWbemMethodSet.CreateRemote(const MachineName: string): ISWbemMethodSet; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemMethodSet) as ISWbemMethodSet; +end; + +class function CoSWbemEventSource.Create: ISWbemEventSource; +begin + Result := CreateComObject(CLASS_SWbemEventSource) as ISWbemEventSource; +end; + +class function CoSWbemEventSource.CreateRemote(const MachineName: string): ISWbemEventSource; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemEventSource) as ISWbemEventSource; +end; + +class function CoSWbemSecurity.Create: ISWbemSecurity; +begin + Result := CreateComObject(CLASS_SWbemSecurity) as ISWbemSecurity; +end; + +class function CoSWbemSecurity.CreateRemote(const MachineName: string): ISWbemSecurity; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemSecurity) as ISWbemSecurity; +end; + +class function CoSWbemPrivilege.Create: ISWbemPrivilege; +begin + Result := CreateComObject(CLASS_SWbemPrivilege) as ISWbemPrivilege; +end; + +class function CoSWbemPrivilege.CreateRemote(const MachineName: string): ISWbemPrivilege; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemPrivilege) as ISWbemPrivilege; +end; + +class function CoSWbemPrivilegeSet.Create: ISWbemPrivilegeSet; +begin + Result := CreateComObject(CLASS_SWbemPrivilegeSet) as ISWbemPrivilegeSet; +end; + +class function CoSWbemPrivilegeSet.CreateRemote(const MachineName: string): ISWbemPrivilegeSet; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemPrivilegeSet) as ISWbemPrivilegeSet; +end; + +class function CoSWbemRefreshableItem.Create: ISWbemRefreshableItem; +begin + Result := CreateComObject(CLASS_SWbemRefreshableItem) as ISWbemRefreshableItem; +end; + +class function CoSWbemRefreshableItem.CreateRemote(const MachineName: string): ISWbemRefreshableItem; +begin + Result := CreateRemoteComObject(MachineName, CLASS_SWbemRefreshableItem) as ISWbemRefreshableItem; +end; + +procedure Register; +begin + RegisterComponents(dtlServerPage, [TSWbemLocator, TSWbemNamedValueSet, TSWbemObjectPath, TSWbemLastError, + TSWbemSink, TSWbemDateTime, TSWbemRefresher]); +end; + +end. + diff --git a/Tocsg.Lib/VCL/Other/EM.WinOSVersion.pas b/Tocsg.Lib/VCL/Other/EM.WinOSVersion.pas new file mode 100644 index 00000000..4993c4e6 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.WinOSVersion.pas @@ -0,0 +1,795 @@ +//--------------------------------------------------------------------- +// Windows Version Pascal Source +// +// Create by: Kang Sin-young (2004.01.25 Last Modify) +//--------------------------------------------------------------------- + +//--------------------------------------------------------------------- +// GetWindowsVersion Pascal Source +// From https://github.com/yypbd/yypbd-Delphi-Libs/blob/master/lib/WindowsVersion.pas +// Create by: Young-pil Yang (2014.05.28 Last Modify) +//--------------------------------------------------------------------- + +unit EM.WinOSVersion; + +interface + +uses + WinApi.Windows, WinApi.Messages, SysUtils, Variants, StrUtils, System.Win.Registry; + +type + TGetProductInfo = function (dwOsMajorVer, dwOSMinorVerion, dwSpMajorVer, dwSpMinorVer : DWORD; pdwReturnProductType : PDWORD):Boolean; stdcall; + + WKSTA_INFO_100 = record + wki100_platform_id: DWORD; + wki100_computername: LPWSTR; + wki100_langroup: LPWSTR; + wki100_ver_major: DWORD; + wki100_ver_minor: DWORD; + end; + + LPWKSTA_INFO_100 = ^WKSTA_INFO_100; + + _USER_INFO_0 = record + usri0_name: LPWSTR; + end; + + + TWinVerSub = record + Major, + Minor, + Build: DWORD; + end; + + TWinVerInfo = record + WinID, + WinVer, + WinName, + ServicePack: String; + Version: TWinVerSub; + end; + + _OSVERSIONINFOEXA = record + dwOSVersionInfoSize: DWORD; + dwMajorVersion: DWORD; + dwMinorVersion: DWORD; + dwBuildNumber: DWORD; + dwPlatformId: DWORD; + szCSDVersion: array[0..127] of AnsiChar; { Maintenance string for PSS usage } + wServicePackMajor: WORD; + wServicePackMinor: WORD; + wSuiteMask: WORD; + wProductType: BYTE; + wReserved: BYTE; + end; + {$EXTERNALSYM _OSVERSIONINFOEXA} + _OSVERSIONINFOEXW = record + dwOSVersionInfoSize: DWORD; + dwMajorVersion: DWORD; + dwMinorVersion: DWORD; + dwBuildNumber: DWORD; + dwPlatformId: DWORD; + szCSDVersion: array[0..127] of WideChar; { Maintenance string for PSS usage } + wServicePackMajor: WORD; + wServicePackMinor: WORD; + wSuiteMask: WORD; + wProductType: BYTE; + wReserved: BYTE; + end; + {$EXTERNALSYM _OSVERSIONINFOEXW} + OSVERSIONINFOEXA = _OSVERSIONINFOEXA; + OSVERSIONINFOEXW = _OSVERSIONINFOEXW; + {$EXTERNALSYM OSVERSIONINFOEXA} + {$EXTERNALSYM OSVERSIONINFOEXW} + OSVERSIONINFOEX = OSVERSIONINFOEXA; + {$EXTERNALSYM OSVERSIONINFOEX} + TOSVersionInfoExA = OSVERSIONINFOEXA; + TOSVersionInfoExW = OSVERSIONINFOEXW; + +const + NERR_Success = 0; + SERVICE_MAX_COUNT = 10; + VER_EQUAL = 1; + + VER_SERVER_NT = $80000000; + {$EXTERNALSYM VER_SERVER_NT} + VER_WORKSTATION_NT = $40000000; + {$EXTERNALSYM VER_WORKSTATION_NT} + + VER_SUITE_SMALLBUSINESS = $00000001; + {$EXTERNALSYM VER_SUITE_SMALLBUSINESS} + VER_SUITE_ENTERPRISE = $00000002; + {$EXTERNALSYM VER_SUITE_ENTERPRISE} + VER_SUITE_BACKOFFICE = $00000004; + {$EXTERNALSYM VER_SUITE_BACKOFFICE} + VER_SUITE_COMMUNICATIONS = $00000008; + {$EXTERNALSYM VER_SUITE_COMMUNICATIONS} + VER_SUITE_TERMINAL = $00000010; + {$EXTERNALSYM VER_SUITE_TERMINAL} + VER_SUITE_SMALLBUSINESS_RESTRICTED = $00000020; + {$EXTERNALSYM VER_SUITE_SMALLBUSINESS_RESTRICTED} + VER_SUITE_EMBEDDEDNT = $00000040; + {$EXTERNALSYM VER_SUITE_EMBEDDEDNT} + VER_SUITE_DATACENTER = $00000080; + {$EXTERNALSYM VER_SUITE_DATACENTER} + VER_SUITE_SINGLEUSERTS = $00000100; + {$EXTERNALSYM VER_SUITE_SINGLEUSERTS} + VER_SUITE_PERSONAL = $00000200; + {$EXTERNALSYM VER_SUITE_PERSONAL} + VER_SUITE_BLADE = $00000400; + {$EXTERNALSYM VER_SUITE_BLADE} + VER_SUITE_EMBEDDED_RESTRICTED = $00000800; + {$EXTERNALSYM VER_SUITE_EMBEDDED_RESTRICTED} + VER_SUITE_SECURITY_APPLIANCE = $00001000; + {$EXTERNALSYM VER_SUITE_SECURITY_APPLIANCE} + + VER_NT_WORKSTATION = $0000001; + {$EXTERNALSYM VER_NT_WORKSTATION} + VER_NT_DOMAIN_CONTROLLER = $0000002; + {$EXTERNALSYM VER_NT_DOMAIN_CONTROLLER} + VER_NT_SERVER = $0000003; + {$EXTERNALSYM VER_NT_SERVER} + + //GetProductInfo vista 이상에서만 사용 + PRODUCT_BUSINESS = $00000006; + PRODUCT_BUSINESS_N = $00000010; + PRODUCT_CLUSTER_SERVER = $00000012; + PRODUCT_DATACENTER_SERVER = $00000008; + PRODUCT_DATACENTER_SERVER_CORE = $0000000C; + PRODUCT_DATACENTER_SERVER_CORE_V = $00000027; + PRODUCT_DATACENTER_SERVER_V = $00000025; + PRODUCT_ENTERPRISE = $00000004; + PRODUCT_ENTERPRISE_E = $00000046; + PRODUCT_ENTERPRISE_N = $0000001B; + PRODUCT_ENTERPRISE_SERVER = $0000000A; + PRODUCT_ENTERPRISE_SERVER_CORE = $0000000E; + PRODUCT_ENTERPRISE_SERVER_CORE_V = $00000029; + PRODUCT_ENTERPRISE_SERVER_IA64 = $0000000F; + PRODUCT_ENTERPRISE_SERVER_V = $00000026; + PRODUCT_HOME_BASIC = $00000002; + PRODUCT_HOME_BASIC_E = $00000043; + PRODUCT_HOME_BASIC_N = $00000005; + PRODUCT_HOME_PREMIUM = $00000003; + PRODUCT_ULTIMATE = $00000001; + PRODUCT_PROFESSIONAL = $00000030; + PRODUCT_PROFESSIONAL_N = $00000031; + PRODUCT_STARTER = $0000000B; + PRODUCT_SMALLBUSINESS_SERVER = $00000009; + PRODUCT_SMALLBUSINESS_SERVER_PREMIUM = $00000019; + PRODUCT_STANDARD_SERVER = $00000007; + PRODUCT_STANDARD_SERVER_CORE = $0000000D; + PRODUCT_WEB_SERVER = $00000011; + +var + MajorCache: DWORD; + MinorCache: DWORD; + ServicePackCache: DWORD; + IsServerCache: Boolean; + +function NetWkstaGetInfo(ServerName: LPWSTR; Level: DWORD; BufPtr: Pointer) + : Longint; stdcall; external 'netapi32.dll' Name 'NetWkstaGetInfo'; +function NetApiBufferFree(Buffer: Pointer): Longint; stdcall; + external 'netapi32.dll' Name 'NetApiBufferFree'; +{$IFDEF UNICODE} +function VerifyVersionInfo(var LPOSVERSIONINFOEX: OSVERSIONINFOEX; + dwTypeMask: DWORD; dwlConditionMask: int64): BOOL; stdcall; + external kernel32 name 'VerifyVersionInfoW'; +{$ELSE} +function VerifyVersionInfo(var LPOSVERSIONINFOEX: OSVERSIONINFOEX; + dwTypeMask: DWORD; dwlConditionMask: int64): BOOL; stdcall; + external kernel32 name 'VerifyVersionInfoA'; +{$ENDIF} +function VerSetConditionMask(dwlConditionMask: int64; dwTypeBitMask: DWORD; + dwConditionMask: Byte): int64; stdcall; external kernel32; + +function GetVersionEx2(var lpVersionInformation: TOSVersionInfoExA): BOOL; stdcall; +{$EXTERNALSYM GetVersionEx2} +function GetVersionEx2A(var lpVersionInformation: TOSVersionInfoExA): BOOL; stdcall; +{$EXTERNALSYM GetVersionEx2A} +function GetVersionEx2W(var lpVersionInformation: TOSVersionInfoExW): BOOL; stdcall; +{$EXTERNALSYM GetVersionEx2W} + +function GetWindowsVersion(var AMajor, AMinor: DWORD): Boolean; overload; +function GetWindowsVersion(var AMajor, AMinor, AServicePack, ABuildNumber: DWORD; + var AIsServer: Boolean): Boolean; overload; + +function GetWinVersion: TWinVerInfo; + +function ParseWinNT(p: TOSVersionInfoExW; IsEx: Boolean): TWinVerInfo; overload; +function ParseWinNT(p: TOSVersionInfoExA; IsEx: Boolean): TWinVerInfo; overload; +function ParseWin9x(p: TOSVersionInfo): TWinVerInfo; + +implementation + +uses + System.Classes, Tocsg.Safe, Tocsg.Path, Tocsg.Strings, Tocsg.Registry, + Tocsg.FileInfo; + +function GetVersionEx2; external kernel32 name 'GetVersionExA'; +function GetVersionEx2A; external kernel32 name 'GetVersionExA'; +function GetVersionEx2W; external kernel32 name 'GetVersionExW'; + +function GetWinVersion: TWinVerInfo; +var + rtnVerEx: TOSVersionInfoExA; + rtnVer: TOSVersionInfo; + rtnParse: TWinVerInfo; +begin + rtnVer.dwOSVersionInfoSize := sizeof(OSVERSIONINFO); //Get 1st OS Info + GetVersionEx(rtnVer); + + if rtnVer.dwPlatformId = VER_PLATFORM_WIN32_NT then + begin + if rtnVer.dwMajorVersion < 5 then + rtnParse := ParseWinNT(rtnVerEx, False) + else begin + rtnVerEx.dwOSVersionInfoSize := sizeof(TOSVersionInfoExA); //*WinNT/2000/XP/2003 + GetVersionEx2(rtnVerEx); + rtnParse := ParseWinNT(rtnVerEx, True); + end; + end else + rtnParse := ParseWin9x(rtnVer); + + Result := rtnParse; +end; + +function ParseWinNT(p: TOSVersionInfoExA; IsEx: Boolean): TWinVerInfo; + + function IsWin11: Boolean; + var + fi: TTgFileInfo; + StrList: TStringList; + begin + Result := false; + Guard(fi, TTgFileInfo.Create(GetSystemDir + 'kernel32.dll')); + Guard(StrList, TStringList.Create); + if SplitString(fi.Version, '.', StrList) > 3 then + begin + if StrToIntDef(StrList[2], -1) >= 22000 then + Result := true; + end; + end; + +var + rtn: TWinVerInfo; + + resVer: TRegistry; + szProduct: String; + procGetProductInfo : TGetProductInfo; + hModule : THandle; + ProdType : DWORD; + dwMajor, dwMinor, dwService, dwBuildNum : DWORD; + bIsServer : Boolean; +begin + GetWindowsVersion(dwMajor, dwMinor, dwService, dwBuildNum, bIsServer); + + p.dwMajorVersion := dwMajor; + p.dwMinorVersion := dwMinor; + p.dwBuildNumber := dwBuildNum; + if not bIsServer then + begin + p.wProductType := VER_NT_WORKSTATION + end; + +// 윈도우 8.0이 추가 되면서 다시 개선함 + rtn.WinVer := 'Unknown'; + + case p.dwMajorVersion of + 5 : + case p.dwMinorVersion of + 0 : rtn.WinName := '2000'; + 1 : rtn.WinName := 'XP'; + 2 : rtn.WinName := '2003 Server Family'; + end; + 6 : + case p.dwMinorVersion of + 0 : + if p.wProductType = VER_NT_WORKSTATION then + rtn.WinVer := 'Vista' + else + rtn.WinVer := 'Server 2008'; + 1 : + if p.wProductType = VER_NT_WORKSTATION then + rtn.WinVer := '7' + else + rtn.WinVer := 'Server 2008 R2'; + 2 : // 윈 8 정보 추가 + if p.wProductType = VER_NT_WORKSTATION then + rtn.WinVer := '8' + else + rtn.WinVer := 'Server 2012'; + 3 : // 윈 8 정보 추가 + if p.wProductType = VER_NT_WORKSTATION then + rtn.WinVer := '8.1' + else + rtn.WinVer := 'Server 2012 R2'; + end; + 10 : + begin + // 윈도우 10 + rtn.WinVer := '10'; + case p.dwMinorVersion of + 0 : ; // .. 하위 정보 확인 필요 + end; + + // windows 11의 공식 메이저 버전은 10이다.. + // 11인걸 판단하기 위해 'kernel32.dll'의 빌드번호가 22000 이상인지 확인한다. 22_0517 10:05:21 kku + if IsWin11 then + rtn.WinVer := '11'; + end; + 0 : + begin + // 안전모드에서는 실패한다. 22_1116 13:11:54 kku + rtn.WinVer := ExtrNumStr(GetRegValueAsString(HKEY_LOCAL_MACHINE, + 'SOFTWARE\Microsoft\Windows NT\CurrentVersion', 'ProductName')); + if rtn.WinVer = '10' then + begin + if IsWin11 then + rtn.WinVer := '11'; + end else + if rtn.WinVer = '' then + rtn.WinVer := '?'; + end; + end; + rtn.WinName := 'Windows ' + rtn.WinVer; + + //Get Product Substring + if (IsEX) then begin + case p.wProductType of + VER_NT_WORKSTATION: + begin + if (p.dwMajorVersion = 4) then + rtn.WinName := rtn.WinName + ' Workstation 4.0' + else if (p.wSuiteMask and VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL then + rtn.WinName := rtn.WinName + ' Home Edition' + else if p.dwMajorVersion = 6 then + begin + // 비스타의 경우.. 버전정보를 모르겠다.. 아직은.. + + + + end + else + rtn.WinName := rtn.WinName + ' Professional'; + end; + VER_NT_SERVER: + begin + if ((p.dwMajorVersion = 5) and (p.dwMinorVersion = 2)) then begin + if (p.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then + rtn.WinName := rtn.WinName + ' Datacenter Edition' + else if (p.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then + rtn.WinName := rtn.WinName + ' Enterprise Edition' + else if (p.wSuiteMask and VER_SUITE_BLADE) = VER_SUITE_BLADE then + rtn.WinName := rtn.WinName + ' Web Edition' + else + rtn.WinName := rtn.WinName + ' Standard Edition'; + end + else if ((p.dwMajorVersion = 5) and (p.dwMinorVersion = 0)) then begin + if (p.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then + rtn.WinName := rtn.WinName + ' Datacenter Server' + else if (p.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then + rtn.WinName := rtn.WinName + ' Advanced Server' + else + rtn.WinName := rtn.WinName + ' Server'; + end + else if (p.dwMajorVersion = 6) then + + else begin + if (p.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then + rtn.WinName := rtn.WinName + ' Server 4.0 Enterprise Edition' + else + rtn.WinName := rtn.WinName + ' Server 4.0'; + end; + end; + end; {case of} + + if p.dwMajorVersion = 6 then + begin + hModule := GetModuleHandle('kernel32.dll'); + procGetProductInfo := GetProcAddress( hModule ,'GetProductInfo'); + if Assigned(procGetProductInfo) then + begin + procGetProductInfo(p.dwMajorVersion, p.dwMinorVersion, 0, 0, @ProdType); + + case ProdType of + PRODUCT_ULTIMATE : rtn.WinName := rtn.WinName + ' Ultimate'; + PRODUCT_PROFESSIONAL : rtn.WinName := rtn.WinName + ' Professional'; + PRODUCT_HOME_PREMIUM : rtn.WinName := rtn.WinName + ' Home Premium Edition'; + PRODUCT_HOME_BASIC : rtn.WinName := rtn.WinName + ' Home Basic Edition'; + PRODUCT_ENTERPRISE : rtn.WinName := rtn.WinName + ' Enterprise Edition'; + PRODUCT_BUSINESS : rtn.WinName := rtn.WinName + ' Business Edition'; + PRODUCT_STARTER : rtn.WinName := rtn.WinName + ' Starter Edition'; + PRODUCT_CLUSTER_SERVER : rtn.WinName := rtn.WinName + ' Cluster Server Edition'; + PRODUCT_DATACENTER_SERVER : rtn.WinName := rtn.WinName + ' Datacenter Edition'; + PRODUCT_DATACENTER_SERVER_CORE : rtn.WinName := rtn.WinName + ' Datacenter Edition (core installation)'; + PRODUCT_ENTERPRISE_SERVER : rtn.WinName := rtn.WinName + ' Enterprise Edition'; + PRODUCT_ENTERPRISE_SERVER_CORE : rtn.WinName := rtn.WinName + ' Enterprise Edition (core installation)'; + PRODUCT_ENTERPRISE_SERVER_IA64 : rtn.WinName := rtn.WinName + ' Enterprise Edition for Itanium-based Systems)'; + PRODUCT_SMALLBUSINESS_SERVER : rtn.WinName := rtn.WinName + ' Small Business Server'; + PRODUCT_SMALLBUSINESS_SERVER_PREMIUM : rtn.WinName := rtn.WinName + ' Small Business Server Premium Edition'; + PRODUCT_STANDARD_SERVER : rtn.WinName := rtn.WinName + ' Standard Edition'; + PRODUCT_STANDARD_SERVER_CORE : rtn.WinName := rtn.WinName + ' Standard Edition (core installation)'; + PRODUCT_WEB_SERVER : rtn.WinName := rtn.WinName + ' Web Server Edition'; + end; + + FreeModule(hModule); + + end; + end; + + + end {If IsEx} + else begin + // Test for specific product on Windows NT 4.0 SP5 and earlier + resVer := TRegistry.Create(KEY_READ); + try + resVer.RootKey := HKEY_LOCAL_MACHINE; + resver.OpenKeyReadOnly('SYSTEM\\CurrentControlSet\\Control\\ProductOptions'); + + szProduct := resVer.ReadString('ProductType'); + + if (Strcomp('WINNT', PChar(szProduct)) = 0) then + rtn.WinName := rtn.WinName + ' Workstation ' + else if (Strcomp('LANMANNT', PChar(szProduct)) = 0) then + rtn.WinName := rtn.WinName + ' Server ' + else if (Strcomp('SERVERNT', PChar(szProduct)) = 0) then + rtn.WinName := rtn.WinName + ' Advanced Server '; + + rtn.WinName := rtn.WinName + IntToStr(p.dwMajorVersion) + '.' + IntToStr(p.dwMinorVersion); + finally + resVer.Free; + end; + end;{else IsEx} + + //Get Version + rtn.Version.Major := p.dwMajorVersion; + rtn.Version.Minor := p.dwMinorVersion; + rtn.Version.Build := p.dwBuildNumber; + + //Get Service Pack + if ((p.dwMajorVersion = 4) and (lstrcmpiA(p.szCSDVersion, 'Service Pack 6' ) = 0)) then begin + // Test for SP6 versus SP6a. + resVer := TRegistry.Create(KEY_READ); + try + resVer.RootKey := HKEY_LOCAL_MACHINE; + if resVer.OpenKeyReadOnly('SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Hotfix\\Q246009') then + rtn.ServicePack := 'Service Pack 6a' + else + rtn.ServicePack := String(p.szCSDVersion); //warring 제거 + finally + resVer.Free; + end; + end + else + //Else Other All Version + if Boolean(p.wServicePackMajor) or Boolean(p.wServicePackMinor) then begin + rtn.ServicePack := 'Service Pack ' + intToStr(p.wServicePackMajor); + if Boolean(p.wServicePackMinor) then + rtn.ServicePack := rtn.ServicePack + '.' + IntToStr(p.wServicePackMinor); + end + else + rtn.ServicePack := String(p.szCSDVersion); + + //Create ID String and Return + rtn.WinID := 'Microsoft ' + rtn.WinName + '(Version ' + IntToStr(rtn.Version.Major) + '.' + IntToStr(rtn.Version.Minor) + + ' Build ' + IntToStr(rtn.Version.Build) + ') ' + rtn.ServicePack; + + Result := rtn; +end; + +function ParseWinNT(p: TOSVersionInfoExW; IsEx: Boolean): TWinVerInfo; +var + rtn: TWinVerInfo; + + resVer: TRegistry; + szProduct: String; + procGetProductInfo : TGetProductInfo; + hModule : THandle; + ProdType : DWORD; + dwMajor, dwMinor, dwService, dwBuildNum : DWORD; + bIsServer : Boolean; +begin + GetWindowsVersion(dwMajor, dwMinor, dwService, dwBuildNum, bIsServer); + + p.dwMajorVersion := dwMajor; + p.dwMinorVersion := dwMinor; + p.dwBuildNumber := dwBuildNum; + if not bIsServer then + begin + p.wProductType := VER_NT_WORKSTATION + end; + + //Get Windows Product + if p.dwMajorVersion = 5 then begin + if p.dwMinorVersion = 2 then + rtn.WinName := 'Windows 2003 Server Family' + else if p.dwMinorVersion = 1 then + rtn.WinName := 'Windows XP' + else if p.dwMinorVersion = 0 then + rtn.WinName := 'Windows 2000'; + end + + else if p.dwMajorVersion = 6 then + if p.dwMinorVersion = 1 then + begin + if p.wProductType = VER_NT_WORKSTATION then + rtn.WinName := 'Windows 7' + else rtn.WinName := 'Windows Server 2008 R2'; + end else if p.dwMinorVersion = 0 then + begin + if p.wProductType = VER_NT_WORKSTATION then + rtn.WinName := 'Windows Vista' + else rtn.WinName := 'Windows Server 2008'; + end + else + rtn.WinName := 'Windows NT'; + + //Get Product Substring + if (IsEX) then begin + case p.wProductType of + VER_NT_WORKSTATION: + begin + if (p.dwMajorVersion = 4) then + rtn.WinName := rtn.WinName + ' Workstation 4.0' + else if (p.wSuiteMask and VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL then + rtn.WinName := rtn.WinName + ' Home Edition' + else if p.dwMajorVersion = 6 then + begin + // 비스타의 경우.. 버전정보를 모르겠다.. 아직은.. + end else + rtn.WinName := rtn.WinName + ' Professional'; + end; + VER_NT_SERVER: + begin + if ((p.dwMajorVersion = 5) and (p.dwMinorVersion = 2)) then begin + if (p.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then + rtn.WinName := rtn.WinName + ' Datacenter Edition' + else if (p.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then + rtn.WinName := rtn.WinName + ' Enterprise Edition' + else if (p.wSuiteMask and VER_SUITE_BLADE) = VER_SUITE_BLADE then + rtn.WinName := rtn.WinName + ' Web Edition' + else + rtn.WinName := rtn.WinName + ' Standard Edition'; + end + else if ((p.dwMajorVersion = 5) and (p.dwMinorVersion = 0)) then begin + if (p.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then + rtn.WinName := rtn.WinName + ' Datacenter Server' + else if (p.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then + rtn.WinName := rtn.WinName + ' Advanced Server' + else + rtn.WinName := rtn.WinName + ' Server'; + end + else if (p.dwMajorVersion = 6) then + + else begin + if (p.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then + rtn.WinName := rtn.WinName + ' Server 4.0 Enterprise Edition' + else + rtn.WinName := rtn.WinName + ' Server 4.0'; + end; + end; + end; {case of} + + if p.dwMajorVersion = 6 then + begin + hModule := GetModuleHandle('kernel32.dll'); + procGetProductInfo := GetProcAddress( hModule ,'GetProductInfo'); + if Assigned(procGetProductInfo) then + begin + procGetProductInfo(p.dwMajorVersion, p.dwMinorVersion, 0, 0, @ProdType); + + case ProdType of + PRODUCT_ULTIMATE : rtn.WinName := rtn.WinName + ' Ultimate'; + PRODUCT_PROFESSIONAL : rtn.WinName := rtn.WinName + ' Professional'; + PRODUCT_HOME_PREMIUM : rtn.WinName := rtn.WinName + ' Home Premium Edition'; + PRODUCT_HOME_BASIC : rtn.WinName := rtn.WinName + ' Home Basic Edition'; + PRODUCT_ENTERPRISE : rtn.WinName := rtn.WinName + ' Enterprise Edition'; + PRODUCT_BUSINESS : rtn.WinName := rtn.WinName + ' Business Edition'; + PRODUCT_STARTER : rtn.WinName := rtn.WinName + ' Starter Edition'; + PRODUCT_CLUSTER_SERVER : rtn.WinName := rtn.WinName + ' Cluster Server Edition'; + PRODUCT_DATACENTER_SERVER : rtn.WinName := rtn.WinName + ' Datacenter Edition'; + PRODUCT_DATACENTER_SERVER_CORE : rtn.WinName := rtn.WinName + ' Datacenter Edition (core installation)'; + PRODUCT_ENTERPRISE_SERVER : rtn.WinName := rtn.WinName + ' Enterprise Edition'; + PRODUCT_ENTERPRISE_SERVER_CORE : rtn.WinName := rtn.WinName + ' Enterprise Edition (core installation)'; + PRODUCT_ENTERPRISE_SERVER_IA64 : rtn.WinName := rtn.WinName + ' Enterprise Edition for Itanium-based Systems)'; + PRODUCT_SMALLBUSINESS_SERVER : rtn.WinName := rtn.WinName + ' Small Business Server'; + PRODUCT_SMALLBUSINESS_SERVER_PREMIUM : rtn.WinName := rtn.WinName + ' Small Business Server Premium Edition'; + PRODUCT_STANDARD_SERVER : rtn.WinName := rtn.WinName + ' Standard Edition'; + PRODUCT_STANDARD_SERVER_CORE : rtn.WinName := rtn.WinName + ' Standard Edition (core installation)'; + PRODUCT_WEB_SERVER : rtn.WinName := rtn.WinName + ' Web Server Edition'; + + end; + + FreeModule(hModule); + end; + end; + + + end {If IsEx} + else begin + // Test for specific product on Windows NT 4.0 SP5 and earlier + resVer := TRegistry.Create(KEY_READ); + try + resVer.RootKey := HKEY_LOCAL_MACHINE; + resver.OpenKeyReadOnly('SYSTEM\\CurrentControlSet\\Control\\ProductOptions'); + + szProduct := resVer.ReadString('ProductType'); + + if (Strcomp('WINNT', PChar(szProduct)) = 0) then + rtn.WinName := rtn.WinName + ' Workstation ' + else if (Strcomp('LANMANNT', PChar(szProduct)) = 0) then + rtn.WinName := rtn.WinName + ' Server ' + else if (Strcomp('SERVERNT', PChar(szProduct)) = 0) then + rtn.WinName := rtn.WinName + ' Advanced Server '; + + rtn.WinName := rtn.WinName + IntToStr(p.dwMajorVersion) + '.' + IntToStr(p.dwMinorVersion); + finally + resVer.Free; + end; + end;{else IsEx} + + //Get Version + rtn.Version.Major := p.dwMajorVersion; + rtn.Version.Minor := p.dwMinorVersion; + rtn.Version.Build := (p.dwBuildNumber and $FFFF); + + //Get Service Pack + if ((p.dwMajorVersion = 4) and (lstrcmpW(p.szCSDVersion, 'Service Pack 6' ) = 0)) then begin + // Test for SP6 versus SP6a. + resVer := TRegistry.Create(KEY_READ); + try + resVer.RootKey := HKEY_LOCAL_MACHINE; + if resVer.OpenKeyReadOnly('SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Hotfix\\Q246009') then + rtn.ServicePack := 'Service Pack 6a' + else + rtn.ServicePack := p.szCSDVersion; + finally + resVer.Free; + end; + end + else + //Else Other All Version + if Boolean(p.wServicePackMajor) or Boolean(p.wServicePackMinor) then begin + rtn.ServicePack := 'Service Pack ' + intToStr(p.wServicePackMajor); + if Boolean(p.wServicePackMinor) then + rtn.ServicePack := rtn.ServicePack + '.' + IntToStr(p.wServicePackMinor); + end + else + rtn.ServicePack := p.szCSDVersion; + + //Create ID String and Return + rtn.WinID := 'Microsoft ' + rtn.WinName + #10#13'(Version ' + IntToStr(rtn.Version.Major) + '.' + IntToStr(rtn.Version.Minor) + + ' Build ' + IntToStr(rtn.Version.Build) + ') ' + rtn.ServicePack; + + Result := rtn; +end; + +function ParseWin9x(p: TOSVersionInfo): TWinVerInfo; +var + rtn: TWinVerInfo; +begin + if ((p.dwMajorVersion = 4) and (p.dwMinorVersion = 0)) then begin + rtn.WinName := 'Windows 95'; + if ((p.szCSDVersion[1] = 'C') or (p.szCSDVersion[1] = 'B')) then + rtn.WinName := rtn.WinName + ' OSR2'; + end + else if ((p.dwMajorVersion = 4) and (p.dwMinorVersion = 10)) then begin + rtn.WinName := 'Windows 98'; + if (p.szCSDVersion[1] = 'A') then + rtn.WinName := rtn.WinName + ' SE'; + end + else if ((p.dwMajorVersion = 4) and (p.dwMinorVersion = 90)) then + rtn.WinName := 'Windows Millennium Edition'; + + rtn.Version.Major := p.dwMajorVersion; + rtn.Version.Minor := p.dwMinorVersion; + rtn.Version.Build := (p.dwBuildNumber and $FFFF); + + rtn.ServicePack := p.szCSDVersion; + if ((p.szCSDVersion[1] = 'C') or (p.szCSDVersion[1] = 'B') or (p.szCSDVersion[1] = 'A')) then + rtn.ServicePack := RightStr(rtn.ServicePack, Length(rtn.ServicePack) - 2); + + //Create ID String and Return + rtn.WinID := 'Microsoft ' + rtn.WinName + #10#13'(Version ' + IntToStr(rtn.Version.Major) + '.' + IntToStr(rtn.Version.Minor) + + ' Build ' + IntToStr(rtn.Version.Build) + ') ' + rtn.ServicePack; + + Result := rtn; +end; + +function GetWindowsVersion(var AMajor, AMinor: DWORD): Boolean; +var + Buf: LPWKSTA_INFO_100; +begin + Result := False; + if MajorCache <> 0 then + begin + AMajor := MajorCache; + AMinor := MinorCache; + Result := True; + Exit; + end; + if NetWkstaGetInfo(nil, 100, @Buf) = NERR_Success then + begin + MajorCache := Buf.wki100_ver_major; + AMajor := MajorCache; + MinorCache := Buf.wki100_ver_minor; + AMinor := MinorCache; + NetApiBufferFree(Buf); + Result := True; + end; +end; + +function GetWindowsVersion(var AMajor, AMinor, AServicePack, ABuildNumber: DWORD; + var AIsServer: Boolean): Boolean; overload; +var + I: Integer; + osvi: OSVERSIONINFOEX; + ConditionMask: LONGLONG; +begin + Result := False; + AMajor := 0; + AMinor := 0; + AServicePack := 0; + ABuildNumber := 0; + + if not GetWindowsVersion(AMajor, AMinor) then + exit; + + if ServicePackCache <> MAXDWORD then + begin + AServicePack := ServicePackCache; + AIsServer := IsServerCache; + Result := True; + Exit; + end; + ZeroMemory(@osvi, SizeOf(OSVERSIONINFOEX)); + osvi.dwOSVersionInfoSize := SizeOf(OSVERSIONINFOEX); + ConditionMask := 0; + ConditionMask := VerSetConditionMask(ConditionMask, VER_SERVICEPACKMAJOR, VER_EQUAL); + for I := 0 to SERVICE_MAX_COUNT - 1 do + begin + osvi.wServicePackMajor := I; + if VerifyVersionInfo(osvi, VER_SERVICEPACKMAJOR, ConditionMask) then + begin + ServicePackCache := I; + AServicePack := ServicePackCache; + ZeroMemory(@osvi, SizeOf(OSVERSIONINFOEX)); + osvi.dwOSVersionInfoSize := SizeOf(OSVERSIONINFOEX); + osvi.wProductType := VER_NT_SERVER; + ConditionMask := 0; + ConditionMask := VerSetConditionMask(ConditionMask, VER_PRODUCT_TYPE, + VER_EQUAL); + IsServerCache := VerifyVersionInfo(osvi, VER_PRODUCT_TYPE, ConditionMask); + AIsServer := IsServerCache; + Result := True; + break; + end; + end; + + ConditionMask := 0; + ConditionMask := VerSetConditionMask(ConditionMask, VER_BUILDNUMBER, + VER_EQUAL); + for I := 0 to 10000 do + begin + osvi.dwBuildNumber := I; + if VerifyVersionInfo(osvi, VER_BUILDNUMBER, ConditionMask) then + begin + ABuildNumber := I; + Result := True; + Exit; + end; + end; +end; + +initialization + MajorCache := 0; + MinorCache := 0; + ServicePackCache := MAXDWORD; + IsServerCache := False; + +end. + + + + + diff --git a/Tocsg.Lib/VCL/Other/EM.jwabluetoothapis.pas b/Tocsg.Lib/VCL/Other/EM.jwabluetoothapis.pas new file mode 100644 index 00000000..e85cfd85 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.jwabluetoothapis.pas @@ -0,0 +1,2017 @@ +{******************************************************************************} +{ } +{ BlueTooth API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Contributors: John Penman } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI } +{ APILIB home page, located at http://jedi-apilib.sourceforge.net } +{ } +{ 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. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License 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 LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + + +unit EM.JwaBluetoothAPIs; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "bluetoothapis.h"'} +{$HPPEMIT ''} + +//{$I jediapilib.inc} + +interface + +uses + Windows, + EM.JwaWinType, {JwaWinBase, }EM.JwaBthSdpDef; + +const + BLUETOOTH_MAX_NAME_SIZE = 248; + {$EXTERNALSYM BLUETOOTH_MAX_NAME_SIZE} + BLUETOOTH_MAX_PASSKEY_SIZE = 16; + {$EXTERNALSYM BLUETOOTH_MAX_PASSKEY_SIZE} + BLUETOOTH_MAX_PASSKEY_BUFFER_SIZE = BLUETOOTH_MAX_PASSKEY_SIZE + 1; + {$EXTERNALSYM BLUETOOTH_MAX_PASSKEY_BUFFER_SIZE} + +// *************************************************************************** +// +// Bluetooth Address +// +// *************************************************************************** + +type + BTH_ADDR = ULONGLONG; // Int64; + {$EXTERNALSYM BTH_ADDR} + + _BLUETOOTH_ADDRESS = record + case Integer of + 0: (ullLong: BTH_ADDR); // easier to compare again BLUETOOTH_NULL_ADDRESS + 1: (rgBytes: array [0..5] of Byte); // easier to format when broken out + end; + {$EXTERNALSYM _BLUETOOTH_ADDRESS} + BLUETOOTH_ADDRESS = _BLUETOOTH_ADDRESS; + {$EXTERNALSYM BLUETOOTH_ADDRESS} + TBlueToothAddress = BLUETOOTH_ADDRESS; + PBlueToothAddress = ^BLUETOOTH_ADDRESS; + +const + BLUETOOTH_NULL_ADDRESS: TBlueToothAddress = (ullLong: 0;); + {$EXTERNALSYM BLUETOOTH_NULL_ADDRESS} + +// *************************************************************************** +// +// Radio Enumeration +// +// Description: +// This group of APIs enumerates the installed Bluetooth radios. +// +// Sample Usage: +// HANDLE hRadio; +// BLUETOOTH_FIND_RADIO_PARAMS btfrp = { sizeof(btfrp) }; +// +// HBLUETOOTH_RADIO_FIND hFind = BluetoothFindFirstRadio( &btfrp, &hRadio ); +// if ( NULL != hFind ) +// { +// do +// { +// // +// // TODO: Do something with the radio handle. +// // +// +// CloseHandle( hRadio ); +// +// } while( BluetoothFindNextRadio( hFind, &hRadio ) ); +// +// BluetoothFindRadioClose( hFind ); +// } +// +// *************************************************************************** + +type + _BLUETOOTH_FIND_RADIO_PARAMS = record + dwSize: DWORD; // IN sizeof this structure + end; + {$EXTERNALSYM _BLUETOOTH_FIND_RADIO_PARAMS} + BLUETOOTH_FIND_RADIO_PARAMS = _BLUETOOTH_FIND_RADIO_PARAMS; + {$EXTERNALSYM BLUETOOTH_FIND_RADIO_PARAMS} + TBlueToothFindRadioParams = BLUETOOTH_FIND_RADIO_PARAMS; + PBlueToothFindRadioParams = ^BLUETOOTH_FIND_RADIO_PARAMS; + + HBLUETOOTH_RADIO_FIND = THandle; + {$EXTERNALSYM HBLUETOOTH_RADIO_FIND} + +// +// Description: +// Begins the enumeration of local Bluetooth radios. +// +// Parameters: +// pbtfrp +// A pointer to a BLUETOOTH_FIND_RADIO_PARAMS structure. The dwSize +// member of this structure must match the sizeof the of the structure. +// +// phRadio +// A pointer where the first radio HANDLE enumerated will be returned. +// +// Return Values: +// NULL +// Error opening radios or no devices found. Use GetLastError() for +// more info. +// +// ERROR_INVALID_PARAMETER +// pbtfrp parameter is NULL. +// +// ERROR_REVISION_MISMATCH +// The pbtfrp structure is not the right length. +// +// ERROR_OUTOFMEMORY +// Out of memory. +// +// other Win32 errors. +// +// any other +// Success. The return handle is valid and phRadio points to a valid handle. +// + +function BluetoothFindFirstRadio(const pbtfrp: PBlueToothFindRadioParams; var phRadio: THandle): HBLUETOOTH_RADIO_FIND; stdcall; +{$EXTERNALSYM BluetoothFindFirstRadio} + +// +// Description: +// Finds the next installed Bluetooth radio. +// +// Parameters: +// hFind +// The handle returned by BluetoothFindFirstRadio(). +// +// phRadio +// A pointer where the next radio HANDLE enumerated will be returned. +// +// Return Values: +// TRUE +// Next device succesfully found. pHandleOut points to valid handle. +// +// FALSE +// No device found. pHandleOut points to an invalid handle. Call +// GetLastError() for more details. +// +// ERROR_INVALID_HANDLE +// The handle is NULL. +// +// ERROR_NO_MORE_ITEMS +// No more radios found. +// +// ERROR_OUTOFMEMORY +// Out of memory. +// +// other Win32 errors +// + +function BluetoothFindNextRadio(hFind: HBLUETOOTH_RADIO_FIND; var phRadio: THandle): BOOL; stdcall; +{$EXTERNALSYM BluetoothFindNextRadio} + +// +// Description: +// Closes the enumeration handle. +// +// Parameters +// hFind +// The handle returned by BluetoothFindFirstRadio(). +// +// Return Values: +// TRUE +// Handle succesfully closed. +// +// FALSE +// Failure. Check GetLastError() for details. +// +// ERROR_INVALID_HANDLE +// The handle is NULL. +// + +function BluetoothFindRadioClose(hFind: HBLUETOOTH_RADIO_FIND): BOOL; stdcall; +{$EXTERNALSYM BluetoothFindRadioClose} + +// *************************************************************************** +// +// Radio Information +// +// *************************************************************************** + +type + _BLUETOOTH_RADIO_INFO = record + dwSize: DWORD; // Size, in bytes, of this entire data structure + address: BLUETOOTH_ADDRESS; // Address of the local radio + szName: array [0..BLUETOOTH_MAX_NAME_SIZE - 1] of WideChar; // Name of the local radio + ulClassofDevice: ULONG; // Class of device for the local radio + lmpSubversion: Word; // lmpSubversion, manufacturer specifc. + manufacturer: Word; // Manufacturer of the radio, BTH_MFG_Xxx value. For the most up to date + // list, goto the Bluetooth specification website and get the Bluetooth + // assigned numbers document. + end; + {$EXTERNALSYM _BLUETOOTH_RADIO_INFO} + BLUETOOTH_RADIO_INFO = _BLUETOOTH_RADIO_INFO; + {$EXTERNALSYM BLUETOOTH_RADIO_INFO} + PBLUETOOTH_RADIO_INFO = ^BLUETOOTH_RADIO_INFO; + {$EXTERNALSYM PBLUETOOTH_RADIO_INFO} + TBlueToothRadioFind = BLUETOOTH_RADIO_INFO; + PBlueToothRadioFind = PBLUETOOTH_RADIO_INFO; + +// +// Description: +// Retrieves the information about the radio represented by the handle. +// +// Parameters: +// hRadio +// Handle to a local radio retrieved through BluetoothFindFirstRadio() +// et al or SetupDiEnumerateDeviceInterfaces() +// +// pRadioInfo +// Radio information to be filled in. The dwSize member must match the +// size of the structure. +// +// Return Values: +// ERROR_SUCCESS +// The information was retrieved successfully. +// +// ERROR_INVALID_PARAMETER +// pRadioInfo or hRadio is NULL. +// +// ERROR_REVISION_MISMATCH +// pRadioInfo->dwSize is invalid. +// +// other Win32 error codes. +// + +function BluetoothGetRadioInfo(hRadio: THandle; var pRadioInfo: BLUETOOTH_RADIO_INFO): DWORD; stdcall; +{$EXTERNALSYM BluetoothGetRadioInfo} + +// *************************************************************************** +// +// Device Information Stuctures +// +// *************************************************************************** + +type + _BLUETOOTH_DEVICE_INFO = record + dwSize: DWORD; // size, in bytes, of this structure - must be the sizeof(BLUETOOTH_DEVICE_INFO) + Address: BLUETOOTH_ADDRESS; // Bluetooth address + ulClassofDevice: ULONG; // Bluetooth "Class of Device" + fConnected: BOOL; // Device connected/in use + fRemembered: BOOL; // Device remembered + fAuthenticated: BOOL; // Device authenticated/paired/bonded + stLastSeen: SYSTEMTIME; // Last time the device was seen + stLastUsed: SYSTEMTIME; // Last time the device was used for other than RNR, inquiry, or SDP + szName: array [0..BLUETOOTH_MAX_NAME_SIZE - 1] of WideChar; // Name of the device + end; + {$EXTERNALSYM _BLUETOOTH_DEVICE_INFO} + BLUETOOTH_DEVICE_INFO = _BLUETOOTH_DEVICE_INFO; + {$EXTERNALSYM BLUETOOTH_DEVICE_INFO} + PBLUETOOTH_DEVICE_INFO = BLUETOOTH_DEVICE_INFO; + {$EXTERNALSYM PBLUETOOTH_DEVICE_INFO} + TBlueToothDeviceInfo = BLUETOOTH_DEVICE_INFO; + PBlueToothDeviceInfo = PBLUETOOTH_DEVICE_INFO; + +// *************************************************************************** +// +// Device Enumeration +// +// Description: +// Enumerates the Bluetooth devices. The types of returned device depends +// on the flags set in the BLUETOOTH_DEVICE_SEARCH_PARAMS (see structure +// definition for details). +// +// Sample Usage: +// HBLUETOOTH_DEVICE_FIND hFind; +// BLUETOOTH_DEVICE_SEARCH_PARAMS btsp = { sizeof(btsp) }; +// BLUETOOTH_DEVICE_INFO btdi = { sizeof(btdi) }; +// +// btsp.fReturnAuthenticated = TRUE; +// btsp.fReturnRemembered = TRUE; +// +// hFind = BluetoothFindFirstDevice( &btsp, &btdi ); +// if ( NULL != hFind ) +// { +// do +// { +// // +// // TODO: Do something useful with the device info. +// // +// +// } while( BluetoothFindNextDevice( hFind, &btdi ) ); +// +// BluetoothFindDeviceClose( hFind ); +// } +// +// *************************************************************************** + +type + _BLUETOOTH_DEVICE_SEARCH_PARAMS = record + dwSize: DWORD; // IN sizeof this structure + + fReturnAuthenticated: BOOL; // IN return authenticated devices + fReturnRemembered: BOOL; // IN return remembered devices + fReturnUnknown: BOOL; // IN return unknown devices + fReturnConnected: BOOL; // IN return connected devices + + fIssueInquiry: BOOL; // IN issue a new inquiry + cTimeoutMultiplier: UCHAR; // IN timeout for the inquiry + + hRadio: THandle; // IN handle to radio to enumerate - NULL == all radios will be searched + end; + {$EXTERNALSYM _BLUETOOTH_DEVICE_SEARCH_PARAMS} + BLUETOOTH_DEVICE_SEARCH_PARAMS = _BLUETOOTH_DEVICE_SEARCH_PARAMS; + {$EXTERNALSYM BLUETOOTH_DEVICE_SEARCH_PARAMS} + TBlueToothDeviceSearchParams = BLUETOOTH_DEVICE_SEARCH_PARAMS; + + HBLUETOOTH_DEVICE_FIND = THandle; + {$EXTERNALSYM HBLUETOOTH_DEVICE_FIND} + +// +// Description: +// Begins the enumeration of Bluetooth devices. +// +// Parameters: +// pbtsp +// A pointer to a BLUETOOTH_DEVICE_SEARCH_PARAMS structure. This +// structure contains the flags and inputs used to conduct the search. +// See BLUETOOTH_DEVICE_SEARCH_PARAMS for details. +// +// pbtdi +// A pointer to a BLUETOOTH_DEVICE_INFO structure to return information +// about the first Bluetooth device found. Note that the dwSize member +// of the structure must be the sizeof(BLUETOOTH_DEVICE_INFO) before +// calling because the APIs hast to know the size of the buffer being +// past in. The dwSize member must also match the exact +// sizeof(BLUETOOTH_DEVICE_INFO) or the call will fail. +// +// Return Values: +// NULL +// Error opening radios or not devices found. Use GetLastError for more info. +// +// ERROR_INVALID_PARAMETER +// pbtsp parameter or pbtdi parameter is NULL. +// +// ERROR_REVISION_MISMATCH +// The pbtfrp structure is not the right length. +// +// other Win32 errors +// +// any other value +// Success. The return handle is valid and pbtdi points to valid data. +// + +function BluetoothFindFirstDevice(const pbtsp: BLUETOOTH_DEVICE_SEARCH_PARAMS; var pbtdi: BLUETOOTH_DEVICE_INFO): HBLUETOOTH_DEVICE_FIND; stdcall; +{$EXTERNALSYM BluetoothFindFirstDevice} + +// +// Description: +// Finds the next Bluetooth device in the enumeration. +// +// Parameters: +// hFind +// The handle returned from BluetoothFindFirstDevice(). +// +// pbtdi +// A pointer to a BLUETOOTH_DEVICE_INFO structure to return information +// about the first Bluetooth device found. Note that the dwSize member +// of the structure must be the sizeof(BLUETOOTH_DEVICE_INFO) before +// calling because the APIs hast to know the size of the buffer being +// past in. The dwSize member must also match the exact +// sizeof(BLUETOOTH_DEVICE_INFO) or the call will fail. +// +// Return Values: +// TRUE +// Next device succesfully found. pHandleOut points to valid handle. +// +// FALSE +// No device found. pHandleOut points to an invalid handle. Call +// GetLastError() for more details. +// +// ERROR_INVALID_HANDLE +// The handle is NULL. +// +// ERROR_NO_MORE_ITEMS +// No more radios found. +// +// ERROR_OUTOFMEMORY +// Out of memory. +// +// other Win32 errors +// + +function BluetoothFindNextDevice(hFind: HBLUETOOTH_DEVICE_FIND; var pbtdi: BLUETOOTH_DEVICE_INFO): BOOL; stdcall; +{$EXTERNALSYM BluetoothFindNextDevice} + +// +// Description: +// Closes the enumeration handle. +// +// Parameters: +// hFind +// The handle returned from BluetoothFindFirstDevice(). +// +// Return Values: +// TRUE +// Handle succesfully closed. +// +// FALSE +// Failure. Check GetLastError() for details. +// +// ERROR_INVALID_HANDLE +// The handle is NULL. +// + +function BluetoothFindDeviceClose(hFind: HBLUETOOTH_DEVICE_FIND): BOOL; stdcall; +{$EXTERNALSYM BluetoothFindDeviceClose} + +// +// Description: +// Retrieves information about a remote device. +// +// Fill in the dwSize and the Address members of the pbtdi structure +// being passed in. On success, the rest of the members will be filled +// out with the information that the system knows. +// +// Parameters: +// hRadio +// Handle to a local radio retrieved through BluetoothFindFirstRadio() +// et al or SetupDiEnumerateDeviceInterfaces() +// +// pbtdi +// A pointer to a BLUETOOTH_DEVICE_INFO structure to return information +// about the first Bluetooth device found. The dwSize member of the +// structure must be the sizeof the structure in bytes. The Address +// member must be filled out with the Bluetooth address of the remote +// device. +// +// Return Values: +// ERROR_SUCCESS +// Success. Information returned. +// +// ERROR_REVISION_MISMATCH +// The size of the BLUETOOTH_DEVICE_INFO isn't compatible. Check +// the dwSize member of the BLUETOOTH_DEVICE_INFO structure you +// passed in. +// +// ERROR_NOT_FOUND +// The radio is not known by the system or the Address field of +// the BLUETOOTH_DEVICE_INFO structure is all zeros. +// +// ERROR_INVALID_PARAMETER +// pbtdi is NULL. +// +// other error codes +// + +function BluetoothGetDeviceInfo(hRadio: THandle; var pbtdi: BLUETOOTH_DEVICE_INFO): DWORD; stdcall; +{$EXTERNALSYM BluetoothGetDeviceInfo} + +// +// Description: +// Updates the computer local cache about the device. +// +// Parameters: +// pbtdi +// A pointer to the BLUETOOTH_DEVICE_INFO structure to be updated. +// The following members must be valid: +// dwSize +// Must match the size of the structure. +// Address +// Must be a previously found radio address. +// szName +// New name to be stored. +// +// Return Values: +// ERROR_SUCCESS +// The device information was updated successfully. +// +// ERROR_INVALID_PARAMETER +// pbtdi is NULL. +// +// ERROR_REVISION_MISMATCH +// pbtdi->dwSize is invalid. +// +// other Win32 error codes. +// + +function BluetoothUpdateDeviceRecord(var pbtdi: BLUETOOTH_DEVICE_INFO): DWORD; stdcall; +{$EXTERNALSYM BluetoothUpdateDeviceRecord} + +// +// Description: +// Delete the authentication (aka "bond") between the computer and the +// device. Also purges any cached information about the device. +// +// Return Values: +// ERROR_SUCCESS +// The device was removed successfully. +// +// ERROR_NOT_FOUND +// The device was not found. If no Bluetooth radio is installed, +// the devices could not be enumerated or removed. +// + +function BluetoothRemoveDevice(var pAddress: BLUETOOTH_ADDRESS): DWORD; stdcall; +{$EXTERNALSYM BluetoothRemoveDevice} + +// *************************************************************************** +// +// Device Picker Dialog +// +// Description: +// Invokes a common dialog for selecting Bluetooth devices. The list +// of devices displayed to the user is determined by the flags and +// settings the caller specifies in the BLUETOOTH_SELECT_DEVICE_PARAMS +// (see structure definition for more details). +// +// If BluetoothSelectDevices() returns TRUE, the caller must call +// BluetoothSelectDevicesFree() or memory will be leaked within the +// process. +// +// Sample Usage: +// +// BLUETOOTH_SELECT_DEVICE_PARAMS btsdp = { sizeof(btsdp) }; +// +// btsdp.hwndParent = hDlg; +// btsdp.fShowUnknown = TRUE; +// btsdp.fAddNewDeviceWizard = TRUE; +// +// BOOL b = BluetoothSelectDevices( &btsdp ); +// if ( b ) +// { +// BLUETOOTH_DEVICE_INFO * pbtdi = btsdp.pDevices; +// for ( ULONG cDevice = 0; cDevice < btsdp.cNumDevices; cDevice ++ ) +// { +// if ( pbtdi->fAuthenticated || pbtdi->fRemembered ) +// { +// // +// // TODO: Do something usefull with the device info +// // +// } +// +// pbtdi = (BLUETOOTH_DEVICE_INFO *) ((LPBYTE)pbtdi + pbtdi->dwSize); +// } +// +// BluetoothSelectDevicesFree( &btsdp ); +// } +// +// *************************************************************************** + +type + _BLUETOOTH_COD_PAIRS = record + ulCODMask: ULONG; // ClassOfDevice mask to compare + pcszDescription: LPWSTR; // Descriptive string of mask + end; + {$EXTERNALSYM _BLUETOOTH_COD_PAIRS} + BLUETOOTH_COD_PAIRS = _BLUETOOTH_COD_PAIRS; + {$EXTERNALSYM BLUETOOTH_COD_PAIRS} + TBlueToothCodPairs = BLUETOOTH_COD_PAIRS; + PBlueToothCodPairs = ^BLUETOOTH_COD_PAIRS; + + PFN_DEVICE_CALLBACK = function(pvParam: Pointer; pDevice: PBLUETOOTH_DEVICE_INFO): BOOL; stdcall; + {$EXTERNALSYM PFN_DEVICE_CALLBACK} + + _BLUETOOTH_SELECT_DEVICE_PARAMS = record + dwSize: DWORD; // IN sizeof this structure + + cNumOfClasses: ULONG; // IN Number in prgClassOfDevice - if ZERO search for all devices + prgClassOfDevices: PBlueToothCodPairs; // IN Array of CODs to find. + + pszInfo: LPWSTR; // IN If not NULL, sets the "information" text + + hwndParent: HWND; // IN parent window - NULL == no parent + + fForceAuthentication: BOOL; // IN If TRUE, authenication will be forced before returning + fShowAuthenticated: BOOL; // IN If TRUE, authenticated devices will be shown in the picker + fShowRemembered: BOOL; // IN If TRUE, remembered devices will be shown in the picker + fShowUnknown: BOOL; // IN If TRUE, unknown devices that are not authenticated or "remember" will be shown. + + fAddNewDeviceWizard: BOOL; // IN If TRUE, invokes the add new device wizard. + fSkipServicesPage: BOOL; // IN If TRUE, skips the "Services" page in the wizard. + + pfnDeviceCallback: PFN_DEVICE_CALLBACK; // IN If non-NULL, a callback that will be called for each device. If the + // the callback returns TRUE, the item will be added. If the callback is + // is FALSE, the item will not be shown. + pvParam: Pointer; // IN Parameter to be passed to pfnDeviceCallback as the pvParam. + + cNumDevices: DWORD; // IN number calles wants - ZERO == no limit. + // OUT the number of devices returned. + + pDevices: PBLUETOOTH_DEVICE_INFO; // OUT pointer to an array for BLUETOOTH_DEVICE_INFOs. + // call BluetoothSelectDevicesFree() to free + end; + {$EXTERNALSYM _BLUETOOTH_SELECT_DEVICE_PARAMS} + BLUETOOTH_SELECT_DEVICE_PARAMS = _BLUETOOTH_SELECT_DEVICE_PARAMS; + {$EXTERNALSYM BLUETOOTH_SELECT_DEVICE_PARAMS} + TBlueToothSelectDeviceParams = BLUETOOTH_SELECT_DEVICE_PARAMS; + PBlueToothSelectDeviceParams = ^BLUETOOTH_SELECT_DEVICE_PARAMS; + +// +// Description: +// (See header above) +// +// Return Values: +// TRUE +// User selected a device. pbtsdp->pDevices points to valid data. +// Caller should check the fAuthenticated && fRemembered flags to +// determine which devices we successfuly authenticated or valid +// selections by the user. +// +// Use BluetoothSelectDevicesFree() to free the nessecary data +// such as pDevices only if this function returns TRUE. +// +// FALSE +// No valid data returned. Call GetLastError() for possible details +// of the failure. If GLE() is: +// +// ERROR_CANCELLED +// The user cancelled the request. +// +// ERROR_INVALID_PARAMETER +// The pbtsdp is NULL. +// +// ERROR_REVISION_MISMATCH +// The structure passed in as pbtsdp is of an unknown size. +// +// other WIN32 errors +// + +function BluetoothSelectDevices(pbtsdp: PBlueToothSelectDeviceParams): BOOL; stdcall; +{$EXTERNALSYM BluetoothSelectDevices} + +// +// Description: +// This function should only be called if BluetoothSelectDevices() returns +// TRUE. This function will free any memory and resource returned by the +// BluetoothSelectDevices() in the BLUETOOTH_SELECT_DEVICE_PARAMS +// structure. +// +// Return Values: +// TRUE +// Success. +// +// FALSE +// Nothing to free. +// + +function BluetoothSelectDevicesFree(pbtsdp: PBlueToothSelectDeviceParams): BOOL; stdcall; +{$EXTERNALSYM BluetoothSelectDevicesFree} + +// *************************************************************************** +// +// Device Property Sheet +// +// *************************************************************************** + +// +// Description: +// Invokes the CPLs device info property sheet. +// +// Parameters: +// hwndParent +// HWND to parent the property sheet. +// +// pbtdi +// A pointer to a BLUETOOTH_DEVICE_INFO structure of the device +// to be displayed. +// +// Return Values: +// TRUE +// The property page was successfully displayed. +// +// FALSE +// Failure. The property page was not displayed. Check GetLastError +// for more details. +// + +function BluetoothDisplayDeviceProperties(hwndParent: HWND; pbtdi: PBLUETOOTH_DEVICE_INFO): BOOL; stdcall; +{$EXTERNALSYM BluetoothDisplayDeviceProperties} + +// *************************************************************************** +// +// Radio Authentication +// +// *************************************************************************** + +// +// Description: +// Sends an authentication request to a remote device. +// +// There are two modes of operation. "Wizard mode" and "Blind mode." +// +// "Wizard mode" is invoked when the pszPasskey is NULL. This will cause +// the "Bluetooth Connection Wizard" to be invoked. The user will be +// prompted to enter a passkey during the wizard after which the +// authentication request will be sent. The user will see the success +// or failure of the authentication attempt. The user will also be +// given the oppurtunity to try to fix a failed authentication. +// +// "Blind mode" is invoked when the pszPasskey is non-NULL. This will +// cause the computer to send a authentication request to the remote +// device. No UI is ever displayed. The Bluetooth status code will be +// mapped to a Win32 Error code. +// +// Parameters: +// +// hwndParent +// The window to parent the authentication wizard. If NULL, the +// wizard will be parented off the desktop. +// +// hRadio +// A valid local radio handle or NULL. If NULL, then all radios will +// be tired. If any of the radios succeed, then the call will +// succeed. +// +// pbtdi +// BLUETOOTH_DEVICE_INFO record of the device to be authenticated. +// +// pszPasskey +// PIN to be used to authenticate the device. If NULL, then UI is +// displayed and the user steps through the authentication process. +// If not NULL, no UI is shown. The passkey is NOT NULL terminated. +// +// ulPasskeyLength +// Length of szPassKey in bytes. The length must be less than or +// equal to BLUETOOTH_MAX_PASSKEY_SIZE * sizeof(WCHAR). +// +// Return Values: +// +// ERROR_SUCCESS +// Success. +// +// ERROR_CANCELLED +// User aborted the operation. +// +// ERROR_INVALID_PARAMETER +// The device structure in pbtdi is invalid. +// +// ERROR_NO_MORE_ITEMS +// The device in pbtdi is already been marked as authenticated. +// +// other WIN32 error +// Failure. Return value is the error code. +// +// For "Blind mode," here is the current mapping of Bluetooth status +// code to Win32 error codes: +// +// { BTH_ERROR_SUCCESS, ERROR_SUCCESS }, +// { BTH_ERROR_NO_CONNECTION, ERROR_DEVICE_NOT_CONNECTED }, +// { BTH_ERROR_PAGE_TIMEOUT, WAIT_TIMEOUT }, +// { BTH_ERROR_HARDWARE_FAILURE, ERROR_GEN_FAILURE }, +// { BTH_ERROR_AUTHENTICATION_FAILURE, ERROR_NOT_AUTHENTICATED }, +// { BTH_ERROR_MEMORY_FULL, ERROR_NOT_ENOUGH_MEMORY }, +// { BTH_ERROR_CONNECTION_TIMEOUT, WAIT_TIMEOUT }, +// { BTH_ERROR_LMP_RESPONSE_TIMEOUT, WAIT_TIMEOUT }, +// { BTH_ERROR_MAX_NUMBER_OF_CONNECTIONS, ERROR_REQ_NOT_ACCEP }, +// { BTH_ERROR_PAIRING_NOT_ALLOWED, ERROR_ACCESS_DENIED }, +// { BTH_ERROR_UNSPECIFIED_ERROR, ERROR_NOT_READY }, +// { BTH_ERROR_LOCAL_HOST_TERMINATED_CONNECTION, ERROR_VC_DISCONNECTED }, +// + +function BluetoothAuthenticateDevice( + hwndParent: HWND; + hRadio: THandle; + pbtbi: PBLUETOOTH_DEVICE_INFO; + pszPasskey: PWideChar; + ulPasskeyLength: ULONG): DWORD; stdcall; +{$EXTERNALSYM BluetoothAuthenticateDevice} + +// +// Description: +// Allows the caller to prompt for multiple devices to be authenticated +// within a single instance of the "Bluetooth Connection Wizard." +// +// Parameters: +// +// hwndParent +// The window to parent the authentication wizard. If NULL, the +// wizard will be parented off the desktop. +// +// hRadio +// A valid local radio handle or NULL. If NULL, then all radios will +// be tired. If any of the radios succeed, then the call will +// succeed. +// +// cDevices +// Number of devices in the rgbtdi array. +// +// rgbtdi +// An array BLUETOOTH_DEVICE_INFO records of the devices to be +// authenticated. +// +// Return Values: +// +// ERROR_SUCCESS +// Success. Check the fAuthenticate flag on each of the devices. +// +// ERROR_CANCELLED +// User aborted the operation. Check the fAuthenticate flags on +// each device to determine if any of the devices were authenticated +// before the user cancelled the operation. +// +// ERROR_INVALID_PARAMETER +// One of the items in the array of devices is invalid. +// +// ERROR_NO_MORE_ITEMS +// All the devices in the array of devices are already been marked as +// being authenticated. +// +// other WIN32 error +// Failure. Return value is the error code. +// + +function BluetoothAuthenticateMultipleDevices( + hwndParent: HWND; + hRadio: THandle; + cDevices: DWORD; + pbtdi: PBLUETOOTH_DEVICE_INFO): DWORD; stdcall; +{$EXTERNALSYM BluetoothAuthenticateMultipleDevices} + +// *************************************************************************** +// +// Bluetooth Services +// +// *************************************************************************** + +const + BLUETOOTH_SERVICE_DISABLE = $00; + {$EXTERNALSYM BLUETOOTH_SERVICE_DISABLE} + BLUETOOTH_SERVICE_ENABLE = $01; + {$EXTERNALSYM BLUETOOTH_SERVICE_ENABLE} + BLUETOOTH_SERVICE_MASK = BLUETOOTH_SERVICE_ENABLE or BLUETOOTH_SERVICE_DISABLE; + {$EXTERNALSYM BLUETOOTH_SERVICE_MASK} + +// +// Description: +// Enables/disables the services for a particular device. +// +// The system maintains a mapping of service guids to supported drivers for +// Bluetooth-enabled devices. Enabling a service installs the corresponding +// device driver. Disabling a service removes the corresponding device driver. +// +// If a non-supported service is enabled, a driver will not be installed. +// +// Parameters +// hRadio +// Handle of the local Bluetooth radio device. +// +// pbtdi +// Pointer to a BLUETOOTH_DEVICE_INFO record. +// +// pGuidService +// The service GUID on the remote device. +// +// dwServiceFlags +// Flags to adjust the service. +// BLUETOOTH_SERVICE_DISABLE - disable the service +// BLUETOOTH_SERVICE_ENABLE - enables the service +// +// Return Values: +// ERROR_SUCCESS +// The call was successful. +// +// ERROR_INVALID_PARAMETER +// dwServiceFlags are invalid. +// +// ERROR_SERVICE_DOES_NOT_EXIST +// The GUID in pGuidService is not supported. +// +// other WIN32 error +// The call failed. +// + +function BluetoothSetServiceState( + hRadio: THandle; + pbtdi: PBLUETOOTH_DEVICE_INFO; + const pGuidService: TGUID; + dwServiceFlags: DWORD): DWORD; stdcall; +{$EXTERNALSYM BluetoothSetServiceState} + +// +// Description: +// Enumerates the services guids enabled on a particular device. If hRadio +// is NULL, all device will be searched for the device and all the services +// enabled will be returned. +// +// Parameters: +// hRadio +// Handle of the local Bluetooth radio device. If NULL, it will search +// all the radios for the address in the pbtdi. +// +// pbtdi +// Pointer to a BLUETOOTH_DEVICE_INFO record. +// +// pcService +// On input, the number of records pointed to by pGuidServices. +// On output, the number of valid records return in pGuidServices. +// +// pGuidServices +// Pointer to memory that is at least *pcService in length. +// +// Return Values: +// ERROR_SUCCESS +// The call succeeded. pGuidServices is valid. +// +// ERROR_MORE_DATA +// The call succeeded. pGuidService contains an incomplete list of +// enabled service GUIDs. +// +// other WIN32 errors +// The call failed. +// + +function BluetoothEnumerateInstalledServices( + hRadio: THandle; + pbtdi: PBLUETOOTH_DEVICE_INFO; + var pcServices: DWORD; + pGuidServices: PGUID): DWORD; stdcall; +{$EXTERNALSYM BluetoothEnumerateInstalledServices} + +// +// Description: +// Change the discovery state of the local radio(s). +// If hRadio is NULL, all the radios will be set. +// +// Use BluetoothIsDiscoverable() to determine the radios current state. +// +// The system ensures that a discoverable system is connectable, thus +// the radio must allow incoming connections (see +// BluetoothEnableIncomingConnections) prior to making a radio +// discoverable. Failure to do so will result in this call failing +// (returns FALSE). +// +// Parameters: +// hRadio +// If not NULL, changes the state of a specific radio. +// If NULL, the API will interate through all the radios. +// +// fEnabled +// If FALSE, discovery will be disabled. +// +// Return Values +// TRUE +// State was successfully changed. If the caller specified NULL for +// hRadio, at least of the radios accepted the state change. +// +// FALSE +// State was not changed. If the caller specified NULL for hRadio, all +// of the radios did not accept the state change. +// + +function BluetoothEnableDiscovery(hRadio: THandle; fEnabled: BOOL): BOOL; stdcall; +{$EXTERNALSYM BluetoothEnableDiscovery} + +// +// Description: +// Determines if the Bluetooth radios are discoverable. If there are +// multiple radios, the first one to say it is discoverable will cause +// this function to return TRUE. +// +// Parameters: +// hRadio +// Handle of the radio to check. If NULL, it will check all local +// radios. +// +// Return Values: +// TRUE +// A least one radio is discoverable. +// +// FALSE +// No radios are discoverable. +// + +function BluetoothIsDiscoverable(hRadio: THandle): BOOL; stdcall; +{$EXTERNALSYM BluetoothIsDiscoverable} + +// +// Description: +// Enables/disables the state of a radio to accept incoming connections. +// If hRadio is NULL, all the radios will be set. +// +// Use BluetoothIsConnectable() to determine the radios current state. +// +// The system enforces that a radio that is not connectable is not +// discoverable too. The radio must be made non-discoverable (see +// BluetoothEnableDiscovery) prior to making a radio non-connectionable. +// Failure to do so will result in this call failing (returns FALSE). +// +// Parameters: +// hRadio +// If not NULL, changes the state of a specific radio. +// If NULL, the API will interate through all the radios. +// +// fEnabled +// If FALSE, incoming connection will be disabled. +// +// Return Values +// TRUE +// State was successfully changed. If the caller specified NULL for +// hRadio, at least of the radios accepted the state change. +// +// FALSE +// State was not changed. If the caller specified NULL for hRadio, all +// of the radios did not accept the state change. +// + +function BluetoothEnableIncomingConnections(hRadio: THandle; fEnabled: BOOL): BOOL; stdcall; +{$EXTERNALSYM BluetoothEnableIncomingConnections} + +// +// Description: +// Determines if the Bluetooth radios are connectable. If there are +// multiple radios, the first one to say it is connectable will cause +// this function to return TRUE. +// +// Parameters: +// hRadio +// Handle of the radio to check. If NULL, it will check all local +// radios. +// +// Return Values: +// TRUE +// A least one radio is allowing incoming connections. +// +// FALSE +// No radios are allowing incoming connections. +// + +function BluetoothIsConnectable(hRadio: THandle): BOOL; stdcall; +{$EXTERNALSYM BluetoothIsConnectable} + +// *************************************************************************** +// +// Authentication Registration +// +// *************************************************************************** + +type + HBLUETOOTH_AUTHENTICATION_REGISTRATION = THandle; + {$EXTERNALSYM HBLUETOOTH_AUTHENTICATION_REGISTRATION} + + PFN_AUTHENTICATION_CALLBACK = function(pvParam: Pointer; pDevice: PBLUETOOTH_DEVICE_INFO): BOOL; stdcall; + {$EXTERNALSYM PFN_AUTHENTICATION_CALLBACK} + +// +// Description: +// Registers a callback function to be called when a particular device +// requests authentication. The request is sent to the last application +// that requested authentication for a particular device. +// +// Parameters: +// pbtdi +// A pointer to a BLUETOOTH_DEVICE_INFO structure. The Bluetooth +// address will be used for comparision. +// +// phRegHandle +// A pointer to where the registration HANDLE value will be +// stored. Call BluetoothUnregisterAuthentication() to close +// the handle. +// +// pfnCallback +// The function that will be called when the authentication event +// occurs. This function should match PFN_AUTHENTICATION_CALLBACK's +// prototype. +// +// pvParam +// Optional parameter to be past through to the callback function. +// This can be anything the application was to define. +// +// Return Values: +// ERROR_SUCCESS +// Success. A valid registration handle was returned. +// +// ERROR_OUTOFMEMORY +// Out of memory. +// +// other Win32 error. +// Failure. The registration handle is invalid. +// + +function BluetoothRegisterForAuthentication( + pbtdi: PBLUETOOTH_DEVICE_INFO; + var phRegHandle: HBLUETOOTH_AUTHENTICATION_REGISTRATION; + pfnCallback: PFN_AUTHENTICATION_CALLBACK; + pvParam: Pointer): DWORD; stdcall; +{$EXTERNALSYM BluetoothRegisterForAuthentication} + +// +// Description: +// Unregisters an authentication callback and closes the handle. See +// BluetoothRegisterForAuthentication() for more information about +// authentication registration. +// +// Parameters: +// hRegHandle +// Handle returned by BluetoothRegisterForAuthentication(). +// +// Return Value: +// TRUE +// The handle was successfully closed. +// +// FALSE +// The handle was not successfully closed. Check GetLastError for +// more details. +// +// ERROR_INVALID_HANDLE +// The handle is NULL. +// +// other Win32 errors. +// + +function BluetoothUnregisterAuthentication(hRegHandle: HBLUETOOTH_AUTHENTICATION_REGISTRATION): BOOL; stdcall; +{$EXTERNALSYM BluetoothUnregisterAuthentication} + +// +// Description: +// This function should be called after receiving an authentication request +// to send the passkey response. +// +// Parameters: +// +// hRadio +// Optional handle to the local radio. If NULL, the function will try +// each radio until one succeeds. +// +// pbtdi +// A pointer to a BLUETOOTH_DEVICE_INFO structure describing the device +// being authenticated. This can be the same structure passed to the +// callback function. +// +// pszPasskey +// A pointer to UNICODE zero-terminated string of the passkey response +// that should be sent back to the authenticating device. +// +// Return Values: +// ERROR_SUCESS +// The device accepted the passkey response. The device is authenticated. +// +// ERROR_CANCELED +// The device denied the passkey reponse. This also will returned if there +// is a communications problem with the local radio. +// +// E_FAIL +// The device returned a failure code during authentication. +// +// other Win32 error codes +// + +function BluetoothSendAuthenticationResponse( + hRadio: THandle; + pbtdi: PBLUETOOTH_DEVICE_INFO; + pszPasskey: LPWSTR): DWORD; stdcall; +{$EXTERNALSYM BluetoothSendAuthenticationResponse} + +// *************************************************************************** +// +// SDP Parsing Functions +// +// *************************************************************************** + +type + TSpdElementDataString = record + // raw string buffer, may not be encoded as ANSI, use + // BluetoothSdpGetString to convert the value if it is described + // by the base language attribute ID list + value: PBYTE; + // raw length of the string, may not be NULL terminuated + length: ULONG; + end; + + TSpdElementDataUrl = record + value: PBYTE; + length: ULONG; + end; + + // type == SDP_TYPE_SEQUENCE + TSpdElementDataSequence = record + // raw sequence, starts at sequence element header + value: PBYTE; + // raw sequence length + length: ULONG; + end; + + // type == SDP_TYPE_ALTERNATIVE + TSpdElementDataAlternative = record + // raw alternative, starts at alternative element header + value: PBYTE; + // raw alternative length + length: ULONG; + end; + + _SDP_ELEMENT_DATA = record + // + // Enumeration of SDP element types. Generic element types will have a + // specificType value other then SDP_ST_NONE. The generic types are: + // o SDP_TYPE_UINT + // o SDP_TYPE_INT + // o SDP_TYPE_UUID + // + type_: SDP_TYPE; + + // + // Specific types for the generic SDP element types. + // + specificType: SDP_SPECIFICTYPE; + + // + // Union of all possible data types. type and specificType will indicate + // which field is valid. For types which do not have a valid specificType, + // specific type will be SDP_ST_NONE. + // + case Integer of + // type == SDP_TYPE_INT + 0: (int128: SDP_LARGE_INTEGER_16); // specificType == SDP_ST_INT128 + 1: (int64: LONGLONG); // specificType == SDP_ST_INT64 + 2: (int32: Integer); // specificType == SDP_ST_INT32 + 3: (int16: SHORT); // specificType == SDP_ST_INT16 + 4: (int8: CHAR); // specificType == SDP_ST_INT8 + + // type == SDP_TYPE_UINT + 5: (uint128: SDP_ULARGE_INTEGER_16); // specificType == SDP_ST_UINT128 + 6: (uint64: Int64); // specificType == SDP_ST_UINT64 + 7: (uint32: ULONG); // specificType == SDP_ST_UINT32 + 8: (uint16: Word); // specificType == SDP_ST_UINT16 + 9: (uint8: UCHAR); // specificType == SDP_ST_UINT8 + + // type == SDP_TYPE_BOOLEAN + 10: (booleanVal: UCHAR); + + // type == SDP_TYPE_UUID + 11: (uuid128: TGUID); // specificType == SDP_ST_UUID128 + 12: (uuid32: ULONG); // specificType == SDP_ST_UUID32 + 13: (uuid16: Word); // specificType == SDP_ST_UUID32 + + // type == SDP_TYPE_STRING + 14: (string_: TSpdElementDataString); + // type == SDP_TYPE_URL + 15: (url: TSpdElementDataUrl); + + // type == SDP_TYPE_SEQUENCE + 16: (sequence: TSpdElementDataSequence); + + // type == SDP_TYPE_ALTERNATIVE + 17: (alternative: TSpdElementDataAlternative); + end; + {$EXTERNALSYM _SDP_ELEMENT_DATA} + SDP_ELEMENT_DATA = _SDP_ELEMENT_DATA; + {$EXTERNALSYM SDP_ELEMENT_DATA} + PSDP_ELEMENT_DATA = ^SDP_ELEMENT_DATA; + {$EXTERNALSYM PSDP_ELEMENT_DATA} + TSdpElementData = SDP_ELEMENT_DATA; + PSdpElementData = PSDP_ELEMENT_DATA; + +// +// Description: +// Retrieves and parses the element found at pSdpStream +// +// Parameters: +// IN pSdpStream +// pointer to valid SDP stream +// +// IN cbSdpStreamLength +// length of pSdpStream in bytes +// +// OUT pData +// pointer to be filled in with the data of the SDP element at the +// beginning of pSdpStream +// +// Return Values: +// ERROR_INVALID_PARAMETER +// one of required parameters is NULL or the pSdpStream is invalid +// +// ERROR_SUCCESS +// the sdp element was parsed correctly +// + +function BluetoothSdpGetElementData( + pSdpStream: PBYTE; + cbSdpStreamLength: ULONG; + pData: PSDP_ELEMENT_DATA): DWORD; stdcall; +{$EXTERNALSYM BluetoothSdpGetElementData} + +type + HBLUETOOTH_CONTAINER_ELEMENT = THandle; + {$EXTERNALSYM HBLUETOOTH_CONTAINER_ELEMENT} + +// +// Description: +// Iterates over a container stream, returning each elemetn contained with +// in the container element at the beginning of pContainerStream +// +// Parameters: +// IN pContainerStream +// pointer to valid SDP stream whose first element is either a sequence +// or alternative +// +// IN cbContainerlength +// length in bytes of pContainerStream +// +// IN OUT pElement +// Value used to keep track of location within the stream. The first +// time this function is called for a particular container, *pElement +// should equal NULL. Upon subsequent calls, the value should be +// unmodified. +// +// OUT pData +// pointer to be filled in with the data of the SDP element at the +// current element of pContainerStream +// +// Return Values: +// ERROR_SUCCESS +// The call succeeded, pData contains the data +// +// ERROR_NO_MORE_ITEMS +// There are no more items in the list, the caller should cease calling +// BluetoothSdpGetContainerElementData for this container. +// +// ERROR_INVALID_PARAMETER +// A required pointer is NULL or the container is not a valid SDP +// stream +// +// Usage example: +// +// HBLUETOOTH_CONTAINER_ELEMENT element; +// SDP_ELEMENT_DATA data; +// ULONG result; +// +// element = NULL; +// +// while (TRUE) { +// result = BluetoothSdpGetContainerElementData( +// pContainer, ulContainerLength, &element, &data); +// +// if (result == ERROR_NO_MORE_ITEMS) { +// // We are done +// break; +// } +// else if (result != ERROR_SUCCESS) { +// // error +// } +// +// // do something with data ... +// } +// +// + +function BluetoothSdpGetContainerElementData( + pContainerStream: PBYTE; + cbContainerLength: ULONG; + var pElement: HBLUETOOTH_CONTAINER_ELEMENT; + pData: PSDP_ELEMENT_DATA): DWORD; stdcall; +{$EXTERNALSYM BluetoothSdpGetContainerElementData} + +// +// Description: +// Retrieves the attribute value for the given attribute ID. pRecordStream +// must be an SDP stream that is formatted as an SDP record, a SEQUENCE +// containing UINT16 + element pairs. +// +// Parameters: +// IN pRecordStream +// pointer to a valid SDP stream which is formatted as a singl SDP +// record +// +// IN cbRecordlnegh +// length of pRecordStream in bytes +// +// IN usAttributeId +// the attribute ID to search for. see bthdef.h for SDP_ATTRIB_Xxx +// values. +// +// OUT pAttributeData +// pointer that will contain the attribute ID's value +// +// Return Values: +// ERRROR_SUCCESS +// Call succeeded, pAttributeData contains the attribute value +// +// ERROR_INVALID_PARAMETER +// One of the required pointers was NULL, pRecordStream was not a valid +// SDP stream, or pRecordStream was not a properly formatted SDP record +// +// ERROR_FILE_NOT_FOUND +// usAttributeId was not found in the record +// +// Usage: +// +// ULONG result; +// SDP_DATA_ELEMENT data; +// +// result = BluetoothSdpGetAttributeValue( +// pRecordStream, cbRecordLength, SDP_ATTRIB_RECORD_HANDLE, &data); +// if (result == ERROR_SUCCESS) { +// printf("record handle is 0x%x\n", data.data.uint32); +// } +// + +function BluetoothSdpGetAttributeValue( + pRecordStream: PBYTE; + cbRecordLength: ULONG; + usAttributeId: Word; + pAttributeData: PSDP_ELEMENT_DATA): DWORD; stdcall; +{$EXTERNALSYM BluetoothSdpGetAttributeValue} + +// +// These three fields correspond one to one with the triplets defined in the +// SDP specification for the language base attribute ID list. +// + +type + _SDP_STRING_TYPE_DATA = record + // + // How the string is encoded according to ISO 639:1988 (E/F): "Code + // for the representation of names of languages". + // + encoding: Word; + + // + // MIBE number from IANA database + // + mibeNum: Word; + + // + // The base attribute where the string is to be found in the record + // + attributeId: Word; + end; + {$EXTERNALSYM _SDP_STRING_TYPE_DATA} + SDP_STRING_TYPE_DATA = _SDP_STRING_TYPE_DATA; + {$EXTERNALSYM SDP_STRING_TYPE_DATA} + PSDP_STRING_TYPE_DATA = ^SDP_STRING_TYPE_DATA; + {$EXTERNALSYM PSDP_STRING_TYPE_DATA} + TSdpStringTypeData = SDP_STRING_TYPE_DATA; + PSdpStringTypeData = PSDP_STRING_TYPE_DATA; + +// +// Description: +// Converts a raw string embedded in the SDP record into a UNICODE string +// +// Parameters: +// IN pRecordStream +// a valid SDP stream which is formatted as an SDP record +// +// IN cbRecordLength +// length of pRecordStream in bytes +// +// IN pStringData +// if NULL, then the calling thread's locale will be used to search +// for a matching string in the SDP record. If not NUL, the mibeNum +// and attributeId will be used to find the string to convert. +// +// IN usStringOffset +// the SDP string type offset to convert. usStringOffset is added to +// the base attribute id of the string. SDP specification defined +// offsets are: STRING_NAME_OFFSET, STRING_DESCRIPTION_OFFSET, and +// STRING_PROVIDER_NAME_OFFSET (found in bthdef.h). +// +// OUT pszString +// if NULL, pcchStringLength will be filled in with the required number +// of characters (not bytes) to retrieve the converted string. +// +// IN OUT pcchStringLength +// Upon input, if pszString is not NULL, will contain the length of +// pszString in characters. Upon output, it will contain either the +// number of required characters including NULL if an error is returned +// or the number of characters written to pszString (including NULL). +// +// Return Values: +// ERROR_SUCCES +// Call was successful and pszString contains the converted string +// +// ERROR_MORE_DATA +// pszString was NULL or too small to contain the converted string, +// pccxhStringLength contains the required length in characters +// +// ERROR_INVALID_DATA +// Could not perform the conversion +// +// ERROR_NO_SYSTEM_RESOURCES +// Could not allocate memory internally to perform the conversion +// +// ERROR_INVALID_PARAMETER +// One of the rquired pointers was NULL, pRecordStream was not a valid +// SDP stream, pRecordStream was not a properly formatted record, or +// the desired attribute + offset was not a string. +// +// Other HRESULTs returned by COM +// + +function BluetoothSdpGetString( + pRecordStream: PBYTE; + cbRecordLength: ULONG; + pStringData: PSDP_STRING_TYPE_DATA; + usStringOffset: Word; + pszString: PWideChar; + pcchStringLength: PULONG): DWORD; stdcall; +{$EXTERNALSYM BluetoothSdpGetString} + +// *************************************************************************** +// +// Raw Attribute Enumeration +// +// *************************************************************************** + +type + PFN_BLUETOOTH_ENUM_ATTRIBUTES_CALLBACK = function( + uAttribId: ULONG; + pValueStream: PBYTE; + cbStreamSize: ULONG; + pvParam: Pointer): BOOL; stdcall; + {$EXTERNALSYM PFN_BLUETOOTH_ENUM_ATTRIBUTES_CALLBACK} + +// +// Description: +// Enumerates through the SDP record stream calling the Callback function +// for each attribute in the record. If the Callback function returns +// FALSE, the enumeration is stopped. +// +// Return Values: +// TRUE +// Success! Something was enumerated. +// +// FALSE +// Failure. GetLastError() could be one of the following: +// +// ERROR_INVALID_PARAMETER +// pSDPStream or pfnCallback is NULL. +// +// ERROR_INVALID_DATA +// The SDP stream is corrupt. +// +// other Win32 errors. +// + +function BluetoothSdpEnumAttributes( + pSDPStream: PBYTE; + cbStreamSize: ULONG; + pfnCallback: PFN_BLUETOOTH_ENUM_ATTRIBUTES_CALLBACK; + pvParam: Pointer): BOOL; stdcall; +{$EXTERNALSYM BluetoothSdpEnumAttributes} + +// (rom) MACRO +function BluetoothEnumAttributes( + pSDPStream: PBYTE; + cbStreamSize: ULONG; + pfnCallback: PFN_BLUETOOTH_ENUM_ATTRIBUTES_CALLBACK; + pvParam: Pointer): BOOL; +{$EXTERNALSYM BluetoothEnumAttributes} + +implementation + +const + btapi = 'irprops.cpl'; + +// (rom) MACRO implementation +function BluetoothEnumAttributes(pSDPStream: PBYTE; cbStreamSize: ULONG; + pfnCallback: PFN_BLUETOOTH_ENUM_ATTRIBUTES_CALLBACK; pvParam: Pointer): BOOL; +begin + Result := BluetoothSdpEnumAttributes(pSDPStream, cbStreamSize, pfnCallback, pvParam); +end; + +{$IFDEF DYNAMIC_LINK} + +var + _BluetoothFindFirstRadio: Pointer; + +function BluetoothFindFirstRadio; +begin + GetProcedureAddress(_BluetoothFindFirstRadio, btapi, 'BluetoothFindFirstRadio'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothFindFirstRadio] + end; +end; + +var + _BluetoothFindNextRadio: Pointer; + +function BluetoothFindNextRadio; +begin + GetProcedureAddress(_BluetoothFindNextRadio, btapi, 'BluetoothFindNextRadio'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothFindNextRadio] + end; +end; + +var + _BluetoothFindRadioClose: Pointer; + +function BluetoothFindRadioClose; +begin + GetProcedureAddress(_BluetoothFindRadioClose, btapi, 'BluetoothFindRadioClose'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothFindRadioClose] + end; +end; + +var + _BluetoothGetRadioInfo: Pointer; + +function BluetoothGetRadioInfo; +begin + GetProcedureAddress(_BluetoothGetRadioInfo, btapi, 'BluetoothGetRadioInfo'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothGetRadioInfo] + end; +end; + +var + _BluetoothFindFirstDevice: Pointer; + +function BluetoothFindFirstDevice; +begin + GetProcedureAddress(_BluetoothFindFirstDevice, btapi, 'BluetoothFindFirstDevice'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothFindFirstDevice] + end; +end; + +var + _BluetoothFindNextDevice: Pointer; + +function BluetoothFindNextDevice; +begin + GetProcedureAddress(_BluetoothFindNextDevice, btapi, 'BluetoothFindNextDevice'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothFindNextDevice] + end; +end; + +var + _BluetoothFindDeviceClose: Pointer; + +function BluetoothFindDeviceClose; +begin + GetProcedureAddress(_BluetoothFindDeviceClose, btapi, 'BluetoothFindDeviceClose'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothFindDeviceClose] + end; +end; + +var + _BluetoothGetDeviceInfo: Pointer; + +function BluetoothGetDeviceInfo; +begin + GetProcedureAddress(_BluetoothGetDeviceInfo, btapi, 'BluetoothGetDeviceInfo'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothGetDeviceInfo] + end; +end; + +var + _BluetoothUpdateDeviceRecord: Pointer; + +function BluetoothUpdateDeviceRecord; +begin + GetProcedureAddress(_BluetoothUpdateDeviceRecord, btapi, 'BluetoothUpdateDeviceRecord'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothUpdateDeviceRecord] + end; +end; + +var + _BluetoothRemoveDevice: Pointer; + +function BluetoothRemoveDevice; +begin + GetProcedureAddress(_BluetoothRemoveDevice, btapi, 'BluetoothRemoveDevice'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothRemoveDevice] + end; +end; + +var + _BluetoothSelectDevices: Pointer; + +function BluetoothSelectDevices; +begin + GetProcedureAddress(_BluetoothSelectDevices, btapi, 'BluetoothSelectDevices'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSelectDevices] + end; +end; + +var + _BluetoothSelectDevicesFree: Pointer; + +function BluetoothSelectDevicesFree; +begin + GetProcedureAddress(_BluetoothSelectDevicesFree, btapi, 'BluetoothSelectDevicesFree'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSelectDevicesFree] + end; +end; + +var + _BluetoothDisplayDeviceProperties: Pointer; + +function BluetoothDisplayDeviceProperties; +begin + GetProcedureAddress(_BluetoothDisplayDeviceProperties, btapi, 'BluetoothDisplayDeviceProperties'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothDisplayDeviceProperties] + end; +end; + +var + _BluetoothAuthenticateDevice: Pointer; + +function BluetoothAuthenticateDevice; +begin + GetProcedureAddress(_BluetoothAuthenticateDevice, btapi, 'BluetoothAuthenticateDevice'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothAuthenticateDevice] + end; +end; + +var + _BluetoothAuthenticateMultipleDevices: Pointer; + +function BluetoothAuthenticateMultipleDevices; +begin + GetProcedureAddress(_BluetoothAuthenticateMultipleDevices, btapi, 'BluetoothAuthenticateMultipleDevices'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothAuthenticateMultipleDevices] + end; +end; + +var + _BluetoothSetServiceState: Pointer; + +function BluetoothSetServiceState; +begin + GetProcedureAddress(_BluetoothSetServiceState, btapi, 'BluetoothSetServiceState'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSetServiceState] + end; +end; + +var + _BluetoothEnumerateInstalledServices: Pointer; + +function BluetoothEnumerateInstalledServices; +begin + GetProcedureAddress(_BluetoothEnumerateInstalledServices, btapi, 'BluetoothEnumerateInstalledServices'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothEnumerateInstalledServices] + end; +end; + +var + _BluetoothEnableDiscovery: Pointer; + +function BluetoothEnableDiscovery; +begin + GetProcedureAddress(_BluetoothEnableDiscovery, btapi, 'BluetoothEnableDiscovery'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothEnableDiscovery] + end; +end; + +var + _BluetoothIsDiscoverable: Pointer; + +function BluetoothIsDiscoverable; +begin + GetProcedureAddress(_BluetoothIsDiscoverable, btapi, 'BluetoothIsDiscoverable'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothIsDiscoverable] + end; +end; + +var + _BluetoothEnableIncomingConnections: Pointer; + +function BluetoothEnableIncomingConnections; +begin + GetProcedureAddress(_BluetoothEnableIncomingConnections, btapi, 'BluetoothEnableIncomingConnections'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothEnableIncomingConnections] + end; +end; + +var + _BluetoothIsConnectable: Pointer; + +function BluetoothIsConnectable; +begin + GetProcedureAddress(_BluetoothIsConnectable, btapi, 'BluetoothIsConnectable'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothIsConnectable] + end; +end; + +var + _BluetoothRegisterForAuthentication: Pointer; + +function BluetoothRegisterForAuthentication; +begin + GetProcedureAddress(_BluetoothRegisterForAuthentication, btapi, 'BluetoothRegisterForAuthentication'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothRegisterForAuthentication] + end; +end; + +var + _BluetoothUnregisterAuthentication: Pointer; + +function BluetoothUnregisterAuthentication; +begin + GetProcedureAddress(_BluetoothUnregisterAuthentication, btapi, 'BluetoothUnregisterAuthentication'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothUnregisterAuthentication] + end; +end; + +var + _BluetoothSendAuthenticationResponse: Pointer; + +function BluetoothSendAuthenticationResponse; +begin + GetProcedureAddress(_BluetoothSendAuthenticationResponse, btapi, 'BluetoothSendAuthenticationResponse'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSendAuthenticationResponse] + end; +end; + +var + _BluetoothSdpGetElementData: Pointer; + +function BluetoothSdpGetElementData; +begin + GetProcedureAddress(_BluetoothSdpGetElementData, btapi, 'BluetoothSdpGetElementData'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSdpGetElementData] + end; +end; + +var + _BluetoothSdpGetContainerElementData: Pointer; + +function BluetoothSdpGetContainerElementData; +begin + GetProcedureAddress(_BluetoothSdpGetContainerElementData, btapi, 'BluetoothSdpGetContainerElementData'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSdpGetContainerElementData] + end; +end; + +var + _BluetoothSdpGetAttributeValue: Pointer; + +function BluetoothSdpGetAttributeValue; +begin + GetProcedureAddress(_BluetoothSdpGetAttributeValue, btapi, 'BluetoothSdpGetAttributeValue'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSdpGetAttributeValue] + end; +end; + +var + _BluetoothSdpGetString: Pointer; + +function BluetoothSdpGetString; +begin + GetProcedureAddress(_BluetoothSdpGetString, btapi, 'BluetoothSdpGetString'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSdpGetString] + end; +end; + +var + _BluetoothSdpEnumAttributes: Pointer; + +function BluetoothSdpEnumAttributes; +begin + GetProcedureAddress(_BluetoothSdpEnumAttributes, btapi, 'BluetoothSdpEnumAttributes'); + asm + MOV ESP, EBP + POP EBP + JMP [_BluetoothSdpEnumAttributes] + end; +end; + +{$ELSE} + +function BluetoothFindFirstRadio; external btapi name 'BluetoothFindFirstRadio'; +function BluetoothFindNextRadio; external btapi name 'BluetoothFindNextRadio'; +function BluetoothFindRadioClose; external btapi name 'BluetoothFindRadioClose'; +function BluetoothGetRadioInfo; external btapi name 'BluetoothGetRadioInfo'; +function BluetoothFindFirstDevice; external btapi name 'BluetoothFindFirstDevice'; +function BluetoothFindNextDevice; external btapi name 'BluetoothFindNextDevice'; +function BluetoothFindDeviceClose; external btapi name 'BluetoothFindDeviceClose'; +function BluetoothGetDeviceInfo; external btapi name 'BluetoothGetDeviceInfo'; +function BluetoothUpdateDeviceRecord; external btapi name 'BluetoothUpdateDeviceRecord'; +function BluetoothRemoveDevice; external btapi name 'BluetoothRemoveDevice'; +function BluetoothSelectDevices; external btapi name 'BluetoothSelectDevices'; +function BluetoothSelectDevicesFree; external btapi name 'BluetoothSelectDevicesFree'; +function BluetoothDisplayDeviceProperties; external btapi name 'BluetoothDisplayDeviceProperties'; +function BluetoothAuthenticateDevice; external btapi name 'BluetoothAuthenticateDevice'; +function BluetoothAuthenticateMultipleDevices; external btapi name 'BluetoothAuthenticateMultipleDevices'; +function BluetoothSetServiceState; external btapi name 'BluetoothSetServiceState'; +function BluetoothEnumerateInstalledServices; external btapi name 'BluetoothEnumerateInstalledServices'; +function BluetoothEnableDiscovery; external btapi name 'BluetoothEnableDiscovery'; +function BluetoothIsDiscoverable; external btapi name 'BluetoothIsDiscoverable'; +function BluetoothEnableIncomingConnections; external btapi name 'BluetoothEnableIncomingConnections'; +function BluetoothIsConnectable; external btapi name 'BluetoothIsConnectable'; +function BluetoothRegisterForAuthentication; external btapi name 'BluetoothRegisterForAuthentication'; +function BluetoothUnregisterAuthentication; external btapi name 'BluetoothUnregisterAuthentication'; +function BluetoothSendAuthenticationResponse; external btapi name 'BluetoothSendAuthenticationResponse'; +function BluetoothSdpGetElementData; external btapi name 'BluetoothSdpGetElementData'; +function BluetoothSdpGetContainerElementData; external btapi name 'BluetoothSdpGetContainerElementData'; +function BluetoothSdpGetAttributeValue; external btapi name 'BluetoothSdpGetAttributeValue'; +function BluetoothSdpGetString; external btapi name 'BluetoothSdpGetString'; +function BluetoothSdpEnumAttributes; external btapi name 'BluetoothSdpEnumAttributes'; + +{$ENDIF DYNAMIC_LINK} + +end. + + + diff --git a/Tocsg.Lib/VCL/Other/EM.jwawinnt.pas b/Tocsg.Lib/VCL/Other/EM.jwawinnt.pas new file mode 100644 index 00000000..d40c1401 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.jwawinnt.pas @@ -0,0 +1,9307 @@ +{******************************************************************************} +{ } +{ Windows Types API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ The original file is: winnt.h, released August 2001. The original Pascal } +{ code is: WinNT.pas, released December 2000. The initial developer of the } +{ Pascal code is Marcel van Brakel (brakelm att chello dott nl). } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI } +{ APILIB home page, located at http://jedi-apilib.sourceforge.net } +{ } +{ 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. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License 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 LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + + +unit EM.jwawinnt; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "winnt.h"'} +{$HPPEMIT ''} +{$HPPEMIT 'typedef PACL *PPACL'} +{$HPPEMIT 'typedef PSID *PPSID'} +{$HPPEMIT 'typedef PSECURITY_DESCRIPTOR *PPSECURITY_DESCRIPTOR'} +{$HPPEMIT ''} + +//{$I jediapilib.inc} + +interface + +uses + EM.JwaWinType; + +const + MAXBYTE = BYTE($ff); + {$EXTERNALSYM MAXBYTE} + MAXWORD = WORD($ffff); + {$EXTERNALSYM MAXWORD} + MAXDWORD = DWORD($ffffffff); + {$EXTERNALSYM MAXDWORD} + +const + VER_SERVER_NT = DWORD($80000000); + {$EXTERNALSYM VER_SERVER_NT} + VER_WORKSTATION_NT = $40000000; + {$EXTERNALSYM VER_WORKSTATION_NT} + VER_SUITE_SMALLBUSINESS = $00000001; + {$EXTERNALSYM VER_SUITE_SMALLBUSINESS} + VER_SUITE_ENTERPRISE = $00000002; + {$EXTERNALSYM VER_SUITE_ENTERPRISE} + VER_SUITE_BACKOFFICE = $00000004; + {$EXTERNALSYM VER_SUITE_BACKOFFICE} + VER_SUITE_COMMUNICATIONS = $00000008; + {$EXTERNALSYM VER_SUITE_COMMUNICATIONS} + VER_SUITE_TERMINAL = $00000010; + {$EXTERNALSYM VER_SUITE_TERMINAL} + VER_SUITE_SMALLBUSINESS_RESTRICTED = $00000020; + {$EXTERNALSYM VER_SUITE_SMALLBUSINESS_RESTRICTED} + VER_SUITE_EMBEDDEDNT = $00000040; + {$EXTERNALSYM VER_SUITE_EMBEDDEDNT} + VER_SUITE_DATACENTER = $00000080; + {$EXTERNALSYM VER_SUITE_DATACENTER} + VER_SUITE_SINGLEUSERTS = $00000100; + {$EXTERNALSYM VER_SUITE_SINGLEUSERTS} + VER_SUITE_PERSONAL = $00000200; + {$EXTERNALSYM VER_SUITE_PERSONAL} + VER_SUITE_BLADE = $00000400; + {$EXTERNALSYM VER_SUITE_BLADE} + VER_SUITE_EMBEDDED_RESTRICTED = $00000800; + {$EXTERNALSYM VER_SUITE_EMBEDDED_RESTRICTED} + VER_SUITE_SECURITY_APPLIANCE = $00001000; + {$EXTERNALSYM VER_SUITE_SECURITY_APPLIANCE} + +// +// Language IDs. +// +// The following two combinations of primary language ID and +// sublanguage ID have special semantics: +// +// Primary Language ID Sublanguage ID Result +// ------------------- --------------- ------------------------ +// LANG_NEUTRAL SUBLANG_NEUTRAL Language neutral +// LANG_NEUTRAL SUBLANG_DEFAULT User default language +// LANG_NEUTRAL SUBLANG_SYS_DEFAULT System default language +// LANG_INVARIANT SUBLANG_NEUTRAL Invariant locale +// + +// +// Primary language IDs. +// + +const + LANG_NEUTRAL = $00; + {$EXTERNALSYM LANG_NEUTRAL} + LANG_INVARIANT = $7f; + {$EXTERNALSYM LANG_INVARIANT} + + LANG_AFRIKAANS = $36; + {$EXTERNALSYM LANG_AFRIKAANS} + LANG_ALBANIAN = $1c; + {$EXTERNALSYM LANG_ALBANIAN} + LANG_ARABIC = $01; + {$EXTERNALSYM LANG_ARABIC} + LANG_ARMENIAN = $2b; + {$EXTERNALSYM LANG_ARMENIAN} + LANG_ASSAMESE = $4d; + {$EXTERNALSYM LANG_ASSAMESE} + LANG_AZERI = $2c; + {$EXTERNALSYM LANG_AZERI} + LANG_BASQUE = $2d; + {$EXTERNALSYM LANG_BASQUE} + LANG_BELARUSIAN = $23; + {$EXTERNALSYM LANG_BELARUSIAN} + LANG_BENGALI = $45; + {$EXTERNALSYM LANG_BENGALI} + LANG_BULGARIAN = $02; + {$EXTERNALSYM LANG_BULGARIAN} + LANG_CATALAN = $03; + {$EXTERNALSYM LANG_CATALAN} + LANG_CHINESE = $04; + {$EXTERNALSYM LANG_CHINESE} + LANG_CROATIAN = $1a; + {$EXTERNALSYM LANG_CROATIAN} + LANG_CZECH = $05; + {$EXTERNALSYM LANG_CZECH} + LANG_DANISH = $06; + {$EXTERNALSYM LANG_DANISH} + LANG_DIVEHI = $65; + {$EXTERNALSYM LANG_DIVEHI} + LANG_DUTCH = $13; + {$EXTERNALSYM LANG_DUTCH} + LANG_ENGLISH = $09; + {$EXTERNALSYM LANG_ENGLISH} + LANG_ESTONIAN = $25; + {$EXTERNALSYM LANG_ESTONIAN} + LANG_FAEROESE = $38; + {$EXTERNALSYM LANG_FAEROESE} + LANG_FARSI = $29; + {$EXTERNALSYM LANG_FARSI} + LANG_FINNISH = $0b; + {$EXTERNALSYM LANG_FINNISH} + LANG_FRENCH = $0c; + {$EXTERNALSYM LANG_FRENCH} + LANG_GALICIAN = $56; + {$EXTERNALSYM LANG_GALICIAN} + LANG_GEORGIAN = $37; + {$EXTERNALSYM LANG_GEORGIAN} + LANG_GERMAN = $07; + {$EXTERNALSYM LANG_GERMAN} + LANG_GREEK = $08; + {$EXTERNALSYM LANG_GREEK} + LANG_GUJARATI = $47; + {$EXTERNALSYM LANG_GUJARATI} + LANG_HEBREW = $0d; + {$EXTERNALSYM LANG_HEBREW} + LANG_HINDI = $39; + {$EXTERNALSYM LANG_HINDI} + LANG_HUNGARIAN = $0e; + {$EXTERNALSYM LANG_HUNGARIAN} + LANG_ICELANDIC = $0f; + {$EXTERNALSYM LANG_ICELANDIC} + LANG_INDONESIAN = $21; + {$EXTERNALSYM LANG_INDONESIAN} + LANG_ITALIAN = $10; + {$EXTERNALSYM LANG_ITALIAN} + LANG_JAPANESE = $11; + {$EXTERNALSYM LANG_JAPANESE} + LANG_KANNADA = $4b; + {$EXTERNALSYM LANG_KANNADA} + LANG_KASHMIRI = $60; + {$EXTERNALSYM LANG_KASHMIRI} + LANG_KAZAK = $3f; + {$EXTERNALSYM LANG_KAZAK} + LANG_KONKANI = $57; + {$EXTERNALSYM LANG_KONKANI} + LANG_KOREAN = $12; + {$EXTERNALSYM LANG_KOREAN} + LANG_KYRGYZ = $40; + {$EXTERNALSYM LANG_KYRGYZ} + LANG_LATVIAN = $26; + {$EXTERNALSYM LANG_LATVIAN} + LANG_LITHUANIAN = $27; + {$EXTERNALSYM LANG_LITHUANIAN} + LANG_MACEDONIAN = $2f; // the Former Yugoslav Republic of Macedonia + {$EXTERNALSYM LANG_MACEDONIAN} + LANG_MALAY = $3e; + {$EXTERNALSYM LANG_MALAY} + LANG_MALAYALAM = $4c; + {$EXTERNALSYM LANG_MALAYALAM} + LANG_MANIPURI = $58; + {$EXTERNALSYM LANG_MANIPURI} + LANG_MARATHI = $4e; + {$EXTERNALSYM LANG_MARATHI} + LANG_MONGOLIAN = $50; + {$EXTERNALSYM LANG_MONGOLIAN} + LANG_NEPALI = $61; + {$EXTERNALSYM LANG_NEPALI} + LANG_NORWEGIAN = $14; + {$EXTERNALSYM LANG_NORWEGIAN} + LANG_ORIYA = $48; + {$EXTERNALSYM LANG_ORIYA} + LANG_POLISH = $15; + {$EXTERNALSYM LANG_POLISH} + LANG_PORTUGUESE = $16; + {$EXTERNALSYM LANG_PORTUGUESE} + LANG_PUNJABI = $46; + {$EXTERNALSYM LANG_PUNJABI} + LANG_ROMANIAN = $18; + {$EXTERNALSYM LANG_ROMANIAN} + LANG_RUSSIAN = $19; + {$EXTERNALSYM LANG_RUSSIAN} + LANG_SANSKRIT = $4f; + {$EXTERNALSYM LANG_SANSKRIT} + LANG_SERBIAN = $1a; + {$EXTERNALSYM LANG_SERBIAN} + LANG_SINDHI = $59; + {$EXTERNALSYM LANG_SINDHI} + LANG_SLOVAK = $1b; + {$EXTERNALSYM LANG_SLOVAK} + LANG_SLOVENIAN = $24; + {$EXTERNALSYM LANG_SLOVENIAN} + LANG_SPANISH = $0a; + {$EXTERNALSYM LANG_SPANISH} + LANG_SWAHILI = $41; + {$EXTERNALSYM LANG_SWAHILI} + LANG_SWEDISH = $1d; + {$EXTERNALSYM LANG_SWEDISH} + LANG_SYRIAC = $5a; + {$EXTERNALSYM LANG_SYRIAC} + LANG_TAMIL = $49; + {$EXTERNALSYM LANG_TAMIL} + LANG_TATAR = $44; + {$EXTERNALSYM LANG_TATAR} + LANG_TELUGU = $4a; + {$EXTERNALSYM LANG_TELUGU} + LANG_THAI = $1e; + {$EXTERNALSYM LANG_THAI} + LANG_TURKISH = $1f; + {$EXTERNALSYM LANG_TURKISH} + LANG_UKRAINIAN = $22; + {$EXTERNALSYM LANG_UKRAINIAN} + LANG_URDU = $20; + {$EXTERNALSYM LANG_URDU} + LANG_UZBEK = $43; + {$EXTERNALSYM LANG_UZBEK} + LANG_VIETNAMESE = $2a; + {$EXTERNALSYM LANG_VIETNAMESE} + +// +// Sublanguage IDs. +// +// The name immediately following SUBLANG_ dictates which primary +// language ID that sublanguage ID can be combined with to form a +// valid language ID. +// + + SUBLANG_NEUTRAL = $00; // language neutral + {$EXTERNALSYM SUBLANG_NEUTRAL} + SUBLANG_DEFAULT = $01; // user default + {$EXTERNALSYM SUBLANG_DEFAULT} + SUBLANG_SYS_DEFAULT = $02; // system default + {$EXTERNALSYM SUBLANG_SYS_DEFAULT} + + SUBLANG_ARABIC_SAUDI_ARABIA = $01; // Arabic (Saudi Arabia) + {$EXTERNALSYM SUBLANG_ARABIC_SAUDI_ARABIA} + SUBLANG_ARABIC_IRAQ = $02; // Arabic (Iraq) + {$EXTERNALSYM SUBLANG_ARABIC_IRAQ} + SUBLANG_ARABIC_EGYPT = $03; // Arabic (Egypt) + {$EXTERNALSYM SUBLANG_ARABIC_EGYPT} + SUBLANG_ARABIC_LIBYA = $04; // Arabic (Libya) + {$EXTERNALSYM SUBLANG_ARABIC_LIBYA} + SUBLANG_ARABIC_ALGERIA = $05; // Arabic (Algeria) + {$EXTERNALSYM SUBLANG_ARABIC_ALGERIA} + SUBLANG_ARABIC_MOROCCO = $06; // Arabic (Morocco) + {$EXTERNALSYM SUBLANG_ARABIC_MOROCCO} + SUBLANG_ARABIC_TUNISIA = $07; // Arabic (Tunisia) + {$EXTERNALSYM SUBLANG_ARABIC_TUNISIA} + SUBLANG_ARABIC_OMAN = $08; // Arabic (Oman) + {$EXTERNALSYM SUBLANG_ARABIC_OMAN} + SUBLANG_ARABIC_YEMEN = $09; // Arabic (Yemen) + {$EXTERNALSYM SUBLANG_ARABIC_YEMEN} + SUBLANG_ARABIC_SYRIA = $0a; // Arabic (Syria) + {$EXTERNALSYM SUBLANG_ARABIC_SYRIA} + SUBLANG_ARABIC_JORDAN = $0b; // Arabic (Jordan) + {$EXTERNALSYM SUBLANG_ARABIC_JORDAN} + SUBLANG_ARABIC_LEBANON = $0c; // Arabic (Lebanon) + {$EXTERNALSYM SUBLANG_ARABIC_LEBANON} + SUBLANG_ARABIC_KUWAIT = $0d; // Arabic (Kuwait) + {$EXTERNALSYM SUBLANG_ARABIC_KUWAIT} + SUBLANG_ARABIC_UAE = $0e; // Arabic (U.A.E) + {$EXTERNALSYM SUBLANG_ARABIC_UAE} + SUBLANG_ARABIC_BAHRAIN = $0f; // Arabic (Bahrain) + {$EXTERNALSYM SUBLANG_ARABIC_BAHRAIN} + SUBLANG_ARABIC_QATAR = $10; // Arabic (Qatar) + {$EXTERNALSYM SUBLANG_ARABIC_QATAR} + SUBLANG_AZERI_LATIN = $01; // Azeri (Latin) + {$EXTERNALSYM SUBLANG_AZERI_LATIN} + SUBLANG_AZERI_CYRILLIC = $02; // Azeri (Cyrillic) + {$EXTERNALSYM SUBLANG_AZERI_CYRILLIC} + SUBLANG_CHINESE_TRADITIONAL = $01; // Chinese (Taiwan) + {$EXTERNALSYM SUBLANG_CHINESE_TRADITIONAL} + SUBLANG_CHINESE_SIMPLIFIED = $02; // Chinese (PR China) + {$EXTERNALSYM SUBLANG_CHINESE_SIMPLIFIED} + SUBLANG_CHINESE_HONGKONG = $03; // Chinese (Hong Kong S.A.R., P.R.C.) + {$EXTERNALSYM SUBLANG_CHINESE_HONGKONG} + SUBLANG_CHINESE_SINGAPORE = $04; // Chinese (Singapore) + {$EXTERNALSYM SUBLANG_CHINESE_SINGAPORE} + SUBLANG_CHINESE_MACAU = $05; // Chinese (Macau S.A.R.) + {$EXTERNALSYM SUBLANG_CHINESE_MACAU} + SUBLANG_DUTCH = $01; // Dutch + {$EXTERNALSYM SUBLANG_DUTCH} + SUBLANG_DUTCH_BELGIAN = $02; // Dutch (Belgian) + {$EXTERNALSYM SUBLANG_DUTCH_BELGIAN} + SUBLANG_ENGLISH_US = $01; // English (USA) + {$EXTERNALSYM SUBLANG_ENGLISH_US} + SUBLANG_ENGLISH_UK = $02; // English (UK) + {$EXTERNALSYM SUBLANG_ENGLISH_UK} + SUBLANG_ENGLISH_AUS = $03; // English (Australian) + {$EXTERNALSYM SUBLANG_ENGLISH_AUS} + SUBLANG_ENGLISH_CAN = $04; // English (Canadian) + {$EXTERNALSYM SUBLANG_ENGLISH_CAN} + SUBLANG_ENGLISH_NZ = $05; // English (New Zealand) + {$EXTERNALSYM SUBLANG_ENGLISH_NZ} + SUBLANG_ENGLISH_EIRE = $06; // English (Irish) + {$EXTERNALSYM SUBLANG_ENGLISH_EIRE} + SUBLANG_ENGLISH_SOUTH_AFRICA = $07; // English (South Africa) + {$EXTERNALSYM SUBLANG_ENGLISH_SOUTH_AFRICA} + SUBLANG_ENGLISH_JAMAICA = $08; // English (Jamaica) + {$EXTERNALSYM SUBLANG_ENGLISH_JAMAICA} + SUBLANG_ENGLISH_CARIBBEAN = $09; // English (Caribbean) + {$EXTERNALSYM SUBLANG_ENGLISH_CARIBBEAN} + SUBLANG_ENGLISH_BELIZE = $0a; // English (Belize) + {$EXTERNALSYM SUBLANG_ENGLISH_BELIZE} + SUBLANG_ENGLISH_TRINIDAD = $0b; // English (Trinidad) + {$EXTERNALSYM SUBLANG_ENGLISH_TRINIDAD} + SUBLANG_ENGLISH_ZIMBABWE = $0c; // English (Zimbabwe) + {$EXTERNALSYM SUBLANG_ENGLISH_ZIMBABWE} + SUBLANG_ENGLISH_PHILIPPINES = $0d; // English (Philippines) + {$EXTERNALSYM SUBLANG_ENGLISH_PHILIPPINES} + SUBLANG_FRENCH = $01; // French + {$EXTERNALSYM SUBLANG_FRENCH} + SUBLANG_FRENCH_BELGIAN = $02; // French (Belgian) + {$EXTERNALSYM SUBLANG_FRENCH_BELGIAN} + SUBLANG_FRENCH_CANADIAN = $03; // French (Canadian) + {$EXTERNALSYM SUBLANG_FRENCH_CANADIAN} + SUBLANG_FRENCH_SWISS = $04; // French (Swiss) + {$EXTERNALSYM SUBLANG_FRENCH_SWISS} + SUBLANG_FRENCH_LUXEMBOURG = $05; // French (Luxembourg) + {$EXTERNALSYM SUBLANG_FRENCH_LUXEMBOURG} + SUBLANG_FRENCH_MONACO = $06; // French (Monaco) + {$EXTERNALSYM SUBLANG_FRENCH_MONACO} + SUBLANG_GERMAN = $01; // German + {$EXTERNALSYM SUBLANG_GERMAN} + SUBLANG_GERMAN_SWISS = $02; // German (Swiss) + {$EXTERNALSYM SUBLANG_GERMAN_SWISS} + SUBLANG_GERMAN_AUSTRIAN = $03; // German (Austrian) + {$EXTERNALSYM SUBLANG_GERMAN_AUSTRIAN} + SUBLANG_GERMAN_LUXEMBOURG = $04; // German (Luxembourg) + {$EXTERNALSYM SUBLANG_GERMAN_LUXEMBOURG} + SUBLANG_GERMAN_LIECHTENSTEIN = $05; // German (Liechtenstein) + {$EXTERNALSYM SUBLANG_GERMAN_LIECHTENSTEIN} + SUBLANG_ITALIAN = $01; // Italian + {$EXTERNALSYM SUBLANG_ITALIAN} + SUBLANG_ITALIAN_SWISS = $02; // Italian (Swiss) + {$EXTERNALSYM SUBLANG_ITALIAN_SWISS} + SUBLANG_KASHMIRI_SASIA = $02; // Kashmiri (South Asia) + {$EXTERNALSYM SUBLANG_KASHMIRI_SASIA} + SUBLANG_KASHMIRI_INDIA = $02; // For app compatibility only + {$EXTERNALSYM SUBLANG_KASHMIRI_INDIA} + SUBLANG_KOREAN = $01; // Korean (Extended Wansung) + {$EXTERNALSYM SUBLANG_KOREAN} + SUBLANG_LITHUANIAN = $01; // Lithuanian + {$EXTERNALSYM SUBLANG_LITHUANIAN} + SUBLANG_MALAY_MALAYSIA = $01; // Malay (Malaysia) + {$EXTERNALSYM SUBLANG_MALAY_MALAYSIA} + SUBLANG_MALAY_BRUNEI_DARUSSALAM = $02; // Malay (Brunei Darussalam) + {$EXTERNALSYM SUBLANG_MALAY_BRUNEI_DARUSSALAM} + SUBLANG_NEPALI_INDIA = $02; // Nepali (India) + {$EXTERNALSYM SUBLANG_NEPALI_INDIA} + SUBLANG_NORWEGIAN_BOKMAL = $01; // Norwegian (Bokmal) + {$EXTERNALSYM SUBLANG_NORWEGIAN_BOKMAL} + SUBLANG_NORWEGIAN_NYNORSK = $02; // Norwegian (Nynorsk) + {$EXTERNALSYM SUBLANG_NORWEGIAN_NYNORSK} + SUBLANG_PORTUGUESE = $02; // Portuguese + {$EXTERNALSYM SUBLANG_PORTUGUESE} + SUBLANG_PORTUGUESE_BRAZILIAN = $01; // Portuguese (Brazilian) + {$EXTERNALSYM SUBLANG_PORTUGUESE_BRAZILIAN} + SUBLANG_SERBIAN_LATIN = $02; // Serbian (Latin) + {$EXTERNALSYM SUBLANG_SERBIAN_LATIN} + SUBLANG_SERBIAN_CYRILLIC = $03; // Serbian (Cyrillic) + {$EXTERNALSYM SUBLANG_SERBIAN_CYRILLIC} + SUBLANG_SPANISH = $01; // Spanish (Castilian) + {$EXTERNALSYM SUBLANG_SPANISH} + SUBLANG_SPANISH_MEXICAN = $02; // Spanish (Mexican) + {$EXTERNALSYM SUBLANG_SPANISH_MEXICAN} + SUBLANG_SPANISH_MODERN = $03; // Spanish (Spain) + {$EXTERNALSYM SUBLANG_SPANISH_MODERN} + SUBLANG_SPANISH_GUATEMALA = $04; // Spanish (Guatemala) + {$EXTERNALSYM SUBLANG_SPANISH_GUATEMALA} + SUBLANG_SPANISH_COSTA_RICA = $05; // Spanish (Costa Rica) + {$EXTERNALSYM SUBLANG_SPANISH_COSTA_RICA} + SUBLANG_SPANISH_PANAMA = $06; // Spanish (Panama) + {$EXTERNALSYM SUBLANG_SPANISH_PANAMA} + SUBLANG_SPANISH_DOMINICAN_REPUBLIC = $07; // Spanish (Dominican Republic) + {$EXTERNALSYM SUBLANG_SPANISH_DOMINICAN_REPUBLIC} + SUBLANG_SPANISH_VENEZUELA = $08; // Spanish (Venezuela) + {$EXTERNALSYM SUBLANG_SPANISH_VENEZUELA} + SUBLANG_SPANISH_COLOMBIA = $09; // Spanish (Colombia) + {$EXTERNALSYM SUBLANG_SPANISH_COLOMBIA} + SUBLANG_SPANISH_PERU = $0a; // Spanish (Peru) + {$EXTERNALSYM SUBLANG_SPANISH_PERU} + SUBLANG_SPANISH_ARGENTINA = $0b; // Spanish (Argentina) + {$EXTERNALSYM SUBLANG_SPANISH_ARGENTINA} + SUBLANG_SPANISH_ECUADOR = $0c; // Spanish (Ecuador) + {$EXTERNALSYM SUBLANG_SPANISH_ECUADOR} + SUBLANG_SPANISH_CHILE = $0d; // Spanish (Chile) + {$EXTERNALSYM SUBLANG_SPANISH_CHILE} + SUBLANG_SPANISH_URUGUAY = $0e; // Spanish (Uruguay) + {$EXTERNALSYM SUBLANG_SPANISH_URUGUAY} + SUBLANG_SPANISH_PARAGUAY = $0f; // Spanish (Paraguay) + {$EXTERNALSYM SUBLANG_SPANISH_PARAGUAY} + SUBLANG_SPANISH_BOLIVIA = $10; // Spanish (Bolivia) + {$EXTERNALSYM SUBLANG_SPANISH_BOLIVIA} + SUBLANG_SPANISH_EL_SALVADOR = $11; // Spanish (El Salvador) + {$EXTERNALSYM SUBLANG_SPANISH_EL_SALVADOR} + SUBLANG_SPANISH_HONDURAS = $12; // Spanish (Honduras) + {$EXTERNALSYM SUBLANG_SPANISH_HONDURAS} + SUBLANG_SPANISH_NICARAGUA = $13; // Spanish (Nicaragua) + {$EXTERNALSYM SUBLANG_SPANISH_NICARAGUA} + SUBLANG_SPANISH_PUERTO_RICO = $14; // Spanish (Puerto Rico) + {$EXTERNALSYM SUBLANG_SPANISH_PUERTO_RICO} + SUBLANG_SWEDISH = $01; // Swedish + {$EXTERNALSYM SUBLANG_SWEDISH} + SUBLANG_SWEDISH_FINLAND = $02; // Swedish (Finland) + {$EXTERNALSYM SUBLANG_SWEDISH_FINLAND} + SUBLANG_URDU_PAKISTAN = $01; // Urdu (Pakistan) + {$EXTERNALSYM SUBLANG_URDU_PAKISTAN} + SUBLANG_URDU_INDIA = $02; // Urdu (India) + {$EXTERNALSYM SUBLANG_URDU_INDIA} + SUBLANG_UZBEK_LATIN = $01; // Uzbek (Latin) + {$EXTERNALSYM SUBLANG_UZBEK_LATIN} + SUBLANG_UZBEK_CYRILLIC = $02; // Uzbek (Cyrillic) + {$EXTERNALSYM SUBLANG_UZBEK_CYRILLIC} + +// +// Sorting IDs. +// + + SORT_DEFAULT = $0; // sorting default + {$EXTERNALSYM SORT_DEFAULT} + + SORT_JAPANESE_XJIS = $0; // Japanese XJIS order + {$EXTERNALSYM SORT_JAPANESE_XJIS} + SORT_JAPANESE_UNICODE = $1; // Japanese Unicode order + {$EXTERNALSYM SORT_JAPANESE_UNICODE} + + SORT_CHINESE_BIG5 = $0; // Chinese BIG5 order + {$EXTERNALSYM SORT_CHINESE_BIG5} + SORT_CHINESE_PRCP = $0; // PRC Chinese Phonetic order + {$EXTERNALSYM SORT_CHINESE_PRCP} + SORT_CHINESE_UNICODE = $1; // Chinese Unicode order + {$EXTERNALSYM SORT_CHINESE_UNICODE} + SORT_CHINESE_PRC = $2; // PRC Chinese Stroke Count order + {$EXTERNALSYM SORT_CHINESE_PRC} + SORT_CHINESE_BOPOMOFO = $3; // Traditional Chinese Bopomofo order + {$EXTERNALSYM SORT_CHINESE_BOPOMOFO} + + SORT_KOREAN_KSC = $0; // Korean KSC order + {$EXTERNALSYM SORT_KOREAN_KSC} + SORT_KOREAN_UNICODE = $1; // Korean Unicode order + {$EXTERNALSYM SORT_KOREAN_UNICODE} + + SORT_GERMAN_PHONE_BOOK = $1; // German Phone Book order + {$EXTERNALSYM SORT_GERMAN_PHONE_BOOK} + + SORT_HUNGARIAN_DEFAULT = $0; // Hungarian Default order + {$EXTERNALSYM SORT_HUNGARIAN_DEFAULT} + SORT_HUNGARIAN_TECHNICAL = $1; // Hungarian Technical order + {$EXTERNALSYM SORT_HUNGARIAN_TECHNICAL} + + SORT_GEORGIAN_TRADITIONAL = $0; // Georgian Traditional order + {$EXTERNALSYM SORT_GEORGIAN_TRADITIONAL} + SORT_GEORGIAN_MODERN = $1; // Georgian Modern order + {$EXTERNALSYM SORT_GEORGIAN_MODERN} + +// +// A language ID is a 16 bit value which is the combination of a +// primary language ID and a secondary language ID. The bits are +// allocated as follows: +// +// +-----------------------+-------------------------+ +// | Sublanguage ID | Primary Language ID | +// +-----------------------+-------------------------+ +// 15 10 9 0 bit +// +// +// Language ID creation/extraction macros: +// +// MAKELANGID - construct language id from a primary language id and +// a sublanguage id. +// PRIMARYLANGID - extract primary language id from a language id. +// SUBLANGID - extract sublanguage id from a language id. +// + +function MAKELANGID(PrimaryLang, SubLang: USHORT): WORD; +{$EXTERNALSYM MAKELANGID} +function PRIMARYLANGID(LangId: WORD): WORD; +{$EXTERNALSYM PRIMARYLANGID} +function SUBLANGID(LangId: WORD): WORD; +{$EXTERNALSYM SUBLANGID} + +// +// A locale ID is a 32 bit value which is the combination of a +// language ID, a sort ID, and a reserved area. The bits are +// allocated as follows: +// +// +-------------+---------+-------------------------+ +// | Reserved | Sort ID | Language ID | +// +-------------+---------+-------------------------+ +// 31 20 19 16 15 0 bit +// +// +// Locale ID creation/extraction macros: +// +// MAKELCID - construct the locale id from a language id and a sort id. +// MAKESORTLCID - construct the locale id from a language id, sort id, and sort version. +// LANGIDFROMLCID - extract the language id from a locale id. +// SORTIDFROMLCID - extract the sort id from a locale id. +// SORTVERSIONFROMLCID - extract the sort version from a locale id. +// + +const + NLS_VALID_LOCALE_MASK = $000fffff; + {$EXTERNALSYM NLS_VALID_LOCALE_MASK} + +function MAKELCID(LangId, SortId: WORD): DWORD; +{$EXTERNALSYM MAKELCID} +function MAKESORTLCID(LangId, SortId, SortVersion: WORD): DWORD; +{$EXTERNALSYM MAKESORTLCID} +function LANGIDFROMLCID(LocaleId: LCID): WORD; +{$EXTERNALSYM LANGIDFROMLCID} +function SORTIDFROMLCID(LocaleId: LCID): WORD; +{$EXTERNALSYM SORTIDFROMLCID} +function SORTVERSIONFROMLCID(LocaleId: LCID): WORD; +{$EXTERNALSYM SORTVERSIONFROMLCID} + +// +// Default System and User IDs for language and locale. +// + +function LANG_SYSTEM_DEFAULT: WORD; +{$EXTERNALSYM LANG_SYSTEM_DEFAULT} +function LANG_USER_DEFAULT: WORD; +{$EXTERNALSYM LANG_USER_DEFAULT} +function LOCALE_SYSTEM_DEFAULT: DWORD; +{$EXTERNALSYM LOCALE_SYSTEM_DEFAULT} +function LOCALE_USER_DEFAULT: DWORD; +{$EXTERNALSYM LOCALE_USER_DEFAULT} +function LOCALE_NEUTRAL: DWORD; +{$EXTERNALSYM LOCALE_NEUTRAL} +function LOCALE_INVARIANT: DWORD; +{$EXTERNALSYM LOCALE_NEUTRAL} + +const + // (rom) deleted status codes already in JwaWinStatus.pas + DBG_COMMAND_EXCEPTION = DWORD($40010009); + {$EXTERNALSYM DBG_COMMAND_EXCEPTION} + STATUS_SXS_EARLY_DEACTIVATION = DWORD($C015000F); + {$EXTERNALSYM STATUS_SXS_EARLY_DEACTIVATION} + STATUS_SXS_INVALID_DEACTIVATION = DWORD($C0150010); + {$EXTERNALSYM STATUS_SXS_INVALID_DEACTIVATION} + +const + MAXIMUM_WAIT_OBJECTS = 64; // Maximum number of wait objects + {$EXTERNALSYM MAXIMUM_WAIT_OBJECTS} + + MAXIMUM_SUSPEND_COUNT = MAXCHAR; // Maximum times thread can be suspended + {$EXTERNALSYM MAXIMUM_SUSPEND_COUNT} + +type + KSPIN_LOCK = ULONG_PTR; + {$EXTERNALSYM KSPIN_LOCK} + PKSPIN_LOCK = ^KSPIN_LOCK; + {$EXTERNALSYM PKSPIN_LOCK} + +// +// Define functions to get the address of the current fiber and the +// current fiber data. +// + +// +// Disable these two pramas that evaluate to "sti" "cli" on x86 so that driver +// writers to not leave them inadvertantly in their code. +// + +function GetFiberData: PVOID; +{$EXTERNALSYM GetFiberData} + +function GetCurrentFiber: PVOID; +{$EXTERNALSYM GetCurrentFiber} + +// +// Define the size of the 80387 save area, which is in the context frame. +// + +const + SIZE_OF_80387_REGISTERS = 80; + {$EXTERNALSYM SIZE_OF_80387_REGISTERS} + +// +// The following flags control the contents of the CONTEXT structure. +// + +const + CONTEXT_i386 = $00010000; // this assumes that i386 and + {$EXTERNALSYM CONTEXT_i386} + CONTEXT_i486 = $00010000; // i486 have identical context records + {$EXTERNALSYM CONTEXT_i486} + +const + CONTEXT_CONTROL = CONTEXT_i386 or $00000001; // SS:SP, CS:IP, FLAGS, BP + {$EXTERNALSYM CONTEXT_CONTROL} + CONTEXT_INTEGER = CONTEXT_i386 or $00000002; // AX, BX, CX, DX, SI, DI + {$EXTERNALSYM CONTEXT_INTEGER} + CONTEXT_SEGMENTS = CONTEXT_i386 or $00000004; // DS, ES, FS, GS + {$EXTERNALSYM CONTEXT_SEGMENTS} + CONTEXT_FLOATING_POINT = CONTEXT_i386 or $00000008; // 387 state + {$EXTERNALSYM CONTEXT_FLOATING_POINT} + CONTEXT_DEBUG_REGISTERS = CONTEXT_i386 or $00000010; // DB 0-3,6,7 + {$EXTERNALSYM CONTEXT_DEBUG_REGISTERS} + CONTEXT_EXTENDED_REGISTERS = CONTEXT_i386 or $00000020; // cpu specific extensions + {$EXTERNALSYM CONTEXT_EXTENDED_REGISTERS} + + CONTEXT_FULL = CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS; + {$EXTERNALSYM CONTEXT_FULL} + + CONTEXT_ALL = CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS or CONTEXT_FLOATING_POINT or CONTEXT_DEBUG_REGISTERS; + {$EXTERNALSYM CONTEXT_ALL} + +// +// Define initial MxCsr control. +// + + INITIAL_MXCSR = $1f80; // initial MXCSR value + {$EXTERNALSYM INITIAL_MXCSR} + + MAXIMUM_SUPPORTED_EXTENSION = 512; + {$EXTERNALSYM MAXIMUM_SUPPORTED_EXTENSION} + +type + PFLOATING_SAVE_AREA = ^FLOATING_SAVE_AREA; + {$EXTERNALSYM PFLOATING_SAVE_AREA} + _FLOATING_SAVE_AREA = record + ControlWord: DWORD; + StatusWord: DWORD; + TagWord: DWORD; + ErrorOffset: DWORD; + ErrorSelector: DWORD; + DataOffset: DWORD; + DataSelector: DWORD; + RegisterArea: array [0..SIZE_OF_80387_REGISTERS - 1] of BYTE; + Cr0NpxState: DWORD; + end; + {$EXTERNALSYM _FLOATING_SAVE_AREA} + FLOATING_SAVE_AREA = _FLOATING_SAVE_AREA; + {$EXTERNALSYM FLOATING_SAVE_AREA} + TFloatingSaveArea = FLOATING_SAVE_AREA; + PFloatingSaveArea = PFLOATING_SAVE_AREA; + +// +// Context Frame +// +// This frame has a several purposes: 1) it is used as an argument to +// NtContinue, 2) is is used to constuct a call frame for APC delivery, +// and 3) it is used in the user level thread creation routines. +// +// The layout of the record conforms to a standard call frame. +// + +type + PContext = ^CONTEXT; + _CONTEXT = record + + // + // The flags values within this flag control the contents of + // a CONTEXT record. + // + // If the context record is used as an input parameter, then + // for each portion of the context record controlled by a flag + // whose value is set, it is assumed that that portion of the + // context record contains valid context. If the context record + // is being used to modify a threads context, then only that + // portion of the threads context will be modified. + // + // If the context record is used as an IN OUT parameter to capture + // the context of a thread, then only those portions of the thread's + // context corresponding to set flags will be returned. + // + // The context record is never used as an OUT only parameter. + // + + ContextFlags: DWORD; + + // + // This section is specified/returned if CONTEXT_DEBUG_REGISTERS is + // set in ContextFlags. Note that CONTEXT_DEBUG_REGISTERS is NOT + // included in CONTEXT_FULL. + // + + Dr0: DWORD; + Dr1: DWORD; + Dr2: DWORD; + Dr3: DWORD; + Dr6: DWORD; + Dr7: DWORD; + + // + // This section is specified/returned if the + // ContextFlags word contians the flag CONTEXT_FLOATING_POINT. + // + + FloatSave: FLOATING_SAVE_AREA; + + // + // This section is specified/returned if the + // ContextFlags word contians the flag CONTEXT_SEGMENTS. + // + + SegGs: DWORD; + SegFs: DWORD; + SegEs: DWORD; + SegDs: DWORD; + + // + // This section is specified/returned if the + // ContextFlags word contians the flag CONTEXT_INTEGER. + // + + Edi: DWORD; + Esi: DWORD; + Ebx: DWORD; + Edx: DWORD; + Ecx: DWORD; + Eax: DWORD; + + // + // This section is specified/returned if the + // ContextFlags word contians the flag CONTEXT_CONTROL. + // + + Ebp: DWORD; + Eip: DWORD; + SegCs: DWORD; // MUST BE SANITIZED + EFlags: DWORD; // MUST BE SANITIZED + Esp: DWORD; + SegSs: DWORD; + + // + // This section is specified/returned if the ContextFlags word + // contains the flag CONTEXT_EXTENDED_REGISTERS. + // The format and contexts are processor specific + // + + ExtendedRegisters: array [0..MAXIMUM_SUPPORTED_EXTENSION - 1] of BYTE; + end; + {$EXTERNALSYM _CONTEXT} + CONTEXT = _CONTEXT; + {$EXTERNALSYM CONTEXT} + TContext = CONTEXT; + +const + LDTENTRY_FLAGS1_TYPE = $1F; + LDTENTRY_FLAGS1_DPL = $60; + LDTENTRY_FLAGS1_PRES = $80; + + LDTENTRY_FLAGS2_LIMITHI = $0F; + LDTENTRY_FLAGS2_SYS = $10; + LDTENTRY_FLAGS2_RESERVED_0 = $20; + LDTENTRY_FLAGS2_DEFAULT_BIG = $40; + LDTENTRY_FLAGS2_GRANULARITY = $80; + +type + PLDT_ENTRY = ^LDT_ENTRY; + {$EXTERNALSYM PLDT_ENTRY} + _LDT_ENTRY = record + LimitLow: WORD; + BaseLow: WORD; + BaseMid: BYTE; + Flags1: BYTE; // Declare as bytes to avoid alignment + Flags2: BYTE; // Problems. + BaseHi: BYTE; + end; + {$EXTERNALSYM _LDT_ENTRY} + LDT_ENTRY = _LDT_ENTRY; + {$EXTERNALSYM LDT_ENTRY} + TLdtEntry = LDT_ENTRY; + PLdtEntry = PLDT_ENTRY; + +// Please contact INTEL to get IA64-specific information + +const + EXCEPTION_NONCONTINUABLE = $1; // Noncontinuable exception + {$EXTERNALSYM EXCEPTION_NONCONTINUABLE} + EXCEPTION_MAXIMUM_PARAMETERS = 15; // maximum number of exception parameters + {$EXTERNALSYM EXCEPTION_MAXIMUM_PARAMETERS} + +// +// Exception record definition. +// + +type + PEXCEPTION_RECORD = ^EXCEPTION_RECORD; + {$EXTERNALSYM PEXCEPTION_RECORD} + _EXCEPTION_RECORD = record + ExceptionCode: DWORD; + ExceptionFlags: DWORD; + ExceptionRecord: PEXCEPTION_RECORD; + ExceptionAddress: Pointer; + NumberParameters: DWORD; + ExceptionInformation: array [0..EXCEPTION_MAXIMUM_PARAMETERS - 1] of ULONG_PTR; + end; + {$EXTERNALSYM _EXCEPTION_RECORD} + EXCEPTION_RECORD = _EXCEPTION_RECORD; + {$EXTERNALSYM EXCEPTION_RECORD} + TExceptionRecord = EXCEPTION_RECORD; + PExceptionRecord = PEXCEPTION_RECORD; + + PEXCEPTION_RECORD32 = ^EXCEPTION_RECORD32; + {$EXTERNALSYM PEXCEPTION_RECORD32} + _EXCEPTION_RECORD32 = record + ExceptionCode: DWORD; + ExceptionFlags: DWORD; + ExceptionRecord: DWORD; + ExceptionAddress: DWORD; + NumberParameters: DWORD; + ExceptionInformation: array [0..EXCEPTION_MAXIMUM_PARAMETERS - 1] of DWORD; + end; + {$EXTERNALSYM _EXCEPTION_RECORD32} + EXCEPTION_RECORD32 = _EXCEPTION_RECORD32; + {$EXTERNALSYM EXCEPTION_RECORD32} + TExceptionRecord32 = EXCEPTION_RECORD32; + PExceptionRecord32 = PEXCEPTION_RECORD32; + + PEXCEPTION_RECORD64 = ^EXCEPTION_RECORD64; + {$EXTERNALSYM PEXCEPTION_RECORD64} + _EXCEPTION_RECORD64 = record + ExceptionCode: DWORD; + ExceptionFlags: DWORD; + ExceptionRecord: DWORD64; + ExceptionAddress: DWORD64; + NumberParameters: DWORD; + __unusedAlignment: DWORD; + ExceptionInformation: array [0..EXCEPTION_MAXIMUM_PARAMETERS - 1] of DWORD64; + end; + {$EXTERNALSYM _EXCEPTION_RECORD64} + EXCEPTION_RECORD64 = _EXCEPTION_RECORD64; + {$EXTERNALSYM EXCEPTION_RECORD64} + TExceptionRecord64 = EXCEPTION_RECORD64; + PExceptionRecord64 = PEXCEPTION_RECORD64; + +// +// Typedef for pointer returned by exception_info() +// + + PEXCEPTION_POINTERS = ^EXCEPTION_POINTERS; + {$EXTERNALSYM PEXCEPTION_POINTERS} + _EXCEPTION_POINTERS = record + ExceptionRecord: PEXCEPTION_RECORD; + ContextRecord: PCONTEXT; + end; + {$EXTERNALSYM _EXCEPTION_POINTERS} + EXCEPTION_POINTERS = _EXCEPTION_POINTERS; + {$EXTERNALSYM EXCEPTION_POINTERS} + TExceptionPointers = EXCEPTION_POINTERS; + PExceptionPointers = ^TExceptionPointers; + + PACCESS_TOKEN = Pointer; + {$EXTERNALSYM PACCESS_TOKEN} + +//////////////////////////////////////////////////////////////////////// +// // +// ACCESS MASK // +// // +//////////////////////////////////////////////////////////////////////// + +// +// Define the access mask as a longword sized structure divided up as +// follows: +// +// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 +// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 +// +---------------+---------------+-------------------------------+ +// |G|G|G|G|Res'd|A| StandardRights| SpecificRights | +// |R|W|E|A| |S| | | +// +-+-------------+---------------+-------------------------------+ +// +// typedef struct _ACCESS_MASK { +// WORD SpecificRights; +// BYTE StandardRights; +// BYTE AccessSystemAcl : 1; +// BYTE Reserved : 3; +// BYTE GenericAll : 1; +// BYTE GenericExecute : 1; +// BYTE GenericWrite : 1; +// BYTE GenericRead : 1; +// } ACCESS_MASK; +// typedef ACCESS_MASK *PACCESS_MASK; +// +// but to make life simple for programmer's we'll allow them to specify +// a desired access mask by simply OR'ing together mulitple single rights +// and treat an access mask as a DWORD. For example +// +// DesiredAccess = DELETE | READ_CONTROL +// +// So we'll declare ACCESS_MASK as DWORD +// + +type + ACCESS_MASK = DWORD; + {$EXTERNALSYM ACCESS_MASK} + PACCESS_MASK = ^ACCESS_MASK; + {$EXTERNALSYM PACCESS_MASK} + TAccessMask = ACCESS_MASK; + PAccessMask = PACCESS_MASK; + +//////////////////////////////////////////////////////////////////////// +// // +// ACCESS TYPES // +// // +//////////////////////////////////////////////////////////////////////// + +// +// The following are masks for the predefined standard access types +// + +const + DELETE = $00010000; + {$EXTERNALSYM DELETE} + READ_CONTROL = $00020000; + {$EXTERNALSYM READ_CONTROL} + WRITE_DAC = $00040000; + {$EXTERNALSYM WRITE_DAC} + WRITE_OWNER = $00080000; + {$EXTERNALSYM WRITE_OWNER} + SYNCHRONIZE = $00100000; + {$EXTERNALSYM SYNCHRONIZE} + + STANDARD_RIGHTS_REQUIRED = $000F0000; + {$EXTERNALSYM STANDARD_RIGHTS_REQUIRED} + + STANDARD_RIGHTS_READ = READ_CONTROL; + {$EXTERNALSYM STANDARD_RIGHTS_READ} + STANDARD_RIGHTS_WRITE = READ_CONTROL; + {$EXTERNALSYM STANDARD_RIGHTS_WRITE} + STANDARD_RIGHTS_EXECUTE = READ_CONTROL; + {$EXTERNALSYM STANDARD_RIGHTS_EXECUTE} + + STANDARD_RIGHTS_ALL = $001F0000; + {$EXTERNALSYM STANDARD_RIGHTS_ALL} + SPECIFIC_RIGHTS_ALL = $0000FFFF; + {$EXTERNALSYM SPECIFIC_RIGHTS_ALL} + +// +// AccessSystemAcl access type +// + + ACCESS_SYSTEM_SECURITY = $01000000; + {$EXTERNALSYM ACCESS_SYSTEM_SECURITY} + +// +// MaximumAllowed access type +// + + MAXIMUM_ALLOWED = $02000000; + {$EXTERNALSYM MAXIMUM_ALLOWED} + +// +// These are the generic rights. +// + + GENERIC_READ = DWORD($80000000); + {$EXTERNALSYM GENERIC_READ} + GENERIC_WRITE = $40000000; + {$EXTERNALSYM GENERIC_WRITE} + GENERIC_EXECUTE = $20000000; + {$EXTERNALSYM GENERIC_EXECUTE} + GENERIC_ALL = $10000000; + {$EXTERNALSYM GENERIC_ALL} + +// +// Define the generic mapping array. This is used to denote the +// mapping of each generic access right to a specific access mask. +// + +type + PGENERIC_MAPPING = ^GENERIC_MAPPING; + {$EXTERNALSYM PGENERIC_MAPPING} + _GENERIC_MAPPING = record + GenericRead: ACCESS_MASK; + GenericWrite: ACCESS_MASK; + GenericExecute: ACCESS_MASK; + GenericAll: ACCESS_MASK; + end; + {$EXTERNALSYM _GENERIC_MAPPING} + GENERIC_MAPPING = _GENERIC_MAPPING; + {$EXTERNALSYM GENERIC_MAPPING} + TGenericMapping = GENERIC_MAPPING; + PGenericMapping = PGENERIC_MAPPING; + +//////////////////////////////////////////////////////////////////////// +// // +// LUID_AND_ATTRIBUTES // +// // +//////////////////////////////////////////////////////////////////////// +// +// + +//#include <pshpack4.h> + + PLUID_AND_ATTRIBUTES = ^LUID_AND_ATTRIBUTES; + {$EXTERNALSYM PLUID_AND_ATTRIBUTES} + _LUID_AND_ATTRIBUTES = record + Luid: LUID; + Attributes: DWORD; + end; + {$EXTERNALSYM _LUID_AND_ATTRIBUTES} + LUID_AND_ATTRIBUTES = _LUID_AND_ATTRIBUTES; + {$EXTERNALSYM LUID_AND_ATTRIBUTES} + TLuidAndAttributes = LUID_AND_ATTRIBUTES; + PLuidAndAttributes = PLUID_AND_ATTRIBUTES; + + LUID_AND_ATTRIBUTES_ARRAY = array [0..ANYSIZE_ARRAY - 1] of LUID_AND_ATTRIBUTES; + {$EXTERNALSYM LUID_AND_ATTRIBUTES_ARRAY} + PLUID_AND_ATTRIBUTES_ARRAY = ^LUID_AND_ATTRIBUTES_ARRAY; + {$EXTERNALSYM PLUID_AND_ATTRIBUTES_ARRAY} + TLuidAndAttributesArray = LUID_AND_ATTRIBUTES_ARRAY; + PLuidAndAttributesArray = ^TLuidAndAttributesArray; + +//#include <poppack.h> + +//////////////////////////////////////////////////////////////////////// +// // +// Security Id (SID) // +// // +//////////////////////////////////////////////////////////////////////// +// +// +// Pictorially the structure of an SID is as follows: +// +// 1 1 1 1 1 1 +// 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 +// +---------------------------------------------------------------+ +// | SubAuthorityCount |Reserved1 (SBZ)| Revision | +// +---------------------------------------------------------------+ +// | IdentifierAuthority[0] | +// +---------------------------------------------------------------+ +// | IdentifierAuthority[1] | +// +---------------------------------------------------------------+ +// | IdentifierAuthority[2] | +// +---------------------------------------------------------------+ +// | | +// +- - - - - - - - SubAuthority[] - - - - - - - - -+ +// | | +// +---------------------------------------------------------------+ +// +// + +type + PSID_IDENTIFIER_AUTHORITY = ^SID_IDENTIFIER_AUTHORITY; + {$EXTERNALSYM PSID_IDENTIFIER_AUTHORITY} + _SID_IDENTIFIER_AUTHORITY = record + Value: array [0..5] of Byte; + end; + {$EXTERNALSYM _SID_IDENTIFIER_AUTHORITY} + SID_IDENTIFIER_AUTHORITY = _SID_IDENTIFIER_AUTHORITY; + {$EXTERNALSYM SID_IDENTIFIER_AUTHORITY} + TSidIdentifierAuthority = SID_IDENTIFIER_AUTHORITY; + PSidIdentifierAuthority = PSID_IDENTIFIER_AUTHORITY; + + PSid = ^SID; + _SID = record + Revision: Byte; + SubAuthorityCount: Byte; + IdentifierAuthority: SID_IDENTIFIER_AUTHORITY; + SubAuthority: array [0..ANYSIZE_ARRAY - 1] of DWORD; + end; + {$EXTERNALSYM _SID} + SID = _SID; + {$EXTERNALSYM SID} + PPSID = ^PSID; + {$NODEFINE PPSID} + TSid = SID; + +const + SID_REVISION = 1; // Current revision level + {$EXTERNALSYM SID_REVISION} + SID_MAX_SUB_AUTHORITIES = 15; + {$EXTERNALSYM SID_MAX_SUB_AUTHORITIES} + SID_RECOMMENDED_SUB_AUTHORITIES = 1; // Will change to around 6 in a future release. + {$EXTERNALSYM SID_RECOMMENDED_SUB_AUTHORITIES} + + SECURITY_MAX_SID_SIZE = SizeOf(SID) - SizeOf(DWORD) + (SID_MAX_SUB_AUTHORITIES * SizeOf(DWORD)); + {$EXTERNALSYM SECURITY_MAX_SID_SIZE} + + SidTypeUser = 1; + {$EXTERNALSYM SidTypeUser} + SidTypeGroup = 2; + {$EXTERNALSYM SidTypeGroup} + SidTypeDomain = 3; + {$EXTERNALSYM SidTypeDomain} + SidTypeAlias = 4; + {$EXTERNALSYM SidTypeAlias} + SidTypeWellKnownGroup = 5; + {$EXTERNALSYM SidTypeWellKnownGroup} + SidTypeDeletedAccount = 6; + {$EXTERNALSYM SidTypeDeletedAccount} + SidTypeInvalid = 7; + {$EXTERNALSYM SidTypeInvalid} + SidTypeUnknown = 8; + {$EXTERNALSYM SidTypeUnknown} + SidTypeComputer = 9; + {$EXTERNALSYM SidTypeComputer} + +type + _SID_NAME_USE = DWORD; + {$EXTERNALSYM _SID_NAME_USE} + SID_NAME_USE = _SID_NAME_USE; + {$EXTERNALSYM SID_NAME_USE} + PSID_NAME_USE = ^SID_NAME_USE; + {$EXTERNALSYM PSID_NAME_USE} + TSidNameUse = SID_NAME_USE; + PSidNameUSe = PSID_NAME_USE; + + PSID_AND_ATTRIBUTES = ^SID_AND_ATTRIBUTES; + {$EXTERNALSYM PSID_AND_ATTRIBUTES} + _SID_AND_ATTRIBUTES = record + Sid: PSID; + Attributes: DWORD; + end; + {$EXTERNALSYM _SID_AND_ATTRIBUTES} + SID_AND_ATTRIBUTES = _SID_AND_ATTRIBUTES; + {$EXTERNALSYM SID_AND_ATTRIBUTES} + TSidAndAttributes = SID_AND_ATTRIBUTES; + PSidAndAttributes = PSID_AND_ATTRIBUTES; + + SID_AND_ATTRIBUTES_ARRAY = array [0..ANYSIZE_ARRAY - 1] of SID_AND_ATTRIBUTES; + {$EXTERNALSYM SID_AND_ATTRIBUTES_ARRAY} + PSID_AND_ATTRIBUTES_ARRAY = ^SID_AND_ATTRIBUTES_ARRAY; + {$EXTERNALSYM PSID_AND_ATTRIBUTES_ARRAY} + PSidAndAttributesArray = ^TSidAndAttributesArray; + TSidAndAttributesArray = SID_AND_ATTRIBUTES_ARRAY; + +///////////////////////////////////////////////////////////////////////////// +// // +// Universal well-known SIDs // +// // +// Null SID S-1-0-0 // +// World S-1-1-0 // +// Local S-1-2-0 // +// Creator Owner ID S-1-3-0 // +// Creator Group ID S-1-3-1 // +// Creator Owner Server ID S-1-3-2 // +// Creator Group Server ID S-1-3-3 // +// // +// (Non-unique IDs) S-1-4 // +// // +///////////////////////////////////////////////////////////////////////////// + +const + SECURITY_NULL_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 0)); + {$EXTERNALSYM SECURITY_NULL_SID_AUTHORITY} + SECURITY_WORLD_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 1)); + {$EXTERNALSYM SECURITY_WORLD_SID_AUTHORITY} + SECURITY_LOCAL_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 2)); + {$EXTERNALSYM SECURITY_LOCAL_SID_AUTHORITY} + SECURITY_CREATOR_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 3)); + {$EXTERNALSYM SECURITY_CREATOR_SID_AUTHORITY} + SECURITY_NON_UNIQUE_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 4)); + {$EXTERNALSYM SECURITY_NON_UNIQUE_AUTHORITY} + SECURITY_RESOURCE_MANAGER_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 9)); + {$EXTERNALSYM SECURITY_RESOURCE_MANAGER_AUTHORITY} + + SECURITY_NULL_RID = $00000000; + {$EXTERNALSYM SECURITY_NULL_RID} + SECURITY_WORLD_RID = $00000000; + {$EXTERNALSYM SECURITY_WORLD_RID} + SECURITY_LOCAL_RID = $00000000; + {$EXTERNALSYM SECURITY_LOCAL_RID} + + SECURITY_CREATOR_OWNER_RID = $00000000; + {$EXTERNALSYM SECURITY_CREATOR_OWNER_RID} + SECURITY_CREATOR_GROUP_RID = $00000001; + {$EXTERNALSYM SECURITY_CREATOR_GROUP_RID} + + SECURITY_CREATOR_OWNER_SERVER_RID = $00000002; + {$EXTERNALSYM SECURITY_CREATOR_OWNER_SERVER_RID} + SECURITY_CREATOR_GROUP_SERVER_RID = $00000003; + {$EXTERNALSYM SECURITY_CREATOR_GROUP_SERVER_RID} + +///////////////////////////////////////////////////////////////////////////// +// // +// NT well-known SIDs // +// // +// NT Authority S-1-5 // +// Dialup S-1-5-1 // +// // +// Network S-1-5-2 // +// Batch S-1-5-3 // +// Interactive S-1-5-4 // +// (Logon IDs) S-1-5-5-X-Y // +// Service S-1-5-6 // +// AnonymousLogon S-1-5-7 (aka null logon session) // +// Proxy S-1-5-8 // +// Enterprise DC (EDC) S-1-5-9 (aka domain controller account) // +// Self S-1-5-10 (self RID) // +// Authenticated User S-1-5-11 (Authenticated user somewhere) // +// Restricted Code S-1-5-12 (Running restricted code) // +// Terminal Server S-1-5-13 (Running on Terminal Server) // +// Remote Logon S-1-5-14 (Remote Interactive Logon) // +// This Organization S-1-5-15 // +// // +// Local System S-1-5-18 // +// Local Service S-1-5-19 // +// Network Service S-1-5-20 // +// // +// (NT non-unique IDs) S-1-5-0x15-... (NT Domain Sids) // +// // +// (Built-in domain) S-1-5-0x20 // +// // +// (Security Package IDs) S-1-5-0x40 // +// NTLM Authentication S-1-5-0x40-10 // +// SChannel Authentication S-1-5-0x40-14 // +// Digest Authentication S-1-5-0x40-21 // +// // +// Other Organization S-1-5-1000 (>=1000 can not be filtered) // +// // +// // +// NOTE: the relative identifier values (RIDs) determine which security // +// boundaries the SID is allowed to cross. Before adding new RIDs, // +// a determination needs to be made regarding which range they should // +// be added to in order to ensure proper "SID filtering" // +// // +/////////////////////////////////////////////////////////////////////////////// + +const + SECURITY_NT_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)); + {$EXTERNALSYM SECURITY_NT_AUTHORITY} + + SECURITY_DIALUP_RID = $00000001; + {$EXTERNALSYM SECURITY_DIALUP_RID} + SECURITY_NETWORK_RID = $00000002; + {$EXTERNALSYM SECURITY_NETWORK_RID} + SECURITY_BATCH_RID = $00000003; + {$EXTERNALSYM SECURITY_BATCH_RID} + SECURITY_INTERACTIVE_RID = $00000004; + {$EXTERNALSYM SECURITY_INTERACTIVE_RID} + SECURITY_LOGON_IDS_RID = $00000005; + {$EXTERNALSYM SECURITY_LOGON_IDS_RID} + SECURITY_LOGON_IDS_RID_COUNT = 3; + {$EXTERNALSYM SECURITY_LOGON_IDS_RID_COUNT} + SECURITY_SERVICE_RID = $00000006; + {$EXTERNALSYM SECURITY_SERVICE_RID} + SECURITY_ANONYMOUS_LOGON_RID = $00000007; + {$EXTERNALSYM SECURITY_ANONYMOUS_LOGON_RID} + SECURITY_PROXY_RID = $00000008; + {$EXTERNALSYM SECURITY_PROXY_RID} + SECURITY_ENTERPRISE_CONTROLLERS_RID = $00000009; + {$EXTERNALSYM SECURITY_ENTERPRISE_CONTROLLERS_RID} + SECURITY_SERVER_LOGON_RID = SECURITY_ENTERPRISE_CONTROLLERS_RID; + {$EXTERNALSYM SECURITY_SERVER_LOGON_RID} + SECURITY_PRINCIPAL_SELF_RID = $0000000A; + {$EXTERNALSYM SECURITY_PRINCIPAL_SELF_RID} + SECURITY_AUTHENTICATED_USER_RID = $0000000B; + {$EXTERNALSYM SECURITY_AUTHENTICATED_USER_RID} + SECURITY_RESTRICTED_CODE_RID = $0000000C; + {$EXTERNALSYM SECURITY_RESTRICTED_CODE_RID} + SECURITY_TERMINAL_SERVER_RID = $0000000D; + {$EXTERNALSYM SECURITY_TERMINAL_SERVER_RID} + SECURITY_REMOTE_LOGON_RID = $0000000E; + {$EXTERNALSYM SECURITY_REMOTE_LOGON_RID} + SECURITY_THIS_ORGANIZATION_RID = $0000000F; + {$EXTERNALSYM SECURITY_THIS_ORGANIZATION_RID} + + SECURITY_LOCAL_SYSTEM_RID = $00000012; + {$EXTERNALSYM SECURITY_LOCAL_SYSTEM_RID} + SECURITY_LOCAL_SERVICE_RID = $00000013; + {$EXTERNALSYM SECURITY_LOCAL_SERVICE_RID} + SECURITY_NETWORK_SERVICE_RID = $00000014; + {$EXTERNALSYM SECURITY_NETWORK_SERVICE_RID} + + SECURITY_NT_NON_UNIQUE = $00000015; + {$EXTERNALSYM SECURITY_NT_NON_UNIQUE} + SECURITY_NT_NON_UNIQUE_SUB_AUTH_COUNT = 3; + {$EXTERNALSYM SECURITY_NT_NON_UNIQUE_SUB_AUTH_COUNT} + + SECURITY_BUILTIN_DOMAIN_RID = $00000020; + {$EXTERNALSYM SECURITY_BUILTIN_DOMAIN_RID} + + SECURITY_PACKAGE_BASE_RID = $00000040; + {$EXTERNALSYM SECURITY_PACKAGE_BASE_RID} + SECURITY_PACKAGE_RID_COUNT = 2; + {$EXTERNALSYM SECURITY_PACKAGE_RID_COUNT} + SECURITY_PACKAGE_NTLM_RID = $0000000A; + {$EXTERNALSYM SECURITY_PACKAGE_NTLM_RID} + SECURITY_PACKAGE_SCHANNEL_RID = $0000000E; + {$EXTERNALSYM SECURITY_PACKAGE_SCHANNEL_RID} + SECURITY_PACKAGE_DIGEST_RID = $00000015; + {$EXTERNALSYM SECURITY_PACKAGE_DIGEST_RID} + + SECURITY_MAX_ALWAYS_FILTERED = $000003E7; + {$EXTERNALSYM SECURITY_MAX_ALWAYS_FILTERED} + SECURITY_MIN_NEVER_FILTERED = $000003E8; + {$EXTERNALSYM SECURITY_MIN_NEVER_FILTERED} + + SECURITY_OTHER_ORGANIZATION_RID = $000003E8; + {$EXTERNALSYM SECURITY_OTHER_ORGANIZATION_RID} + +///////////////////////////////////////////////////////////////////////////// +// // +// well-known domain relative sub-authority values (RIDs)... // +// // +///////////////////////////////////////////////////////////////////////////// + +// Well-known users ... + + FOREST_USER_RID_MAX = $000001F3; + {$EXTERNALSYM FOREST_USER_RID_MAX} + + DOMAIN_USER_RID_ADMIN = $000001F4; + {$EXTERNALSYM DOMAIN_USER_RID_ADMIN} + DOMAIN_USER_RID_GUEST = $000001F5; + {$EXTERNALSYM DOMAIN_USER_RID_GUEST} + DOMAIN_USER_RID_KRBTGT = $000001F6; + {$EXTERNALSYM DOMAIN_USER_RID_KRBTGT} + + DOMAIN_USER_RID_MAX = $000003E7; + {$EXTERNALSYM DOMAIN_USER_RID_MAX} + +// well-known groups ... + + DOMAIN_GROUP_RID_ADMINS = $00000200; + {$EXTERNALSYM DOMAIN_GROUP_RID_ADMINS} + DOMAIN_GROUP_RID_USERS = $00000201; + {$EXTERNALSYM DOMAIN_GROUP_RID_USERS} + DOMAIN_GROUP_RID_GUESTS = $00000202; + {$EXTERNALSYM DOMAIN_GROUP_RID_GUESTS} + DOMAIN_GROUP_RID_COMPUTERS = $00000203; + {$EXTERNALSYM DOMAIN_GROUP_RID_COMPUTERS} + DOMAIN_GROUP_RID_CONTROLLERS = $00000204; + {$EXTERNALSYM DOMAIN_GROUP_RID_CONTROLLERS} + DOMAIN_GROUP_RID_CERT_ADMINS = $00000205; + {$EXTERNALSYM DOMAIN_GROUP_RID_CERT_ADMINS} + DOMAIN_GROUP_RID_SCHEMA_ADMINS = $00000206; + {$EXTERNALSYM DOMAIN_GROUP_RID_SCHEMA_ADMINS} + DOMAIN_GROUP_RID_ENTERPRISE_ADMINS = $00000207; + {$EXTERNALSYM DOMAIN_GROUP_RID_ENTERPRISE_ADMINS} + DOMAIN_GROUP_RID_POLICY_ADMINS = $00000208; + {$EXTERNALSYM DOMAIN_GROUP_RID_POLICY_ADMINS} + +// well-known aliases ... + + DOMAIN_ALIAS_RID_ADMINS = $00000220; + {$EXTERNALSYM DOMAIN_ALIAS_RID_ADMINS} + DOMAIN_ALIAS_RID_USERS = $00000221; + {$EXTERNALSYM DOMAIN_ALIAS_RID_USERS} + DOMAIN_ALIAS_RID_GUESTS = $00000222; + {$EXTERNALSYM DOMAIN_ALIAS_RID_GUESTS} + DOMAIN_ALIAS_RID_POWER_USERS = $00000223; + {$EXTERNALSYM DOMAIN_ALIAS_RID_POWER_USERS} + + DOMAIN_ALIAS_RID_ACCOUNT_OPS = $00000224; + {$EXTERNALSYM DOMAIN_ALIAS_RID_ACCOUNT_OPS} + DOMAIN_ALIAS_RID_SYSTEM_OPS = $00000225; + {$EXTERNALSYM DOMAIN_ALIAS_RID_SYSTEM_OPS} + DOMAIN_ALIAS_RID_PRINT_OPS = $00000226; + {$EXTERNALSYM DOMAIN_ALIAS_RID_PRINT_OPS} + DOMAIN_ALIAS_RID_BACKUP_OPS = $00000227; + {$EXTERNALSYM DOMAIN_ALIAS_RID_BACKUP_OPS} + + DOMAIN_ALIAS_RID_REPLICATOR = $00000228; + {$EXTERNALSYM DOMAIN_ALIAS_RID_REPLICATOR} + DOMAIN_ALIAS_RID_RAS_SERVERS = $00000229; + {$EXTERNALSYM DOMAIN_ALIAS_RID_RAS_SERVERS} + DOMAIN_ALIAS_RID_PREW2KCOMPACCESS = $0000022A; + {$EXTERNALSYM DOMAIN_ALIAS_RID_PREW2KCOMPACCESS} + DOMAIN_ALIAS_RID_REMOTE_DESKTOP_USERS = $0000022B; + {$EXTERNALSYM DOMAIN_ALIAS_RID_REMOTE_DESKTOP_USERS} + DOMAIN_ALIAS_RID_NETWORK_CONFIGURATION_OPS = $0000022C; + {$EXTERNALSYM DOMAIN_ALIAS_RID_NETWORK_CONFIGURATION_OPS} + DOMAIN_ALIAS_RID_INCOMING_FOREST_TRUST_BUILDERS = $0000022D; + {$EXTERNALSYM DOMAIN_ALIAS_RID_INCOMING_FOREST_TRUST_BUILDERS} + + DOMAIN_ALIAS_RID_MONITORING_USERS = $0000022E; + {$EXTERNALSYM DOMAIN_ALIAS_RID_MONITORING_USERS} + DOMAIN_ALIAS_RID_LOGGING_USERS = $0000022F; + {$EXTERNALSYM DOMAIN_ALIAS_RID_LOGGING_USERS} + DOMAIN_ALIAS_RID_AUTHORIZATIONACCESS = $00000230; + {$EXTERNALSYM DOMAIN_ALIAS_RID_AUTHORIZATIONACCESS} + DOMAIN_ALIAS_RID_TS_LICENSE_SERVERS = $00000231; + {$EXTERNALSYM DOMAIN_ALIAS_RID_TS_LICENSE_SERVERS} + +type + WELL_KNOWN_SID_TYPE = ( + WinNullSid, + WinWorldSid, + WinLocalSid, + WinCreatorOwnerSid, + WinCreatorGroupSid, + WinCreatorOwnerServerSid, + WinCreatorGroupServerSid, + WinNtAuthoritySid, + WinDialupSid, + WinNetworkSid, + WinBatchSid, + WinInteractiveSid, + WinServiceSid, + WinAnonymousSid, + WinProxySid, + WinEnterpriseControllersSid, + WinSelfSid, + WinAuthenticatedUserSid, + WinRestrictedCodeSid, + WinTerminalServerSid, + WinRemoteLogonIdSid, + WinLogonIdsSid, + WinLocalSystemSid, + WinLocalServiceSid, + WinNetworkServiceSid, + WinBuiltinDomainSid, + WinBuiltinAdministratorsSid, + WinBuiltinUsersSid, + WinBuiltinGuestsSid, + WinBuiltinPowerUsersSid, + WinBuiltinAccountOperatorsSid, + WinBuiltinSystemOperatorsSid, + WinBuiltinPrintOperatorsSid, + WinBuiltinBackupOperatorsSid, + WinBuiltinReplicatorSid, + WinBuiltinPreWindows2000CompatibleAccessSid, + WinBuiltinRemoteDesktopUsersSid, + WinBuiltinNetworkConfigurationOperatorsSid, + WinAccountAdministratorSid, + WinAccountGuestSid, + WinAccountKrbtgtSid, + WinAccountDomainAdminsSid, + WinAccountDomainUsersSid, + WinAccountDomainGuestsSid, + WinAccountComputersSid, + WinAccountControllersSid, + WinAccountCertAdminsSid, + WinAccountSchemaAdminsSid, + WinAccountEnterpriseAdminsSid, + WinAccountPolicyAdminsSid, + WinAccountRasAndIasServersSid, + WinNTLMAuthenticationSid, + WinDigestAuthenticationSid, + WinSChannelAuthenticationSid, + WinThisOrganizationSid, + WinOtherOrganizationSid, + WinBuiltinIncomingForestTrustBuildersSid, + WinBuiltinPerfMonitoringUsersSid, + WinBuiltinPerfLoggingUsersSid, + WinBuiltinAuthorizationAccessSid, + WinBuiltinTerminalServerLicenseServersSid); + {$EXTERNALSYM WELL_KNOWN_SID_TYPE} + TWellKnownSidType = WELL_KNOWN_SID_TYPE; + +// +// Allocate the System Luid. The first 1000 LUIDs are reserved. +// Use #999 here (0x3E7 = 999) +// + +const + SYSTEM_LUID: LUID = (LowPart: $3E7; HighPart: $0); + {$EXTERNALSYM SYSTEM_LUID} + ANONYMOUS_LOGON_LUID: LUID = (LowPart: $3E6; HighPart: $0); + {$EXTERNALSYM ANONYMOUS_LOGON_LUID} + LOCALSERVICE_LUID: LUID = (LowPart: $3E5; HighPart: $0); + {$EXTERNALSYM LOCALSERVICE_LUID} + NETWORKSERVICE_LUID: LUID = (LowPart: $3E4; HighPart: $0); + {$EXTERNALSYM NETWORKSERVICE_LUID} + +//////////////////////////////////////////////////////////////////////// +// // +// User and Group related SID attributes // +// // +//////////////////////////////////////////////////////////////////////// + +// +// Group attributes +// + + SE_GROUP_MANDATORY = $00000001; + {$EXTERNALSYM SE_GROUP_MANDATORY} + SE_GROUP_ENABLED_BY_DEFAULT = $00000002; + {$EXTERNALSYM SE_GROUP_ENABLED_BY_DEFAULT} + SE_GROUP_ENABLED = $00000004; + {$EXTERNALSYM SE_GROUP_ENABLED} + SE_GROUP_OWNER = $00000008; + {$EXTERNALSYM SE_GROUP_OWNER} + SE_GROUP_USE_FOR_DENY_ONLY = $00000010; + {$EXTERNALSYM SE_GROUP_USE_FOR_DENY_ONLY} + SE_GROUP_LOGON_ID = $C0000000; + {$EXTERNALSYM SE_GROUP_LOGON_ID} + SE_GROUP_RESOURCE = $20000000; + {$EXTERNALSYM SE_GROUP_RESOURCE} + +// +// User attributes +// + +// (None yet defined.) + +//////////////////////////////////////////////////////////////////////// +// // +// ACL and ACE // +// // +//////////////////////////////////////////////////////////////////////// + +// +// Define an ACL and the ACE format. The structure of an ACL header +// followed by one or more ACEs. Pictorally the structure of an ACL header +// is as follows: +// +// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 +// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 +// +-------------------------------+---------------+---------------+ +// | AclSize | Sbz1 | AclRevision | +// +-------------------------------+---------------+---------------+ +// | Sbz2 | AceCount | +// +-------------------------------+-------------------------------+ +// +// The current AclRevision is defined to be ACL_REVISION. +// +// AclSize is the size, in bytes, allocated for the ACL. This includes +// the ACL header, ACES, and remaining free space in the buffer. +// +// AceCount is the number of ACES in the ACL. +// + +// This is the *current* ACL revision + + ACL_REVISION = 2; + {$EXTERNALSYM ACL_REVISION} + ACL_REVISION_DS = 4; + {$EXTERNALSYM ACL_REVISION_DS} + +// This is the history of ACL revisions. Add a new one whenever +// ACL_REVISION is updated + + ACL_REVISION1 = 1; + {$EXTERNALSYM ACL_REVISION1} + ACL_REVISION2 = 2; + {$EXTERNALSYM ACL_REVISION2} + MIN_ACL_REVISION = ACL_REVISION2; + {$EXTERNALSYM MIN_ACL_REVISION} + ACL_REVISION3 = 3; + {$EXTERNALSYM ACL_REVISION3} + ACL_REVISION4 = 4; + {$EXTERNALSYM ACL_REVISION4} + MAX_ACL_REVISION = ACL_REVISION4; + {$EXTERNALSYM MAX_ACL_REVISION} + +type + PACL = ^ACL; + {$EXTERNALSYM PACL} + _ACL = record + AclRevision: Byte; + Sbz1: Byte; + AclSize: Word; + AceCount: Word; + Sbz2: Word; + end; + {$EXTERNALSYM _ACL} + ACL = _ACL; + {$EXTERNALSYM ACL} + TAcl = ACL; + + PPACL = ^PAcl; + {$NODEFINE PPACL} + +// +// The structure of an ACE is a common ace header followed by ace type +// specific data. Pictorally the structure of the common ace header is +// as follows: +// +// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 +// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 +// +---------------+-------+-------+---------------+---------------+ +// | AceSize | AceFlags | AceType | +// +---------------+-------+-------+---------------+---------------+ +// +// AceType denotes the type of the ace, there are some predefined ace +// types +// +// AceSize is the size, in bytes, of ace. +// +// AceFlags are the Ace flags for audit and inheritance, defined shortly. + +type + PACE_HEADER = ^ACE_HEADER; + {$EXTERNALSYM PACE_HEADER} + _ACE_HEADER = record + AceType: Byte; + AceFlags: Byte; + AceSize: Word; + end; + {$EXTERNALSYM _ACE_HEADER} + ACE_HEADER = _ACE_HEADER; + {$EXTERNALSYM ACE_HEADER} + TAceHeader = ACE_HEADER; + PAceHeader = PACE_HEADER; + +// +// The following are the predefined ace types that go into the AceType +// field of an Ace header. +// + +const + ACCESS_MIN_MS_ACE_TYPE = $0; + {$EXTERNALSYM ACCESS_MIN_MS_ACE_TYPE} + ACCESS_ALLOWED_ACE_TYPE = $0; + {$EXTERNALSYM ACCESS_ALLOWED_ACE_TYPE} + ACCESS_DENIED_ACE_TYPE = $1; + {$EXTERNALSYM ACCESS_DENIED_ACE_TYPE} + SYSTEM_AUDIT_ACE_TYPE = $2; + {$EXTERNALSYM SYSTEM_AUDIT_ACE_TYPE} + SYSTEM_ALARM_ACE_TYPE = $3; + {$EXTERNALSYM SYSTEM_ALARM_ACE_TYPE} + ACCESS_MAX_MS_V2_ACE_TYPE = $3; + {$EXTERNALSYM ACCESS_MAX_MS_V2_ACE_TYPE} + + ACCESS_ALLOWED_COMPOUND_ACE_TYPE = $4; + {$EXTERNALSYM ACCESS_ALLOWED_COMPOUND_ACE_TYPE} + ACCESS_MAX_MS_V3_ACE_TYPE = $4; + {$EXTERNALSYM ACCESS_MAX_MS_V3_ACE_TYPE} + + ACCESS_MIN_MS_OBJECT_ACE_TYPE = $5; + {$EXTERNALSYM ACCESS_MIN_MS_OBJECT_ACE_TYPE} + ACCESS_ALLOWED_OBJECT_ACE_TYPE = $5; + {$EXTERNALSYM ACCESS_ALLOWED_OBJECT_ACE_TYPE} + ACCESS_DENIED_OBJECT_ACE_TYPE = $6; + {$EXTERNALSYM ACCESS_DENIED_OBJECT_ACE_TYPE} + SYSTEM_AUDIT_OBJECT_ACE_TYPE = $7; + {$EXTERNALSYM SYSTEM_AUDIT_OBJECT_ACE_TYPE} + SYSTEM_ALARM_OBJECT_ACE_TYPE = $8; + {$EXTERNALSYM SYSTEM_ALARM_OBJECT_ACE_TYPE} + ACCESS_MAX_MS_OBJECT_ACE_TYPE = $8; + {$EXTERNALSYM ACCESS_MAX_MS_OBJECT_ACE_TYPE} + + ACCESS_MAX_MS_V4_ACE_TYPE = $8; + {$EXTERNALSYM ACCESS_MAX_MS_V4_ACE_TYPE} + ACCESS_MAX_MS_ACE_TYPE = $8; + {$EXTERNALSYM ACCESS_MAX_MS_ACE_TYPE} + + ACCESS_ALLOWED_CALLBACK_ACE_TYPE = $9; + {$EXTERNALSYM ACCESS_ALLOWED_CALLBACK_ACE_TYPE} + ACCESS_DENIED_CALLBACK_ACE_TYPE = $A; + {$EXTERNALSYM ACCESS_DENIED_CALLBACK_ACE_TYPE} + ACCESS_ALLOWED_CALLBACK_OBJECT_ACE_TYPE = $B; + {$EXTERNALSYM ACCESS_ALLOWED_CALLBACK_OBJECT_ACE_TYPE} + ACCESS_DENIED_CALLBACK_OBJECT_ACE_TYPE = $C; + {$EXTERNALSYM ACCESS_DENIED_CALLBACK_OBJECT_ACE_TYPE} + SYSTEM_AUDIT_CALLBACK_ACE_TYPE = $D; + {$EXTERNALSYM SYSTEM_AUDIT_CALLBACK_ACE_TYPE} + SYSTEM_ALARM_CALLBACK_ACE_TYPE = $E; + {$EXTERNALSYM SYSTEM_ALARM_CALLBACK_ACE_TYPE} + SYSTEM_AUDIT_CALLBACK_OBJECT_ACE_TYPE = $F; + {$EXTERNALSYM SYSTEM_AUDIT_CALLBACK_OBJECT_ACE_TYPE} + SYSTEM_ALARM_CALLBACK_OBJECT_ACE_TYPE = $10; + {$EXTERNALSYM SYSTEM_ALARM_CALLBACK_OBJECT_ACE_TYPE} + + ACCESS_MAX_MS_V5_ACE_TYPE = $10; + {$EXTERNALSYM ACCESS_MAX_MS_V5_ACE_TYPE} + +// +// The following are the inherit flags that go into the AceFlags field +// of an Ace header. +// + + OBJECT_INHERIT_ACE = $1; + {$EXTERNALSYM OBJECT_INHERIT_ACE} + CONTAINER_INHERIT_ACE = $2; + {$EXTERNALSYM CONTAINER_INHERIT_ACE} + NO_PROPAGATE_INHERIT_ACE = $4; + {$EXTERNALSYM NO_PROPAGATE_INHERIT_ACE} + INHERIT_ONLY_ACE = $8; + {$EXTERNALSYM INHERIT_ONLY_ACE} + INHERITED_ACE = $10; + {$EXTERNALSYM INHERITED_ACE} + VALID_INHERIT_FLAGS = $1F; + {$EXTERNALSYM VALID_INHERIT_FLAGS} + +// The following are the currently defined ACE flags that go into the +// AceFlags field of an ACE header. Each ACE type has its own set of +// AceFlags. +// +// SUCCESSFUL_ACCESS_ACE_FLAG - used only with system audit and alarm ACE +// types to indicate that a message is generated for successful accesses. +// +// FAILED_ACCESS_ACE_FLAG - used only with system audit and alarm ACE types +// to indicate that a message is generated for failed accesses. +// + +// +// SYSTEM_AUDIT and SYSTEM_ALARM AceFlags +// +// These control the signaling of audit and alarms for success or failure. +// + + SUCCESSFUL_ACCESS_ACE_FLAG = $40; + {$EXTERNALSYM SUCCESSFUL_ACCESS_ACE_FLAG} + FAILED_ACCESS_ACE_FLAG = $80; + {$EXTERNALSYM FAILED_ACCESS_ACE_FLAG} + +// +// We'll define the structure of the predefined ACE types. Pictorally +// the structure of the predefined ACE's is as follows: +// +// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 +// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 +// +---------------+-------+-------+---------------+---------------+ +// | AceFlags | Resd |Inherit| AceSize | AceType | +// +---------------+-------+-------+---------------+---------------+ +// | Mask | +// +---------------------------------------------------------------+ +// | | +// + + +// | | +// + Sid + +// | | +// + + +// | | +// +---------------------------------------------------------------+ +// +// Mask is the access mask associated with the ACE. This is either the +// access allowed, access denied, audit, or alarm mask. +// +// Sid is the Sid associated with the ACE. +// + +// The following are the four predefined ACE types. + +// Examine the AceType field in the Header to determine +// which structure is appropriate to use for casting. + +type + PACCESS_ALLOWED_ACE = ^ACCESS_ALLOWED_ACE; + {$EXTERNALSYM PACCESS_ALLOWED_ACE} + _ACCESS_ALLOWED_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + end; + {$EXTERNALSYM _ACCESS_ALLOWED_ACE} + ACCESS_ALLOWED_ACE = _ACCESS_ALLOWED_ACE; + {$EXTERNALSYM ACCESS_ALLOWED_ACE} + TAccessAllowedAce = ACCESS_ALLOWED_ACE; + PAccessAllowedAce = PACCESS_ALLOWED_ACE; + + PACCESS_DENIED_ACE = ^ACCESS_DENIED_ACE; + {$EXTERNALSYM PACCESS_DENIED_ACE} + _ACCESS_DENIED_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + end; + {$EXTERNALSYM _ACCESS_DENIED_ACE} + ACCESS_DENIED_ACE = _ACCESS_DENIED_ACE; + {$EXTERNALSYM ACCESS_DENIED_ACE} + TAccessDeniedAce = ACCESS_DENIED_ACE; + PAccessDeniedAce = PACCESS_DENIED_ACE; + + PSYSTEM_AUDIT_ACE = ^SYSTEM_AUDIT_ACE; + {$EXTERNALSYM PSYSTEM_AUDIT_ACE} + _SYSTEM_AUDIT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + end; + {$EXTERNALSYM _SYSTEM_AUDIT_ACE} + SYSTEM_AUDIT_ACE = _SYSTEM_AUDIT_ACE; + {$EXTERNALSYM SYSTEM_AUDIT_ACE} + TSystemAuditAce = SYSTEM_AUDIT_ACE; + PSystemAuditAce = PSYSTEM_AUDIT_ACE; + + PSYSTEM_ALARM_ACE = ^SYSTEM_ALARM_ACE; + {$EXTERNALSYM PSYSTEM_ALARM_ACE} + _SYSTEM_ALARM_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + end; + {$EXTERNALSYM _SYSTEM_ALARM_ACE} + SYSTEM_ALARM_ACE = _SYSTEM_ALARM_ACE; + {$EXTERNALSYM SYSTEM_ALARM_ACE} + TSystemAlarmAce = SYSTEM_ALARM_ACE; + PSystemAlarmAce = PSYSTEM_ALARM_ACE; + + PACCESS_ALLOWED_OBJECT_ACE = ^ACCESS_ALLOWED_OBJECT_ACE; + {$EXTERNALSYM PACCESS_ALLOWED_OBJECT_ACE} + _ACCESS_ALLOWED_OBJECT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + Flags: DWORD; + ObjectType: GUID; + InheritedObjectType: GUID; + SidStart: DWORD; + end; + {$EXTERNALSYM _ACCESS_ALLOWED_OBJECT_ACE} + ACCESS_ALLOWED_OBJECT_ACE = _ACCESS_ALLOWED_OBJECT_ACE; + {$EXTERNALSYM ACCESS_ALLOWED_OBJECT_ACE} + TAccessAllowedObjectAce = ACCESS_ALLOWED_OBJECT_ACE; + PAccessAllowedObjectAce = PACCESS_ALLOWED_OBJECT_ACE; + + PACCESS_DENIED_OBJECT_ACE = ^ACCESS_DENIED_OBJECT_ACE; + {$EXTERNALSYM PACCESS_DENIED_OBJECT_ACE} + _ACCESS_DENIED_OBJECT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + Flags: DWORD; + ObjectType: GUID; + InheritedObjectType: GUID; + SidStart: DWORD; + end; + {$EXTERNALSYM _ACCESS_DENIED_OBJECT_ACE} + ACCESS_DENIED_OBJECT_ACE = _ACCESS_DENIED_OBJECT_ACE; + {$EXTERNALSYM ACCESS_DENIED_OBJECT_ACE} + TAccessDeniedObjectAce = ACCESS_DENIED_OBJECT_ACE; + PAccessDeniedObjectAce = PACCESS_DENIED_OBJECT_ACE; + + PSYSTEM_AUDIT_OBJECT_ACE = ^SYSTEM_AUDIT_OBJECT_ACE; + {$EXTERNALSYM PSYSTEM_AUDIT_OBJECT_ACE} + _SYSTEM_AUDIT_OBJECT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + Flags: DWORD; + ObjectType: GUID; + InheritedObjectType: GUID; + SidStart: DWORD; + end; + {$EXTERNALSYM _SYSTEM_AUDIT_OBJECT_ACE} + SYSTEM_AUDIT_OBJECT_ACE = _SYSTEM_AUDIT_OBJECT_ACE; + {$EXTERNALSYM SYSTEM_AUDIT_OBJECT_ACE} + TSystemAuditObjectAce = SYSTEM_AUDIT_OBJECT_ACE; + PSystemAuditObjectAce = PSYSTEM_AUDIT_OBJECT_ACE; + + PSYSTEM_ALARM_OBJECT_ACE = ^SYSTEM_ALARM_OBJECT_ACE; + {$EXTERNALSYM PSYSTEM_ALARM_OBJECT_ACE} + _SYSTEM_ALARM_OBJECT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + Flags: DWORD; + ObjectType: GUID; + InheritedObjectType: GUID; + SidStart: DWORD; + end; + {$EXTERNALSYM _SYSTEM_ALARM_OBJECT_ACE} + SYSTEM_ALARM_OBJECT_ACE = _SYSTEM_ALARM_OBJECT_ACE; + {$EXTERNALSYM SYSTEM_ALARM_OBJECT_ACE} + TSystemAlarmObjectAce = SYSTEM_ALARM_OBJECT_ACE; + PSystemAlarmObjectAce = PSYSTEM_ALARM_OBJECT_ACE; + +// +// Callback ace support in post Win2000. +// Resource managers can put their own data after Sidstart + Length of the sid +// + + _ACCESS_ALLOWED_CALLBACK_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + // Opaque resouce manager specific data + end; + {$EXTERNALSYM _ACCESS_ALLOWED_CALLBACK_ACE} + ACCESS_ALLOWED_CALLBACK_ACE = _ACCESS_ALLOWED_CALLBACK_ACE; + {$EXTERNALSYM ACCESS_ALLOWED_CALLBACK_ACE} + PACCESS_ALLOWED_CALLBACK_ACE = ^ACCESS_ALLOWED_CALLBACK_ACE; + {$EXTERNALSYM PACCESS_ALLOWED_CALLBACK_ACE} + TAccessAllowedCallBackAce = ACCESS_ALLOWED_CALLBACK_ACE; + PAccessAllowedCallBackAce = PACCESS_ALLOWED_CALLBACK_ACE; + + _ACCESS_DENIED_CALLBACK_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + // Opaque resouce manager specific data + end; + {$EXTERNALSYM _ACCESS_DENIED_CALLBACK_ACE} + ACCESS_DENIED_CALLBACK_ACE = _ACCESS_DENIED_CALLBACK_ACE; + {$EXTERNALSYM ACCESS_DENIED_CALLBACK_ACE} + PACCESS_DENIED_CALLBACK_ACE = ^ACCESS_DENIED_CALLBACK_ACE; + {$EXTERNALSYM PACCESS_DENIED_CALLBACK_ACE} + TAccessDeniedCallBackAce = ACCESS_DENIED_CALLBACK_ACE; + PAccessDeniedCallBackAce = PACCESS_DENIED_CALLBACK_ACE; + + _SYSTEM_AUDIT_CALLBACK_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + // Opaque resouce manager specific data + end; + {$EXTERNALSYM _SYSTEM_AUDIT_CALLBACK_ACE} + SYSTEM_AUDIT_CALLBACK_ACE = _SYSTEM_AUDIT_CALLBACK_ACE; + {$EXTERNALSYM SYSTEM_AUDIT_CALLBACK_ACE} + PSYSTEM_AUDIT_CALLBACK_ACE = ^SYSTEM_AUDIT_CALLBACK_ACE; + {$EXTERNALSYM PSYSTEM_AUDIT_CALLBACK_ACE} + TSystemAuditCallBackAce = SYSTEM_AUDIT_CALLBACK_ACE; + PSystemAuditCallBackAce = PSYSTEM_AUDIT_CALLBACK_ACE; + + _SYSTEM_ALARM_CALLBACK_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + // Opaque resouce manager specific data + end; + {$EXTERNALSYM _SYSTEM_ALARM_CALLBACK_ACE} + SYSTEM_ALARM_CALLBACK_ACE = _SYSTEM_ALARM_CALLBACK_ACE; + {$EXTERNALSYM SYSTEM_ALARM_CALLBACK_ACE} + PSYSTEM_ALARM_CALLBACK_ACE = ^SYSTEM_ALARM_CALLBACK_ACE; + {$EXTERNALSYM PSYSTEM_ALARM_CALLBACK_ACE} + TSystemAlarmCallBackAce = SYSTEM_ALARM_CALLBACK_ACE; + PSystemAlarmCallBackAce = PSYSTEM_ALARM_CALLBACK_ACE; + + _ACCESS_ALLOWED_CALLBACK_OBJECT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + Flags: DWORD; + ObjectType: GUID; + InheritedObjectType: GUID; + SidStart: DWORD; + // Opaque resouce manager specific data + end; + {$EXTERNALSYM _ACCESS_ALLOWED_CALLBACK_OBJECT_ACE} + ACCESS_ALLOWED_CALLBACK_OBJECT_ACE = _ACCESS_ALLOWED_CALLBACK_OBJECT_ACE; + {$EXTERNALSYM ACCESS_ALLOWED_CALLBACK_OBJECT_ACE} + PACCESS_ALLOWED_CALLBACK_OBJECT_ACE = ^ACCESS_ALLOWED_CALLBACK_OBJECT_ACE; + {$EXTERNALSYM PACCESS_ALLOWED_CALLBACK_OBJECT_ACE} + TAccessAllowedCallBackObjectAce = ACCESS_ALLOWED_CALLBACK_OBJECT_ACE; + PAccessAllowedCallBackObjectAce = PACCESS_ALLOWED_CALLBACK_OBJECT_ACE; + + _ACCESS_DENIED_CALLBACK_OBJECT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + Flags: DWORD; + ObjectType: GUID; + InheritedObjectType: GUID; + SidStart: DWORD; + // Opaque resouce manager specific data + end; + {$EXTERNALSYM _ACCESS_DENIED_CALLBACK_OBJECT_ACE} + ACCESS_DENIED_CALLBACK_OBJECT_ACE = _ACCESS_DENIED_CALLBACK_OBJECT_ACE; + {$EXTERNALSYM ACCESS_DENIED_CALLBACK_OBJECT_ACE} + PACCESS_DENIED_CALLBACK_OBJECT_ACE = ^ACCESS_DENIED_CALLBACK_OBJECT_ACE; + {$EXTERNALSYM PACCESS_DENIED_CALLBACK_OBJECT_ACE} + TAccessDeniedCallBackObjectAce = ACCESS_DENIED_CALLBACK_OBJECT_ACE; + PAccessDeniedCallBackObjectAce = PACCESS_DENIED_CALLBACK_OBJECT_ACE; + + _SYSTEM_AUDIT_CALLBACK_OBJECT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + Flags: DWORD; + ObjectType: GUID; + InheritedObjectType: GUID; + SidStart: DWORD; + // Opaque resouce manager specific data + end; + {$EXTERNALSYM _SYSTEM_AUDIT_CALLBACK_OBJECT_ACE} + SYSTEM_AUDIT_CALLBACK_OBJECT_ACE = _SYSTEM_AUDIT_CALLBACK_OBJECT_ACE; + {$EXTERNALSYM SYSTEM_AUDIT_CALLBACK_OBJECT_ACE} + PSYSTEM_AUDIT_CALLBACK_OBJECT_ACE = ^SYSTEM_AUDIT_CALLBACK_OBJECT_ACE; + {$EXTERNALSYM PSYSTEM_AUDIT_CALLBACK_OBJECT_ACE} + TSystemAuditCallBackObjectAce = SYSTEM_AUDIT_CALLBACK_OBJECT_ACE; + PSystemAuditCallBackObjectAce = PSYSTEM_AUDIT_CALLBACK_OBJECT_ACE; + + _SYSTEM_ALARM_CALLBACK_OBJECT_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + Flags: DWORD; + ObjectType: GUID; + InheritedObjectType: GUID; + SidStart: DWORD; + // Opaque resouce manager specific data + end; + {$EXTERNALSYM _SYSTEM_ALARM_CALLBACK_OBJECT_ACE} + SYSTEM_ALARM_CALLBACK_OBJECT_ACE = _SYSTEM_ALARM_CALLBACK_OBJECT_ACE; + {$EXTERNALSYM SYSTEM_ALARM_CALLBACK_OBJECT_ACE} + PSYSTEM_ALARM_CALLBACK_OBJECT_ACE = ^SYSTEM_ALARM_CALLBACK_OBJECT_ACE; + {$EXTERNALSYM PSYSTEM_ALARM_CALLBACK_OBJECT_ACE} + TSystemAlarmCallBackObjectAce = SYSTEM_ALARM_CALLBACK_OBJECT_ACE; + PSystemAlarmCallBackObjectAce = PSYSTEM_ALARM_CALLBACK_OBJECT_ACE; + +// +// Currently define Flags for "OBJECT" ACE types. +// + +const + ACE_OBJECT_TYPE_PRESENT = $1; + {$EXTERNALSYM ACE_OBJECT_TYPE_PRESENT} + ACE_INHERITED_OBJECT_TYPE_PRESENT = $2; + {$EXTERNALSYM ACE_INHERITED_OBJECT_TYPE_PRESENT} + +// +// The following declarations are used for setting and querying information +// about and ACL. First are the various information classes available to +// the user. +// + + AclRevisionInformation = 1; + {$EXTERNALSYM AclRevisionInformation} + AclSizeInformation = 2; + {$EXTERNALSYM AclSizeInformation} + +type + _ACL_INFORMATION_CLASS = DWORD; + {$EXTERNALSYM _ACL_INFORMATION_CLASS} + ACL_INFORMATION_CLASS = _ACL_INFORMATION_CLASS; + {$EXTERNALSYM ACL_INFORMATION_CLASS} + TAclInformationClass = ACL_INFORMATION_CLASS; + +// +// This record is returned/sent if the user is requesting/setting the +// AclRevisionInformation +// + + PACL_REVISION_INFORMATION = ^ACL_REVISION_INFORMATION; + {$EXTERNALSYM PACL_REVISION_INFORMATION} + _ACL_REVISION_INFORMATION = record + AclRevision: DWORD; + end; + {$EXTERNALSYM _ACL_REVISION_INFORMATION} + ACL_REVISION_INFORMATION = _ACL_REVISION_INFORMATION; + {$EXTERNALSYM ACL_REVISION_INFORMATION} + TAclRevisionInformation = ACL_REVISION_INFORMATION; + PAclRevisionInformation = PACL_REVISION_INFORMATION; + +// +// This record is returned if the user is requesting AclSizeInformation +// + + PACL_SIZE_INFORMATION = ^ACL_SIZE_INFORMATION; + {$EXTERNALSYM PACL_SIZE_INFORMATION} + _ACL_SIZE_INFORMATION = record + AceCount: DWORD; + AclBytesInUse: DWORD; + AclBytesFree: DWORD; + end; + {$EXTERNALSYM _ACL_SIZE_INFORMATION} + ACL_SIZE_INFORMATION = _ACL_SIZE_INFORMATION; + {$EXTERNALSYM ACL_SIZE_INFORMATION} + TAclSizeInformation = ACL_SIZE_INFORMATION; + PAclSizeInformation = PACL_SIZE_INFORMATION; + +//////////////////////////////////////////////////////////////////////// +// // +// SECURITY_DESCRIPTOR // +// // +//////////////////////////////////////////////////////////////////////// +// +// Define the Security Descriptor and related data types. +// This is an opaque data structure. +// + +// +// Current security descriptor revision value +// + +const + SECURITY_DESCRIPTOR_REVISION = 1; + {$EXTERNALSYM SECURITY_DESCRIPTOR_REVISION} + SECURITY_DESCRIPTOR_REVISION1 = 1; + {$EXTERNALSYM SECURITY_DESCRIPTOR_REVISION1} + +type + SECURITY_DESCRIPTOR_CONTROL = WORD; + {$EXTERNALSYM SECURITY_DESCRIPTOR_CONTROL} + PSECURITY_DESCRIPTOR_CONTROL = ^SECURITY_DESCRIPTOR_CONTROL; + {$EXTERNALSYM PSECURITY_DESCRIPTOR_CONTROL} + TSecurityDescriptorControl = SECURITY_DESCRIPTOR_CONTROL; + PSecurityDescriptorControl = PSECURITY_DESCRIPTOR_CONTROL; + +const + SE_OWNER_DEFAULTED = $0001; + {$EXTERNALSYM SE_OWNER_DEFAULTED} + SE_GROUP_DEFAULTED = $0002; + {$EXTERNALSYM SE_GROUP_DEFAULTED} + SE_DACL_PRESENT = $0004; + {$EXTERNALSYM SE_DACL_PRESENT} + SE_DACL_DEFAULTED = $0008; + {$EXTERNALSYM SE_DACL_DEFAULTED} + SE_SACL_PRESENT = $0010; + {$EXTERNALSYM SE_SACL_PRESENT} + SE_SACL_DEFAULTED = $0020; + {$EXTERNALSYM SE_SACL_DEFAULTED} + SE_DACL_AUTO_INHERIT_REQ = $0100; + {$EXTERNALSYM SE_DACL_AUTO_INHERIT_REQ} + SE_SACL_AUTO_INHERIT_REQ = $0200; + {$EXTERNALSYM SE_SACL_AUTO_INHERIT_REQ} + SE_DACL_AUTO_INHERITED = $0400; + {$EXTERNALSYM SE_DACL_AUTO_INHERITED} + SE_SACL_AUTO_INHERITED = $0800; + {$EXTERNALSYM SE_SACL_AUTO_INHERITED} + SE_DACL_PROTECTED = $1000; + {$EXTERNALSYM SE_DACL_PROTECTED} + SE_SACL_PROTECTED = $2000; + {$EXTERNALSYM SE_SACL_PROTECTED} + SE_RM_CONTROL_VALID = $4000; + {$EXTERNALSYM SE_RM_CONTROL_VALID} + SE_SELF_RELATIVE = $8000; + {$EXTERNALSYM SE_SELF_RELATIVE} + +// +// Where: +// +// SE_OWNER_DEFAULTED - This boolean flag, when set, indicates that the +// SID pointed to by the Owner field was provided by a +// defaulting mechanism rather than explicitly provided by the +// original provider of the security descriptor. This may +// affect the treatment of the SID with respect to inheritence +// of an owner. +// +// SE_GROUP_DEFAULTED - This boolean flag, when set, indicates that the +// SID in the Group field was provided by a defaulting mechanism +// rather than explicitly provided by the original provider of +// the security descriptor. This may affect the treatment of +// the SID with respect to inheritence of a primary group. +// +// SE_DACL_PRESENT - This boolean flag, when set, indicates that the +// security descriptor contains a discretionary ACL. If this +// flag is set and the Dacl field of the SECURITY_DESCRIPTOR is +// null, then a null ACL is explicitly being specified. +// +// SE_DACL_DEFAULTED - This boolean flag, when set, indicates that the +// ACL pointed to by the Dacl field was provided by a defaulting +// mechanism rather than explicitly provided by the original +// provider of the security descriptor. This may affect the +// treatment of the ACL with respect to inheritence of an ACL. +// This flag is ignored if the DaclPresent flag is not set. +// +// SE_SACL_PRESENT - This boolean flag, when set, indicates that the +// security descriptor contains a system ACL pointed to by the +// Sacl field. If this flag is set and the Sacl field of the +// SECURITY_DESCRIPTOR is null, then an empty (but present) +// ACL is being specified. +// +// SE_SACL_DEFAULTED - This boolean flag, when set, indicates that the +// ACL pointed to by the Sacl field was provided by a defaulting +// mechanism rather than explicitly provided by the original +// provider of the security descriptor. This may affect the +// treatment of the ACL with respect to inheritence of an ACL. +// This flag is ignored if the SaclPresent flag is not set. +// +// SE_SELF_RELATIVE - This boolean flag, when set, indicates that the +// security descriptor is in self-relative form. In this form, +// all fields of the security descriptor are contiguous in memory +// and all pointer fields are expressed as offsets from the +// beginning of the security descriptor. This form is useful +// for treating security descriptors as opaque data structures +// for transmission in communication protocol or for storage on +// secondary media. +// +// +// +// Pictorially the structure of a security descriptor is as follows: +// +// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 +// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 +// +---------------------------------------------------------------+ +// | Control |Reserved1 (SBZ)| Revision | +// +---------------------------------------------------------------+ +// | Owner | +// +---------------------------------------------------------------+ +// | Group | +// +---------------------------------------------------------------+ +// | Sacl | +// +---------------------------------------------------------------+ +// | Dacl | +// +---------------------------------------------------------------+ +// +// In general, this data structure should be treated opaquely to ensure future +// compatibility. +// +// + +type + PSECURITY_DESCRIPTOR_RELATIVE = ^SECURITY_DESCRIPTOR_RELATIVE; + {$EXTERNALSYM PSECURITY_DESCRIPTOR_RELATIVE} + _SECURITY_DESCRIPTOR_RELATIVE = record + Revision: Byte; + Sbz1: Byte; + Control: SECURITY_DESCRIPTOR_CONTROL; + Owner: DWORD; + Group: DWORD; + Sacl: DWORD; + Dacl: DWORD; + end; + {$EXTERNALSYM _SECURITY_DESCRIPTOR_RELATIVE} + SECURITY_DESCRIPTOR_RELATIVE = _SECURITY_DESCRIPTOR_RELATIVE; + {$EXTERNALSYM SECURITY_DESCRIPTOR_RELATIVE} + TSecurityDescriptorRelative = SECURITY_DESCRIPTOR_RELATIVE; + PSecurityDescriptorRelative = PSECURITY_DESCRIPTOR_RELATIVE; + + PSECURITY_DESCRIPTOR = ^SECURITY_DESCRIPTOR; + {$EXTERNALSYM PSECURITY_DESCRIPTOR} + _SECURITY_DESCRIPTOR = record + Revision: Byte; + Sbz1: Byte; + Control: SECURITY_DESCRIPTOR_CONTROL; + Owner: PSID; + Group: PSID; + Sacl: PACL; + Dacl: PACL; + end; + {$EXTERNALSYM _SECURITY_DESCRIPTOR} + SECURITY_DESCRIPTOR = _SECURITY_DESCRIPTOR; + {$EXTERNALSYM SECURITY_DESCRIPTOR} + TSecurityDescriptor = SECURITY_DESCRIPTOR; + PSecurityDescriptor = PSECURITY_DESCRIPTOR; + + PPSECURITY_DESCRIPTOR = ^PSECURITY_DESCRIPTOR; + {$NODEFINE PPSECURITY_DESCRIPTOR} + +const + SECURITY_DESCRIPTOR_MIN_LENGTH = SizeOf(SECURITY_DESCRIPTOR); + {$EXTERNALSYM SECURITY_DESCRIPTOR_MIN_LENGTH} + +// Where: +// +// Revision - Contains the revision level of the security +// descriptor. This allows this structure to be passed between +// systems or stored on disk even though it is expected to +// change in the future. +// +// Control - A set of flags which qualify the meaning of the +// security descriptor or individual fields of the security +// descriptor. +// +// Owner - is a pointer to an SID representing an object's owner. +// If this field is null, then no owner SID is present in the +// security descriptor. If the security descriptor is in +// self-relative form, then this field contains an offset to +// the SID, rather than a pointer. +// +// Group - is a pointer to an SID representing an object's primary +// group. If this field is null, then no primary group SID is +// present in the security descriptor. If the security descriptor +// is in self-relative form, then this field contains an offset to +// the SID, rather than a pointer. +// +// Sacl - is a pointer to a system ACL. This field value is only +// valid if the DaclPresent control flag is set. If the +// SaclPresent flag is set and this field is null, then a null +// ACL is specified. If the security descriptor is in +// self-relative form, then this field contains an offset to +// the ACL, rather than a pointer. +// +// Dacl - is a pointer to a discretionary ACL. This field value is +// only valid if the DaclPresent control flag is set. If the +// DaclPresent flag is set and this field is null, then a null +// ACL (unconditionally granting access) is specified. If the +// security descriptor is in self-relative form, then this field +// contains an offset to the ACL, rather than a pointer. +// + +//////////////////////////////////////////////////////////////////////// +// // +// Object Type list for AccessCheckByType // +// // +//////////////////////////////////////////////////////////////////////// + +type + POBJECT_TYPE_LIST = ^OBJECT_TYPE_LIST; + {$EXTERNALSYM POBJECT_TYPE_LIST} + _OBJECT_TYPE_LIST = record + Level: Word; + Sbz: Word; + ObjectType: PGUID; + end; + {$EXTERNALSYM _OBJECT_TYPE_LIST} + OBJECT_TYPE_LIST = _OBJECT_TYPE_LIST; + {$EXTERNALSYM OBJECT_TYPE_LIST} + TObjectTypeList = OBJECT_TYPE_LIST; + PObjectTypeList = POBJECT_TYPE_LIST; + +// +// DS values for Level +// + +const + ACCESS_OBJECT_GUID = 0; + {$EXTERNALSYM ACCESS_OBJECT_GUID} + ACCESS_PROPERTY_SET_GUID = 1; + {$EXTERNALSYM ACCESS_PROPERTY_SET_GUID} + ACCESS_PROPERTY_GUID = 2; + {$EXTERNALSYM ACCESS_PROPERTY_GUID} + + ACCESS_MAX_LEVEL = 4; + {$EXTERNALSYM ACCESS_MAX_LEVEL} + +// +// Parameters to NtAccessCheckByTypeAndAditAlarm +// + +type + _AUDIT_EVENT_TYPE = (AuditEventObjectAccess, AuditEventDirectoryServiceAccess); + {$EXTERNALSYM _AUDIT_EVENT_TYPE} + AUDIT_EVENT_TYPE = _AUDIT_EVENT_TYPE; + {$EXTERNALSYM AUDIT_EVENT_TYPE} + PAUDIT_EVENT_TYPE = ^AUDIT_EVENT_TYPE; + {$EXTERNALSYM PAUDIT_EVENT_TYPE} + TAuditEventType = AUDIT_EVENT_TYPE; + PAuditEventType = PAUDIT_EVENT_TYPE; + +const + AUDIT_ALLOW_NO_PRIVILEGE = $1; + {$EXTERNALSYM AUDIT_ALLOW_NO_PRIVILEGE} + +// +// DS values for Source and ObjectTypeName +// + + ACCESS_DS_SOURCE_A = 'DS'; + {$EXTERNALSYM ACCESS_DS_SOURCE_A} + ACCESS_DS_SOURCE_W = WideString('DS'); + {$EXTERNALSYM ACCESS_DS_SOURCE_W} + ACCESS_DS_OBJECT_TYPE_NAME_A = 'Directory Service Object'; + {$EXTERNALSYM ACCESS_DS_OBJECT_TYPE_NAME_A} + ACCESS_DS_OBJECT_TYPE_NAME_W = WideString('Directory Service Object'); + {$EXTERNALSYM ACCESS_DS_OBJECT_TYPE_NAME_W} + +//////////////////////////////////////////////////////////////////////// +// // +// Privilege Related Data Structures // +// // +//////////////////////////////////////////////////////////////////////// + +// +// Privilege attributes +// + +const + SE_PRIVILEGE_ENABLED_BY_DEFAULT = $00000001; + {$EXTERNALSYM SE_PRIVILEGE_ENABLED_BY_DEFAULT} + SE_PRIVILEGE_ENABLED = $00000002; + {$EXTERNALSYM SE_PRIVILEGE_ENABLED} + SE_PRIVILEGE_REMOVED = $00000004; + {$EXTERNALSYM SE_PRIVILEGE_REMOVED} + SE_PRIVILEGE_USED_FOR_ACCESS = DWORD($80000000); + {$EXTERNALSYM SE_PRIVILEGE_USED_FOR_ACCESS} + +// +// Privilege Set Control flags +// + + PRIVILEGE_SET_ALL_NECESSARY = 1; + {$EXTERNALSYM PRIVILEGE_SET_ALL_NECESSARY} + +// +// Privilege Set - This is defined for a privilege set of one. +// If more than one privilege is needed, then this structure +// will need to be allocated with more space. +// +// Note: don't change this structure without fixing the INITIAL_PRIVILEGE_SET +// structure (defined in se.h) +// + +type + PPRIVILEGE_SET = ^PRIVILEGE_SET; + {$EXTERNALSYM PPRIVILEGE_SET} + _PRIVILEGE_SET = record + PrivilegeCount: DWORD; + Control: DWORD; + Privilege: array [0..ANYSIZE_ARRAY - 1] of LUID_AND_ATTRIBUTES; + //Privilege: LUID_AND_ATTRIBUTES; + end; + {$EXTERNALSYM _PRIVILEGE_SET} + PRIVILEGE_SET = _PRIVILEGE_SET; + {$EXTERNALSYM PRIVILEGE_SET} + TPrivilegeSet = PRIVILEGE_SET; + PPrivilegeSet = PPRIVILEGE_SET; + +//////////////////////////////////////////////////////////////////////// +// // +// NT Defined Privileges // +// // +//////////////////////////////////////////////////////////////////////// + +const + SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege'; + {$EXTERNALSYM SE_CREATE_TOKEN_NAME} + SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege'; + {$EXTERNALSYM SE_ASSIGNPRIMARYTOKEN_NAME} + SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege'; + {$EXTERNALSYM SE_LOCK_MEMORY_NAME} + SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege'; + {$EXTERNALSYM SE_INCREASE_QUOTA_NAME} + SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege'; + {$EXTERNALSYM SE_UNSOLICITED_INPUT_NAME} + SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege'; + {$EXTERNALSYM SE_MACHINE_ACCOUNT_NAME} + SE_TCB_NAME = 'SeTcbPrivilege'; + {$EXTERNALSYM SE_TCB_NAME} + SE_SECURITY_NAME = 'SeSecurityPrivilege'; + {$EXTERNALSYM SE_SECURITY_NAME} + SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege'; + {$EXTERNALSYM SE_TAKE_OWNERSHIP_NAME} + SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege'; + {$EXTERNALSYM SE_LOAD_DRIVER_NAME} + SE_SYSTEM_PROFILE_NAME = 'SeSystemProfilePrivilege'; + {$EXTERNALSYM SE_SYSTEM_PROFILE_NAME} + SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege'; + {$EXTERNALSYM SE_SYSTEMTIME_NAME} + SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege'; + {$EXTERNALSYM SE_PROF_SINGLE_PROCESS_NAME} + SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege'; + {$EXTERNALSYM SE_INC_BASE_PRIORITY_NAME} + SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege'; + {$EXTERNALSYM SE_CREATE_PAGEFILE_NAME} + SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege'; + {$EXTERNALSYM SE_CREATE_PERMANENT_NAME} + SE_BACKUP_NAME = 'SeBackupPrivilege'; + {$EXTERNALSYM SE_BACKUP_NAME} + SE_RESTORE_NAME = 'SeRestorePrivilege'; + {$EXTERNALSYM SE_RESTORE_NAME} + SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; + {$EXTERNALSYM SE_SHUTDOWN_NAME} + SE_DEBUG_NAME = 'SeDebugPrivilege'; + {$EXTERNALSYM SE_DEBUG_NAME} + SE_AUDIT_NAME = 'SeAuditPrivilege'; + {$EXTERNALSYM SE_AUDIT_NAME} + SE_SYSTEM_ENVIRONMENT_NAME = 'SeSystemEnvironmentPrivilege'; + {$EXTERNALSYM SE_SYSTEM_ENVIRONMENT_NAME} + SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege'; + {$EXTERNALSYM SE_CHANGE_NOTIFY_NAME} + SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege'; + {$EXTERNALSYM SE_REMOTE_SHUTDOWN_NAME} + SE_UNDOCK_NAME = 'SeUndockPrivilege'; + {$EXTERNALSYM SE_UNDOCK_NAME} + SE_SYNC_AGENT_NAME = 'SeSyncAgentPrivilege'; + {$EXTERNALSYM SE_SYNC_AGENT_NAME} + SE_ENABLE_DELEGATION_NAME = 'SeEnableDelegationPrivilege'; + {$EXTERNALSYM SE_ENABLE_DELEGATION_NAME} + SE_MANAGE_VOLUME_NAME = 'SeManageVolumePrivilege'; + {$EXTERNALSYM SE_MANAGE_VOLUME_NAME} + SE_IMPERSONATE_NAME = 'SeImpersonatePrivilege'; + {$EXTERNALSYM SE_IMPERSONATE_NAME} + SE_CREATE_GLOBAL_NAME = 'SeCreateGlobalPrivilege'; + {$EXTERNALSYM SE_CREATE_GLOBAL_NAME} + +//////////////////////////////////////////////////////////////////// +// // +// Security Quality Of Service // +// // +// // +//////////////////////////////////////////////////////////////////// + +// +// Impersonation Level +// +// Impersonation level is represented by a pair of bits in Windows. +// If a new impersonation level is added or lowest value is changed from +// 0 to something else, fix the Windows CreateFile call. +// + +type + _SECURITY_IMPERSONATION_LEVEL = (SecurityAnonymous, SecurityIdentification, + SecurityImpersonation, SecurityDelegation); + {$EXTERNALSYM _SECURITY_IMPERSONATION_LEVEL} + SECURITY_IMPERSONATION_LEVEL = _SECURITY_IMPERSONATION_LEVEL; + {$EXTERNALSYM SECURITY_IMPERSONATION_LEVEL} + PSECURITY_IMPERSONATION_LEVEL = ^SECURITY_IMPERSONATION_LEVEL; + {$EXTERNALSYM PSECURITY_IMPERSONATION_LEVEL} + TSecurityImpersonationLevel = SECURITY_IMPERSONATION_LEVEL; + PSecurityImpersonationLevel = PSECURITY_IMPERSONATION_LEVEL; + +const + SECURITY_MAX_IMPERSONATION_LEVEL = SecurityDelegation; + {$EXTERNALSYM SECURITY_MAX_IMPERSONATION_LEVEL} + SECURITY_MIN_IMPERSONATION_LEVEL = SecurityAnonymous; + {$EXTERNALSYM SECURITY_MIN_IMPERSONATION_LEVEL} + DEFAULT_IMPERSONATION_LEVEL = SecurityImpersonation; + {$EXTERNALSYM DEFAULT_IMPERSONATION_LEVEL} + +function VALID_IMPERSONATION_LEVEL(L: TSecurityImpersonationLevel): BOOL; +{$EXTERNALSYM VALID_IMPERSONATION_LEVEL} + +//////////////////////////////////////////////////////////////////// +// // +// Token Object Definitions // +// // +// // +//////////////////////////////////////////////////////////////////// + +// +// Token Specific Access Rights. +// + +const + TOKEN_ASSIGN_PRIMARY = $0001; + {$EXTERNALSYM TOKEN_ASSIGN_PRIMARY} + TOKEN_DUPLICATE = $0002; + {$EXTERNALSYM TOKEN_DUPLICATE} + TOKEN_IMPERSONATE = $0004; + {$EXTERNALSYM TOKEN_IMPERSONATE} + TOKEN_QUERY = $0008; + {$EXTERNALSYM TOKEN_QUERY} + TOKEN_QUERY_SOURCE = $0010; + {$EXTERNALSYM TOKEN_QUERY_SOURCE} + TOKEN_ADJUST_PRIVILEGES = $0020; + {$EXTERNALSYM TOKEN_ADJUST_PRIVILEGES} + TOKEN_ADJUST_GROUPS = $0040; + {$EXTERNALSYM TOKEN_ADJUST_GROUPS} + TOKEN_ADJUST_DEFAULT = $0080; + {$EXTERNALSYM TOKEN_ADJUST_DEFAULT} + TOKEN_ADJUST_SESSIONID = $0100; + {$EXTERNALSYM TOKEN_ADJUST_SESSIONID} + + TOKEN_ALL_ACCESS_P = STANDARD_RIGHTS_REQUIRED or TOKEN_ASSIGN_PRIMARY or + TOKEN_DUPLICATE or TOKEN_IMPERSONATE or TOKEN_QUERY or TOKEN_QUERY_SOURCE or + TOKEN_ADJUST_PRIVILEGES or TOKEN_ADJUST_GROUPS or TOKEN_ADJUST_DEFAULT; + {$EXTERNALSYM TOKEN_ALL_ACCESS_P} + + TOKEN_ALL_ACCESS = TOKEN_ALL_ACCESS_P or TOKEN_ADJUST_SESSIONID; + {$EXTERNALSYM TOKEN_ALL_ACCESS} + + TOKEN_READ = STANDARD_RIGHTS_READ or TOKEN_QUERY; + {$EXTERNALSYM TOKEN_READ} + + TOKEN_WRITE = (STANDARD_RIGHTS_WRITE or TOKEN_ADJUST_PRIVILEGES or + TOKEN_ADJUST_GROUPS or TOKEN_ADJUST_DEFAULT); + {$EXTERNALSYM TOKEN_WRITE} + + TOKEN_EXECUTE = STANDARD_RIGHTS_EXECUTE; + {$EXTERNALSYM TOKEN_EXECUTE} + +// +// Token Types +// + +type + _TOKEN_TYPE = (TokenTypePad0, TokenPrimary, TokenImpersonation); + {$EXTERNALSYM _TOKEN_TYPE} + TOKEN_TYPE = _TOKEN_TYPE; + {$EXTERNALSYM TOKEN_TYPE} + PTOKEN_TYPE = ^TOKEN_TYPE; + {$EXTERNALSYM PTOKEN_TYPE} + + TTokenType = TOKEN_TYPE; + PTokenType = PTOKEN_TYPE; + +// +// Token Information Classes. +// + +type + _TOKEN_INFORMATION_CLASS = (TokenInfoClassPad0, TokenUser, TokenGroups, + TokenPrivileges, TokenOwner, TokenPrimaryGroup, TokenDefaultDacl, TokenSource, + TokenType, TokenImpersonationLevel, TokenStatistics, TokenRestrictedSids, + TokenSessionId, TokenGroupsAndPrivileges, TokenSessionReference, + TokenSandBoxInert, TokenAuditPolicy, TokenOrigin, + MaxTokenInfoClass); {MaxTokenInfoClass should always be the last enum} + {$EXTERNALSYM _TOKEN_INFORMATION_CLASS} + TOKEN_INFORMATION_CLASS = _TOKEN_INFORMATION_CLASS; + {$EXTERNALSYM TOKEN_INFORMATION_CLASS} + PTOKEN_INFORMATION_CLASS = ^TOKEN_INFORMATION_CLASS; + {$EXTERNALSYM PTOKEN_INFORMATION_CLASS} + + TTokenInformationClass = TOKEN_INFORMATION_CLASS; + PTokenInformationClass = PTOKEN_INFORMATION_CLASS; + +// +// Token information class structures +// + +type + PTOKEN_USER = ^TOKEN_USER; + {$EXTERNALSYM PTOKEN_USER} + _TOKEN_USER = record + User: SID_AND_ATTRIBUTES; + end; + {$EXTERNALSYM _TOKEN_USER} + TOKEN_USER = _TOKEN_USER; + {$EXTERNALSYM TOKEN_USER} + TTokenUser = TOKEN_USER; + PTokenUser = PTOKEN_USER; + + PTOKEN_GROUPS = ^TOKEN_GROUPS; + {$EXTERNALSYM PTOKEN_GROUPS} + _TOKEN_GROUPS = record + GroupCount: DWORD; + Groups: array [0..ANYSIZE_ARRAY - 1] of SID_AND_ATTRIBUTES; + end; + {$EXTERNALSYM _TOKEN_GROUPS} + TOKEN_GROUPS = _TOKEN_GROUPS; + {$EXTERNALSYM TOKEN_GROUPS} + TTokenGroups = TOKEN_GROUPS; + PTokenGroups = PTOKEN_GROUPS; + + PTOKEN_PRIVILEGES = ^TOKEN_PRIVILEGES; + {$EXTERNALSYM PTOKEN_PRIVILEGES} + _TOKEN_PRIVILEGES = record + PrivilegeCount: DWORD; + Privileges: array [0..ANYSIZE_ARRAY - 1] of LUID_AND_ATTRIBUTES; + end; + {$EXTERNALSYM _TOKEN_PRIVILEGES} + TOKEN_PRIVILEGES = _TOKEN_PRIVILEGES; + {$EXTERNALSYM TOKEN_PRIVILEGES} + TTokenPrivileges = TOKEN_PRIVILEGES; + PTokenPrivileges = PTOKEN_PRIVILEGES; + + PTOKEN_OWNER = ^TOKEN_OWNER; + {$EXTERNALSYM PTOKEN_OWNER} + _TOKEN_OWNER = record + Owner: PSID; + end; + {$EXTERNALSYM _TOKEN_OWNER} + TOKEN_OWNER = _TOKEN_OWNER; + {$EXTERNALSYM TOKEN_OWNER} + TTokenOwner = TOKEN_OWNER; + PTokenOwner = PTOKEN_OWNER; + + PTOKEN_PRIMARY_GROUP = ^TOKEN_PRIMARY_GROUP; + {$EXTERNALSYM PTOKEN_PRIMARY_GROUP} + _TOKEN_PRIMARY_GROUP = record + PrimaryGroup: PSID; + end; + {$EXTERNALSYM _TOKEN_PRIMARY_GROUP} + TOKEN_PRIMARY_GROUP = _TOKEN_PRIMARY_GROUP; + {$EXTERNALSYM TOKEN_PRIMARY_GROUP} + TTokenPrimaryGroup = TOKEN_PRIMARY_GROUP; + PTokenPrimaryGroup = PTOKEN_PRIMARY_GROUP; + + PTOKEN_DEFAULT_DACL = ^TOKEN_DEFAULT_DACL; + {$EXTERNALSYM PTOKEN_DEFAULT_DACL} + _TOKEN_DEFAULT_DACL = record + DefaultDacl: PACL; + end; + {$EXTERNALSYM _TOKEN_DEFAULT_DACL} + TOKEN_DEFAULT_DACL = _TOKEN_DEFAULT_DACL; + {$EXTERNALSYM TOKEN_DEFAULT_DACL} + TTokenDefaultDacl = TOKEN_DEFAULT_DACL; + PTokenDefaultDacl = PTOKEN_DEFAULT_DACL; + + _TOKEN_GROUPS_AND_PRIVILEGES = record + SidCount: DWORD; + SidLength: DWORD; + Sids: PSID_AND_ATTRIBUTES; + RestrictedSidCount: DWORD; + RestrictedSidLength: DWORD; + RestrictedSids: PSID_AND_ATTRIBUTES; + PrivilegeCount: DWORD; + PrivilegeLength: DWORD; + Privileges: PLUID_AND_ATTRIBUTES; + AuthenticationId: LUID; + end; + {$EXTERNALSYM _TOKEN_GROUPS_AND_PRIVILEGES} + TOKEN_GROUPS_AND_PRIVILEGES = _TOKEN_GROUPS_AND_PRIVILEGES; + {$EXTERNALSYM TOKEN_GROUPS_AND_PRIVILEGES} + PTOKEN_GROUPS_AND_PRIVILEGES = ^TOKEN_GROUPS_AND_PRIVILEGES; + {$EXTERNALSYM PTOKEN_GROUPS_AND_PRIVILEGES} + TTokenGroupsAndPrivileges = TOKEN_GROUPS_AND_PRIVILEGES; + PTokenGroupsAndPrivileges = PTOKEN_GROUPS_AND_PRIVILEGES; + +// +// Valid bits for each TOKEN_AUDIT_POLICY policy mask field. +// + +const + TOKEN_AUDIT_SUCCESS_INCLUDE = $1; + {$EXTERNALSYM TOKEN_AUDIT_SUCCESS_INCLUDE} + TOKEN_AUDIT_SUCCESS_EXCLUDE = $2; + {$EXTERNALSYM TOKEN_AUDIT_SUCCESS_EXCLUDE} + TOKEN_AUDIT_FAILURE_INCLUDE = $4; + {$EXTERNALSYM TOKEN_AUDIT_FAILURE_INCLUDE} + TOKEN_AUDIT_FAILURE_EXCLUDE = $8; + {$EXTERNALSYM TOKEN_AUDIT_FAILURE_EXCLUDE} + + VALID_AUDIT_POLICY_BITS = (TOKEN_AUDIT_SUCCESS_INCLUDE or + TOKEN_AUDIT_SUCCESS_EXCLUDE or + TOKEN_AUDIT_FAILURE_INCLUDE or + TOKEN_AUDIT_FAILURE_EXCLUDE); + {$EXTERNALSYM VALID_AUDIT_POLICY_BITS} + +type + _TOKEN_AUDIT_POLICY_ELEMENT = record + Category: DWORD; + PolicyMask: DWORD; + end; + {$EXTERNALSYM _TOKEN_AUDIT_POLICY_ELEMENT} + TOKEN_AUDIT_POLICY_ELEMENT = _TOKEN_AUDIT_POLICY_ELEMENT; + {$EXTERNALSYM TOKEN_AUDIT_POLICY_ELEMENT} + PTOKEN_AUDIT_POLICY_ELEMENT = ^TOKEN_AUDIT_POLICY_ELEMENT; + {$EXTERNALSYM PTOKEN_AUDIT_POLICY_ELEMENT} + TTokenAuditPolicyElement = TOKEN_AUDIT_POLICY_ELEMENT; + PTokenAuditPolicyElement = PTOKEN_AUDIT_POLICY_ELEMENT; + +// TODO Implementation references AuditEventMaxType, which isn't defined anywhere +//function VALID_TOKEN_AUDIT_POLICY_ELEMENT(P: TOKEN_AUDIT_POLICY_ELEMENT): BOOL; +//{$EXTERNALSYM VALID_TOKEN_AUDIT_POLICY_ELEMENT} + +type + _TOKEN_AUDIT_POLICY = record + PolicyCount: DWORD; + Policy: array [0..ANYSIZE_ARRAY - 1] of TOKEN_AUDIT_POLICY_ELEMENT; + end; + {$EXTERNALSYM _TOKEN_AUDIT_POLICY} + TOKEN_AUDIT_POLICY = _TOKEN_AUDIT_POLICY; + {$EXTERNALSYM TOKEN_AUDIT_POLICY} + PTOKEN_AUDIT_POLICY = ^TOKEN_AUDIT_POLICY; + {$EXTERNALSYM PTOKEN_AUDIT_POLICY} + TTokenAuditPolicy = TOKEN_AUDIT_POLICY; + PTokenAuditPolicy = PTOKEN_AUDIT_POLICY; + +function PER_USER_AUDITING_POLICY_SIZE(p: PTOKEN_AUDIT_POLICY): DWORD; +{$EXTERNALSYM PER_USER_AUDITING_POLICY_SIZE} + +function PER_USER_AUDITING_POLICY_SIZE_BY_COUNT(C: DWORD): DWORD; +{$EXTERNALSYM PER_USER_AUDITING_POLICY_SIZE_BY_COUNT} + +const + TOKEN_SOURCE_LENGTH = 8; + {$EXTERNALSYM TOKEN_SOURCE_LENGTH} + +type + PTOKEN_SOURCE = ^TOKEN_SOURCE; + {$EXTERNALSYM PTOKEN_SOURCE} + _TOKEN_SOURCE = record + SourceName: array [0..TOKEN_SOURCE_LENGTH - 1] of CHAR; + SourceIdentifier: LUID; + end; + {$EXTERNALSYM _TOKEN_SOURCE} + TOKEN_SOURCE = _TOKEN_SOURCE; + {$EXTERNALSYM TOKEN_SOURCE} + TTokenSource = TOKEN_SOURCE; + PTokenSource = PTOKEN_SOURCE; + + PTOKEN_STATISTICS = ^TOKEN_STATISTICS; + {$EXTERNALSYM PTOKEN_STATISTICS} + _TOKEN_STATISTICS = record + TokenId: LUID; + AuthenticationId: LUID; + ExpirationTime: LARGE_INTEGER; + TokenType: TOKEN_TYPE; + ImpersonationLevel: SECURITY_IMPERSONATION_LEVEL; + DynamicCharged: DWORD; + DynamicAvailable: DWORD; + GroupCount: DWORD; + PrivilegeCount: DWORD; + ModifiedId: LUID; + end; + {$EXTERNALSYM _TOKEN_STATISTICS} + TOKEN_STATISTICS = _TOKEN_STATISTICS; + {$EXTERNALSYM TOKEN_STATISTICS} + TTokenStatistics = TOKEN_STATISTICS; + PTokenStatistics = PTOKEN_STATISTICS; + + PTOKEN_CONTROL = ^TOKEN_CONTROL; + {$EXTERNALSYM PTOKEN_CONTROL} + _TOKEN_CONTROL = record + TokenId: LUID; + AuthenticationId: LUID; + ModifiedId: LUID; + TokenSource: TOKEN_SOURCE; + end; + {$EXTERNALSYM _TOKEN_CONTROL} + TOKEN_CONTROL = _TOKEN_CONTROL; + {$EXTERNALSYM TOKEN_CONTROL} + TTokenControl = TOKEN_CONTROL; + PTokenControl = PTOKEN_CONTROL; + + _TOKEN_ORIGIN = record + OriginatingLogonSession: LUID; + end; + {$EXTERNALSYM _TOKEN_ORIGIN} + TOKEN_ORIGIN = _TOKEN_ORIGIN; + {$EXTERNALSYM TOKEN_ORIGIN} + PTOKEN_ORIGIN = ^TOKEN_ORIGIN; + {$EXTERNALSYM PTOKEN_ORIGIN} + TTokenOrigin = TOKEN_ORIGIN; + PTokenOrigin = PTOKEN_ORIGIN; + +// +// Security Tracking Mode +// + +const + SECURITY_DYNAMIC_TRACKING = True; + {$EXTERNALSYM SECURITY_DYNAMIC_TRACKING} + SECURITY_STATIC_TRACKING = False; + {$EXTERNALSYM SECURITY_STATIC_TRACKING} + +type + SECURITY_CONTEXT_TRACKING_MODE = ByteBool; + {$EXTERNALSYM SECURITY_CONTEXT_TRACKING_MODE} + PSECURITY_CONTEXT_TRACKING_MODE = ^SECURITY_CONTEXT_TRACKING_MODE; + {$EXTERNALSYM PSECURITY_CONTEXT_TRACKING_MODE} + +// +// Quality Of Service +// + + PSECURITY_QUALITY_OF_SERVICE = ^SECURITY_QUALITY_OF_SERVICE; + {$EXTERNALSYM PSECURITY_QUALITY_OF_SERVICE} + _SECURITY_QUALITY_OF_SERVICE = record + Length: DWORD; + ImpersonationLevel: SECURITY_IMPERSONATION_LEVEL; + ContextTrackingMode: SECURITY_CONTEXT_TRACKING_MODE; + EffectiveOnly: ByteBool; + end; + {$EXTERNALSYM _SECURITY_QUALITY_OF_SERVICE} + SECURITY_QUALITY_OF_SERVICE = _SECURITY_QUALITY_OF_SERVICE; + {$EXTERNALSYM SECURITY_QUALITY_OF_SERVICE} + TSecurityQualityOfService = SECURITY_QUALITY_OF_SERVICE; + PSecurityQualityOfService = PSECURITY_QUALITY_OF_SERVICE; + +// +// Used to represent information related to a thread impersonation +// + + PSE_IMPERSONATION_STATE = ^SE_IMPERSONATION_STATE; + {$EXTERNALSYM PSE_IMPERSONATION_STATE} + _SE_IMPERSONATION_STATE = record + Token: PACCESS_TOKEN; + CopyOnOpen: ByteBool; + EffectiveOnly: ByteBool; + Level: SECURITY_IMPERSONATION_LEVEL; + end; + {$EXTERNALSYM _SE_IMPERSONATION_STATE} + SE_IMPERSONATION_STATE = _SE_IMPERSONATION_STATE; + {$EXTERNALSYM SE_IMPERSONATION_STATE} + TSeImpersonationState = SE_IMPERSONATION_STATE; + PSeImpersonationState = PSE_IMPERSONATION_STATE; + +const + DISABLE_MAX_PRIVILEGE = $1; + {$EXTERNALSYM DISABLE_MAX_PRIVILEGE} + SANDBOX_INERT = $2; + {$EXTERNALSYM SANDBOX_INERT} + +type + SECURITY_INFORMATION = DWORD; + {$EXTERNALSYM SECURITY_INFORMATION} + PSECURITY_INFORMATION = ^SECURITY_INFORMATION; + {$EXTERNALSYM PSECURITY_INFORMATION} + TSecurityInformation = SECURITY_INFORMATION; + PSecurityInformation = PSECURITY_INFORMATION; + +const + OWNER_SECURITY_INFORMATION = $00000001; + {$EXTERNALSYM OWNER_SECURITY_INFORMATION} + GROUP_SECURITY_INFORMATION = $00000002; + {$EXTERNALSYM GROUP_SECURITY_INFORMATION} + DACL_SECURITY_INFORMATION = $00000004; + {$EXTERNALSYM DACL_SECURITY_INFORMATION} + SACL_SECURITY_INFORMATION = $00000008; + {$EXTERNALSYM SACL_SECURITY_INFORMATION} + + PROTECTED_DACL_SECURITY_INFORMATION = $80000000; + {$EXTERNALSYM PROTECTED_DACL_SECURITY_INFORMATION} + PROTECTED_SACL_SECURITY_INFORMATION = $40000000; + {$EXTERNALSYM PROTECTED_SACL_SECURITY_INFORMATION} + UNPROTECTED_DACL_SECURITY_INFORMATION = $20000000; + {$EXTERNALSYM UNPROTECTED_DACL_SECURITY_INFORMATION} + UNPROTECTED_SACL_SECURITY_INFORMATION = $10000000; + {$EXTERNALSYM UNPROTECTED_SACL_SECURITY_INFORMATION} + + PROCESS_TERMINATE = $0001; + {$EXTERNALSYM PROCESS_TERMINATE} + PROCESS_CREATE_THREAD = $0002; + {$EXTERNALSYM PROCESS_CREATE_THREAD} + PROCESS_SET_SESSIONID = $0004; + {$EXTERNALSYM PROCESS_SET_SESSIONID} + PROCESS_VM_OPERATION = $0008; + {$EXTERNALSYM PROCESS_VM_OPERATION} + PROCESS_VM_READ = $0010; + {$EXTERNALSYM PROCESS_VM_READ} + PROCESS_VM_WRITE = $0020; + {$EXTERNALSYM PROCESS_VM_WRITE} + PROCESS_DUP_HANDLE = $0040; + {$EXTERNALSYM PROCESS_DUP_HANDLE} + PROCESS_CREATE_PROCESS = $0080; + {$EXTERNALSYM PROCESS_CREATE_PROCESS} + PROCESS_SET_QUOTA = $0100; + {$EXTERNALSYM PROCESS_SET_QUOTA} + PROCESS_SET_INFORMATION = $0200; + {$EXTERNALSYM PROCESS_SET_INFORMATION} + PROCESS_QUERY_INFORMATION = $0400; + {$EXTERNALSYM PROCESS_QUERY_INFORMATION} + PROCESS_SUSPEND_RESUME = $0800; + {$EXTERNALSYM PROCESS_SUSPEND_RESUME} + PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $FFF; + {$EXTERNALSYM PROCESS_ALL_ACCESS} + + MAXIMUM_PROCESSORS = 32; + {$EXTERNALSYM MAXIMUM_PROCESSORS} + + THREAD_TERMINATE = $0001; + {$EXTERNALSYM THREAD_TERMINATE} + THREAD_SUSPEND_RESUME = $0002; + {$EXTERNALSYM THREAD_SUSPEND_RESUME} + THREAD_GET_CONTEXT = $0008; + {$EXTERNALSYM THREAD_GET_CONTEXT} + THREAD_SET_CONTEXT = $0010; + {$EXTERNALSYM THREAD_SET_CONTEXT} + THREAD_SET_INFORMATION = $0020; + {$EXTERNALSYM THREAD_SET_INFORMATION} + THREAD_QUERY_INFORMATION = $0040; + {$EXTERNALSYM THREAD_QUERY_INFORMATION} + THREAD_SET_THREAD_TOKEN = $0080; + {$EXTERNALSYM THREAD_SET_THREAD_TOKEN} + THREAD_IMPERSONATE = $0100; + {$EXTERNALSYM THREAD_IMPERSONATE} + THREAD_DIRECT_IMPERSONATION = $0200; + {$EXTERNALSYM THREAD_DIRECT_IMPERSONATION} + + THREAD_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $3FF; + {$EXTERNALSYM THREAD_ALL_ACCESS} + + JOB_OBJECT_ASSIGN_PROCESS = $0001; + {$EXTERNALSYM JOB_OBJECT_ASSIGN_PROCESS} + JOB_OBJECT_SET_ATTRIBUTES = $0002; + {$EXTERNALSYM JOB_OBJECT_SET_ATTRIBUTES} + JOB_OBJECT_QUERY = $0004; + {$EXTERNALSYM JOB_OBJECT_QUERY} + JOB_OBJECT_TERMINATE = $0008; + {$EXTERNALSYM JOB_OBJECT_TERMINATE} + JOB_OBJECT_SET_SECURITY_ATTRIBUTES = $0010; + {$EXTERNALSYM JOB_OBJECT_SET_SECURITY_ATTRIBUTES} + JOB_OBJECT_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $1F ; + {$EXTERNALSYM JOB_OBJECT_ALL_ACCESS} + +type + _JOB_SET_ARRAY = record + JobHandle: HANDLE; // Handle to job object to insert + MemberLevel: DWORD; // Level of this job in the set. Must be > 0. Can be sparse. + Flags: DWORD; // Unused. Must be zero + end; + {$EXTERNALSYM _JOB_SET_ARRAY} + JOB_SET_ARRAY = _JOB_SET_ARRAY; + {$EXTERNALSYM JOB_SET_ARRAY} + PJOB_SET_ARRAY = ^JOB_SET_ARRAY; + {$EXTERNALSYM PJOB_SET_ARRAY} + TJobSetArray = JOB_SET_ARRAY; + PJobSetArray = PJOB_SET_ARRAY; + +const + FLS_MAXIMUM_AVAILABLE = 128; + {$EXTERNALSYM FLS_MAXIMUM_AVAILABLE} + TLS_MINIMUM_AVAILABLE = 64; + {$EXTERNALSYM TLS_MINIMUM_AVAILABLE} + +type + PEXCEPTION_REGISTRATION_RECORD = ^EXCEPTION_REGISTRATION_RECORD; + _EXCEPTION_REGISTRATION_RECORD = packed record + pNext: PEXCEPTION_REGISTRATION_RECORD; + pfnHandler: FARPROC; + end; + EXCEPTION_REGISTRATION_RECORD = _EXCEPTION_REGISTRATION_RECORD; + TExceptionRegistrationRecord = EXCEPTION_REGISTRATION_RECORD; + PExceptionRegistrationRecord = PEXCEPTION_REGISTRATION_RECORD; + + PNT_TIB = ^NT_TIB; + {$EXTERNALSYM PNT_TIB} + _NT_TIB = record + ExceptionList: PEXCEPTION_REGISTRATION_RECORD; // 00h Head of exception record list + StackBase: PVOID; // 04h Top of user stack + StackLimit: PVOID; // 08h Base of user stack + + //union // 0Ch (NT/Win95 differences) + //{ + // struct // Win95 fields + // { + // WORD pvTDB; // 0Ch TDB + // WORD pvThunkSS; // 0Eh SS selector used for thunking to 16 bits + // DWORD unknown1; // 10h + // } WIN95; + // + // struct // WinNT fields + // { + + SubSystemTib: PVOID; // 0Ch + + Union: record // 10H + case Integer of + 0: (FiberData: PVOID); + 1: (Version: DWORD); + end; + + // } WINNT; + //} TIB_UNION1; + + ArbitraryUserPointer: PVOID; // 14h Available for application use + Self: PNT_TIB; // 18h Linear address of TIB structure + + //union // 1Ch (NT/Win95 differences) + //{ + // struct // Win95 fields + // { + // WORD TIBFlags; // 1Ch + // WORD Win16MutexCount; // 1Eh + // DWORD DebugContext; // 20h + // DWORD pCurrentPriority; // 24h + // DWORD pvQueue; // 28h Message Queue selector + // } WIN95; + // + // struct // WinNT fields + // { + + unknown1: DWORD; // 1Ch + processID: DWORD; // 20h + threadID: DWORD; // 24h + unknown2: DWORD; // 28h + + // } WINNT; + //} TIB_UNION2; + + pvTLSArray: PVOID; // (PPVOID!) 2Ch Thread Local Storage array + + //union // 30h (NT/Win95 differences) + //{ + // struct // Win95 fields + // { + // PVOID* pProcess; // 30h Pointer to owning process database + // } WIN95; + //} TIB_UNION3; + end; + {$EXTERNALSYM _NT_TIB} + NT_TIB = _NT_TIB; + {$EXTERNALSYM NT_TIB} + TNtTib = NT_TIB; + PNtTib = ^TNtTib; + +// +// 32 and 64 bit specific version for wow64 and the debugger +// + + PNT_TIB32 = ^NT_TIB32; + {$EXTERNALSYM PNT_TIB32} + _NT_TIB32 = record + ExceptionList: DWORD; + StackBase: DWORD; + StackLimit: DWORD; + SubSystemTib: DWORD; + Union: record + case Integer of + 0: (FiberData: DWORD); + 1: (Version: DWORD); + end; + ArbitraryUserPointer: DWORD; + Self: DWORD; + end; + {$EXTERNALSYM _NT_TIB32} + NT_TIB32 = _NT_TIB32; + {$EXTERNALSYM NT_TIB32} + TNtTib32 = NT_TIB32; + PNtTib32 = ^TNtTib32; + + PNT_TIB64 = ^NT_TIB64; + {$EXTERNALSYM PNT_TIB64} + _NT_TIB64 = record + ExceptionList: DWORD64; + StackBase: DWORD64; + StackLimit: DWORD64; + SubSystemTib: DWORD64; + Union: record + case Integer of + 0: (FiberData: DWORD64); + 1: (Version: DWORD); + end; + ArbitraryUserPointer: DWORD64; + Self: DWORD64; + end; + {$EXTERNALSYM _NT_TIB64} + NT_TIB64 = _NT_TIB64; + {$EXTERNALSYM NT_TIB64} + TNtTib64 = NT_TIB64; + PNtTib64 = ^TNtTib64; + +// +// Define function to return the current Thread Environment Block +// + +function NtCurrentTeb: PNT_TIB; +{$EXTERNALSYM NtCurrentTeb} + +const + THREAD_BASE_PRIORITY_LOWRT = 15; // value that gets a thread to LowRealtime-1 + {$EXTERNALSYM THREAD_BASE_PRIORITY_LOWRT} + THREAD_BASE_PRIORITY_MAX = 2; // maximum thread base priority boost + {$EXTERNALSYM THREAD_BASE_PRIORITY_MAX} + THREAD_BASE_PRIORITY_MIN = DWORD(-2); // minimum thread base priority boost + {$EXTERNALSYM THREAD_BASE_PRIORITY_MIN} + THREAD_BASE_PRIORITY_IDLE = DWORD(-15); // value that gets a thread to idle + {$EXTERNALSYM THREAD_BASE_PRIORITY_IDLE} + +type + PQUOTA_LIMITS = ^QUOTA_LIMITS; + {$EXTERNALSYM PQUOTA_LIMITS} + _QUOTA_LIMITS = record + PagedPoolLimit: SIZE_T; + NonPagedPoolLimit: SIZE_T; + MinimumWorkingSetSize: SIZE_T; + MaximumWorkingSetSize: SIZE_T; + PagefileLimit: SIZE_T; + TimeLimit: LARGE_INTEGER; + end; + {$EXTERNALSYM _QUOTA_LIMITS} + QUOTA_LIMITS = _QUOTA_LIMITS; + {$EXTERNALSYM QUOTA_LIMITS} + TQuotaLimits = QUOTA_LIMITS; + PQuotaLimits = PQUOTA_LIMITS; + +const + QUOTA_LIMITS_HARDWS_MIN_ENABLE = $00000001; + {$EXTERNALSYM QUOTA_LIMITS_HARDWS_MIN_ENABLE} + QUOTA_LIMITS_HARDWS_MIN_DISABLE = $00000002; + {$EXTERNALSYM QUOTA_LIMITS_HARDWS_MIN_DISABLE} + QUOTA_LIMITS_HARDWS_MAX_ENABLE = $00000004; + {$EXTERNALSYM QUOTA_LIMITS_HARDWS_MAX_ENABLE} + QUOTA_LIMITS_HARDWS_MAX_DISABLE = $00000008; + {$EXTERNALSYM QUOTA_LIMITS_HARDWS_MAX_DISABLE} + +type + _QUOTA_LIMITS_EX = record + PagedPoolLimit: SIZE_T; + NonPagedPoolLimit: SIZE_T; + MinimumWorkingSetSize: SIZE_T; + MaximumWorkingSetSize: SIZE_T; + PagefileLimit: SIZE_T; + TimeLimit: LARGE_INTEGER; + Reserved1: SIZE_T; + Reserved2: SIZE_T; + Reserved3: SIZE_T; + Reserved4: SIZE_T; + Flags: DWORD; + Reserved5: DWORD; + end; + {$EXTERNALSYM _QUOTA_LIMITS_EX} + QUOTA_LIMITS_EX = _QUOTA_LIMITS_EX; + {$EXTERNALSYM QUOTA_LIMITS_EX} + PQUOTA_LIMITS_EX = ^QUOTA_LIMITS_EX; + {$EXTERNALSYM PQUOTA_LIMITS_EX} + TQuotaLimitsEx = QUOTA_LIMITS_EX; + PQuotaLimitsEx = PQUOTA_LIMITS_EX; + + PIO_COUNTERS = ^IO_COUNTERS; + {$EXTERNALSYM PIO_COUNTERS} + _IO_COUNTERS = record + ReadOperationCount: Int64; + WriteOperationCount: Int64; + OtherOperationCount: Int64; + ReadTransferCount: Int64; + WriteTransferCount: Int64; + OtherTransferCount: Int64; + end; + {$EXTERNALSYM _IO_COUNTERS} + IO_COUNTERS = _IO_COUNTERS; + {$EXTERNALSYM IO_COUNTERS} + TIoCounters = IO_COUNTERS; + PIoCounters = PIO_COUNTERS; + + PJOBOBJECT_BASIC_ACCOUNTING_INFORMATION = ^JOBOBJECT_BASIC_ACCOUNTING_INFORMATION; + {$EXTERNALSYM PJOBOBJECT_BASIC_ACCOUNTING_INFORMATION} + _JOBOBJECT_BASIC_ACCOUNTING_INFORMATION = record + TotalUserTime: LARGE_INTEGER; + TotalKernelTime: LARGE_INTEGER; + ThisPeriodTotalUserTime: LARGE_INTEGER; + ThisPeriodTotalKernelTime: LARGE_INTEGER; + TotalPageFaultCount: DWORD; + TotalProcesses: DWORD; + ActiveProcesses: DWORD; + TotalTerminatedProcesses: DWORD; + end; + {$EXTERNALSYM _JOBOBJECT_BASIC_ACCOUNTING_INFORMATION} + JOBOBJECT_BASIC_ACCOUNTING_INFORMATION = _JOBOBJECT_BASIC_ACCOUNTING_INFORMATION; + {$EXTERNALSYM JOBOBJECT_BASIC_ACCOUNTING_INFORMATION} + TJobObjectBasicAccountingInformation = JOBOBJECT_BASIC_ACCOUNTING_INFORMATION; + PJobObjectBasicAccountingInformation = PJOBOBJECT_BASIC_ACCOUNTING_INFORMATION; + + PJOBOBJECT_BASIC_LIMIT_INFORMATION = ^JOBOBJECT_BASIC_LIMIT_INFORMATION; + {$EXTERNALSYM PJOBOBJECT_BASIC_LIMIT_INFORMATION} + _JOBOBJECT_BASIC_LIMIT_INFORMATION = record + PerProcessUserTimeLimit: LARGE_INTEGER; + PerJobUserTimeLimit: LARGE_INTEGER; + LimitFlags: DWORD; + MinimumWorkingSetSize: SIZE_T; + MaximumWorkingSetSize: SIZE_T; + ActiveProcessLimit: DWORD; + Affinity: ULONG_PTR; + PriorityClass: DWORD; + SchedulingClass: DWORD; + end; + {$EXTERNALSYM _JOBOBJECT_BASIC_LIMIT_INFORMATION} + JOBOBJECT_BASIC_LIMIT_INFORMATION = _JOBOBJECT_BASIC_LIMIT_INFORMATION; + {$EXTERNALSYM JOBOBJECT_BASIC_LIMIT_INFORMATION} + TJobObjectBasicLimitInformation = JOBOBJECT_BASIC_LIMIT_INFORMATION; + PJobObjectBasicLimitInformation = PJOBOBJECT_BASIC_LIMIT_INFORMATION; + + PJOBOBJECT_EXTENDED_LIMIT_INFORMATION = ^JOBOBJECT_EXTENDED_LIMIT_INFORMATION; + {$EXTERNALSYM PJOBOBJECT_EXTENDED_LIMIT_INFORMATION} + _JOBOBJECT_EXTENDED_LIMIT_INFORMATION = record + BasicLimitInformation: JOBOBJECT_BASIC_LIMIT_INFORMATION; + IoInfo: IO_COUNTERS; + ProcessMemoryLimit: SIZE_T; + JobMemoryLimit: SIZE_T; + PeakProcessMemoryUsed: SIZE_T; + PeakJobMemoryUsed: SIZE_T; + end; + {$EXTERNALSYM _JOBOBJECT_EXTENDED_LIMIT_INFORMATION} + JOBOBJECT_EXTENDED_LIMIT_INFORMATION = _JOBOBJECT_EXTENDED_LIMIT_INFORMATION; + {$EXTERNALSYM JOBOBJECT_EXTENDED_LIMIT_INFORMATION} + TJobObjectExtendedLimitInformation = JOBOBJECT_EXTENDED_LIMIT_INFORMATION; + PJobObjectExtendedLimitInformation = PJOBOBJECT_EXTENDED_LIMIT_INFORMATION; + + PJOBOBJECT_BASIC_PROCESS_ID_LIST = ^JOBOBJECT_BASIC_PROCESS_ID_LIST; + {$EXTERNALSYM PJOBOBJECT_BASIC_PROCESS_ID_LIST} + _JOBOBJECT_BASIC_PROCESS_ID_LIST = record + NumberOfAssignedProcesses: DWORD; + NumberOfProcessIdsInList: DWORD; + ProcessIdList: array [0..0] of ULONG_PTR; + end; + {$EXTERNALSYM _JOBOBJECT_BASIC_PROCESS_ID_LIST} + JOBOBJECT_BASIC_PROCESS_ID_LIST = _JOBOBJECT_BASIC_PROCESS_ID_LIST; + {$EXTERNALSYM JOBOBJECT_BASIC_PROCESS_ID_LIST} + TJobObjectBasicProcessIdList = JOBOBJECT_BASIC_PROCESS_ID_LIST; + PJobObjectBasicProcessIdList = PJOBOBJECT_BASIC_PROCESS_ID_LIST; + + PJOBOBJECT_BASIC_UI_RESTRICTIONS = ^JOBOBJECT_BASIC_UI_RESTRICTIONS; + {$EXTERNALSYM PJOBOBJECT_BASIC_UI_RESTRICTIONS} + _JOBOBJECT_BASIC_UI_RESTRICTIONS = record + UIRestrictionsClass: DWORD; + end; + {$EXTERNALSYM _JOBOBJECT_BASIC_UI_RESTRICTIONS} + JOBOBJECT_BASIC_UI_RESTRICTIONS = _JOBOBJECT_BASIC_UI_RESTRICTIONS; + {$EXTERNALSYM JOBOBJECT_BASIC_UI_RESTRICTIONS} + TJobObjectBasicUiRestrictions = JOBOBJECT_BASIC_UI_RESTRICTIONS; + PJobObjectBasicUiRestrictions = PJOBOBJECT_BASIC_UI_RESTRICTIONS; + + PJOBOBJECT_SECURITY_LIMIT_INFORMATION = ^JOBOBJECT_SECURITY_LIMIT_INFORMATION; + {$EXTERNALSYM PJOBOBJECT_SECURITY_LIMIT_INFORMATION} + _JOBOBJECT_SECURITY_LIMIT_INFORMATION = record + SecurityLimitFlags : DWORD; + JobToken : THandle; + SidsToDisable : PTOKEN_GROUPS; + PrivilegesToDelete : PTOKEN_PRIVILEGES; + RestrictedSids : PTOKEN_GROUPS; + end; + {$EXTERNALSYM _JOBOBJECT_SECURITY_LIMIT_INFORMATION} + JOBOBJECT_SECURITY_LIMIT_INFORMATION = _JOBOBJECT_SECURITY_LIMIT_INFORMATION; + {$EXTERNALSYM JOBOBJECT_SECURITY_LIMIT_INFORMATION} + TJobObjectSecurityLimitInformation = JOBOBJECT_SECURITY_LIMIT_INFORMATION; + PJobObjectSecurityLimitInformation = PJOBOBJECT_SECURITY_LIMIT_INFORMATION; + + PJOBOBJECT_END_OF_JOB_TIME_INFORMATION = ^JOBOBJECT_END_OF_JOB_TIME_INFORMATION; + {$EXTERNALSYM PJOBOBJECT_END_OF_JOB_TIME_INFORMATION} + _JOBOBJECT_END_OF_JOB_TIME_INFORMATION = record + EndOfJobTimeAction: DWORD; + end; + {$EXTERNALSYM _JOBOBJECT_END_OF_JOB_TIME_INFORMATION} + JOBOBJECT_END_OF_JOB_TIME_INFORMATION = _JOBOBJECT_END_OF_JOB_TIME_INFORMATION; + {$EXTERNALSYM JOBOBJECT_END_OF_JOB_TIME_INFORMATION} + TJobObjectEndOfJobTimeInformation = JOBOBJECT_END_OF_JOB_TIME_INFORMATION; + PJobObjectEndOfJobTimeInformation = PJOBOBJECT_END_OF_JOB_TIME_INFORMATION; + + PJOBOBJECT_ASSOCIATE_COMPLETION_PORT = ^JOBOBJECT_ASSOCIATE_COMPLETION_PORT; + {$EXTERNALSYM PJOBOBJECT_ASSOCIATE_COMPLETION_PORT} + _JOBOBJECT_ASSOCIATE_COMPLETION_PORT = record + CompletionKey: Pointer; + CompletionPort: THandle; + end; + {$EXTERNALSYM _JOBOBJECT_ASSOCIATE_COMPLETION_PORT} + JOBOBJECT_ASSOCIATE_COMPLETION_PORT = _JOBOBJECT_ASSOCIATE_COMPLETION_PORT; + {$EXTERNALSYM JOBOBJECT_ASSOCIATE_COMPLETION_PORT} + TJobObjectAssociateCompletionPort = JOBOBJECT_ASSOCIATE_COMPLETION_PORT; + PJobObjectAssociateCompletionPort = PJOBOBJECT_ASSOCIATE_COMPLETION_PORT; + + PJOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION = ^JOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION; + {$EXTERNALSYM PJOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION} + _JOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION = record + BasicInfo: JOBOBJECT_BASIC_ACCOUNTING_INFORMATION; + IoInfo: IO_COUNTERS; + end; + {$EXTERNALSYM _JOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION} + JOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION = _JOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION; + {$EXTERNALSYM JOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION} + TJobObjectBasicAndIoAccountingInformation = JOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION; + PJobObjectBasicAndIoAccountingInformation = PJOBOBJECT_BASIC_AND_IO_ACCOUNTING_INFORMATION; + + _JOBOBJECT_JOBSET_INFORMATION = record + MemberLevel: DWORD; + end; + {$EXTERNALSYM _JOBOBJECT_JOBSET_INFORMATION} + JOBOBJECT_JOBSET_INFORMATION = _JOBOBJECT_JOBSET_INFORMATION; + {$EXTERNALSYM JOBOBJECT_JOBSET_INFORMATION} + PJOBOBJECT_JOBSET_INFORMATION = ^JOBOBJECT_JOBSET_INFORMATION; + {$EXTERNALSYM PJOBOBJECT_JOBSET_INFORMATION} + TJobObjectSetInformation = JOBOBJECT_JOBSET_INFORMATION; + PJobObjectSetInformation = PJOBOBJECT_JOBSET_INFORMATION; + +const + JOB_OBJECT_TERMINATE_AT_END_OF_JOB = 0; + {$EXTERNALSYM JOB_OBJECT_TERMINATE_AT_END_OF_JOB} + JOB_OBJECT_POST_AT_END_OF_JOB = 1; + {$EXTERNALSYM JOB_OBJECT_POST_AT_END_OF_JOB} + +// +// Completion Port Messages for job objects +// +// These values are returned via the lpNumberOfBytesTransferred parameter +// + + JOB_OBJECT_MSG_END_OF_JOB_TIME = 1; + {$EXTERNALSYM JOB_OBJECT_MSG_END_OF_JOB_TIME} + JOB_OBJECT_MSG_END_OF_PROCESS_TIME = 2; + {$EXTERNALSYM JOB_OBJECT_MSG_END_OF_PROCESS_TIME} + JOB_OBJECT_MSG_ACTIVE_PROCESS_LIMIT = 3; + {$EXTERNALSYM JOB_OBJECT_MSG_ACTIVE_PROCESS_LIMIT} + JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO = 4; + {$EXTERNALSYM JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO} + JOB_OBJECT_MSG_NEW_PROCESS = 6; + {$EXTERNALSYM JOB_OBJECT_MSG_NEW_PROCESS} + JOB_OBJECT_MSG_EXIT_PROCESS = 7; + {$EXTERNALSYM JOB_OBJECT_MSG_EXIT_PROCESS} + JOB_OBJECT_MSG_ABNORMAL_EXIT_PROCESS = 8; + {$EXTERNALSYM JOB_OBJECT_MSG_ABNORMAL_EXIT_PROCESS} + JOB_OBJECT_MSG_PROCESS_MEMORY_LIMIT = 9; + {$EXTERNALSYM JOB_OBJECT_MSG_PROCESS_MEMORY_LIMIT} + JOB_OBJECT_MSG_JOB_MEMORY_LIMIT = 10; + {$EXTERNALSYM JOB_OBJECT_MSG_JOB_MEMORY_LIMIT} + +// +// Basic Limits +// + + JOB_OBJECT_LIMIT_WORKINGSET = $00000001; + {$EXTERNALSYM JOB_OBJECT_LIMIT_WORKINGSET} + JOB_OBJECT_LIMIT_PROCESS_TIME = $00000002; + {$EXTERNALSYM JOB_OBJECT_LIMIT_PROCESS_TIME} + JOB_OBJECT_LIMIT_JOB_TIME = $00000004; + {$EXTERNALSYM JOB_OBJECT_LIMIT_JOB_TIME} + JOB_OBJECT_LIMIT_ACTIVE_PROCESS = $00000008; + {$EXTERNALSYM JOB_OBJECT_LIMIT_ACTIVE_PROCESS} + JOB_OBJECT_LIMIT_AFFINITY = $00000010; + {$EXTERNALSYM JOB_OBJECT_LIMIT_AFFINITY} + JOB_OBJECT_LIMIT_PRIORITY_CLASS = $00000020; + {$EXTERNALSYM JOB_OBJECT_LIMIT_PRIORITY_CLASS} + JOB_OBJECT_LIMIT_PRESERVE_JOB_TIME = $00000040; + {$EXTERNALSYM JOB_OBJECT_LIMIT_PRESERVE_JOB_TIME} + JOB_OBJECT_LIMIT_SCHEDULING_CLASS = $00000080; + {$EXTERNALSYM JOB_OBJECT_LIMIT_SCHEDULING_CLASS} + +// +// Extended Limits +// + + JOB_OBJECT_LIMIT_PROCESS_MEMORY = $00000100; + {$EXTERNALSYM JOB_OBJECT_LIMIT_PROCESS_MEMORY} + JOB_OBJECT_LIMIT_JOB_MEMORY = $00000200; + {$EXTERNALSYM JOB_OBJECT_LIMIT_JOB_MEMORY} + JOB_OBJECT_LIMIT_DIE_ON_UNHANDLED_EXCEPTION = $00000400; + {$EXTERNALSYM JOB_OBJECT_LIMIT_DIE_ON_UNHANDLED_EXCEPTION} + JOB_OBJECT_LIMIT_BREAKAWAY_OK = $00000800; + {$EXTERNALSYM JOB_OBJECT_LIMIT_BREAKAWAY_OK} + JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK = $00001000; + {$EXTERNALSYM JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK} + JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE = $00002000; + {$EXTERNALSYM JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE} + + JOB_OBJECT_LIMIT_RESERVED2 = $00004000; + {$EXTERNALSYM JOB_OBJECT_LIMIT_RESERVED2} + JOB_OBJECT_LIMIT_RESERVED3 = $00008000; + {$EXTERNALSYM JOB_OBJECT_LIMIT_RESERVED3} + JOB_OBJECT_LIMIT_RESERVED4 = $00010000; + {$EXTERNALSYM JOB_OBJECT_LIMIT_RESERVED4} + JOB_OBJECT_LIMIT_RESERVED5 = $00020000; + {$EXTERNALSYM JOB_OBJECT_LIMIT_RESERVED5} + JOB_OBJECT_LIMIT_RESERVED6 = $00040000; + {$EXTERNALSYM JOB_OBJECT_LIMIT_RESERVED6} + + JOB_OBJECT_LIMIT_VALID_FLAGS = $0007ffff; + {$EXTERNALSYM JOB_OBJECT_LIMIT_VALID_FLAGS} + + JOB_OBJECT_BASIC_LIMIT_VALID_FLAGS = $000000ff; + {$EXTERNALSYM JOB_OBJECT_BASIC_LIMIT_VALID_FLAGS} + JOB_OBJECT_EXTENDED_LIMIT_VALID_FLAGS = $00003fff; + {$EXTERNALSYM JOB_OBJECT_EXTENDED_LIMIT_VALID_FLAGS} + JOB_OBJECT_RESERVED_LIMIT_VALID_FLAGS = $0007ffff; + {$EXTERNALSYM JOB_OBJECT_RESERVED_LIMIT_VALID_FLAGS} + +// +// UI restrictions for jobs +// + + JOB_OBJECT_UILIMIT_NONE = $00000000; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_NONE} + + JOB_OBJECT_UILIMIT_HANDLES = $00000001; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_HANDLES} + JOB_OBJECT_UILIMIT_READCLIPBOARD = $00000002; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_READCLIPBOARD} + JOB_OBJECT_UILIMIT_WRITECLIPBOARD = $00000004; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_WRITECLIPBOARD} + JOB_OBJECT_UILIMIT_SYSTEMPARAMETERS = $00000008; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_SYSTEMPARAMETERS} + JOB_OBJECT_UILIMIT_DISPLAYSETTINGS = $00000010; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_DISPLAYSETTINGS} + JOB_OBJECT_UILIMIT_GLOBALATOMS = $00000020; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_GLOBALATOMS} + JOB_OBJECT_UILIMIT_DESKTOP = $00000040; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_DESKTOP} + JOB_OBJECT_UILIMIT_EXITWINDOWS = $00000080; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_EXITWINDOWS} + + JOB_OBJECT_UILIMIT_ALL = $000000FF; + {$EXTERNALSYM JOB_OBJECT_UILIMIT_ALL} + + JOB_OBJECT_UI_VALID_FLAGS = $000000FF; + {$EXTERNALSYM JOB_OBJECT_UI_VALID_FLAGS} + + JOB_OBJECT_SECURITY_NO_ADMIN = $00000001; + {$EXTERNALSYM JOB_OBJECT_SECURITY_NO_ADMIN} + JOB_OBJECT_SECURITY_RESTRICTED_TOKEN = $00000002; + {$EXTERNALSYM JOB_OBJECT_SECURITY_RESTRICTED_TOKEN} + JOB_OBJECT_SECURITY_ONLY_TOKEN = $00000004; + {$EXTERNALSYM JOB_OBJECT_SECURITY_ONLY_TOKEN} + JOB_OBJECT_SECURITY_FILTER_TOKENS = $00000008; + {$EXTERNALSYM JOB_OBJECT_SECURITY_FILTER_TOKENS} + + JOB_OBJECT_SECURITY_VALID_FLAGS = $0000000f; + {$EXTERNALSYM JOB_OBJECT_SECURITY_VALID_FLAGS} + +type + _JOBOBJECTINFOCLASS = ( + JobObjectInfoClassPadding0, + JobObjectBasicAccountingInformation, + JobObjectBasicLimitInformation, + JobObjectBasicProcessIdList, + JobObjectBasicUIRestrictions, + JobObjectSecurityLimitInformation, + JobObjectEndOfJobTimeInformation, + JobObjectAssociateCompletionPortInformation, + JobObjectBasicAndIoAccountingInformation, + JobObjectExtendedLimitInformation, + JobObjectJobSetInformation, + MaxJobObjectInfoClass); + {$EXTERNALSYM _JOBOBJECTINFOCLASS} + JOBOBJECTINFOCLASS = _JOBOBJECTINFOCLASS; + {$EXTERNALSYM JOBOBJECTINFOCLASS} + TJobObjectInfoClass = JOBOBJECTINFOCLASS; + +const + EVENT_MODIFY_STATE = $0002; + {$EXTERNALSYM EVENT_MODIFY_STATE} + EVENT_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $3; + {$EXTERNALSYM EVENT_ALL_ACCESS} + MUTANT_QUERY_STATE = $0001; + {$EXTERNALSYM MUTANT_QUERY_STATE} + + MUTANT_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or MUTANT_QUERY_STATE; + {$EXTERNALSYM MUTANT_ALL_ACCESS} + SEMAPHORE_MODIFY_STATE = $0002; + {$EXTERNALSYM SEMAPHORE_MODIFY_STATE} + SEMAPHORE_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $3; + {$EXTERNALSYM SEMAPHORE_ALL_ACCESS} + +// +// Timer Specific Access Rights. +// + + TIMER_QUERY_STATE = $0001; + {$EXTERNALSYM TIMER_QUERY_STATE} + TIMER_MODIFY_STATE = $0002; + {$EXTERNALSYM TIMER_MODIFY_STATE} + + TIMER_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or TIMER_QUERY_STATE or TIMER_MODIFY_STATE; + {$EXTERNALSYM TIMER_ALL_ACCESS} + + TIME_ZONE_ID_UNKNOWN = 0; + {$EXTERNALSYM TIME_ZONE_ID_UNKNOWN} + TIME_ZONE_ID_STANDARD = 1; + {$EXTERNALSYM TIME_ZONE_ID_STANDARD} + TIME_ZONE_ID_DAYLIGHT = 2; + {$EXTERNALSYM TIME_ZONE_ID_DAYLIGHT} + +type + _LOGICAL_PROCESSOR_RELATIONSHIP = (RelationProcessorCore, RelationNumaNode); + {$EXTERNALSYM _LOGICAL_PROCESSOR_RELATIONSHIP} + LOGICAL_PROCESSOR_RELATIONSHIP = _LOGICAL_PROCESSOR_RELATIONSHIP; + {$EXTERNALSYM LOGICAL_PROCESSOR_RELATIONSHIP} + TLogicalProcessorRelationship = LOGICAL_PROCESSOR_RELATIONSHIP; + +const + LTP_PC_SMT = $1; + {$EXTERNALSYM LTP_PC_SMT} + +type + _SYSTEM_LOGICAL_PROCESSOR_INFORMATION = record + ProcessorMask: ULONG_PTR; + Relationship: LOGICAL_PROCESSOR_RELATIONSHIP; + case Integer of + 0: (Flags: BYTE); // ProcessorCore + 1: (NodeNumber: DWORD); // NumaNode + 2: (Reserved: array [0..1] of ULONGLONG); + end; + {$EXTERNALSYM _SYSTEM_LOGICAL_PROCESSOR_INFORMATION} + SYSTEM_LOGICAL_PROCESSOR_INFORMATION = _SYSTEM_LOGICAL_PROCESSOR_INFORMATION; + {$EXTERNALSYM SYSTEM_LOGICAL_PROCESSOR_INFORMATION} + PSYSTEM_LOGICAL_PROCESSOR_INFORMATION = ^SYSTEM_LOGICAL_PROCESSOR_INFORMATION; + TSystemLogicalProcessorInformation = SYSTEM_LOGICAL_PROCESSOR_INFORMATION; + PSystemLogicalProcessorInformation = PSYSTEM_LOGICAL_PROCESSOR_INFORMATION; + +const + PROCESSOR_INTEL_386 = 386; + {$EXTERNALSYM PROCESSOR_INTEL_386} + PROCESSOR_INTEL_486 = 486; + {$EXTERNALSYM PROCESSOR_INTEL_486} + PROCESSOR_INTEL_PENTIUM = 586; + {$EXTERNALSYM PROCESSOR_INTEL_PENTIUM} + PROCESSOR_INTEL_IA64 = 2200; + {$EXTERNALSYM PROCESSOR_INTEL_IA64} + PROCESSOR_AMD_X8664 = 8664; + {$EXTERNALSYM PROCESSOR_AMD_X8664} + PROCESSOR_MIPS_R4000 = 4000; // incl R4101 & R3910 for Windows CE + {$EXTERNALSYM PROCESSOR_MIPS_R4000} + PROCESSOR_ALPHA_21064 = 21064; + {$EXTERNALSYM PROCESSOR_ALPHA_21064} + PROCESSOR_PPC_601 = 601; + {$EXTERNALSYM PROCESSOR_PPC_601} + PROCESSOR_PPC_603 = 603; + {$EXTERNALSYM PROCESSOR_PPC_603} + PROCESSOR_PPC_604 = 604; + {$EXTERNALSYM PROCESSOR_PPC_604} + PROCESSOR_PPC_620 = 620; + {$EXTERNALSYM PROCESSOR_PPC_620} + PROCESSOR_HITACHI_SH3 = 10003; // Windows CE + {$EXTERNALSYM PROCESSOR_HITACHI_SH3} + PROCESSOR_HITACHI_SH3E = 10004; // Windows CE + {$EXTERNALSYM PROCESSOR_HITACHI_SH3E} + PROCESSOR_HITACHI_SH4 = 10005; // Windows CE + {$EXTERNALSYM PROCESSOR_HITACHI_SH4} + PROCESSOR_MOTOROLA_821 = 821; // Windows CE + {$EXTERNALSYM PROCESSOR_MOTOROLA_821} + PROCESSOR_SHx_SH3 = 103; // Windows CE + {$EXTERNALSYM PROCESSOR_SHx_SH3} + PROCESSOR_SHx_SH4 = 104; // Windows CE + {$EXTERNALSYM PROCESSOR_SHx_SH4} + PROCESSOR_STRONGARM = 2577; // Windows CE - 0xA11 + {$EXTERNALSYM PROCESSOR_STRONGARM} + PROCESSOR_ARM720 = 1824; // Windows CE - 0x720 + {$EXTERNALSYM PROCESSOR_ARM720} + PROCESSOR_ARM820 = 2080; // Windows CE - 0x820 + {$EXTERNALSYM PROCESSOR_ARM820} + PROCESSOR_ARM920 = 2336; // Windows CE - 0x920 + {$EXTERNALSYM PROCESSOR_ARM920} + PROCESSOR_ARM_7TDMI = 70001; // Windows CE + {$EXTERNALSYM PROCESSOR_ARM_7TDMI} + PROCESSOR_OPTIL = $494f; // MSIL + {$EXTERNALSYM PROCESSOR_OPTIL} + + PROCESSOR_ARCHITECTURE_INTEL = 0; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_INTEL} + PROCESSOR_ARCHITECTURE_MIPS = 1; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_MIPS} + PROCESSOR_ARCHITECTURE_ALPHA = 2; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_ALPHA} + PROCESSOR_ARCHITECTURE_PPC = 3; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_PPC} + PROCESSOR_ARCHITECTURE_SHX = 4; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_SHX} + PROCESSOR_ARCHITECTURE_ARM = 5; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_ARM} + PROCESSOR_ARCHITECTURE_IA64 = 6; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_IA64} + PROCESSOR_ARCHITECTURE_ALPHA64 = 7; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_ALPHA64} + PROCESSOR_ARCHITECTURE_MSIL = 8; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_MSIL} + PROCESSOR_ARCHITECTURE_AMD64 = 9; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_AMD64} + PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 = 10; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_IA32_ON_WIN64} + + PROCESSOR_ARCHITECTURE_UNKNOWN = $FFFF; + {$EXTERNALSYM PROCESSOR_ARCHITECTURE_UNKNOWN} + + PF_FLOATING_POINT_PRECISION_ERRATA = 0; + {$EXTERNALSYM PF_FLOATING_POINT_PRECISION_ERRATA} + PF_FLOATING_POINT_EMULATED = 1; + {$EXTERNALSYM PF_FLOATING_POINT_EMULATED} + PF_COMPARE_EXCHANGE_DOUBLE = 2; + {$EXTERNALSYM PF_COMPARE_EXCHANGE_DOUBLE} + PF_MMX_INSTRUCTIONS_AVAILABLE = 3; + {$EXTERNALSYM PF_MMX_INSTRUCTIONS_AVAILABLE} + PF_PPC_MOVEMEM_64BIT_OK = 4; + {$EXTERNALSYM PF_PPC_MOVEMEM_64BIT_OK} + PF_ALPHA_BYTE_INSTRUCTIONS = 5; + {$EXTERNALSYM PF_ALPHA_BYTE_INSTRUCTIONS} + PF_XMMI_INSTRUCTIONS_AVAILABLE = 6; + {$EXTERNALSYM PF_XMMI_INSTRUCTIONS_AVAILABLE} + PF_3DNOW_INSTRUCTIONS_AVAILABLE = 7; + {$EXTERNALSYM PF_3DNOW_INSTRUCTIONS_AVAILABLE} + PF_RDTSC_INSTRUCTION_AVAILABLE = 8; + {$EXTERNALSYM PF_RDTSC_INSTRUCTION_AVAILABLE} + PF_PAE_ENABLED = 9; + {$EXTERNALSYM PF_PAE_ENABLED} + PF_XMMI64_INSTRUCTIONS_AVAILABLE = 10; + {$EXTERNALSYM PF_XMMI64_INSTRUCTIONS_AVAILABLE} + +type + PMEMORY_BASIC_INFORMATION = ^MEMORY_BASIC_INFORMATION; + {$EXTERNALSYM PMEMORY_BASIC_INFORMATION} + _MEMORY_BASIC_INFORMATION = record + BaseAddress: Pointer; + AllocationBase: Pointer; + AllocationProtect: DWORD; + RegionSize: SIZE_T; + State: DWORD; + Protect: DWORD; + Type_: DWORD; + end; + {$EXTERNALSYM _MEMORY_BASIC_INFORMATION} + MEMORY_BASIC_INFORMATION = _MEMORY_BASIC_INFORMATION; + {$EXTERNALSYM MEMORY_BASIC_INFORMATION} + TMemoryBasicInformation = MEMORY_BASIC_INFORMATION; + PMemoryBasicInformation = PMEMORY_BASIC_INFORMATION; + + PMEMORY_BASIC_INFORMATION32 = ^MEMORY_BASIC_INFORMATION32; + {$EXTERNALSYM PMEMORY_BASIC_INFORMATION32} + _MEMORY_BASIC_INFORMATION32 = record + BaseAddress: DWORD; + AllocationBase: DWORD; + AllocationProtect: DWORD; + RegionSize: DWORD; + State: DWORD; + Protect: DWORD; + Type_: DWORD; + end; + {$EXTERNALSYM _MEMORY_BASIC_INFORMATION32} + MEMORY_BASIC_INFORMATION32 = _MEMORY_BASIC_INFORMATION32; + {$EXTERNALSYM MEMORY_BASIC_INFORMATION32} + TMemoryBasicInformation32 = MEMORY_BASIC_INFORMATION32; + PMemoryBasicInformation32 = PMEMORY_BASIC_INFORMATION32; + + PMEMORY_BASIC_INFORMATION64 = ^MEMORY_BASIC_INFORMATION64; + {$EXTERNALSYM PMEMORY_BASIC_INFORMATION64} + _MEMORY_BASIC_INFORMATION64 = record + BaseAddress: ULONGLONG; + AllocationBase: ULONGLONG; + AllocationProtect: DWORD; + __alignment1: DWORD; + RegionSize: ULONGLONG; + State: DWORD; + Protect: DWORD; + Type_: DWORD; + __alignment2: DWORD; + end; + {$EXTERNALSYM _MEMORY_BASIC_INFORMATION64} + MEMORY_BASIC_INFORMATION64 = _MEMORY_BASIC_INFORMATION64; + {$EXTERNALSYM MEMORY_BASIC_INFORMATION64} + TMemoryBasicInformation64 = MEMORY_BASIC_INFORMATION64; + PMemoryBasicInformation64 = PMEMORY_BASIC_INFORMATION64; + +const + SECTION_QUERY = $0001; + {$EXTERNALSYM SECTION_QUERY} + SECTION_MAP_WRITE = $0002; + {$EXTERNALSYM SECTION_MAP_WRITE} + SECTION_MAP_READ = $0004; + {$EXTERNALSYM SECTION_MAP_READ} + SECTION_MAP_EXECUTE = $0008; + {$EXTERNALSYM SECTION_MAP_EXECUTE} + SECTION_EXTEND_SIZE = $0010; + {$EXTERNALSYM SECTION_EXTEND_SIZE} + + SECTION_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED or SECTION_QUERY or + SECTION_MAP_WRITE or SECTION_MAP_READ or SECTION_MAP_EXECUTE or + SECTION_EXTEND_SIZE); + {$EXTERNALSYM SECTION_ALL_ACCESS} + + PAGE_NOACCESS = $01; + {$EXTERNALSYM PAGE_NOACCESS} + PAGE_READONLY = $02; + {$EXTERNALSYM PAGE_READONLY} + PAGE_READWRITE = $04; + {$EXTERNALSYM PAGE_READWRITE} + PAGE_WRITECOPY = $08; + {$EXTERNALSYM PAGE_WRITECOPY} + PAGE_EXECUTE = $10; + {$EXTERNALSYM PAGE_EXECUTE} + PAGE_EXECUTE_READ = $20; + {$EXTERNALSYM PAGE_EXECUTE_READ} + PAGE_EXECUTE_READWRITE = $40; + {$EXTERNALSYM PAGE_EXECUTE_READWRITE} + PAGE_EXECUTE_WRITECOPY = $80; + {$EXTERNALSYM PAGE_EXECUTE_WRITECOPY} + PAGE_GUARD = $100; + {$EXTERNALSYM PAGE_GUARD} + PAGE_NOCACHE = $200; + {$EXTERNALSYM PAGE_NOCACHE} + PAGE_WRITECOMBINE = $400; + {$EXTERNALSYM PAGE_WRITECOMBINE} + MEM_COMMIT = $1000; + {$EXTERNALSYM MEM_COMMIT} + MEM_RESERVE = $2000; + {$EXTERNALSYM MEM_RESERVE} + MEM_DECOMMIT = $4000; + {$EXTERNALSYM MEM_DECOMMIT} + MEM_RELEASE = $8000; + {$EXTERNALSYM MEM_RELEASE} + MEM_FREE = $10000; + {$EXTERNALSYM MEM_FREE} + MEM_PRIVATE = $20000; + {$EXTERNALSYM MEM_PRIVATE} + MEM_MAPPED = $40000; + {$EXTERNALSYM MEM_MAPPED} + MEM_RESET = $80000; + {$EXTERNALSYM MEM_RESET} + MEM_TOP_DOWN = $100000; + {$EXTERNALSYM MEM_TOP_DOWN} + MEM_WRITE_WATCH = $200000; + {$EXTERNALSYM MEM_WRITE_WATCH} + MEM_PHYSICAL = $400000; + {$EXTERNALSYM MEM_PHYSICAL} + MEM_LARGE_PAGES = $20000000; + {$EXTERNALSYM MEM_LARGE_PAGES} + MEM_4MB_PAGES = DWORD($80000000); + {$EXTERNALSYM MEM_4MB_PAGES} + SEC_FILE = $800000; + {$EXTERNALSYM SEC_FILE} + SEC_IMAGE = $1000000; + {$EXTERNALSYM SEC_IMAGE} + SEC_RESERVE = $4000000; + {$EXTERNALSYM SEC_RESERVE} + SEC_COMMIT = DWORD($8000000); + {$EXTERNALSYM SEC_COMMIT} + SEC_NOCACHE = $10000000; + {$EXTERNALSYM SEC_NOCACHE} + MEM_IMAGE = SEC_IMAGE; + {$EXTERNALSYM MEM_IMAGE} + WRITE_WATCH_FLAG_RESET = $01; + {$EXTERNALSYM WRITE_WATCH_FLAG_RESET} + +// +// Define access rights to files and directories +// + +// +// The FILE_READ_DATA and FILE_WRITE_DATA constants are also defined in +// devioctl.h as FILE_READ_ACCESS and FILE_WRITE_ACCESS. The values for these +// constants *MUST* always be in sync. +// The values are redefined in devioctl.h because they must be available to +// both DOS and NT. +// + + FILE_READ_DATA = $0001; // file & pipe + {$EXTERNALSYM FILE_READ_DATA} + FILE_LIST_DIRECTORY = $0001; // directory + {$EXTERNALSYM FILE_LIST_DIRECTORY} + + FILE_WRITE_DATA = $0002; // file & pipe + {$EXTERNALSYM FILE_WRITE_DATA} + FILE_ADD_FILE = $0002; // directory + {$EXTERNALSYM FILE_ADD_FILE} + + FILE_APPEND_DATA = $0004; // file + {$EXTERNALSYM FILE_APPEND_DATA} + FILE_ADD_SUBDIRECTORY = $0004; // directory + {$EXTERNALSYM FILE_ADD_SUBDIRECTORY} + FILE_CREATE_PIPE_INSTANCE = $0004; // named pipe + {$EXTERNALSYM FILE_CREATE_PIPE_INSTANCE} + + FILE_READ_EA = $0008; // file & directory + {$EXTERNALSYM FILE_READ_EA} + + FILE_WRITE_EA = $0010; // file & directory + {$EXTERNALSYM FILE_WRITE_EA} + + FILE_EXECUTE = $0020; // file + {$EXTERNALSYM FILE_EXECUTE} + FILE_TRAVERSE = $0020; // directory + {$EXTERNALSYM FILE_TRAVERSE} + + FILE_DELETE_CHILD = $0040; // directory + {$EXTERNALSYM FILE_DELETE_CHILD} + + FILE_READ_ATTRIBUTES = $0080; // all + {$EXTERNALSYM FILE_READ_ATTRIBUTES} + + FILE_WRITE_ATTRIBUTES = $0100; // all + {$EXTERNALSYM FILE_WRITE_ATTRIBUTES} + + FILE_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $1FF; + {$EXTERNALSYM FILE_ALL_ACCESS} + + FILE_GENERIC_READ = (STANDARD_RIGHTS_READ or FILE_READ_DATA or + FILE_READ_ATTRIBUTES or FILE_READ_EA or SYNCHRONIZE); + {$EXTERNALSYM FILE_GENERIC_READ} + + FILE_GENERIC_WRITE = (STANDARD_RIGHTS_WRITE or FILE_WRITE_DATA or + FILE_WRITE_ATTRIBUTES or FILE_WRITE_EA or FILE_APPEND_DATA or SYNCHRONIZE); + {$EXTERNALSYM FILE_GENERIC_WRITE} + + FILE_GENERIC_EXECUTE = (STANDARD_RIGHTS_EXECUTE or FILE_READ_ATTRIBUTES or + FILE_EXECUTE or SYNCHRONIZE); + {$EXTERNALSYM FILE_GENERIC_EXECUTE} + + FILE_SHARE_READ = $00000001; + {$EXTERNALSYM FILE_SHARE_READ} + FILE_SHARE_WRITE = $00000002; + {$EXTERNALSYM FILE_SHARE_WRITE} + FILE_SHARE_DELETE = $00000004; + {$EXTERNALSYM FILE_SHARE_DELETE} + FILE_ATTRIBUTE_READONLY = $00000001; + {$EXTERNALSYM FILE_ATTRIBUTE_READONLY} + FILE_ATTRIBUTE_HIDDEN = $00000002; + {$EXTERNALSYM FILE_ATTRIBUTE_HIDDEN} + FILE_ATTRIBUTE_SYSTEM = $00000004; + {$EXTERNALSYM FILE_ATTRIBUTE_SYSTEM} + FILE_ATTRIBUTE_DIRECTORY = $00000010; + {$EXTERNALSYM FILE_ATTRIBUTE_DIRECTORY} + FILE_ATTRIBUTE_ARCHIVE = $00000020; + {$EXTERNALSYM FILE_ATTRIBUTE_ARCHIVE} + FILE_ATTRIBUTE_DEVICE = $00000040; + {$EXTERNALSYM FILE_ATTRIBUTE_DEVICE} + FILE_ATTRIBUTE_NORMAL = $00000080; + {$EXTERNALSYM FILE_ATTRIBUTE_NORMAL} + FILE_ATTRIBUTE_TEMPORARY = $00000100; + {$EXTERNALSYM FILE_ATTRIBUTE_TEMPORARY} + FILE_ATTRIBUTE_SPARSE_FILE = $00000200; + {$EXTERNALSYM FILE_ATTRIBUTE_SPARSE_FILE} + FILE_ATTRIBUTE_REPARSE_POINT = $00000400; + {$EXTERNALSYM FILE_ATTRIBUTE_REPARSE_POINT} + FILE_ATTRIBUTE_COMPRESSED = $00000800; + {$EXTERNALSYM FILE_ATTRIBUTE_COMPRESSED} + FILE_ATTRIBUTE_OFFLINE = $00001000; + {$EXTERNALSYM FILE_ATTRIBUTE_OFFLINE} + FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = $00002000; + {$EXTERNALSYM FILE_ATTRIBUTE_NOT_CONTENT_INDEXED} + FILE_ATTRIBUTE_ENCRYPTED = $00004000; + {$EXTERNALSYM FILE_ATTRIBUTE_ENCRYPTED} + FILE_NOTIFY_CHANGE_FILE_NAME = $00000001; + {$EXTERNALSYM FILE_NOTIFY_CHANGE_FILE_NAME} + FILE_NOTIFY_CHANGE_DIR_NAME = $00000002; + {$EXTERNALSYM FILE_NOTIFY_CHANGE_DIR_NAME} + FILE_NOTIFY_CHANGE_ATTRIBUTES = $00000004; + {$EXTERNALSYM FILE_NOTIFY_CHANGE_ATTRIBUTES} + FILE_NOTIFY_CHANGE_SIZE = $00000008; + {$EXTERNALSYM FILE_NOTIFY_CHANGE_SIZE} + FILE_NOTIFY_CHANGE_LAST_WRITE = $00000010; + {$EXTERNALSYM FILE_NOTIFY_CHANGE_LAST_WRITE} + FILE_NOTIFY_CHANGE_LAST_ACCESS = $00000020; + {$EXTERNALSYM FILE_NOTIFY_CHANGE_LAST_ACCESS} + FILE_NOTIFY_CHANGE_CREATION = $00000040; + {$EXTERNALSYM FILE_NOTIFY_CHANGE_CREATION} + FILE_NOTIFY_CHANGE_SECURITY = $00000100; + {$EXTERNALSYM FILE_NOTIFY_CHANGE_SECURITY} + FILE_ACTION_ADDED = $00000001; + {$EXTERNALSYM FILE_ACTION_ADDED} + FILE_ACTION_REMOVED = $00000002; + {$EXTERNALSYM FILE_ACTION_REMOVED} + FILE_ACTION_MODIFIED = $00000003; + {$EXTERNALSYM FILE_ACTION_MODIFIED} + FILE_ACTION_RENAMED_OLD_NAME = $00000004; + {$EXTERNALSYM FILE_ACTION_RENAMED_OLD_NAME} + FILE_ACTION_RENAMED_NEW_NAME = $00000005; + {$EXTERNALSYM FILE_ACTION_RENAMED_NEW_NAME} + MAILSLOT_NO_MESSAGE = DWORD(-1); + {$EXTERNALSYM MAILSLOT_NO_MESSAGE} + MAILSLOT_WAIT_FOREVER = DWORD(-1); + {$EXTERNALSYM MAILSLOT_WAIT_FOREVER} + FILE_CASE_SENSITIVE_SEARCH = $00000001; + {$EXTERNALSYM FILE_CASE_SENSITIVE_SEARCH} + FILE_CASE_PRESERVED_NAMES = $00000002; + {$EXTERNALSYM FILE_CASE_PRESERVED_NAMES} + FILE_UNICODE_ON_DISK = $00000004; + {$EXTERNALSYM FILE_UNICODE_ON_DISK} + FILE_PERSISTENT_ACLS = $00000008; + {$EXTERNALSYM FILE_PERSISTENT_ACLS} + FILE_FILE_COMPRESSION = $00000010; + {$EXTERNALSYM FILE_FILE_COMPRESSION} + FILE_VOLUME_QUOTAS = $00000020; + {$EXTERNALSYM FILE_VOLUME_QUOTAS} + FILE_SUPPORTS_SPARSE_FILES = $00000040; + {$EXTERNALSYM FILE_SUPPORTS_SPARSE_FILES} + FILE_SUPPORTS_REPARSE_POINTS = $00000080; + {$EXTERNALSYM FILE_SUPPORTS_REPARSE_POINTS} + FILE_SUPPORTS_REMOTE_STORAGE = $00000100; + {$EXTERNALSYM FILE_SUPPORTS_REMOTE_STORAGE} + FILE_VOLUME_IS_COMPRESSED = $00008000; + {$EXTERNALSYM FILE_VOLUME_IS_COMPRESSED} + FILE_SUPPORTS_OBJECT_IDS = $00010000; + {$EXTERNALSYM FILE_SUPPORTS_OBJECT_IDS} + FILE_SUPPORTS_ENCRYPTION = $00020000; + {$EXTERNALSYM FILE_SUPPORTS_ENCRYPTION} + FILE_NAMED_STREAMS = $00040000; + {$EXTERNALSYM FILE_NAMED_STREAMS} + FILE_READ_ONLY_VOLUME = $00080000; + {$EXTERNALSYM FILE_READ_ONLY_VOLUME} + +// +// Define the file notification information structure +// + +type + PFILE_NOTIFY_INFORMATION = ^FILE_NOTIFY_INFORMATION; + {$EXTERNALSYM PFILE_NOTIFY_INFORMATION} + _FILE_NOTIFY_INFORMATION = record + NextEntryOffset: DWORD; + Action: DWORD; + FileNameLength: DWORD; + FileName: array [0..0] of WCHAR; + end; + {$EXTERNALSYM _FILE_NOTIFY_INFORMATION} + FILE_NOTIFY_INFORMATION = _FILE_NOTIFY_INFORMATION; + {$EXTERNALSYM FILE_NOTIFY_INFORMATION} + TFileNotifyInformation = FILE_NOTIFY_INFORMATION; + PFileNotifyInformation = PFILE_NOTIFY_INFORMATION; + +// +// Define segement buffer structure for scatter/gather read/write. +// + +type + PFILE_SEGMENT_ELEMENT = ^FILE_SEGMENT_ELEMENT; + {$EXTERNALSYM PFILE_SEGMENT_ELEMENT} + _FILE_SEGMENT_ELEMENT = record + case Integer of + 0: (Buffer: PVOID64); + 1: (Alignment: ULONGLONG); + end; + {$EXTERNALSYM _FILE_SEGMENT_ELEMENT} + FILE_SEGMENT_ELEMENT = _FILE_SEGMENT_ELEMENT; + {$EXTERNALSYM FILE_SEGMENT_ELEMENT} + TFileSegmentElement = FILE_SEGMENT_ELEMENT; + PFileSegmentElement = PFILE_SEGMENT_ELEMENT; + +// +// The reparse GUID structure is used by all 3rd party layered drivers to +// store data in a reparse point. For non-Microsoft tags, The GUID field +// cannot be GUID_NULL. +// The constraints on reparse tags are defined below. +// Microsoft tags can also be used with this format of the reparse point buffer. +// + TGenericReparseBuffer = record + DataBuffer: array [0..0] of BYTE; + end; + + PREPARSE_GUID_DATA_BUFFER = ^REPARSE_GUID_DATA_BUFFER; + {$EXTERNALSYM PREPARSE_GUID_DATA_BUFFER} + _REPARSE_GUID_DATA_BUFFER = record + ReparseTag: DWORD; + ReparseDataLength: WORD; + Reserved: WORD; + ReparseGuid: GUID; + GenericReparseBuffer: TGenericReparseBuffer; + end; + {$EXTERNALSYM _REPARSE_GUID_DATA_BUFFER} + REPARSE_GUID_DATA_BUFFER = _REPARSE_GUID_DATA_BUFFER; + {$EXTERNALSYM REPARSE_GUID_DATA_BUFFER} + TReparseGuidDataBuffer = REPARSE_GUID_DATA_BUFFER; + PReparseGuidDataBuffer = PREPARSE_GUID_DATA_BUFFER; + +const + REPARSE_GUID_DATA_BUFFER_HEADER_SIZE = 24; + {$EXTERNALSYM REPARSE_GUID_DATA_BUFFER_HEADER_SIZE} +// +// Maximum allowed size of the reparse data. +// + +const + MAXIMUM_REPARSE_DATA_BUFFER_SIZE = 16 * 1024; + {$EXTERNALSYM MAXIMUM_REPARSE_DATA_BUFFER_SIZE} + +// +// Predefined reparse tags. +// These tags need to avoid conflicting with IO_REMOUNT defined in ntos\inc\io.h +// + + IO_REPARSE_TAG_RESERVED_ZERO = 0; + {$EXTERNALSYM IO_REPARSE_TAG_RESERVED_ZERO} + IO_REPARSE_TAG_RESERVED_ONE = 1; + {$EXTERNALSYM IO_REPARSE_TAG_RESERVED_ONE} + +// +// The value of the following constant needs to satisfy the following conditions: +// (1) Be at least as large as the largest of the reserved tags. +// (2) Be strictly smaller than all the tags in use. +// + + IO_REPARSE_TAG_RESERVED_RANGE = IO_REPARSE_TAG_RESERVED_ONE; + {$EXTERNALSYM IO_REPARSE_TAG_RESERVED_RANGE} + +// +// The reparse tags are a DWORD. The 32 bits are laid out as follows: +// +// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 +// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 +// +-+-+-+-+-----------------------+-------------------------------+ +// |M|R|N|R| Reserved bits | Reparse Tag Value | +// +-+-+-+-+-----------------------+-------------------------------+ +// +// M is the Microsoft bit. When set to 1, it denotes a tag owned by Microsoft. +// All ISVs must use a tag with a 0 in this position. +// Note: If a Microsoft tag is used by non-Microsoft software, the +// behavior is not defined. +// +// R is reserved. Must be zero for non-Microsoft tags. +// +// N is name surrogate. When set to 1, the file represents another named +// entity in the system. +// +// The M and N bits are OR-able. +// The following macros check for the M and N bit values: +// + +// +// Macro to determine whether a reparse point tag corresponds to a tag +// owned by Microsoft. +// + +function IsReparseTagMicrosoft(Tag: ULONG): Boolean; +{$EXTERNALSYM IsReparseTagMicrosoft} + +// +// Macro to determine whether a reparse point tag corresponds to a file +// that is to be displayed with the slow icon overlay. +// + +function IsReparseTagHighLatency(Tag: ULONG): Boolean; +{$EXTERNALSYM IsReparseTagHighLatency} + +// +// Macro to determine whether a reparse point tag is a name surrogate +// + +function IsReparseTagNameSurrogate(Tag: ULONG): Boolean; +{$EXTERNALSYM IsReparseTagNameSurrogate} + +const + IO_REPARSE_TAG_MOUNT_POINT = DWORD($A0000003); + {$EXTERNALSYM IO_REPARSE_TAG_MOUNT_POINT} + IO_REPARSE_TAG_HSM = DWORD($C0000004); + {$EXTERNALSYM IO_REPARSE_TAG_HSM} + IO_REPARSE_TAG_SIS = DWORD($80000007); + {$EXTERNALSYM IO_REPARSE_TAG_SIS} + IO_REPARSE_TAG_DFS = DWORD($8000000A); + {$EXTERNALSYM IO_REPARSE_TAG_DFS} + IO_REPARSE_TAG_FILTER_MANAGER = DWORD($8000000B); + {$EXTERNALSYM IO_REPARSE_TAG_FILTER_MANAGER} + IO_COMPLETION_MODIFY_STATE = $0002; + {$EXTERNALSYM IO_COMPLETION_MODIFY_STATE} + IO_COMPLETION_ALL_ACCESS = DWORD(STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $3); + {$EXTERNALSYM IO_COMPLETION_ALL_ACCESS} + DUPLICATE_CLOSE_SOURCE = $00000001; + {$EXTERNALSYM DUPLICATE_CLOSE_SOURCE} + DUPLICATE_SAME_ACCESS = $00000002; + {$EXTERNALSYM DUPLICATE_SAME_ACCESS} + +type + _SYSTEM_POWER_STATE = ( + PowerSystemUnspecified, + PowerSystemWorking, + PowerSystemSleeping1, + PowerSystemSleeping2, + PowerSystemSleeping3, + PowerSystemHibernate, + PowerSystemShutdown, + PowerSystemMaximum); + {$EXTERNALSYM _SYSTEM_POWER_STATE} + SYSTEM_POWER_STATE = _SYSTEM_POWER_STATE; + {$EXTERNALSYM SYSTEM_POWER_STATE} + PSYSTEM_POWER_STATE = ^SYSTEM_POWER_STATE; + {$EXTERNALSYM PSYSTEM_POWER_STATE} + TSystemPowerState = SYSTEM_POWER_STATE; + PSystemPowerState = PSYSTEM_POWER_STATE; + +const + POWER_SYSTEM_MAXIMUM = 7; + {$EXTERNALSYM POWER_SYSTEM_MAXIMUM} + +type + POWER_ACTION = ( + PowerActionNone, + PowerActionReserved, + PowerActionSleep, + PowerActionHibernate, + PowerActionShutdown, + PowerActionShutdownReset, + PowerActionShutdownOff, + PowerActionWarmEject); + {$EXTERNALSYM POWER_ACTION} + PPOWER_ACTION = ^POWER_ACTION; + {$EXTERNALSYM PPOWER_ACTION} + TPowerAction = POWER_ACTION; + PPowerAction = PPOWER_ACTION; + + _DEVICE_POWER_STATE = ( + PowerDeviceUnspecified, + PowerDeviceD0, + PowerDeviceD1, + PowerDeviceD2, + PowerDeviceD3, + PowerDeviceMaximum); + {$EXTERNALSYM _DEVICE_POWER_STATE} + DEVICE_POWER_STATE = _DEVICE_POWER_STATE; + {$EXTERNALSYM DEVICE_POWER_STATE} + PDEVICE_POWER_STATE = ^DEVICE_POWER_STATE; + {$EXTERNALSYM PDEVICE_POWER_STATE} + TDevicePowerState = DEVICE_POWER_STATE; + PDevicePowerState = PDEVICE_POWER_STATE; + +const + ES_SYSTEM_REQUIRED = DWORD($00000001); + {$EXTERNALSYM ES_SYSTEM_REQUIRED} + ES_DISPLAY_REQUIRED = DWORD($00000002); + {$EXTERNALSYM ES_DISPLAY_REQUIRED} + ES_USER_PRESENT = DWORD($00000004); + {$EXTERNALSYM ES_USER_PRESENT} + ES_CONTINUOUS = DWORD($80000000); + {$EXTERNALSYM ES_CONTINUOUS} + +type + EXECUTION_STATE = DWORD; + {$EXTERNALSYM EXECUTION_STATE} + + LATENCY_TIME = (LT_DONT_CARE, LT_LOWEST_LATENCY); + {$EXTERNALSYM LATENCY_TIME} + TLatencyTime = LATENCY_TIME; + +//----------------------------------------------------------------------------- +// Device Power Information +// Accessable via CM_Get_DevInst_Registry_Property_Ex(CM_DRP_DEVICE_POWER_DATA) +//----------------------------------------------------------------------------- + +const + PDCAP_D0_SUPPORTED = $00000001; + {$EXTERNALSYM PDCAP_D0_SUPPORTED} + PDCAP_D1_SUPPORTED = $00000002; + {$EXTERNALSYM PDCAP_D1_SUPPORTED} + PDCAP_D2_SUPPORTED = $00000004; + {$EXTERNALSYM PDCAP_D2_SUPPORTED} + PDCAP_D3_SUPPORTED = $00000008; + {$EXTERNALSYM PDCAP_D3_SUPPORTED} + PDCAP_WAKE_FROM_D0_SUPPORTED = $00000010; + {$EXTERNALSYM PDCAP_WAKE_FROM_D0_SUPPORTED} + PDCAP_WAKE_FROM_D1_SUPPORTED = $00000020; + {$EXTERNALSYM PDCAP_WAKE_FROM_D1_SUPPORTED} + PDCAP_WAKE_FROM_D2_SUPPORTED = $00000040; + {$EXTERNALSYM PDCAP_WAKE_FROM_D2_SUPPORTED} + PDCAP_WAKE_FROM_D3_SUPPORTED = $00000080; + {$EXTERNALSYM PDCAP_WAKE_FROM_D3_SUPPORTED} + PDCAP_WARM_EJECT_SUPPORTED = $00000100; + {$EXTERNALSYM PDCAP_WARM_EJECT_SUPPORTED} + +type + CM_Power_Data_s = record + PD_Size: DWORD; + PD_MostRecentPowerState: DEVICE_POWER_STATE; + PD_Capabilities: DWORD; + PD_D1Latency: DWORD; + PD_D2Latency: DWORD; + PD_D3Latency: DWORD; + PD_PowerStateMapping: array [0..POWER_SYSTEM_MAXIMUM - 1] of DEVICE_POWER_STATE; + PD_DeepestSystemWake: SYSTEM_POWER_STATE; + end; + {$EXTERNALSYM CM_Power_Data_s} + CM_POWER_DATA = CM_Power_Data_s; + {$EXTERNALSYM CM_POWER_DATA} + PCM_POWER_DATA = ^CM_POWER_DATA; + {$EXTERNALSYM PCM_POWER_DATA} + TCmPowerData = CM_POWER_DATA; + PCmPowerData = PCM_POWER_DATA; + + POWER_INFORMATION_LEVEL = ( + SystemPowerPolicyAc, + SystemPowerPolicyDc, + VerifySystemPolicyAc, + VerifySystemPolicyDc, + SystemPowerCapabilities, + SystemBatteryState, + SystemPowerStateHandler, + ProcessorStateHandler, + SystemPowerPolicyCurrent, + AdministratorPowerPolicy, + SystemReserveHiberFile, + ProcessorInformation, + SystemPowerInformation, + ProcessorStateHandler2, + LastWakeTime, // Compare with KeQueryInterruptTime() + LastSleepTime, // Compare with KeQueryInterruptTime() + SystemExecutionState, + SystemPowerStateNotifyHandler, + ProcessorPowerPolicyAc, + ProcessorPowerPolicyDc, + VerifyProcessorPowerPolicyAc, + VerifyProcessorPowerPolicyDc, + ProcessorPowerPolicyCurrent, + SystemPowerStateLogging, + SystemPowerLoggingEntry); + {$EXTERNALSYM POWER_INFORMATION_LEVEL} + TPowerInformationLevel = POWER_INFORMATION_LEVEL; + +// +// System power manager capabilities +// + + BATTERY_REPORTING_SCALE = record + Granularity: DWORD; + Capacity: DWORD; + end; + {$EXTERNALSYM BATTERY_REPORTING_SCALE} + PBATTERY_REPORTING_SCALE = ^BATTERY_REPORTING_SCALE; + {$EXTERNALSYM PBATTERY_REPORTING_SCALE} + TBatteryReportingScale = BATTERY_REPORTING_SCALE; + PBatteryReportingScale = PBATTERY_REPORTING_SCALE; + +// Power Policy Management interfaces +// + + PPOWER_ACTION_POLICY = ^POWER_ACTION_POLICY; + {$EXTERNALSYM PPOWER_ACTION_POLICY} + POWER_ACTION_POLICY = record + Action: POWER_ACTION; + Flags: DWORD; + EventCode: DWORD; + end; + {$EXTERNALSYM POWER_ACTION_POLICY} + TPowerActionPolicy = POWER_ACTION_POLICY; + PPowerActionPolicy = PPOWER_ACTION_POLICY; + +// POWER_ACTION_POLICY->Flags: + +const + POWER_ACTION_QUERY_ALLOWED = $00000001; + {$EXTERNALSYM POWER_ACTION_QUERY_ALLOWED} + POWER_ACTION_UI_ALLOWED = $00000002; + {$EXTERNALSYM POWER_ACTION_UI_ALLOWED} + POWER_ACTION_OVERRIDE_APPS = $00000004; + {$EXTERNALSYM POWER_ACTION_OVERRIDE_APPS} + POWER_ACTION_LIGHTEST_FIRST = $10000000; + {$EXTERNALSYM POWER_ACTION_LIGHTEST_FIRST} + POWER_ACTION_LOCK_CONSOLE = $20000000; + {$EXTERNALSYM POWER_ACTION_LOCK_CONSOLE} + POWER_ACTION_DISABLE_WAKES = $40000000; + {$EXTERNALSYM POWER_ACTION_DISABLE_WAKES} + POWER_ACTION_CRITICAL = DWORD($80000000); + {$EXTERNALSYM POWER_ACTION_CRITICAL} + +// POWER_ACTION_POLICY->EventCode flags + + POWER_LEVEL_USER_NOTIFY_TEXT = $00000001; + {$EXTERNALSYM POWER_LEVEL_USER_NOTIFY_TEXT} + POWER_LEVEL_USER_NOTIFY_SOUND = $00000002; + {$EXTERNALSYM POWER_LEVEL_USER_NOTIFY_SOUND} + POWER_LEVEL_USER_NOTIFY_EXEC = $00000004; + {$EXTERNALSYM POWER_LEVEL_USER_NOTIFY_EXEC} + POWER_USER_NOTIFY_BUTTON = $00000008; + {$EXTERNALSYM POWER_USER_NOTIFY_BUTTON} + POWER_USER_NOTIFY_SHUTDOWN = $00000010; + {$EXTERNALSYM POWER_USER_NOTIFY_SHUTDOWN} + POWER_FORCE_TRIGGER_RESET = DWORD($80000000); + {$EXTERNALSYM POWER_FORCE_TRIGGER_RESET} + +// system battery drain policies + +type + PSYSTEM_POWER_LEVEL = ^SYSTEM_POWER_LEVEL; + {$EXTERNALSYM PSYSTEM_POWER_LEVEL} + SYSTEM_POWER_LEVEL = record + Enable: BOOLEAN; + Spare: array [0..3 - 1] of BYTE; + BatteryLevel: DWORD; + PowerPolicy: POWER_ACTION_POLICY; + MinSystemState: SYSTEM_POWER_STATE; + end; + {$EXTERNALSYM SYSTEM_POWER_LEVEL} + TSystemPowerLevel = SYSTEM_POWER_LEVEL; + PSystemPowerLevel = PSYSTEM_POWER_LEVEL; + +// Discharge policy constants + +const + NUM_DISCHARGE_POLICIES = 4; + {$EXTERNALSYM NUM_DISCHARGE_POLICIES} + DISCHARGE_POLICY_CRITICAL = 0; + {$EXTERNALSYM DISCHARGE_POLICY_CRITICAL} + DISCHARGE_POLICY_LOW = 1; + {$EXTERNALSYM DISCHARGE_POLICY_LOW} + +// +// Throttling policies +// + + PO_THROTTLE_NONE = 0; + {$EXTERNALSYM PO_THROTTLE_NONE} + PO_THROTTLE_CONSTANT = 1; + {$EXTERNALSYM PO_THROTTLE_CONSTANT} + PO_THROTTLE_DEGRADE = 2; + {$EXTERNALSYM PO_THROTTLE_DEGRADE} + PO_THROTTLE_ADAPTIVE = 3; + {$EXTERNALSYM PO_THROTTLE_ADAPTIVE} + PO_THROTTLE_MAXIMUM = 4; // not a policy, just a limit + {$EXTERNALSYM PO_THROTTLE_MAXIMUM} + +// system power policies + +type + PSYSTEM_POWER_POLICY = ^SYSTEM_POWER_POLICY; + {$EXTERNALSYM PSYSTEM_POWER_POLICY} + _SYSTEM_POWER_POLICY = record + Revision: DWORD; // 1 + // events + PowerButton: POWER_ACTION_POLICY; + SleepButton: POWER_ACTION_POLICY; + LidClose: POWER_ACTION_POLICY; + LidOpenWake: SYSTEM_POWER_STATE; + Reserved: DWORD; + // "system idle" detection + Idle: POWER_ACTION_POLICY; + IdleTimeout: DWORD; + IdleSensitivity: BYTE; + // dynamic throttling policy + // PO_THROTTLE_NONE, PO_THROTTLE_CONSTANT, PO_THROTTLE_DEGRADE, or PO_THROTTLE_ADAPTIVE + DynamicThrottle: BYTE; + Spare2: array [0..1] of BYTE; + // meaning of power action "sleep" + MinSleep: SYSTEM_POWER_STATE; + MaxSleep: SYSTEM_POWER_STATE; + ReducedLatencySleep: SYSTEM_POWER_STATE; + WinLogonFlags: DWORD; + // parameters for dozing + Spare3: DWORD; + DozeS4Timeout: DWORD; + // battery policies + BroadcastCapacityResolution: DWORD; + DischargePolicy: array [0..NUM_DISCHARGE_POLICIES - 1] of SYSTEM_POWER_LEVEL; + // video policies + VideoTimeout: DWORD; + VideoDimDisplay: BOOLEAN; + VideoReserved: array [0..2] of DWORD; + // hard disk policies + SpindownTimeout: DWORD; + // processor policies + OptimizeForPower: LongBool; + FanThrottleTolerance: BYTE; + ForcedThrottle: BYTE; + MinThrottle: BYTE; + OverThrottled: POWER_ACTION_POLICY; + end; + {$EXTERNALSYM _SYSTEM_POWER_POLICY} + SYSTEM_POWER_POLICY = _SYSTEM_POWER_POLICY; + {$EXTERNALSYM SYSTEM_POWER_POLICY} + TSystemPowerPolicy = SYSTEM_POWER_POLICY; + PSystemPowerPolicy = PSYSTEM_POWER_POLICY; + +// processor power policy state + + PPROCESSOR_POWER_POLICY_INFO = ^PROCESSOR_POWER_POLICY_INFO; + {$EXTERNALSYM PPROCESSOR_POWER_POLICY_INFO} + _PROCESSOR_POWER_POLICY_INFO = record + // Time based information (will be converted to kernel units) + TimeCheck: DWORD; // in US + DemoteLimit: DWORD; // in US + PromoteLimit: DWORD; // in US + // Percentage based information + DemotePercent: BYTE; + PromotePercent: BYTE; + Spare: array [0..1] of BYTE; + // Flags + Flags: DWORD; + //DWORD AllowDemotion:1; + //DWORD AllowPromotion:1; + //DWORD Reserved:30; + end; + {$EXTERNALSYM _PROCESSOR_POWER_POLICY_INFO} + PROCESSOR_POWER_POLICY_INFO = _PROCESSOR_POWER_POLICY_INFO; + {$EXTERNALSYM PROCESSOR_POWER_POLICY_INFO} + TProcessorPowerPolicyInfo = PROCESSOR_POWER_POLICY_INFO; + PProcessorPowerPolicyInfo = PPROCESSOR_POWER_POLICY_INFO; + +// processor power policy + + PPROCESSOR_POWER_POLICY = ^PROCESSOR_POWER_POLICY; + {$EXTERNALSYM PPROCESSOR_POWER_POLICY} + _PROCESSOR_POWER_POLICY = record + Revision: DWORD; // 1 + // Dynamic Throttling Policy + DynamicThrottle: BYTE; + Spare: array [0..2] of BYTE; + // Flags + Reserved: DWORD; + //DWORD DisableCStates:1; + //DWORD Reserved:31; + + // System policy information + // The Array is last, in case it needs to be grown and the structure + // revision incremented. + PolicyCount: DWORD; + Policy: array [0..2] of PROCESSOR_POWER_POLICY_INFO; + end; + {$EXTERNALSYM _PROCESSOR_POWER_POLICY} + PROCESSOR_POWER_POLICY = _PROCESSOR_POWER_POLICY; + {$EXTERNALSYM PROCESSOR_POWER_POLICY} + TProcessorPowerPolicy = PROCESSOR_POWER_POLICY; + PProcessorPowerPolicy = PPROCESSOR_POWER_POLICY; + +// administrator power policy overrides + + PADMINISTRATOR_POWER_POLICY = ^ADMINISTRATOR_POWER_POLICY; + {$EXTERNALSYM PADMINISTRATOR_POWER_POLICY} + _ADMINISTRATOR_POWER_POLICY = record + // meaning of power action "sleep" + MinSleep: SYSTEM_POWER_STATE; + MaxSleep: SYSTEM_POWER_STATE; + // video policies + MinVideoTimeout: DWORD; + MaxVideoTimeout: DWORD; + // disk policies + MinSpindownTimeout: DWORD; + MaxSpindownTimeout: DWORD; + end; + {$EXTERNALSYM _ADMINISTRATOR_POWER_POLICY} + ADMINISTRATOR_POWER_POLICY = _ADMINISTRATOR_POWER_POLICY; + {$EXTERNALSYM ADMINISTRATOR_POWER_POLICY} + TAdministratorPowerPolicy = ADMINISTRATOR_POWER_POLICY; + PAdministratorPowerPolicy = PADMINISTRATOR_POWER_POLICY; + + PSYSTEM_POWER_CAPABILITIES = ^SYSTEM_POWER_CAPABILITIES; + {$EXTERNALSYM PSYSTEM_POWER_CAPABILITIES} + SYSTEM_POWER_CAPABILITIES = record + // Misc supported system features + PowerButtonPresent: BOOLEAN; + SleepButtonPresent: BOOLEAN; + LidPresent: BOOLEAN; + SystemS1: BOOLEAN; + SystemS2: BOOLEAN; + SystemS3: BOOLEAN; + SystemS4: BOOLEAN; // hibernate + SystemS5: BOOLEAN; // off + HiberFilePresent: BOOLEAN; + FullWake: BOOLEAN; + VideoDimPresent: BOOLEAN; + ApmPresent: BOOLEAN; + UpsPresent: BOOLEAN; + // Processors + ThermalControl: BOOLEAN; + ProcessorThrottle: BOOLEAN; + ProcessorMinThrottle: BYTE; + ProcessorMaxThrottle: BYTE; + spare2: array [0..4 - 1] of BYTE; + // Disk + DiskSpinDown: BOOLEAN; + spare3: array [0..8 - 1] of BYTE; + // System Battery + SystemBatteriesPresent: BOOLEAN; + BatteriesAreShortTerm: BOOLEAN; + BatteryScale: array [0..3 - 1] of BATTERY_REPORTING_SCALE; + // Wake + AcOnLineWake: SYSTEM_POWER_STATE; + SoftLidWake: SYSTEM_POWER_STATE; + RtcWake: SYSTEM_POWER_STATE; + MinDeviceWakeState: SYSTEM_POWER_STATE; // note this may change on driver load + DefaultLowLatencyWake: SYSTEM_POWER_STATE; + end; + {$EXTERNALSYM SYSTEM_POWER_CAPABILITIES} + TSystemPowerCapabilities = SYSTEM_POWER_CAPABILITIES; + PSystemPowerCapabilities = PSYSTEM_POWER_CAPABILITIES; + + PSYSTEM_BATTERY_STATE = ^SYSTEM_BATTERY_STATE; + {$EXTERNALSYM PSYSTEM_BATTERY_STATE} + SYSTEM_BATTERY_STATE = record + AcOnLine: BOOLEAN; + BatteryPresent: BOOLEAN; + Charging: BOOLEAN; + Discharging: BOOLEAN; + Spare1: array [0..3] of BOOLEAN; + MaxCapacity: DWORD; + RemainingCapacity: DWORD; + Rate: DWORD; + EstimatedTime: DWORD; + DefaultAlert1: DWORD; + DefaultAlert2: DWORD; + end; + {$EXTERNALSYM SYSTEM_BATTERY_STATE} + TSystemBatteryState = SYSTEM_BATTERY_STATE; + PSystemBatteryState = PSYSTEM_BATTERY_STATE; + +// +// Image Format +// + +// #include "pshpack4.h" // 4 byte packing is the default + +const + IMAGE_DOS_SIGNATURE = $5A4D; // MZ + {$EXTERNALSYM IMAGE_DOS_SIGNATURE} + IMAGE_OS2_SIGNATURE = $454E; // NE + {$EXTERNALSYM IMAGE_OS2_SIGNATURE} + IMAGE_OS2_SIGNATURE_LE = $454C; // LE + {$EXTERNALSYM IMAGE_OS2_SIGNATURE_LE} + IMAGE_VXD_SIGNATURE = $454C; // LE + {$EXTERNALSYM IMAGE_VXD_SIGNATURE} + IMAGE_NT_SIGNATURE = $00004550; // PE00 + {$EXTERNALSYM IMAGE_NT_SIGNATURE} + +// #include "pshpack2.h" // 16 bit headers are 2 byte packed + +type + + // DOS .EXE header + + PIMAGE_DOS_HEADER = ^IMAGE_DOS_HEADER; + {$EXTERNALSYM PIMAGE_DOS_HEADER} + _IMAGE_DOS_HEADER = record + e_magic: Word; // Magic number + e_cblp: Word; // Bytes on last page of file + e_cp: Word; // Pages in file + e_crlc: Word; // Relocations + e_cparhdr: Word; // Size of header in paragraphs + e_minalloc: Word; // Minimum extra paragraphs needed + e_maxalloc: Word; // Maximum extra paragraphs needed + e_ss: Word; // Initial (relative) SS value + e_sp: Word; // Initial SP value + e_csum: Word; // Checksum + e_ip: Word; // Initial IP value + e_cs: Word; // Initial (relative) CS value + e_lfarlc: Word; // File address of relocation table + e_ovno: Word; // Overlay number + e_res: array [0..3] of Word; // Reserved words + e_oemid: Word; // OEM identifier (for e_oeminfo) + e_oeminfo: Word; // OEM information; e_oemid specific + e_res2: array [0..9] of Word; // Reserved words + e_lfanew: Longint; // File address of new exe header + end; + {$EXTERNALSYM _IMAGE_DOS_HEADER} + IMAGE_DOS_HEADER = _IMAGE_DOS_HEADER; + {$EXTERNALSYM IMAGE_DOS_HEADER} + TImageDosHeader = IMAGE_DOS_HEADER; + PImageDosHeader = PIMAGE_DOS_HEADER; + + // OS/2 .EXE header + + PIMAGE_OS2_HEADER = ^IMAGE_OS2_HEADER; + {$EXTERNALSYM PIMAGE_OS2_HEADER} + _IMAGE_OS2_HEADER = record + ne_magic: Word; // Magic number + ne_ver: CHAR; // Version number + ne_rev: CHAR; // Revision number + ne_enttab: Word; // Offset of Entry Table + ne_cbenttab: Word; // Number of bytes in Entry Table + ne_crc: Longint; // Checksum of whole file + ne_flags: Word; // Flag word + ne_autodata: Word; // Automatic data segment number + ne_heap: Word; // Initial heap allocation + ne_stack: Word; // Initial stack allocation + ne_csip: Longint; // Initial CS:IP setting + ne_sssp: Longint; // Initial SS:SP setting + ne_cseg: Word; // Count of file segments + ne_cmod: Word; // Entries in Module Reference Table + ne_cbnrestab: Word; // Size of non-resident name table + ne_segtab: Word; // Offset of Segment Table + ne_rsrctab: Word; // Offset of Resource Table + ne_restab: Word; // Offset of resident name table + ne_modtab: Word; // Offset of Module Reference Table + ne_imptab: Word; // Offset of Imported Names Table + ne_nrestab: Longint; // Offset of Non-resident Names Table + ne_cmovent: Word; // Count of movable entries + ne_align: Word; // Segment alignment shift count + ne_cres: Word; // Count of resource segments + ne_exetyp: Byte; // Target Operating system + ne_flagsothers: Byte; // Other .EXE flags + ne_pretthunks: Word; // offset to return thunks + ne_psegrefbytes: Word; // offset to segment ref. bytes + ne_swaparea: Word; // Minimum code swap area size + ne_expver: Word; // Expected Windows version number + end; + {$EXTERNALSYM _IMAGE_OS2_HEADER} + IMAGE_OS2_HEADER = _IMAGE_OS2_HEADER; + {$EXTERNALSYM IMAGE_OS2_HEADER} + TImageOs2Header = IMAGE_OS2_HEADER; + PImageOs2Header = PIMAGE_OS2_HEADER; + + // Windows VXD header + + PIMAGE_VXD_HEADER = ^IMAGE_VXD_HEADER; + {$EXTERNALSYM PIMAGE_VXD_HEADER} + _IMAGE_VXD_HEADER = record + e32_magic: Word; // Magic number + e32_border: Byte; // The byte ordering for the VXD + e32_worder: Byte; // The word ordering for the VXD + e32_level: DWORD; // The EXE format level for now = 0 + e32_cpu: Word; // The CPU type + e32_os: Word; // The OS type + e32_ver: DWORD; // Module version + e32_mflags: DWORD; // Module flags + e32_mpages: DWORD; // Module # pages + e32_startobj: DWORD; // Object # for instruction pointer + e32_eip: DWORD; // Extended instruction pointer + e32_stackobj: DWORD; // Object # for stack pointer + e32_esp: DWORD; // Extended stack pointer + e32_pagesize: DWORD; // VXD page size + e32_lastpagesize: DWORD; // Last page size in VXD + e32_fixupsize: DWORD; // Fixup section size + e32_fixupsum: DWORD; // Fixup section checksum + e32_ldrsize: DWORD; // Loader section size + e32_ldrsum: DWORD; // Loader section checksum + e32_objtab: DWORD; // Object table offset + e32_objcnt: DWORD; // Number of objects in module + e32_objmap: DWORD; // Object page map offset + e32_itermap: DWORD; // Object iterated data map offset + e32_rsrctab: DWORD; // Offset of Resource Table + e32_rsrccnt: DWORD; // Number of resource entries + e32_restab: DWORD; // Offset of resident name table + e32_enttab: DWORD; // Offset of Entry Table + e32_dirtab: DWORD; // Offset of Module Directive Table + e32_dircnt: DWORD; // Number of module directives + e32_fpagetab: DWORD; // Offset of Fixup Page Table + e32_frectab: DWORD; // Offset of Fixup Record Table + e32_impmod: DWORD; // Offset of Import Module Name Table + e32_impmodcnt: DWORD; // Number of entries in Import Module Name Table + e32_impproc: DWORD; // Offset of Import Procedure Name Table + e32_pagesum: DWORD; // Offset of Per-Page Checksum Table + e32_datapage: DWORD; // Offset of Enumerated Data Pages + e32_preload: DWORD; // Number of preload pages + e32_nrestab: DWORD; // Offset of Non-resident Names Table + e32_cbnrestab: DWORD; // Size of Non-resident Name Table + e32_nressum: DWORD; // Non-resident Name Table Checksum + e32_autodata: DWORD; // Object # for automatic data object + e32_debuginfo: DWORD; // Offset of the debugging information + e32_debuglen: DWORD; // The length of the debugging info. in bytes + e32_instpreload: DWORD; // Number of instance pages in preload section of VXD file + e32_instdemand: DWORD; // Number of instance pages in demand load section of VXD file + e32_heapsize: DWORD; // Size of heap - for 16-bit apps + e32_res3: array [0..11] of Byte; // Reserved words + e32_winresoff: DWORD; + e32_winreslen: DWORD; + e32_devid: Word; // Device ID for VxD + e32_ddkver: Word; // DDK version for VxD + end; + {$EXTERNALSYM _IMAGE_VXD_HEADER} + IMAGE_VXD_HEADER = _IMAGE_VXD_HEADER; + {$EXTERNALSYM IMAGE_VXD_HEADER} + TImageVxdHeader = IMAGE_VXD_HEADER; + PImageVxdHeader = PIMAGE_VXD_HEADER; + +// #include "poppack.h" // Back to 4 byte packing + +// +// File header format. +// + + PIMAGE_FILE_HEADER = ^IMAGE_FILE_HEADER; + {$EXTERNALSYM PIMAGE_FILE_HEADER} + _IMAGE_FILE_HEADER = record + Machine: WORD; + NumberOfSections: WORD; + TimeDateStamp: DWORD; + PointerToSymbolTable: DWORD; + NumberOfSymbols: DWORD; + SizeOfOptionalHeader: WORD; + Characteristics: WORD; + end; + {$EXTERNALSYM _IMAGE_FILE_HEADER} + IMAGE_FILE_HEADER = _IMAGE_FILE_HEADER; + {$EXTERNALSYM IMAGE_FILE_HEADER} + TImageFileHeader = IMAGE_FILE_HEADER; + PImageFileHeader = PIMAGE_FILE_HEADER; + +const + IMAGE_SIZEOF_FILE_HEADER = 20; + {$EXTERNALSYM IMAGE_SIZEOF_FILE_HEADER} + + IMAGE_FILE_RELOCS_STRIPPED = $0001; // Relocation info stripped from file. + {$EXTERNALSYM IMAGE_FILE_RELOCS_STRIPPED} + IMAGE_FILE_EXECUTABLE_IMAGE = $0002; // File is executable (i.e. no unresolved externel references). + {$EXTERNALSYM IMAGE_FILE_EXECUTABLE_IMAGE} + IMAGE_FILE_LINE_NUMS_STRIPPED = $0004; // Line nunbers stripped from file. + {$EXTERNALSYM IMAGE_FILE_LINE_NUMS_STRIPPED} + IMAGE_FILE_LOCAL_SYMS_STRIPPED = $0008; // Local symbols stripped from file. + {$EXTERNALSYM IMAGE_FILE_LOCAL_SYMS_STRIPPED} + IMAGE_FILE_AGGRESIVE_WS_TRIM = $0010; // Agressively trim working set + {$EXTERNALSYM IMAGE_FILE_AGGRESIVE_WS_TRIM} + IMAGE_FILE_LARGE_ADDRESS_AWARE = $0020; // App can handle >2gb addresses + {$EXTERNALSYM IMAGE_FILE_LARGE_ADDRESS_AWARE} + IMAGE_FILE_BYTES_REVERSED_LO = $0080; // Bytes of machine word are reversed. + {$EXTERNALSYM IMAGE_FILE_BYTES_REVERSED_LO} + IMAGE_FILE_32BIT_MACHINE = $0100; // 32 bit word machine. + {$EXTERNALSYM IMAGE_FILE_32BIT_MACHINE} + IMAGE_FILE_DEBUG_STRIPPED = $0200; // Debugging info stripped from file in .DBG file + {$EXTERNALSYM IMAGE_FILE_DEBUG_STRIPPED} + IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP = $0400; // If Image is on removable media, copy and run from the swap file. + {$EXTERNALSYM IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP} + IMAGE_FILE_NET_RUN_FROM_SWAP = $0800; // If Image is on Net, copy and run from the swap file. + {$EXTERNALSYM IMAGE_FILE_NET_RUN_FROM_SWAP} + IMAGE_FILE_SYSTEM = $1000; // System File. + {$EXTERNALSYM IMAGE_FILE_SYSTEM} + IMAGE_FILE_DLL = $2000; // File is a DLL. + {$EXTERNALSYM IMAGE_FILE_DLL} + IMAGE_FILE_UP_SYSTEM_ONLY = $4000; // File should only be run on a UP machine + {$EXTERNALSYM IMAGE_FILE_UP_SYSTEM_ONLY} + IMAGE_FILE_BYTES_REVERSED_HI = $8000; // Bytes of machine word are reversed. + {$EXTERNALSYM IMAGE_FILE_BYTES_REVERSED_HI} + + IMAGE_FILE_MACHINE_UNKNOWN = 0; + {$EXTERNALSYM IMAGE_FILE_MACHINE_UNKNOWN} + IMAGE_FILE_MACHINE_I386 = $014c; // Intel 386. + {$EXTERNALSYM IMAGE_FILE_MACHINE_I386} + IMAGE_FILE_MACHINE_R3000 = $0162; // MIPS little-endian, 0x160 big-endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_R3000} + IMAGE_FILE_MACHINE_R4000 = $0166; // MIPS little-endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_R4000} + IMAGE_FILE_MACHINE_R10000 = $0168; // MIPS little-endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_R10000} + IMAGE_FILE_MACHINE_WCEMIPSV2 = $0169; // MIPS little-endian WCE v2 + {$EXTERNALSYM IMAGE_FILE_MACHINE_WCEMIPSV2} + IMAGE_FILE_MACHINE_ALPHA = $0184; // Alpha_AXP + {$EXTERNALSYM IMAGE_FILE_MACHINE_ALPHA} + IMAGE_FILE_MACHINE_SH3 = $01a2; // SH3 little-endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_SH3} + IMAGE_FILE_MACHINE_SH3DSP = $01a3; + {$EXTERNALSYM IMAGE_FILE_MACHINE_SH3DSP} + IMAGE_FILE_MACHINE_SH3E = $01a4; // SH3E little-endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_SH3E} + IMAGE_FILE_MACHINE_SH4 = $01a6; // SH4 little-endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_SH4} + IMAGE_FILE_MACHINE_SH5 = $01a8; // SH5 + {$EXTERNALSYM IMAGE_FILE_MACHINE_SH5} + IMAGE_FILE_MACHINE_ARM = $01c0; // ARM Little-Endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_ARM} + IMAGE_FILE_MACHINE_THUMB = $01c2; + {$EXTERNALSYM IMAGE_FILE_MACHINE_THUMB} + IMAGE_FILE_MACHINE_AM33 = $01d3; + {$EXTERNALSYM IMAGE_FILE_MACHINE_AM33} + IMAGE_FILE_MACHINE_POWERPC = $01F0; // IBM PowerPC Little-Endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_POWERPC} + IMAGE_FILE_MACHINE_POWERPCFP = $01f1; + {$EXTERNALSYM IMAGE_FILE_MACHINE_POWERPCFP} + IMAGE_FILE_MACHINE_IA64 = $0200; // Intel 64 + {$EXTERNALSYM IMAGE_FILE_MACHINE_IA64} + IMAGE_FILE_MACHINE_MIPS16 = $0266; // MIPS + {$EXTERNALSYM IMAGE_FILE_MACHINE_MIPS16} + IMAGE_FILE_MACHINE_ALPHA64 = $0284; // ALPHA64 + {$EXTERNALSYM IMAGE_FILE_MACHINE_ALPHA64} + IMAGE_FILE_MACHINE_MIPSFPU = $0366; // MIPS + {$EXTERNALSYM IMAGE_FILE_MACHINE_MIPSFPU} + IMAGE_FILE_MACHINE_MIPSFPU16 = $0466; // MIPS + {$EXTERNALSYM IMAGE_FILE_MACHINE_MIPSFPU16} + IMAGE_FILE_MACHINE_AXP64 = IMAGE_FILE_MACHINE_ALPHA64; + {$EXTERNALSYM IMAGE_FILE_MACHINE_AXP64} + IMAGE_FILE_MACHINE_TRICORE = $0520; // Infineon + {$EXTERNALSYM IMAGE_FILE_MACHINE_TRICORE} + IMAGE_FILE_MACHINE_CEF = $0CEF; + {$EXTERNALSYM IMAGE_FILE_MACHINE_CEF} + IMAGE_FILE_MACHINE_EBC = $0EBC; // EFI Byte Code + {$EXTERNALSYM IMAGE_FILE_MACHINE_EBC} + IMAGE_FILE_MACHINE_AMD64 = $8664; // AMD64 (K8) + {$EXTERNALSYM IMAGE_FILE_MACHINE_AMD64} + IMAGE_FILE_MACHINE_M32R = $9041; // M32R little-endian + {$EXTERNALSYM IMAGE_FILE_MACHINE_M32R} + IMAGE_FILE_MACHINE_CEE = $C0EE; + {$EXTERNALSYM IMAGE_FILE_MACHINE_CEE} + +// +// Directory format. +// + +type + PIMAGE_DATA_DIRECTORY = ^IMAGE_DATA_DIRECTORY; + {$EXTERNALSYM PIMAGE_DATA_DIRECTORY} + _IMAGE_DATA_DIRECTORY = record + VirtualAddress: DWORD; + Size: DWORD; + end; + {$EXTERNALSYM _IMAGE_DATA_DIRECTORY} + IMAGE_DATA_DIRECTORY = _IMAGE_DATA_DIRECTORY; + {$EXTERNALSYM IMAGE_DATA_DIRECTORY} + TImageDataDirectory = IMAGE_DATA_DIRECTORY; + PImageDataDirectory = PIMAGE_DATA_DIRECTORY; + +const + IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16; + {$EXTERNALSYM IMAGE_NUMBEROF_DIRECTORY_ENTRIES} + +// +// Optional header format. +// + +type + PIMAGE_OPTIONAL_HEADER32 = ^IMAGE_OPTIONAL_HEADER32; + {$EXTERNALSYM PIMAGE_OPTIONAL_HEADER32} + _IMAGE_OPTIONAL_HEADER = record + // + // Standard fields. + // + Magic: Word; + MajorLinkerVersion: Byte; + MinorLinkerVersion: Byte; + SizeOfCode: DWORD; + SizeOfInitializedData: DWORD; + SizeOfUninitializedData: DWORD; + AddressOfEntryPoint: DWORD; + BaseOfCode: DWORD; + BaseOfData: DWORD; + // + // NT additional fields. + // + ImageBase: DWORD; + SectionAlignment: DWORD; + FileAlignment: DWORD; + MajorOperatingSystemVersion: Word; + MinorOperatingSystemVersion: Word; + MajorImageVersion: Word; + MinorImageVersion: Word; + MajorSubsystemVersion: Word; + MinorSubsystemVersion: Word; + Win32VersionValue: DWORD; + SizeOfImage: DWORD; + SizeOfHeaders: DWORD; + CheckSum: DWORD; + Subsystem: Word; + DllCharacteristics: Word; + SizeOfStackReserve: DWORD; + SizeOfStackCommit: DWORD; + SizeOfHeapReserve: DWORD; + SizeOfHeapCommit: DWORD; + LoaderFlags: DWORD; + NumberOfRvaAndSizes: DWORD; + DataDirectory: array [0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1] of IMAGE_DATA_DIRECTORY; + end; + {$EXTERNALSYM _IMAGE_OPTIONAL_HEADER} + IMAGE_OPTIONAL_HEADER32 = _IMAGE_OPTIONAL_HEADER; + {$EXTERNALSYM IMAGE_OPTIONAL_HEADER32} + TImageOptionalHeader32 = IMAGE_OPTIONAL_HEADER32; + PImageOptionalHeader32 = PIMAGE_OPTIONAL_HEADER32; + + PIMAGE_ROM_OPTIONAL_HEADER = ^IMAGE_ROM_OPTIONAL_HEADER; + {$EXTERNALSYM PIMAGE_ROM_OPTIONAL_HEADER} + _IMAGE_ROM_OPTIONAL_HEADER = record + Magic: Word; + MajorLinkerVersion: Byte; + MinorLinkerVersion: Byte; + SizeOfCode: DWORD; + SizeOfInitializedData: DWORD; + SizeOfUninitializedData: DWORD; + AddressOfEntryPoint: DWORD; + BaseOfCode: DWORD; + BaseOfData: DWORD; + BaseOfBss: DWORD; + GprMask: DWORD; + CprMask: array [0..3] of DWORD; + GpValue: DWORD; + end; + {$EXTERNALSYM _IMAGE_ROM_OPTIONAL_HEADER} + IMAGE_ROM_OPTIONAL_HEADER = _IMAGE_ROM_OPTIONAL_HEADER; + {$EXTERNALSYM IMAGE_ROM_OPTIONAL_HEADER} + TImageRomOptionalHeader = IMAGE_ROM_OPTIONAL_HEADER; + PImageRomOptionalHeader = PIMAGE_ROM_OPTIONAL_HEADER; + + PIMAGE_OPTIONAL_HEADER64 = ^IMAGE_OPTIONAL_HEADER64; + {$EXTERNALSYM PIMAGE_OPTIONAL_HEADER64} + _IMAGE_OPTIONAL_HEADER64 = record + Magic: Word; + MajorLinkerVersion: Byte; + MinorLinkerVersion: Byte; + SizeOfCode: DWORD; + SizeOfInitializedData: DWORD; + SizeOfUninitializedData: DWORD; + AddressOfEntryPoint: DWORD; + BaseOfCode: DWORD; + ImageBase: Int64; + SectionAlignment: DWORD; + FileAlignment: DWORD; + MajorOperatingSystemVersion: Word; + MinorOperatingSystemVersion: Word; + MajorImageVersion: Word; + MinorImageVersion: Word; + MajorSubsystemVersion: Word; + MinorSubsystemVersion: Word; + Win32VersionValue: DWORD; + SizeOfImage: DWORD; + SizeOfHeaders: DWORD; + CheckSum: DWORD; + Subsystem: Word; + DllCharacteristics: Word; + SizeOfStackReserve: Int64; + SizeOfStackCommit: Int64; + SizeOfHeapReserve: Int64; + SizeOfHeapCommit: Int64; + LoaderFlags: DWORD; + NumberOfRvaAndSizes: DWORD; + DataDirectory: array [0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1] of IMAGE_DATA_DIRECTORY; + end; + {$EXTERNALSYM _IMAGE_OPTIONAL_HEADER64} + IMAGE_OPTIONAL_HEADER64 = _IMAGE_OPTIONAL_HEADER64; + {$EXTERNALSYM IMAGE_OPTIONAL_HEADER64} + TImageOptionalHeader64 = IMAGE_OPTIONAL_HEADER64; + PImageOptionalHeader64 = PIMAGE_OPTIONAL_HEADER64; + +const + IMAGE_SIZEOF_ROM_OPTIONAL_HEADER = 56; + {$EXTERNALSYM IMAGE_SIZEOF_ROM_OPTIONAL_HEADER} + IMAGE_SIZEOF_STD_OPTIONAL_HEADER = 28; + {$EXTERNALSYM IMAGE_SIZEOF_STD_OPTIONAL_HEADER} + IMAGE_SIZEOF_NT_OPTIONAL32_HEADER = 224; + {$EXTERNALSYM IMAGE_SIZEOF_NT_OPTIONAL32_HEADER} + IMAGE_SIZEOF_NT_OPTIONAL64_HEADER = 240; + {$EXTERNALSYM IMAGE_SIZEOF_NT_OPTIONAL64_HEADER} + + IMAGE_NT_OPTIONAL_HDR32_MAGIC = $10b; + {$EXTERNALSYM IMAGE_NT_OPTIONAL_HDR32_MAGIC} + IMAGE_NT_OPTIONAL_HDR64_MAGIC = $20b; + {$EXTERNALSYM IMAGE_NT_OPTIONAL_HDR64_MAGIC} + IMAGE_ROM_OPTIONAL_HDR_MAGIC = $107; + {$EXTERNALSYM IMAGE_ROM_OPTIONAL_HDR_MAGIC} + +type + IMAGE_OPTIONAL_HEADER = IMAGE_OPTIONAL_HEADER32; + {$EXTERNALSYM IMAGE_OPTIONAL_HEADER} + PIMAGE_OPTIONAL_HEADER = PIMAGE_OPTIONAL_HEADER32; + {$EXTERNALSYM PIMAGE_OPTIONAL_HEADER} + +const + IMAGE_SIZEOF_NT_OPTIONAL_HEADER = IMAGE_SIZEOF_NT_OPTIONAL32_HEADER; + {$EXTERNALSYM IMAGE_SIZEOF_NT_OPTIONAL_HEADER} + IMAGE_NT_OPTIONAL_HDR_MAGIC = IMAGE_NT_OPTIONAL_HDR32_MAGIC; + {$EXTERNALSYM IMAGE_NT_OPTIONAL_HDR_MAGIC} + +type + PIMAGE_NT_HEADERS64 = ^IMAGE_NT_HEADERS64; + {$EXTERNALSYM PIMAGE_NT_HEADERS64} + _IMAGE_NT_HEADERS64 = record + Signature: DWORD; + FileHeader: IMAGE_FILE_HEADER; + OptionalHeader: IMAGE_OPTIONAL_HEADER64; + end; + {$EXTERNALSYM _IMAGE_NT_HEADERS64} + IMAGE_NT_HEADERS64 = _IMAGE_NT_HEADERS64; + {$EXTERNALSYM IMAGE_NT_HEADERS64} + TImageNtHeaders64 = IMAGE_NT_HEADERS64; + PImageNtHeaders64 = PIMAGE_NT_HEADERS64; + + PIMAGE_NT_HEADERS32 = ^IMAGE_NT_HEADERS32; + {$EXTERNALSYM PIMAGE_NT_HEADERS32} + _IMAGE_NT_HEADERS = record + Signature: DWORD; + FileHeader: IMAGE_FILE_HEADER; + OptionalHeader: IMAGE_OPTIONAL_HEADER32; + end; + {$EXTERNALSYM _IMAGE_NT_HEADERS} + IMAGE_NT_HEADERS32 = _IMAGE_NT_HEADERS; + {$EXTERNALSYM IMAGE_NT_HEADERS32} + TImageNtHeaders32 = IMAGE_NT_HEADERS32; + PImageNtHeaders32 = PIMAGE_NT_HEADERS32; + + PIMAGE_ROM_HEADERS = ^IMAGE_ROM_HEADERS; + {$EXTERNALSYM PIMAGE_ROM_HEADERS} + _IMAGE_ROM_HEADERS = record + FileHeader: IMAGE_FILE_HEADER; + OptionalHeader: IMAGE_ROM_OPTIONAL_HEADER; + end; + {$EXTERNALSYM _IMAGE_ROM_HEADERS} + IMAGE_ROM_HEADERS = _IMAGE_ROM_HEADERS; + {$EXTERNALSYM IMAGE_ROM_HEADERS} + TImageRomHeaders = IMAGE_ROM_HEADERS; + PImageRomHeaders = PIMAGE_ROM_HEADERS; + + IMAGE_NT_HEADERS = IMAGE_NT_HEADERS32; + {$EXTERNALSYM IMAGE_NT_HEADERS} + PIMAGE_NT_HEADERS = PIMAGE_NT_HEADERS32; + {$EXTERNALSYM PIMAGE_NT_HEADERS} + + PImageNtHeaders = PIMAGE_NT_HEADERS; + +// Subsystem Values + +const + IMAGE_SUBSYSTEM_UNKNOWN = 0; // Unknown subsystem. + {$EXTERNALSYM IMAGE_SUBSYSTEM_UNKNOWN} + IMAGE_SUBSYSTEM_NATIVE = 1; // Image doesn't require a subsystem. + {$EXTERNALSYM IMAGE_SUBSYSTEM_NATIVE} + IMAGE_SUBSYSTEM_WINDOWS_GUI = 2; // Image runs in the Windows GUI subsystem. + {$EXTERNALSYM IMAGE_SUBSYSTEM_WINDOWS_GUI} + IMAGE_SUBSYSTEM_WINDOWS_CUI = 3; // Image runs in the Windows character subsystem. + {$EXTERNALSYM IMAGE_SUBSYSTEM_WINDOWS_CUI} + IMAGE_SUBSYSTEM_OS2_CUI = 5; // image runs in the OS/2 character subsystem. + {$EXTERNALSYM IMAGE_SUBSYSTEM_OS2_CUI} + IMAGE_SUBSYSTEM_POSIX_CUI = 7; // image runs in the Posix character subsystem. + {$EXTERNALSYM IMAGE_SUBSYSTEM_POSIX_CUI} + IMAGE_SUBSYSTEM_NATIVE_WINDOWS = 8; // image is a native Win9x driver. + {$EXTERNALSYM IMAGE_SUBSYSTEM_NATIVE_WINDOWS} + IMAGE_SUBSYSTEM_WINDOWS_CE_GUI = 9; // Image runs in the Windows CE subsystem. + {$EXTERNALSYM IMAGE_SUBSYSTEM_WINDOWS_CE_GUI} + IMAGE_SUBSYSTEM_EFI_APPLICATION = 10; + {$EXTERNALSYM IMAGE_SUBSYSTEM_EFI_APPLICATION} + IMAGE_SUBSYSTEM_EFI_BOOT_SERVICE_DRIVER = 11; + {$EXTERNALSYM IMAGE_SUBSYSTEM_EFI_BOOT_SERVICE_DRIVER} + IMAGE_SUBSYSTEM_EFI_RUNTIME_DRIVER = 12; + {$EXTERNALSYM IMAGE_SUBSYSTEM_EFI_RUNTIME_DRIVER} + IMAGE_SUBSYSTEM_EFI_ROM = 13; + {$EXTERNALSYM IMAGE_SUBSYSTEM_EFI_ROM} + IMAGE_SUBSYSTEM_XBOX = 14; + {$EXTERNALSYM IMAGE_SUBSYSTEM_XBOX} + +// DllCharacteristics Entries + +// IMAGE_LIBRARY_PROCESS_INIT 0x0001 // Reserved. +// IMAGE_LIBRARY_PROCESS_TERM 0x0002 // Reserved. +// IMAGE_LIBRARY_THREAD_INIT 0x0004 // Reserved. +// IMAGE_LIBRARY_THREAD_TERM 0x0008 // Reserved. + IMAGE_DLLCHARACTERISTICS_NO_ISOLATION = $0200; // Image understands isolation and doesn't want it + {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_NO_ISOLATION} + IMAGE_DLLCHARACTERISTICS_NO_SEH = $0400; // Image does not use SEH. No SE handler may reside in this image + {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_NO_SEH} + IMAGE_DLLCHARACTERISTICS_NO_BIND = $0800; // Do not bind this image. + {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_NO_BIND} + +// 0x1000 // Reserved. + + IMAGE_DLLCHARACTERISTICS_WDM_DRIVER = $2000; // Driver uses WDM model + {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_WDM_DRIVER} + +// 0x4000 // Reserved. + + IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE = $8000; + {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE} + +// Directory Entries + + IMAGE_DIRECTORY_ENTRY_EXPORT = 0; // Export Directory + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_EXPORT} + IMAGE_DIRECTORY_ENTRY_IMPORT = 1; // Import Directory + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_IMPORT} + IMAGE_DIRECTORY_ENTRY_RESOURCE = 2; // Resource Directory + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_RESOURCE} + IMAGE_DIRECTORY_ENTRY_EXCEPTION = 3; // Exception Directory + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_EXCEPTION} + IMAGE_DIRECTORY_ENTRY_SECURITY = 4; // Security Directory + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_SECURITY} + IMAGE_DIRECTORY_ENTRY_BASERELOC = 5; // Base Relocation Table + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_BASERELOC} + IMAGE_DIRECTORY_ENTRY_DEBUG = 6; // Debug Directory + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_DEBUG} + +// IMAGE_DIRECTORY_ENTRY_COPYRIGHT 7 // (X86 usage) + + IMAGE_DIRECTORY_ENTRY_ARCHITECTURE = 7; // Architecture Specific Data + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_ARCHITECTURE} + IMAGE_DIRECTORY_ENTRY_GLOBALPTR = 8; // RVA of GP + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_GLOBALPTR} + IMAGE_DIRECTORY_ENTRY_TLS = 9; // TLS Directory + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_TLS} + IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG = 10; // Load Configuration Directory + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG} + IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT = 11; // Bound Import Directory in headers + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT} + IMAGE_DIRECTORY_ENTRY_IAT = 12; // Import Address Table + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_IAT} + IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT = 13; // Delay Load Import Descriptors + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT} + IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR = 14; // COM Runtime descriptor + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR} + +// +// Non-COFF Object file header +// + +type + PAnonObjectHeader = ^ANON_OBJECT_HEADER; + ANON_OBJECT_HEADER = record + Sig1: Word; // Must be IMAGE_FILE_MACHINE_UNKNOWN + Sig2: Word; // Must be 0xffff + Version: Word; // >= 1 (implies the CLSID field is present) + Machine: Word; + TimeDateStamp: DWORD; + ClassID: CLSID; // Used to invoke CoCreateInstance + SizeOfData: DWORD; // Size of data that follows the header + end; + {$EXTERNALSYM ANON_OBJECT_HEADER} + TAnonObjectHeader = ANON_OBJECT_HEADER; + +// +// Section header format. +// + +const + IMAGE_SIZEOF_SHORT_NAME = 8; + {$EXTERNALSYM IMAGE_SIZEOF_SHORT_NAME} + +type + TImgSecHdrMisc = record + case Integer of + 0: (PhysicalAddress: DWORD); + 1: (VirtualSize: DWORD); + end; + + PIMAGE_SECTION_HEADER = ^IMAGE_SECTION_HEADER; + {$EXTERNALSYM PIMAGE_SECTION_HEADER} + _IMAGE_SECTION_HEADER = record + Name: array [0..IMAGE_SIZEOF_SHORT_NAME - 1] of BYTE; + Misc: TImgSecHdrMisc; + VirtualAddress: DWORD; + SizeOfRawData: DWORD; + PointerToRawData: DWORD; + PointerToRelocations: DWORD; + PointerToLinenumbers: DWORD; + NumberOfRelocations: WORD; + NumberOfLinenumbers: WORD; + Characteristics: DWORD; + end; + {$EXTERNALSYM _IMAGE_SECTION_HEADER} + IMAGE_SECTION_HEADER = _IMAGE_SECTION_HEADER; + {$EXTERNALSYM IMAGE_SECTION_HEADER} + TImageSectionHeader = IMAGE_SECTION_HEADER; + PImageSectionHeader = PIMAGE_SECTION_HEADER; + +// IMAGE_FIRST_SECTION doesn't need 32/64 versions since the file header is the same either way. + +function IMAGE_FIRST_SECTION(NtHeader: PImageNtHeaders): PImageSectionHeader; +{$EXTERNALSYM IMAGE_FIRST_SECTION} + +const + IMAGE_SIZEOF_SECTION_HEADER = 40; + {$EXTERNALSYM IMAGE_SIZEOF_SECTION_HEADER} + +// +// Section characteristics. +// +// IMAGE_SCN_TYPE_REG 0x00000000 // Reserved. +// IMAGE_SCN_TYPE_DSECT 0x00000001 // Reserved. +// IMAGE_SCN_TYPE_NOLOAD 0x00000002 // Reserved. +// IMAGE_SCN_TYPE_GROUP 0x00000004 // Reserved. + + IMAGE_SCN_TYPE_NO_PAD = $00000008; // Reserved. + {$EXTERNALSYM IMAGE_SCN_TYPE_NO_PAD} + +// IMAGE_SCN_TYPE_COPY 0x00000010 // Reserved. + + IMAGE_SCN_CNT_CODE = $00000020; // Section contains code. + {$EXTERNALSYM IMAGE_SCN_CNT_CODE} + IMAGE_SCN_CNT_INITIALIZED_DATA = $00000040; // Section contains initialized data. + {$EXTERNALSYM IMAGE_SCN_CNT_INITIALIZED_DATA} + IMAGE_SCN_CNT_UNINITIALIZED_DATA = $00000080; // Section contains uninitialized data. + {$EXTERNALSYM IMAGE_SCN_CNT_UNINITIALIZED_DATA} + + IMAGE_SCN_LNK_OTHER = $00000100; // Reserved. + {$EXTERNALSYM IMAGE_SCN_LNK_OTHER} + IMAGE_SCN_LNK_INFO = $00000200; // Section contains comments or some other type of information. + {$EXTERNALSYM IMAGE_SCN_LNK_INFO} + +// IMAGE_SCN_TYPE_OVER 0x00000400 // Reserved. + + IMAGE_SCN_LNK_REMOVE = $00000800; // Section contents will not become part of image. + {$EXTERNALSYM IMAGE_SCN_LNK_REMOVE} + IMAGE_SCN_LNK_COMDAT = $00001000; // Section contents comdat. + {$EXTERNALSYM IMAGE_SCN_LNK_COMDAT} + +// 0x00002000 // Reserved. +// IMAGE_SCN_MEM_PROTECTED - Obsolete 0x00004000 + + IMAGE_SCN_NO_DEFER_SPEC_EXC = $00004000; // Reset speculative exceptions handling bits in the TLB entries for this section. + {$EXTERNALSYM IMAGE_SCN_NO_DEFER_SPEC_EXC} + IMAGE_SCN_GPREL = $00008000; // Section content can be accessed relative to GP + {$EXTERNALSYM IMAGE_SCN_GPREL} + IMAGE_SCN_MEM_FARDATA = $00008000; + {$EXTERNALSYM IMAGE_SCN_MEM_FARDATA} + +// IMAGE_SCN_MEM_SYSHEAP - Obsolete 0x00010000 + + IMAGE_SCN_MEM_PURGEABLE = $00020000; + {$EXTERNALSYM IMAGE_SCN_MEM_PURGEABLE} + IMAGE_SCN_MEM_16BIT = $00020000; + {$EXTERNALSYM IMAGE_SCN_MEM_16BIT} + IMAGE_SCN_MEM_LOCKED = $00040000; + {$EXTERNALSYM IMAGE_SCN_MEM_LOCKED} + IMAGE_SCN_MEM_PRELOAD = $00080000; + {$EXTERNALSYM IMAGE_SCN_MEM_PRELOAD} + + IMAGE_SCN_ALIGN_1BYTES = $00100000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_1BYTES} + IMAGE_SCN_ALIGN_2BYTES = $00200000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_2BYTES} + IMAGE_SCN_ALIGN_4BYTES = $00300000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_4BYTES} + IMAGE_SCN_ALIGN_8BYTES = $00400000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_8BYTES} + IMAGE_SCN_ALIGN_16BYTES = $00500000; // Default alignment if no others are specified. + {$EXTERNALSYM IMAGE_SCN_ALIGN_16BYTES} + IMAGE_SCN_ALIGN_32BYTES = $00600000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_32BYTES} + IMAGE_SCN_ALIGN_64BYTES = $00700000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_64BYTES} + IMAGE_SCN_ALIGN_128BYTES = $00800000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_128BYTES} + IMAGE_SCN_ALIGN_256BYTES = $00900000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_256BYTES} + IMAGE_SCN_ALIGN_512BYTES = $00A00000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_512BYTES} + IMAGE_SCN_ALIGN_1024BYTES = $00B00000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_1024BYTES} + IMAGE_SCN_ALIGN_2048BYTES = $00C00000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_2048BYTES} + IMAGE_SCN_ALIGN_4096BYTES = $00D00000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_4096BYTES} + IMAGE_SCN_ALIGN_8192BYTES = $00E00000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_8192BYTES} + +// Unused 0x00F00000 + + IMAGE_SCN_ALIGN_MASK = $00F00000; + {$EXTERNALSYM IMAGE_SCN_ALIGN_MASK} + + IMAGE_SCN_LNK_NRELOC_OVFL = $01000000; // Section contains extended relocations. + {$EXTERNALSYM IMAGE_SCN_LNK_NRELOC_OVFL} + IMAGE_SCN_MEM_DISCARDABLE = $02000000; // Section can be discarded. + {$EXTERNALSYM IMAGE_SCN_MEM_DISCARDABLE} + IMAGE_SCN_MEM_NOT_CACHED = $04000000; // Section is not cachable. + {$EXTERNALSYM IMAGE_SCN_MEM_NOT_CACHED} + IMAGE_SCN_MEM_NOT_PAGED = $08000000; // Section is not pageable. + {$EXTERNALSYM IMAGE_SCN_MEM_NOT_PAGED} + IMAGE_SCN_MEM_SHARED = $10000000; // Section is shareable. + {$EXTERNALSYM IMAGE_SCN_MEM_SHARED} + IMAGE_SCN_MEM_EXECUTE = $20000000; // Section is executable. + {$EXTERNALSYM IMAGE_SCN_MEM_EXECUTE} + IMAGE_SCN_MEM_READ = $40000000; // Section is readable. + {$EXTERNALSYM IMAGE_SCN_MEM_READ} + IMAGE_SCN_MEM_WRITE = DWORD($80000000); // Section is writeable. + {$EXTERNALSYM IMAGE_SCN_MEM_WRITE} + +// +// TLS Chaacteristic Flags +// + + IMAGE_SCN_SCALE_INDEX = $00000001; // Tls index is scaled + {$EXTERNALSYM IMAGE_SCN_SCALE_INDEX} + +// #include "pshpack2.h" // Symbols, relocs, and linenumbers are 2 byte packed + +// +// Symbol format. +// + +type + TImageSymbolN = record + case Integer of + 0: ( + ShortName: array [0..7] of BYTE); + 1: ( + Short: DWORD; // if 0, use LongName + Long: DWORD); // offset into string table + 2: ( + LongName: array [0..1] of DWORD); + end; + + PIMAGE_SYMBOL = ^IMAGE_SYMBOL; + {$EXTERNALSYM PIMAGE_SYMBOL} + _IMAGE_SYMBOL = record + N: TImageSymbolN; + Value: DWORD; + SectionNumber: SHORT; + Type_: WORD; + StorageClass: BYTE; + NumberOfAuxSymbols: BYTE; + end; + {$EXTERNALSYM _IMAGE_SYMBOL} + IMAGE_SYMBOL = _IMAGE_SYMBOL; + {$EXTERNALSYM IMAGE_SYMBOL} + TImageSymbol = IMAGE_SYMBOL; + PImageSymbol = PIMAGE_SYMBOL; + +const + IMAGE_SIZEOF_SYMBOL = 18; + {$EXTERNALSYM IMAGE_SIZEOF_SYMBOL} + +// +// Section values. +// +// Symbols have a section number of the section in which they are +// defined. Otherwise, section numbers have the following meanings: +// + + IMAGE_SYM_UNDEFINED = SHORT(0); // Symbol is undefined or is common. + {$EXTERNALSYM IMAGE_SYM_UNDEFINED} + IMAGE_SYM_ABSOLUTE = SHORT(-1); // Symbol is an absolute value. + {$EXTERNALSYM IMAGE_SYM_ABSOLUTE} + IMAGE_SYM_DEBUG = SHORT(-2); // Symbol is a special debug item. + {$EXTERNALSYM IMAGE_SYM_DEBUG} + IMAGE_SYM_SECTION_MAX = SHORT($FEFF ); // Values 0xFF00-0xFFFF are special + {$EXTERNALSYM IMAGE_SYM_SECTION_MAX} + +// +// Type (fundamental) values. +// + + IMAGE_SYM_TYPE_NULL = $0000; // no type. + {$EXTERNALSYM IMAGE_SYM_TYPE_NULL} + IMAGE_SYM_TYPE_VOID = $0001; + {$EXTERNALSYM IMAGE_SYM_TYPE_VOID} + IMAGE_SYM_TYPE_CHAR = $0002; // type character. + {$EXTERNALSYM IMAGE_SYM_TYPE_CHAR} + IMAGE_SYM_TYPE_SHORT = $0003; // type short integer. + {$EXTERNALSYM IMAGE_SYM_TYPE_SHORT} + IMAGE_SYM_TYPE_INT = $0004; + {$EXTERNALSYM IMAGE_SYM_TYPE_INT} + IMAGE_SYM_TYPE_LONG = $0005; + {$EXTERNALSYM IMAGE_SYM_TYPE_LONG} + IMAGE_SYM_TYPE_FLOAT = $0006; + {$EXTERNALSYM IMAGE_SYM_TYPE_FLOAT} + IMAGE_SYM_TYPE_DOUBLE = $0007; + {$EXTERNALSYM IMAGE_SYM_TYPE_DOUBLE} + IMAGE_SYM_TYPE_STRUCT = $0008; + {$EXTERNALSYM IMAGE_SYM_TYPE_STRUCT} + IMAGE_SYM_TYPE_UNION = $0009; + {$EXTERNALSYM IMAGE_SYM_TYPE_UNION} + IMAGE_SYM_TYPE_ENUM = $000A; // enumeration. + {$EXTERNALSYM IMAGE_SYM_TYPE_ENUM} + IMAGE_SYM_TYPE_MOE = $000B; // member of enumeration. + {$EXTERNALSYM IMAGE_SYM_TYPE_MOE} + IMAGE_SYM_TYPE_BYTE = $000C; + {$EXTERNALSYM IMAGE_SYM_TYPE_BYTE} + IMAGE_SYM_TYPE_WORD = $000D; + {$EXTERNALSYM IMAGE_SYM_TYPE_WORD} + IMAGE_SYM_TYPE_UINT = $000E; + {$EXTERNALSYM IMAGE_SYM_TYPE_UINT} + IMAGE_SYM_TYPE_DWORD = $000F; + {$EXTERNALSYM IMAGE_SYM_TYPE_DWORD} + IMAGE_SYM_TYPE_PCODE = $8000; + {$EXTERNALSYM IMAGE_SYM_TYPE_PCODE} + +// +// Type (derived) values. +// + + IMAGE_SYM_DTYPE_NULL = 0; // no derived type. + {$EXTERNALSYM IMAGE_SYM_DTYPE_NULL} + IMAGE_SYM_DTYPE_POINTER = 1; // pointer. + {$EXTERNALSYM IMAGE_SYM_DTYPE_POINTER} + IMAGE_SYM_DTYPE_FUNCTION = 2; // function. + {$EXTERNALSYM IMAGE_SYM_DTYPE_FUNCTION} + IMAGE_SYM_DTYPE_ARRAY = 3; // array. + {$EXTERNALSYM IMAGE_SYM_DTYPE_ARRAY} + +// +// Storage classes. +// + + IMAGE_SYM_CLASS_END_OF_FUNCTION = BYTE(-1); + {$EXTERNALSYM IMAGE_SYM_CLASS_END_OF_FUNCTION} + IMAGE_SYM_CLASS_NULL = $0000; + {$EXTERNALSYM IMAGE_SYM_CLASS_NULL} + IMAGE_SYM_CLASS_AUTOMATIC = $0001; + {$EXTERNALSYM IMAGE_SYM_CLASS_AUTOMATIC} + IMAGE_SYM_CLASS_EXTERNAL = $0002; + {$EXTERNALSYM IMAGE_SYM_CLASS_EXTERNAL} + IMAGE_SYM_CLASS_STATIC = $0003; + {$EXTERNALSYM IMAGE_SYM_CLASS_STATIC} + IMAGE_SYM_CLASS_REGISTER = $0004; + {$EXTERNALSYM IMAGE_SYM_CLASS_REGISTER} + IMAGE_SYM_CLASS_EXTERNAL_DEF = $0005; + {$EXTERNALSYM IMAGE_SYM_CLASS_EXTERNAL_DEF} + IMAGE_SYM_CLASS_LABEL = $0006; + {$EXTERNALSYM IMAGE_SYM_CLASS_LABEL} + IMAGE_SYM_CLASS_UNDEFINED_LABEL = $0007; + {$EXTERNALSYM IMAGE_SYM_CLASS_UNDEFINED_LABEL} + IMAGE_SYM_CLASS_MEMBER_OF_STRUCT = $0008; + {$EXTERNALSYM IMAGE_SYM_CLASS_MEMBER_OF_STRUCT} + IMAGE_SYM_CLASS_ARGUMENT = $0009; + {$EXTERNALSYM IMAGE_SYM_CLASS_ARGUMENT} + IMAGE_SYM_CLASS_STRUCT_TAG = $000A; + {$EXTERNALSYM IMAGE_SYM_CLASS_STRUCT_TAG} + IMAGE_SYM_CLASS_MEMBER_OF_UNION = $000B; + {$EXTERNALSYM IMAGE_SYM_CLASS_MEMBER_OF_UNION} + IMAGE_SYM_CLASS_UNION_TAG = $000C; + {$EXTERNALSYM IMAGE_SYM_CLASS_UNION_TAG} + IMAGE_SYM_CLASS_TYPE_DEFINITION = $000D; + {$EXTERNALSYM IMAGE_SYM_CLASS_TYPE_DEFINITION} + IMAGE_SYM_CLASS_UNDEFINED_STATIC = $000E; + {$EXTERNALSYM IMAGE_SYM_CLASS_UNDEFINED_STATIC} + IMAGE_SYM_CLASS_ENUM_TAG = $000F; + {$EXTERNALSYM IMAGE_SYM_CLASS_ENUM_TAG} + IMAGE_SYM_CLASS_MEMBER_OF_ENUM = $0010; + {$EXTERNALSYM IMAGE_SYM_CLASS_MEMBER_OF_ENUM} + IMAGE_SYM_CLASS_REGISTER_PARAM = $0011; + {$EXTERNALSYM IMAGE_SYM_CLASS_REGISTER_PARAM} + IMAGE_SYM_CLASS_BIT_FIELD = $0012; + {$EXTERNALSYM IMAGE_SYM_CLASS_BIT_FIELD} + + IMAGE_SYM_CLASS_FAR_EXTERNAL = $0044; + {$EXTERNALSYM IMAGE_SYM_CLASS_FAR_EXTERNAL} + + IMAGE_SYM_CLASS_BLOCK = $0064; + {$EXTERNALSYM IMAGE_SYM_CLASS_BLOCK} + IMAGE_SYM_CLASS_FUNCTION = $0065; + {$EXTERNALSYM IMAGE_SYM_CLASS_FUNCTION} + IMAGE_SYM_CLASS_END_OF_STRUCT = $0066; + {$EXTERNALSYM IMAGE_SYM_CLASS_END_OF_STRUCT} + IMAGE_SYM_CLASS_FILE = $0067; + {$EXTERNALSYM IMAGE_SYM_CLASS_FILE} + +// new + + IMAGE_SYM_CLASS_SECTION = $0068; + {$EXTERNALSYM IMAGE_SYM_CLASS_SECTION} + IMAGE_SYM_CLASS_WEAK_EXTERNAL = $0069; + {$EXTERNALSYM IMAGE_SYM_CLASS_WEAK_EXTERNAL} + + IMAGE_SYM_CLASS_CLR_TOKEN = $006B; + {$EXTERNALSYM IMAGE_SYM_CLASS_CLR_TOKEN} + +// type packing constants + + N_BTMASK = $000F; + {$EXTERNALSYM N_BTMASK} + N_TMASK = $0030; + {$EXTERNALSYM N_TMASK} + N_TMASK1 = $00C0; + {$EXTERNALSYM N_TMASK1} + N_TMASK2 = $00F0; + {$EXTERNALSYM N_TMASK2} + N_BTSHFT = 4; + {$EXTERNALSYM N_BTSHFT} + N_TSHIFT = 2; + {$EXTERNALSYM N_TSHIFT} + +// MACROS + +// Basic Type of x + +function BTYPE(x: DWORD): DWORD; +{$EXTERNALSYM BTYPE} + +// Is x a pointer? + +function ISPTR(x: DWORD): Boolean; +{$EXTERNALSYM ISPTR} + +// Is x a function? + +function ISFCN(x: DWORD): Boolean; +{$EXTERNALSYM ISFCN} + +// Is x an array? + +function ISARY(x: DWORD): Boolean; +{$EXTERNALSYM ISARY} + +// Is x a structure, union, or enumeration TAG? + +function ISTAG(x: DWORD): Boolean; +{$EXTERNALSYM ISTAG} + +// +// Auxiliary entry format. +// + +type + TImgAuzSymSymMisc = record + case Integer of + 0: ( + Linenumber: WORD; // declaration line number + Size: WORD); // size of struct, union, or enum + 1: ( + TotalSize: DWORD); + end; + + TImgAuzSymSymFcnAry = record + case Integer of + 0: ( // if ISFCN, tag, or .bb + PointerToLinenumber: DWORD; + PointerToNextFunction: DWORD); + 1: ( // if ISARY, up to 4 dimen. + Dimension: array [0..3] of WORD); + end; + + TImgAuxSymSym = record + TagIndex: DWORD; // struct, union, or enum tag index + Misc: TImgAuzSymSymMisc; + FcnAry: TImgAuzSymSymFcnAry; + TvIndex: WORD; // tv index + end; + + TImgAuxSymFile = record + Name: array [0..IMAGE_SIZEOF_SYMBOL - 1] of BYTE; + end; + + TImgAuxSymSection = record + Length: DWORD; // section length + NumberOfRelocations: WORD; // number of relocation entries + NumberOfLinenumbers: WORD; // number of line numbers + CheckSum: DWORD; // checksum for communal + Number: SHORT; // section number to associate with + Selection: BYTE; // communal selection type + end; + + PIMAGE_AUX_SYMBOL = ^IMAGE_AUX_SYMBOL; + {$EXTERNALSYM PIMAGE_AUX_SYMBOL} + _IMAGE_AUX_SYMBOL = record + case Integer of + 0: (Sym: TImgAuxSymSym); + 1: (File_: TImgAuxSymFile); + 2: (Section: TImgAuxSymSection); + end; + {$EXTERNALSYM _IMAGE_AUX_SYMBOL} + IMAGE_AUX_SYMBOL = _IMAGE_AUX_SYMBOL; + {$EXTERNALSYM IMAGE_AUX_SYMBOL} + TImageAuxSymbol = IMAGE_AUX_SYMBOL; + PImageAuxSymbol = PIMAGE_AUX_SYMBOL; + +const + IMAGE_SIZEOF_AUX_SYMBOL = 18; + {$EXTERNALSYM IMAGE_SIZEOF_AUX_SYMBOL} + + IMAGE_AUX_SYMBOL_TYPE_TOKEN_DEF = 1; + {$EXTERNALSYM IMAGE_AUX_SYMBOL_TYPE_TOKEN_DEF} + +type + IMAGE_AUX_SYMBOL_TYPE = DWORD; + {$EXTERNALSYM IMAGE_AUX_SYMBOL_TYPE} + TImageAuxSymbolType = IMAGE_AUX_SYMBOL_TYPE; + + IMAGE_AUX_SYMBOL_TOKEN_DEF = packed record + bAuxType: BYTE; // IMAGE_AUX_SYMBOL_TYPE + bReserved: BYTE; // Must be 0 + SymbolTableIndex: DWORD; + rgbReserved: array [0..11] of BYTE; // Must be 0 + end; + {$EXTERNALSYM IMAGE_AUX_SYMBOL_TOKEN_DEF} + PIMAGE_AUX_SYMBOL_TOKEN_DEF = ^IMAGE_AUX_SYMBOL_TOKEN_DEF; + {$EXTERNALSYM PIMAGE_AUX_SYMBOL_TOKEN_DEF} + TImageAuxSymbolTokenDef = IMAGE_AUX_SYMBOL_TOKEN_DEF; + PImageAuxSymbolTokenDef = PIMAGE_AUX_SYMBOL_TOKEN_DEF; + +// +// Communal selection types. +// + +const + IMAGE_COMDAT_SELECT_NODUPLICATES = 1; + {$EXTERNALSYM IMAGE_COMDAT_SELECT_NODUPLICATES} + IMAGE_COMDAT_SELECT_ANY = 2; + {$EXTERNALSYM IMAGE_COMDAT_SELECT_ANY} + IMAGE_COMDAT_SELECT_SAME_SIZE = 3; + {$EXTERNALSYM IMAGE_COMDAT_SELECT_SAME_SIZE} + IMAGE_COMDAT_SELECT_EXACT_MATCH = 4; + {$EXTERNALSYM IMAGE_COMDAT_SELECT_EXACT_MATCH} + IMAGE_COMDAT_SELECT_ASSOCIATIVE = 5; + {$EXTERNALSYM IMAGE_COMDAT_SELECT_ASSOCIATIVE} + IMAGE_COMDAT_SELECT_LARGEST = 6; + {$EXTERNALSYM IMAGE_COMDAT_SELECT_LARGEST} + IMAGE_COMDAT_SELECT_NEWEST = 7; + {$EXTERNALSYM IMAGE_COMDAT_SELECT_NEWEST} + + IMAGE_WEAK_EXTERN_SEARCH_NOLIBRARY = 1; + {$EXTERNALSYM IMAGE_WEAK_EXTERN_SEARCH_NOLIBRARY} + IMAGE_WEAK_EXTERN_SEARCH_LIBRARY = 2; + {$EXTERNALSYM IMAGE_WEAK_EXTERN_SEARCH_LIBRARY} + IMAGE_WEAK_EXTERN_SEARCH_ALIAS = 3; + {$EXTERNALSYM IMAGE_WEAK_EXTERN_SEARCH_ALIAS} + +// +// Relocation format. +// + +type + TImgRelocUnion = record + case Integer of + 0: (VirtualAddress: DWORD); + 1: (RelocCount: DWORD); // Set to the real count when IMAGE_SCN_LNK_NRELOC_OVFL is set + end; + + PIMAGE_RELOCATION = ^IMAGE_RELOCATION; + {$EXTERNALSYM PIMAGE_RELOCATION} + _IMAGE_RELOCATION = record + Union: TImgRelocUnion; + SymbolTableIndex: DWORD; + Type_: WORD; + end; + {$EXTERNALSYM _IMAGE_RELOCATION} + IMAGE_RELOCATION = _IMAGE_RELOCATION; + {$EXTERNALSYM IMAGE_RELOCATION} + TImageRelocation = IMAGE_RELOCATION; + PImageRelocation = PIMAGE_RELOCATION; + +const + IMAGE_SIZEOF_RELOCATION = 10; + {$EXTERNALSYM IMAGE_SIZEOF_RELOCATION} + +// +// I386 relocation types. +// + + IMAGE_REL_I386_ABSOLUTE = $0000; // Reference is absolute, no relocation is necessary + {$EXTERNALSYM IMAGE_REL_I386_ABSOLUTE} + IMAGE_REL_I386_DIR16 = $0001; // Direct 16-bit reference to the symbols virtual address + {$EXTERNALSYM IMAGE_REL_I386_DIR16} + IMAGE_REL_I386_REL16 = $0002; // PC-relative 16-bit reference to the symbols virtual address + {$EXTERNALSYM IMAGE_REL_I386_REL16} + IMAGE_REL_I386_DIR32 = $0006; // Direct 32-bit reference to the symbols virtual address + {$EXTERNALSYM IMAGE_REL_I386_DIR32} + IMAGE_REL_I386_DIR32NB = $0007; // Direct 32-bit reference to the symbols virtual address, base not included + {$EXTERNALSYM IMAGE_REL_I386_DIR32NB} + IMAGE_REL_I386_SEG12 = $0009; // Direct 16-bit reference to the segment-selector bits of a 32-bit virtual address + {$EXTERNALSYM IMAGE_REL_I386_SEG12} + IMAGE_REL_I386_SECTION = $000A; + {$EXTERNALSYM IMAGE_REL_I386_SECTION} + IMAGE_REL_I386_SECREL = $000B; + {$EXTERNALSYM IMAGE_REL_I386_SECREL} + IMAGE_REL_MIPS_SECRELLO = $000C; // Low 16-bit section relative referemce (used for >32k TLS) + {$EXTERNALSYM IMAGE_REL_MIPS_SECRELLO} + IMAGE_REL_MIPS_SECRELHI = $000D; // High 16-bit section relative reference (used for >32k TLS) + {$EXTERNALSYM IMAGE_REL_MIPS_SECRELHI} + IMAGE_REL_I386_REL32 = $0014; // PC-relative 32-bit reference to the symbols virtual address + {$EXTERNALSYM IMAGE_REL_I386_REL32} + +// +// MIPS relocation types. +// + + IMAGE_REL_MIPS_ABSOLUTE = $0000; // Reference is absolute, no relocation is necessary + {$EXTERNALSYM IMAGE_REL_MIPS_ABSOLUTE} + IMAGE_REL_MIPS_REFHALF = $0001; + {$EXTERNALSYM IMAGE_REL_MIPS_REFHALF} + IMAGE_REL_MIPS_REFWORD = $0002; + {$EXTERNALSYM IMAGE_REL_MIPS_REFWORD} + IMAGE_REL_MIPS_JMPADDR = $0003; + {$EXTERNALSYM IMAGE_REL_MIPS_JMPADDR} + IMAGE_REL_MIPS_REFHI = $0004; + {$EXTERNALSYM IMAGE_REL_MIPS_REFHI} + IMAGE_REL_MIPS_REFLO = $0005; + {$EXTERNALSYM IMAGE_REL_MIPS_REFLO} + IMAGE_REL_MIPS_GPREL = $0006; + {$EXTERNALSYM IMAGE_REL_MIPS_GPREL} + IMAGE_REL_MIPS_LITERAL = $0007; + {$EXTERNALSYM IMAGE_REL_MIPS_LITERAL} + IMAGE_REL_MIPS_SECTION = $000A; + {$EXTERNALSYM IMAGE_REL_MIPS_SECTION} + IMAGE_REL_MIPS_SECREL = $000B; + {$EXTERNALSYM IMAGE_REL_MIPS_SECREL} + //IMAGE_REL_MIPS_SECRELLO = $000C; // Low 16-bit section relative referemce (used for >32k TLS) + //{$EXTERNALSYM IMAGE_REL_MIPS_SECRELLO} + //IMAGE_REL_MIPS_SECRELHI = $000D; // High 16-bit section relative reference (used for >32k TLS) + //{$EXTERNALSYM IMAGE_REL_MIPS_SECRELHI} + IMAGE_REL_MIPS_TOKEN = $000E; // clr token + {$EXTERNALSYM IMAGE_REL_MIPS_TOKEN} + IMAGE_REL_MIPS_JMPADDR16 = $0010; + {$EXTERNALSYM IMAGE_REL_MIPS_JMPADDR16} + IMAGE_REL_MIPS_REFWORDNB = $0022; + {$EXTERNALSYM IMAGE_REL_MIPS_REFWORDNB} + IMAGE_REL_MIPS_PAIR = $0025; + {$EXTERNALSYM IMAGE_REL_MIPS_PAIR} + +// +// Alpha Relocation types. +// + + IMAGE_REL_ALPHA_ABSOLUTE = $0000; + {$EXTERNALSYM IMAGE_REL_ALPHA_ABSOLUTE} + IMAGE_REL_ALPHA_REFLONG = $0001; + {$EXTERNALSYM IMAGE_REL_ALPHA_REFLONG} + IMAGE_REL_ALPHA_REFQUAD = $0002; + {$EXTERNALSYM IMAGE_REL_ALPHA_REFQUAD} + IMAGE_REL_ALPHA_GPREL32 = $0003; + {$EXTERNALSYM IMAGE_REL_ALPHA_GPREL32} + IMAGE_REL_ALPHA_LITERAL = $0004; + {$EXTERNALSYM IMAGE_REL_ALPHA_LITERAL} + IMAGE_REL_ALPHA_LITUSE = $0005; + {$EXTERNALSYM IMAGE_REL_ALPHA_LITUSE} + IMAGE_REL_ALPHA_GPDISP = $0006; + {$EXTERNALSYM IMAGE_REL_ALPHA_GPDISP} + IMAGE_REL_ALPHA_BRADDR = $0007; + {$EXTERNALSYM IMAGE_REL_ALPHA_BRADDR} + IMAGE_REL_ALPHA_HINT = $0008; + {$EXTERNALSYM IMAGE_REL_ALPHA_HINT} + IMAGE_REL_ALPHA_INLINE_REFLONG = $0009; + {$EXTERNALSYM IMAGE_REL_ALPHA_INLINE_REFLONG} + IMAGE_REL_ALPHA_REFHI = $000A; + {$EXTERNALSYM IMAGE_REL_ALPHA_REFHI} + IMAGE_REL_ALPHA_REFLO = $000B; + {$EXTERNALSYM IMAGE_REL_ALPHA_REFLO} + IMAGE_REL_ALPHA_PAIR = $000C; + {$EXTERNALSYM IMAGE_REL_ALPHA_PAIR} + IMAGE_REL_ALPHA_MATCH = $000D; + {$EXTERNALSYM IMAGE_REL_ALPHA_MATCH} + IMAGE_REL_ALPHA_SECTION = $000E; + {$EXTERNALSYM IMAGE_REL_ALPHA_SECTION} + IMAGE_REL_ALPHA_SECREL = $000F; + {$EXTERNALSYM IMAGE_REL_ALPHA_SECREL} + IMAGE_REL_ALPHA_REFLONGNB = $0010; + {$EXTERNALSYM IMAGE_REL_ALPHA_REFLONGNB} + IMAGE_REL_ALPHA_SECRELLO = $0011; // Low 16-bit section relative reference + {$EXTERNALSYM IMAGE_REL_ALPHA_SECRELLO} + IMAGE_REL_ALPHA_SECRELHI = $0012; // High 16-bit section relative reference + {$EXTERNALSYM IMAGE_REL_ALPHA_SECRELHI} + IMAGE_REL_ALPHA_REFQ3 = $0013; // High 16 bits of 48 bit reference + {$EXTERNALSYM IMAGE_REL_ALPHA_REFQ3} + IMAGE_REL_ALPHA_REFQ2 = $0014; // Middle 16 bits of 48 bit reference + {$EXTERNALSYM IMAGE_REL_ALPHA_REFQ2} + IMAGE_REL_ALPHA_REFQ1 = $0015; // Low 16 bits of 48 bit reference + {$EXTERNALSYM IMAGE_REL_ALPHA_REFQ1} + IMAGE_REL_ALPHA_GPRELLO = $0016; // Low 16-bit GP relative reference + {$EXTERNALSYM IMAGE_REL_ALPHA_GPRELLO} + IMAGE_REL_ALPHA_GPRELHI = $0017; // High 16-bit GP relative reference + {$EXTERNALSYM IMAGE_REL_ALPHA_GPRELHI} + +// +// IBM PowerPC relocation types. +// + + IMAGE_REL_PPC_ABSOLUTE = $0000; // NOP + {$EXTERNALSYM IMAGE_REL_PPC_ABSOLUTE} + IMAGE_REL_PPC_ADDR64 = $0001; // 64-bit address + {$EXTERNALSYM IMAGE_REL_PPC_ADDR64} + IMAGE_REL_PPC_ADDR32 = $0002; // 32-bit address + {$EXTERNALSYM IMAGE_REL_PPC_ADDR32} + IMAGE_REL_PPC_ADDR24 = $0003; // 26-bit address, shifted left 2 (branch absolute) + {$EXTERNALSYM IMAGE_REL_PPC_ADDR24} + IMAGE_REL_PPC_ADDR16 = $0004; // 16-bit address + {$EXTERNALSYM IMAGE_REL_PPC_ADDR16} + IMAGE_REL_PPC_ADDR14 = $0005; // 16-bit address, shifted left 2 (load doubleword) + {$EXTERNALSYM IMAGE_REL_PPC_ADDR14} + IMAGE_REL_PPC_REL24 = $0006; // 26-bit PC-relative offset, shifted left 2 (branch relative) + {$EXTERNALSYM IMAGE_REL_PPC_REL24} + IMAGE_REL_PPC_REL14 = $0007; // 16-bit PC-relative offset, shifted left 2 (br cond relative) + {$EXTERNALSYM IMAGE_REL_PPC_REL14} + IMAGE_REL_PPC_TOCREL16 = $0008; // 16-bit offset from TOC base + {$EXTERNALSYM IMAGE_REL_PPC_TOCREL16} + IMAGE_REL_PPC_TOCREL14 = $0009; // 16-bit offset from TOC base, shifted left 2 (load doubleword) + {$EXTERNALSYM IMAGE_REL_PPC_TOCREL14} + + IMAGE_REL_PPC_ADDR32NB = $000A; // 32-bit addr w/o image base + {$EXTERNALSYM IMAGE_REL_PPC_ADDR32NB} + IMAGE_REL_PPC_SECREL = $000B; // va of containing section (as in an image sectionhdr) + {$EXTERNALSYM IMAGE_REL_PPC_SECREL} + IMAGE_REL_PPC_SECTION = $000C; // sectionheader number + {$EXTERNALSYM IMAGE_REL_PPC_SECTION} + IMAGE_REL_PPC_IFGLUE = $000D; // substitute TOC restore instruction iff symbol is glue code + {$EXTERNALSYM IMAGE_REL_PPC_IFGLUE} + IMAGE_REL_PPC_IMGLUE = $000E; // symbol is glue code; virtual address is TOC restore instruction + {$EXTERNALSYM IMAGE_REL_PPC_IMGLUE} + IMAGE_REL_PPC_SECREL16 = $000F; // va of containing section (limited to 16 bits) + {$EXTERNALSYM IMAGE_REL_PPC_SECREL16} + IMAGE_REL_PPC_REFHI = $0010; + {$EXTERNALSYM IMAGE_REL_PPC_REFHI} + IMAGE_REL_PPC_REFLO = $0011; + {$EXTERNALSYM IMAGE_REL_PPC_REFLO} + IMAGE_REL_PPC_PAIR = $0012; + {$EXTERNALSYM IMAGE_REL_PPC_PAIR} + IMAGE_REL_PPC_SECRELLO = $0013; // Low 16-bit section relative reference (used for >32k TLS) + {$EXTERNALSYM IMAGE_REL_PPC_SECRELLO} + IMAGE_REL_PPC_SECRELHI = $0014; // High 16-bit section relative reference (used for >32k TLS) + {$EXTERNALSYM IMAGE_REL_PPC_SECRELHI} + IMAGE_REL_PPC_GPREL = $0015; + {$EXTERNALSYM IMAGE_REL_PPC_GPREL} + IMAGE_REL_PPC_TOKEN = $0016; // clr token + {$EXTERNALSYM IMAGE_REL_PPC_TOKEN} + + IMAGE_REL_PPC_TYPEMASK = $00FF; // mask to isolate above values in IMAGE_RELOCATION.Type + {$EXTERNALSYM IMAGE_REL_PPC_TYPEMASK} + +// Flag bits in IMAGE_RELOCATION.TYPE + + IMAGE_REL_PPC_NEG = $0100; // subtract reloc value rather than adding it + {$EXTERNALSYM IMAGE_REL_PPC_NEG} + IMAGE_REL_PPC_BRTAKEN = $0200; // fix branch prediction bit to predict branch taken + {$EXTERNALSYM IMAGE_REL_PPC_BRTAKEN} + IMAGE_REL_PPC_BRNTAKEN = $0400; // fix branch prediction bit to predict branch not taken + {$EXTERNALSYM IMAGE_REL_PPC_BRNTAKEN} + IMAGE_REL_PPC_TOCDEFN = $0800; // toc slot defined in file (or, data in toc) + {$EXTERNALSYM IMAGE_REL_PPC_TOCDEFN} + +// +// Hitachi SH3 relocation types. +// + + IMAGE_REL_SH3_ABSOLUTE = $0000; // No relocation + {$EXTERNALSYM IMAGE_REL_SH3_ABSOLUTE} + IMAGE_REL_SH3_DIRECT16 = $0001; // 16 bit direct + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT16} + IMAGE_REL_SH3_DIRECT32 = $0002; // 32 bit direct + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT32} + IMAGE_REL_SH3_DIRECT8 = $0003; // 8 bit direct, -128..255 + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT8} + IMAGE_REL_SH3_DIRECT8_WORD = $0004; // 8 bit direct .W (0 ext.) + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT8_WORD} + IMAGE_REL_SH3_DIRECT8_LONG = $0005; // 8 bit direct .L (0 ext.) + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT8_LONG} + IMAGE_REL_SH3_DIRECT4 = $0006; // 4 bit direct (0 ext.) + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT4} + IMAGE_REL_SH3_DIRECT4_WORD = $0007; // 4 bit direct .W (0 ext.) + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT4_WORD} + IMAGE_REL_SH3_DIRECT4_LONG = $0008; // 4 bit direct .L (0 ext.) + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT4_LONG} + IMAGE_REL_SH3_PCREL8_WORD = $0009; // 8 bit PC relative .W + {$EXTERNALSYM IMAGE_REL_SH3_PCREL8_WORD} + IMAGE_REL_SH3_PCREL8_LONG = $000A; // 8 bit PC relative .L + {$EXTERNALSYM IMAGE_REL_SH3_PCREL8_LONG} + IMAGE_REL_SH3_PCREL12_WORD = $000B; // 12 LSB PC relative .W + {$EXTERNALSYM IMAGE_REL_SH3_PCREL12_WORD} + IMAGE_REL_SH3_STARTOF_SECTION = $000C; // Start of EXE section + {$EXTERNALSYM IMAGE_REL_SH3_STARTOF_SECTION} + IMAGE_REL_SH3_SIZEOF_SECTION = $000D; // Size of EXE section + {$EXTERNALSYM IMAGE_REL_SH3_SIZEOF_SECTION} + IMAGE_REL_SH3_SECTION = $000E; // Section table index + {$EXTERNALSYM IMAGE_REL_SH3_SECTION} + IMAGE_REL_SH3_SECREL = $000F; // Offset within section + {$EXTERNALSYM IMAGE_REL_SH3_SECREL} + IMAGE_REL_SH3_DIRECT32_NB = $0010; // 32 bit direct not based + {$EXTERNALSYM IMAGE_REL_SH3_DIRECT32_NB} + IMAGE_REL_SH3_GPREL4_LONG = $0011; // GP-relative addressing + {$EXTERNALSYM IMAGE_REL_SH3_GPREL4_LONG} + IMAGE_REL_SH3_TOKEN = $0012; // clr token + {$EXTERNALSYM IMAGE_REL_SH3_TOKEN} + + IMAGE_REL_ARM_ABSOLUTE = $0000; // No relocation required + {$EXTERNALSYM IMAGE_REL_ARM_ABSOLUTE} + IMAGE_REL_ARM_ADDR32 = $0001; // 32 bit address + {$EXTERNALSYM IMAGE_REL_ARM_ADDR32} + IMAGE_REL_ARM_ADDR32NB = $0002; // 32 bit address w/o image base + {$EXTERNALSYM IMAGE_REL_ARM_ADDR32NB} + IMAGE_REL_ARM_BRANCH24 = $0003; // 24 bit offset << 2 & sign ext. + {$EXTERNALSYM IMAGE_REL_ARM_BRANCH24} + IMAGE_REL_ARM_BRANCH11 = $0004; // Thumb: 2 11 bit offsets + {$EXTERNALSYM IMAGE_REL_ARM_BRANCH11} + IMAGE_REL_ARM_TOKEN = $0005; // clr token + {$EXTERNALSYM IMAGE_REL_ARM_TOKEN} + IMAGE_REL_ARM_GPREL12 = $0006; // GP-relative addressing (ARM) + {$EXTERNALSYM IMAGE_REL_ARM_GPREL12} + IMAGE_REL_ARM_GPREL7 = $0007; // GP-relative addressing (Thumb) + {$EXTERNALSYM IMAGE_REL_ARM_GPREL7} + IMAGE_REL_ARM_BLX24 = $0008; + {$EXTERNALSYM IMAGE_REL_ARM_BLX24} + IMAGE_REL_ARM_BLX11 = $0009; + {$EXTERNALSYM IMAGE_REL_ARM_BLX11} + IMAGE_REL_ARM_SECTION = $000E; // Section table index + {$EXTERNALSYM IMAGE_REL_ARM_SECTION} + IMAGE_REL_ARM_SECREL = $000F; // Offset within section + {$EXTERNALSYM IMAGE_REL_ARM_SECREL} + + IMAGE_REL_AM_ABSOLUTE = $0000; + {$EXTERNALSYM IMAGE_REL_AM_ABSOLUTE} + IMAGE_REL_AM_ADDR32 = $0001; + {$EXTERNALSYM IMAGE_REL_AM_ADDR32} + IMAGE_REL_AM_ADDR32NB = $0002; + {$EXTERNALSYM IMAGE_REL_AM_ADDR32NB} + IMAGE_REL_AM_CALL32 = $0003; + {$EXTERNALSYM IMAGE_REL_AM_CALL32} + IMAGE_REL_AM_FUNCINFO = $0004; + {$EXTERNALSYM IMAGE_REL_AM_FUNCINFO} + IMAGE_REL_AM_REL32_1 = $0005; + {$EXTERNALSYM IMAGE_REL_AM_REL32_1} + IMAGE_REL_AM_REL32_2 = $0006; + {$EXTERNALSYM IMAGE_REL_AM_REL32_2} + IMAGE_REL_AM_SECREL = $0007; + {$EXTERNALSYM IMAGE_REL_AM_SECREL} + IMAGE_REL_AM_SECTION = $0008; + {$EXTERNALSYM IMAGE_REL_AM_SECTION} + IMAGE_REL_AM_TOKEN = $0009; + {$EXTERNALSYM IMAGE_REL_AM_TOKEN} + +// +// X86-64 relocations +// + + IMAGE_REL_AMD64_ABSOLUTE = $0000; // Reference is absolute, no relocation is necessary + {$EXTERNALSYM IMAGE_REL_AMD64_ABSOLUTE} + IMAGE_REL_AMD64_ADDR64 = $0001; // 64-bit address (VA). + {$EXTERNALSYM IMAGE_REL_AMD64_ADDR64} + IMAGE_REL_AMD64_ADDR32 = $0002; // 32-bit address (VA). + {$EXTERNALSYM IMAGE_REL_AMD64_ADDR32} + IMAGE_REL_AMD64_ADDR32NB = $0003; // 32-bit address w/o image base (RVA). + {$EXTERNALSYM IMAGE_REL_AMD64_ADDR32NB} + IMAGE_REL_AMD64_REL32 = $0004; // 32-bit relative address from byte following reloc + {$EXTERNALSYM IMAGE_REL_AMD64_REL32} + IMAGE_REL_AMD64_REL32_1 = $0005; // 32-bit relative address from byte distance 1 from reloc + {$EXTERNALSYM IMAGE_REL_AMD64_REL32_1} + IMAGE_REL_AMD64_REL32_2 = $0006; // 32-bit relative address from byte distance 2 from reloc + {$EXTERNALSYM IMAGE_REL_AMD64_REL32_2} + IMAGE_REL_AMD64_REL32_3 = $0007; // 32-bit relative address from byte distance 3 from reloc + {$EXTERNALSYM IMAGE_REL_AMD64_REL32_3} + IMAGE_REL_AMD64_REL32_4 = $0008; // 32-bit relative address from byte distance 4 from reloc + {$EXTERNALSYM IMAGE_REL_AMD64_REL32_4} + IMAGE_REL_AMD64_REL32_5 = $0009; // 32-bit relative address from byte distance 5 from reloc + {$EXTERNALSYM IMAGE_REL_AMD64_REL32_5} + IMAGE_REL_AMD64_SECTION = $000A; // Section index + {$EXTERNALSYM IMAGE_REL_AMD64_SECTION} + IMAGE_REL_AMD64_SECREL = $000B; // 32 bit offset from base of section containing target + {$EXTERNALSYM IMAGE_REL_AMD64_SECREL} + IMAGE_REL_AMD64_SECREL7 = $000C; // 7 bit unsigned offset from base of section containing target + {$EXTERNALSYM IMAGE_REL_AMD64_SECREL7} + IMAGE_REL_AMD64_TOKEN = $000D; // 32 bit metadata token + {$EXTERNALSYM IMAGE_REL_AMD64_TOKEN} + IMAGE_REL_AMD64_SREL32 = $000E; // 32 bit signed span-dependent value emitted into object + {$EXTERNALSYM IMAGE_REL_AMD64_SREL32} + IMAGE_REL_AMD64_PAIR = $000F; + {$EXTERNALSYM IMAGE_REL_AMD64_PAIR} + IMAGE_REL_AMD64_SSPAN32 = $0010; // 32 bit signed span-dependent value applied at link time + {$EXTERNALSYM IMAGE_REL_AMD64_SSPAN32} + +// +// IA64 relocation types. +// + + IMAGE_REL_IA64_ABSOLUTE = $0000; + {$EXTERNALSYM IMAGE_REL_IA64_ABSOLUTE} + IMAGE_REL_IA64_IMM14 = $0001; + {$EXTERNALSYM IMAGE_REL_IA64_IMM14} + IMAGE_REL_IA64_IMM22 = $0002; + {$EXTERNALSYM IMAGE_REL_IA64_IMM22} + IMAGE_REL_IA64_IMM64 = $0003; + {$EXTERNALSYM IMAGE_REL_IA64_IMM64} + IMAGE_REL_IA64_DIR32 = $0004; + {$EXTERNALSYM IMAGE_REL_IA64_DIR32} + IMAGE_REL_IA64_DIR64 = $0005; + {$EXTERNALSYM IMAGE_REL_IA64_DIR64} + IMAGE_REL_IA64_PCREL21B = $0006; + {$EXTERNALSYM IMAGE_REL_IA64_PCREL21B} + IMAGE_REL_IA64_PCREL21M = $0007; + {$EXTERNALSYM IMAGE_REL_IA64_PCREL21M} + IMAGE_REL_IA64_PCREL21F = $0008; + {$EXTERNALSYM IMAGE_REL_IA64_PCREL21F} + IMAGE_REL_IA64_GPREL22 = $0009; + {$EXTERNALSYM IMAGE_REL_IA64_GPREL22} + IMAGE_REL_IA64_LTOFF22 = $000A; + {$EXTERNALSYM IMAGE_REL_IA64_LTOFF22} + IMAGE_REL_IA64_SECTION = $000B; + {$EXTERNALSYM IMAGE_REL_IA64_SECTION} + IMAGE_REL_IA64_SECREL22 = $000C; + {$EXTERNALSYM IMAGE_REL_IA64_SECREL22} + IMAGE_REL_IA64_SECREL64I = $000D; + {$EXTERNALSYM IMAGE_REL_IA64_SECREL64I} + IMAGE_REL_IA64_SECREL32 = $000E; + {$EXTERNALSYM IMAGE_REL_IA64_SECREL32} + +// + + IMAGE_REL_IA64_DIR32NB = $0010; + {$EXTERNALSYM IMAGE_REL_IA64_DIR32NB} + IMAGE_REL_IA64_SREL14 = $0011; + {$EXTERNALSYM IMAGE_REL_IA64_SREL14} + IMAGE_REL_IA64_SREL22 = $0012; + {$EXTERNALSYM IMAGE_REL_IA64_SREL22} + IMAGE_REL_IA64_SREL32 = $0013; + {$EXTERNALSYM IMAGE_REL_IA64_SREL32} + IMAGE_REL_IA64_UREL32 = $0014; + {$EXTERNALSYM IMAGE_REL_IA64_UREL32} + IMAGE_REL_IA64_PCREL60X = $0015; // This is always a BRL and never converted + {$EXTERNALSYM IMAGE_REL_IA64_PCREL60X} + IMAGE_REL_IA64_PCREL60B = $0016; // If possible, convert to MBB bundle with NOP.B in slot 1 + {$EXTERNALSYM IMAGE_REL_IA64_PCREL60B} + IMAGE_REL_IA64_PCREL60F = $0017; // If possible, convert to MFB bundle with NOP.F in slot 1 + {$EXTERNALSYM IMAGE_REL_IA64_PCREL60F} + IMAGE_REL_IA64_PCREL60I = $0018; // If possible, convert to MIB bundle with NOP.I in slot 1 + {$EXTERNALSYM IMAGE_REL_IA64_PCREL60I} + IMAGE_REL_IA64_PCREL60M = $0019; // If possible, convert to MMB bundle with NOP.M in slot 1 + {$EXTERNALSYM IMAGE_REL_IA64_PCREL60M} + IMAGE_REL_IA64_IMMGPREL64 = $001A; + {$EXTERNALSYM IMAGE_REL_IA64_IMMGPREL64} + IMAGE_REL_IA64_TOKEN = $001B; // clr token + {$EXTERNALSYM IMAGE_REL_IA64_TOKEN} + IMAGE_REL_IA64_GPREL32 = $001C; + {$EXTERNALSYM IMAGE_REL_IA64_GPREL32} + IMAGE_REL_IA64_ADDEND = $001F; + {$EXTERNALSYM IMAGE_REL_IA64_ADDEND} + +// +// CEF relocation types. +// + + IMAGE_REL_CEF_ABSOLUTE = $0000; // Reference is absolute, no relocation is necessary + {$EXTERNALSYM IMAGE_REL_CEF_ABSOLUTE} + IMAGE_REL_CEF_ADDR32 = $0001; // 32-bit address (VA). + {$EXTERNALSYM IMAGE_REL_CEF_ADDR32} + IMAGE_REL_CEF_ADDR64 = $0002; // 64-bit address (VA). + {$EXTERNALSYM IMAGE_REL_CEF_ADDR64} + IMAGE_REL_CEF_ADDR32NB = $0003; // 32-bit address w/o image base (RVA). + {$EXTERNALSYM IMAGE_REL_CEF_ADDR32NB} + IMAGE_REL_CEF_SECTION = $0004; // Section index + {$EXTERNALSYM IMAGE_REL_CEF_SECTION} + IMAGE_REL_CEF_SECREL = $0005; // 32 bit offset from base of section containing target + {$EXTERNALSYM IMAGE_REL_CEF_SECREL} + IMAGE_REL_CEF_TOKEN = $0006; // 32 bit metadata token + {$EXTERNALSYM IMAGE_REL_CEF_TOKEN} + +// +// clr relocation types. +// + + IMAGE_REL_CEE_ABSOLUTE = $0000; // Reference is absolute, no relocation is necessary + {$EXTERNALSYM IMAGE_REL_CEE_ABSOLUTE} + IMAGE_REL_CEE_ADDR32 = $0001; // 32-bit address (VA). + {$EXTERNALSYM IMAGE_REL_CEE_ADDR32} + IMAGE_REL_CEE_ADDR64 = $0002; // 64-bit address (VA). + {$EXTERNALSYM IMAGE_REL_CEE_ADDR64} + IMAGE_REL_CEE_ADDR32NB = $0003; // 32-bit address w/o image base (RVA). + {$EXTERNALSYM IMAGE_REL_CEE_ADDR32NB} + IMAGE_REL_CEE_SECTION = $0004; // Section index + {$EXTERNALSYM IMAGE_REL_CEE_SECTION} + IMAGE_REL_CEE_SECREL = $0005; // 32 bit offset from base of section containing target + {$EXTERNALSYM IMAGE_REL_CEE_SECREL} + IMAGE_REL_CEE_TOKEN = $0006; // 32 bit metadata token + {$EXTERNALSYM IMAGE_REL_CEE_TOKEN} + + IMAGE_REL_M32R_ABSOLUTE = $0000; // No relocation required + {$EXTERNALSYM IMAGE_REL_M32R_ABSOLUTE} + IMAGE_REL_M32R_ADDR32 = $0001; // 32 bit address + {$EXTERNALSYM IMAGE_REL_M32R_ADDR32} + IMAGE_REL_M32R_ADDR32NB = $0002; // 32 bit address w/o image base + {$EXTERNALSYM IMAGE_REL_M32R_ADDR32NB} + IMAGE_REL_M32R_ADDR24 = $0003; // 24 bit address + {$EXTERNALSYM IMAGE_REL_M32R_ADDR24} + IMAGE_REL_M32R_GPREL16 = $0004; // GP relative addressing + {$EXTERNALSYM IMAGE_REL_M32R_GPREL16} + IMAGE_REL_M32R_PCREL24 = $0005; // 24 bit offset << 2 & sign ext. + {$EXTERNALSYM IMAGE_REL_M32R_PCREL24} + IMAGE_REL_M32R_PCREL16 = $0006; // 16 bit offset << 2 & sign ext. + {$EXTERNALSYM IMAGE_REL_M32R_PCREL16} + IMAGE_REL_M32R_PCREL8 = $0007; // 8 bit offset << 2 & sign ext. + {$EXTERNALSYM IMAGE_REL_M32R_PCREL8} + IMAGE_REL_M32R_REFHALF = $0008; // 16 MSBs + {$EXTERNALSYM IMAGE_REL_M32R_REFHALF} + IMAGE_REL_M32R_REFHI = $0009; // 16 MSBs; adj for LSB sign ext. + {$EXTERNALSYM IMAGE_REL_M32R_REFHI} + IMAGE_REL_M32R_REFLO = $000A; // 16 LSBs + {$EXTERNALSYM IMAGE_REL_M32R_REFLO} + IMAGE_REL_M32R_PAIR = $000B; // Link HI and LO + {$EXTERNALSYM IMAGE_REL_M32R_PAIR} + IMAGE_REL_M32R_SECTION = $000C; // Section table index + {$EXTERNALSYM IMAGE_REL_M32R_SECTION} + IMAGE_REL_M32R_SECREL32 = $000D; // 32 bit section relative reference + {$EXTERNALSYM IMAGE_REL_M32R_SECREL32} + IMAGE_REL_M32R_TOKEN = $000E; // clr token + {$EXTERNALSYM IMAGE_REL_M32R_TOKEN} + +// Please contact INTEL to get IA64-specific information + +(* TODO +#define EXT_IMM64(Value, Address, Size, InstPos, ValPos) + Value |= (((ULONGLONG)((*(Address) >> InstPos) & (((ULONGLONG)1 << Size) - 1))) << ValPos) // Intel-IA64-Filler + +#define INS_IMM64(Value, Address, Size, InstPos, ValPos) /* Intel-IA64-Filler */\ + *(PDWORD)Address = (*(PDWORD)Address & ~(((1 << Size) - 1) << InstPos)) | /* Intel-IA64-Filler */\ + ((DWORD)((((ULONGLONG)Value >> ValPos) & (((ULONGLONG)1 << Size) - 1))) << InstPos) // Intel-IA64-Filler +*) + +const + EMARCH_ENC_I17_IMM7B_INST_WORD_X = 3; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM7B_INST_WORD_X} + EMARCH_ENC_I17_IMM7B_SIZE_X = 7; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM7B_SIZE_X} + EMARCH_ENC_I17_IMM7B_INST_WORD_POS_X = 4; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM7B_INST_WORD_POS_X} + EMARCH_ENC_I17_IMM7B_VAL_POS_X = 0; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM7B_VAL_POS_X} + + EMARCH_ENC_I17_IMM9D_INST_WORD_X = 3; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM9D_INST_WORD_X} + EMARCH_ENC_I17_IMM9D_SIZE_X = 9; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM9D_SIZE_X} + EMARCH_ENC_I17_IMM9D_INST_WORD_POS_X = 18; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM9D_INST_WORD_POS_X} + EMARCH_ENC_I17_IMM9D_VAL_POS_X = 7; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM9D_VAL_POS_X} + + EMARCH_ENC_I17_IMM5C_INST_WORD_X = 3; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM5C_INST_WORD_X} + EMARCH_ENC_I17_IMM5C_SIZE_X = 5; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM5C_SIZE_X} + EMARCH_ENC_I17_IMM5C_INST_WORD_POS_X = 13; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM5C_INST_WORD_POS_X} + EMARCH_ENC_I17_IMM5C_VAL_POS_X = 16; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM5C_VAL_POS_X} + + EMARCH_ENC_I17_IC_INST_WORD_X = 3; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IC_INST_WORD_X} + EMARCH_ENC_I17_IC_SIZE_X = 1; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IC_SIZE_X} + EMARCH_ENC_I17_IC_INST_WORD_POS_X = 12; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IC_INST_WORD_POS_X} + EMARCH_ENC_I17_IC_VAL_POS_X = 21; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IC_VAL_POS_X} + + EMARCH_ENC_I17_IMM41a_INST_WORD_X = 1; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41a_INST_WORD_X} + EMARCH_ENC_I17_IMM41a_SIZE_X = 10; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41a_SIZE_X} + EMARCH_ENC_I17_IMM41a_INST_WORD_POS_X = 14; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41a_INST_WORD_POS_X} + EMARCH_ENC_I17_IMM41a_VAL_POS_X = 22; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41a_VAL_POS_X} + + EMARCH_ENC_I17_IMM41b_INST_WORD_X = 1; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41b_INST_WORD_X} + EMARCH_ENC_I17_IMM41b_SIZE_X = 8; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41b_SIZE_X} + EMARCH_ENC_I17_IMM41b_INST_WORD_POS_X = 24; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41b_INST_WORD_POS_X} + EMARCH_ENC_I17_IMM41b_VAL_POS_X = 32; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41b_VAL_POS_X} + + EMARCH_ENC_I17_IMM41c_INST_WORD_X = 2; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41c_INST_WORD_X} + EMARCH_ENC_I17_IMM41c_SIZE_X = 23; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41c_SIZE_X} + EMARCH_ENC_I17_IMM41c_INST_WORD_POS_X = 0; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41c_INST_WORD_POS_X} + EMARCH_ENC_I17_IMM41c_VAL_POS_X = 40; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_IMM41c_VAL_POS_X} + + EMARCH_ENC_I17_SIGN_INST_WORD_X = 3; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_SIGN_INST_WORD_X} + EMARCH_ENC_I17_SIGN_SIZE_X = 1; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_SIGN_SIZE_X} + EMARCH_ENC_I17_SIGN_INST_WORD_POS_X = 27; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_SIGN_INST_WORD_POS_X} + EMARCH_ENC_I17_SIGN_VAL_POS_X = 63; // Intel-IA64-Filler + {$EXTERNALSYM EMARCH_ENC_I17_SIGN_VAL_POS_X} + +// +// Line number format. +// + +type + TImgLineNoType = record + case Integer of + 0: (SymbolTableIndex: DWORD); // Symbol table index of function name if Linenumber is 0. + 1: (VirtualAddress: DWORD); // Virtual address of line number. + end; + + PIMAGE_LINENUMBER = ^IMAGE_LINENUMBER; + {$EXTERNALSYM PIMAGE_LINENUMBER} + _IMAGE_LINENUMBER = record + Type_: TImgLineNoType; + Linenumber: WORD; // Line number. + end; + {$EXTERNALSYM _IMAGE_LINENUMBER} + IMAGE_LINENUMBER = _IMAGE_LINENUMBER; + {$EXTERNALSYM IMAGE_LINENUMBER} + TImageLineNumber = IMAGE_LINENUMBER; + PImageLineNumber = PIMAGE_LINENUMBER; + +const + IMAGE_SIZEOF_LINENUMBER = 6; + {$EXTERNALSYM IMAGE_SIZEOF_LINENUMBER} + +// #include "poppack.h" // Back to 4 byte packing + +// +// Based relocation format. +// + +type + PIMAGE_BASE_RELOCATION = ^IMAGE_BASE_RELOCATION; + {$EXTERNALSYM PIMAGE_BASE_RELOCATION} + _IMAGE_BASE_RELOCATION = record + VirtualAddress: DWORD; + SizeOfBlock: DWORD; + // WORD TypeOffset[1]; + end; + {$EXTERNALSYM _IMAGE_BASE_RELOCATION} + IMAGE_BASE_RELOCATION = _IMAGE_BASE_RELOCATION; + {$EXTERNALSYM IMAGE_BASE_RELOCATION} + TImageBaseRelocation = IMAGE_BASE_RELOCATION; + PImageBaseRelocation = PIMAGE_BASE_RELOCATION; + +const + IMAGE_SIZEOF_BASE_RELOCATION = 8; + {$EXTERNALSYM IMAGE_SIZEOF_BASE_RELOCATION} + +// +// Based relocation types. +// + + IMAGE_REL_BASED_ABSOLUTE = 0; + {$EXTERNALSYM IMAGE_REL_BASED_ABSOLUTE} + IMAGE_REL_BASED_HIGH = 1; + {$EXTERNALSYM IMAGE_REL_BASED_HIGH} + IMAGE_REL_BASED_LOW = 2; + {$EXTERNALSYM IMAGE_REL_BASED_LOW} + IMAGE_REL_BASED_HIGHLOW = 3; + {$EXTERNALSYM IMAGE_REL_BASED_HIGHLOW} + IMAGE_REL_BASED_HIGHADJ = 4; + {$EXTERNALSYM IMAGE_REL_BASED_HIGHADJ} + IMAGE_REL_BASED_MIPS_JMPADDR = 5; + {$EXTERNALSYM IMAGE_REL_BASED_MIPS_JMPADDR} + + IMAGE_REL_BASED_MIPS_JMPADDR16 = 9; + {$EXTERNALSYM IMAGE_REL_BASED_MIPS_JMPADDR16} + IMAGE_REL_BASED_IA64_IMM64 = 9; + {$EXTERNALSYM IMAGE_REL_BASED_IA64_IMM64} + IMAGE_REL_BASED_DIR64 = 10; + {$EXTERNALSYM IMAGE_REL_BASED_DIR64} + +// +// Archive format. +// + + IMAGE_ARCHIVE_START_SIZE = 8; + {$EXTERNALSYM IMAGE_ARCHIVE_START_SIZE} + IMAGE_ARCHIVE_START = '!<arch>'#10; + {$EXTERNALSYM IMAGE_ARCHIVE_START} + IMAGE_ARCHIVE_END = '`'#10; + {$EXTERNALSYM IMAGE_ARCHIVE_END} + IMAGE_ARCHIVE_PAD = #10; + {$EXTERNALSYM IMAGE_ARCHIVE_PAD} + IMAGE_ARCHIVE_LINKER_MEMBER = '/ '; + {$EXTERNALSYM IMAGE_ARCHIVE_LINKER_MEMBER} + IMAGE_ARCHIVE_LONGNAMES_MEMBER = '// '; + {$EXTERNALSYM IMAGE_ARCHIVE_LONGNAMES_MEMBER} + +type + PIMAGE_ARCHIVE_MEMBER_HEADER = ^IMAGE_ARCHIVE_MEMBER_HEADER; + {$EXTERNALSYM PIMAGE_ARCHIVE_MEMBER_HEADER} + _IMAGE_ARCHIVE_MEMBER_HEADER = record + Name: array [0..15] of Byte; // File member name - `/' terminated. + Date: array [0..11] of Byte; // File member date - decimal. + UserID: array [0..5] of Byte; // File member user id - decimal. + GroupID: array [0..5] of Byte; // File member group id - decimal. + Mode: array [0..7] of Byte; // File member mode - octal. + Size: array [0..9] of Byte; // File member size - decimal. + EndHeader: array [0..1] of Byte; // String to end header. + end; + {$EXTERNALSYM _IMAGE_ARCHIVE_MEMBER_HEADER} + IMAGE_ARCHIVE_MEMBER_HEADER = _IMAGE_ARCHIVE_MEMBER_HEADER; + {$EXTERNALSYM IMAGE_ARCHIVE_MEMBER_HEADER} + TImageArchiveMemberHeader = IMAGE_ARCHIVE_MEMBER_HEADER; + PImageArchiveMemberHeader = PIMAGE_ARCHIVE_MEMBER_HEADER; + +const + IMAGE_SIZEOF_ARCHIVE_MEMBER_HDR = 60; + {$EXTERNALSYM IMAGE_SIZEOF_ARCHIVE_MEMBER_HDR} + +// +// DLL support. +// + +// +// Export Format +// + +type + PIMAGE_EXPORT_DIRECTORY = ^IMAGE_EXPORT_DIRECTORY; + {$EXTERNALSYM PIMAGE_EXPORT_DIRECTORY} + _IMAGE_EXPORT_DIRECTORY = record + Characteristics: DWORD; + TimeDateStamp: DWORD; + MajorVersion: Word; + MinorVersion: Word; + Name: DWORD; + Base: DWORD; + NumberOfFunctions: DWORD; + NumberOfNames: DWORD; + AddressOfFunctions: DWORD; // RVA from base of image + AddressOfNames: DWORD; // RVA from base of image + AddressOfNameOrdinals: DWORD; // RVA from base of image + end; + {$EXTERNALSYM _IMAGE_EXPORT_DIRECTORY} + IMAGE_EXPORT_DIRECTORY = _IMAGE_EXPORT_DIRECTORY; + {$EXTERNALSYM IMAGE_EXPORT_DIRECTORY} + TImageExportDirectory = IMAGE_EXPORT_DIRECTORY; + PImageExportDirectory = PIMAGE_EXPORT_DIRECTORY; + +// +// Import Format +// + + PIMAGE_IMPORT_BY_NAME = ^IMAGE_IMPORT_BY_NAME; + {$EXTERNALSYM PIMAGE_IMPORT_BY_NAME} + _IMAGE_IMPORT_BY_NAME = record + Hint: Word; + Name: array [0..0] of Byte; + end; + {$EXTERNALSYM _IMAGE_IMPORT_BY_NAME} + IMAGE_IMPORT_BY_NAME = _IMAGE_IMPORT_BY_NAME; + {$EXTERNALSYM IMAGE_IMPORT_BY_NAME} + TImageImportByName = IMAGE_IMPORT_BY_NAME; + PImageImportByName = PIMAGE_IMPORT_BY_NAME; + +// #include "pshpack8.h" // Use align 8 for the 64-bit IAT. + + PIMAGE_THUNK_DATA64 = ^IMAGE_THUNK_DATA64; + {$EXTERNALSYM PIMAGE_THUNK_DATA64} + _IMAGE_THUNK_DATA64 = record + case Integer of + 0: (ForwarderString: ULONGLONG); // PBYTE + 1: (Function_: ULONGLONG); // PDWORD + 2: (Ordinal: ULONGLONG); + 3: (AddressOfData: ULONGLONG); // PIMAGE_IMPORT_BY_NAME + end; + {$EXTERNALSYM _IMAGE_THUNK_DATA64} + IMAGE_THUNK_DATA64 = _IMAGE_THUNK_DATA64; + {$EXTERNALSYM IMAGE_THUNK_DATA64} + TImageThunkData64 = IMAGE_THUNK_DATA64; + PImageThunkData64 = PIMAGE_THUNK_DATA64; + +// #include "poppack.h" // Back to 4 byte packing + + PIMAGE_THUNK_DATA32 = ^IMAGE_THUNK_DATA32; + {$EXTERNALSYM PIMAGE_THUNK_DATA32} + _IMAGE_THUNK_DATA32 = record + case Integer of + 0: (ForwarderString: DWORD); // PBYTE + 1: (Function_: DWORD); // PDWORD + 2: (Ordinal: DWORD); + 3: (AddressOfData: DWORD); // PIMAGE_IMPORT_BY_NAME + end; + {$EXTERNALSYM _IMAGE_THUNK_DATA32} + IMAGE_THUNK_DATA32 = _IMAGE_THUNK_DATA32; + {$EXTERNALSYM IMAGE_THUNK_DATA32} + TImageThunkData32 = IMAGE_THUNK_DATA32; + PImageThunkData32 = PIMAGE_THUNK_DATA32; + +const + IMAGE_ORDINAL_FLAG64 = ULONGLONG($8000000000000000); + {$EXTERNALSYM IMAGE_ORDINAL_FLAG64} + IMAGE_ORDINAL_FLAG32 = DWORD($80000000); + {$EXTERNALSYM IMAGE_ORDINAL_FLAG32} + +function IMAGE_ORDINAL64(Ordinal: ULONGLONG): ULONGLONG; +{$EXTERNALSYM IMAGE_ORDINAL64} +function IMAGE_ORDINAL32(Ordinal: DWORD): DWORD; +{$EXTERNALSYM IMAGE_ORDINAL32} +function IMAGE_SNAP_BY_ORDINAL64(Ordinal: ULONGLONG): Boolean; +{$EXTERNALSYM IMAGE_SNAP_BY_ORDINAL64} +function IMAGE_SNAP_BY_ORDINAL32(Ordinal: DWORD): Boolean; +{$EXTERNALSYM IMAGE_SNAP_BY_ORDINAL32} + +// +// Thread Local Storage +// + +type + PIMAGE_TLS_CALLBACK = procedure(DllHandle: Pointer; Reason: DWORD; Reserved: Pointer); stdcall; + {$EXTERNALSYM PIMAGE_TLS_CALLBACK} + TImageTlsCallback = PIMAGE_TLS_CALLBACK; + + PIMAGE_TLS_DIRECTORY64 = ^IMAGE_TLS_DIRECTORY64; + {$EXTERNALSYM PIMAGE_TLS_DIRECTORY64} + _IMAGE_TLS_DIRECTORY64 = record + StartAddressOfRawData: ULONGLONG; + EndAddressOfRawData: ULONGLONG; + AddressOfIndex: ULONGLONG; // PDWORD + AddressOfCallBacks: ULONGLONG; // PIMAGE_TLS_CALLBACK *; + SizeOfZeroFill: DWORD; + Characteristics: DWORD; + end; + {$EXTERNALSYM _IMAGE_TLS_DIRECTORY64} + IMAGE_TLS_DIRECTORY64 = _IMAGE_TLS_DIRECTORY64; + {$EXTERNALSYM IMAGE_TLS_DIRECTORY64} + TImageTlsDirectory64 = IMAGE_TLS_DIRECTORY64; + PImageTlsDirectory64 = PIMAGE_TLS_DIRECTORY64; + + PIMAGE_TLS_DIRECTORY32 = ^IMAGE_TLS_DIRECTORY32; + {$EXTERNALSYM PIMAGE_TLS_DIRECTORY32} + _IMAGE_TLS_DIRECTORY32 = record + StartAddressOfRawData: DWORD; + EndAddressOfRawData: DWORD; + AddressOfIndex: DWORD; // PDWORD + AddressOfCallBacks: DWORD; // PIMAGE_TLS_CALLBACK * + SizeOfZeroFill: DWORD; + Characteristics: DWORD; + end; + {$EXTERNALSYM _IMAGE_TLS_DIRECTORY32} + IMAGE_TLS_DIRECTORY32 = _IMAGE_TLS_DIRECTORY32; + {$EXTERNALSYM IMAGE_TLS_DIRECTORY32} + TImageTlsDirectory32 = IMAGE_TLS_DIRECTORY32; + PImageTlsDirectory32 = PIMAGE_TLS_DIRECTORY32; + +const + IMAGE_ORDINAL_FLAG = IMAGE_ORDINAL_FLAG32; + {$EXTERNALSYM IMAGE_ORDINAL_FLAG} + +function IMAGE_ORDINAL(Ordinal: DWORD): DWORD; + +type + IMAGE_THUNK_DATA = IMAGE_THUNK_DATA32; + {$EXTERNALSYM IMAGE_THUNK_DATA} + PIMAGE_THUNK_DATA = PIMAGE_THUNK_DATA32; + {$EXTERNALSYM PIMAGE_THUNK_DATA} + TImageThunkData = TImageThunkData32; + PImageThunkData = PImageThunkData32; + +function IMAGE_SNAP_BY_ORDINAL(Ordinal: DWORD): Boolean; +{$EXTERNALSYM IMAGE_SNAP_BY_ORDINAL} + +type + IMAGE_TLS_DIRECTORY = IMAGE_TLS_DIRECTORY32; + {$EXTERNALSYM IMAGE_TLS_DIRECTORY} + PIMAGE_TLS_DIRECTORY = PIMAGE_TLS_DIRECTORY32; + {$EXTERNALSYM PIMAGE_TLS_DIRECTORY} + TImageTlsDirectory = TImageTlsDirectory32; + PImageTlsDirectory = PImageTlsDirectory32; + + TIIDUnion = record + case Integer of + 0: (Characteristics: DWORD); // 0 for terminating null import descriptor + 1: (OriginalFirstThunk: DWORD); // RVA to original unbound IAT (PIMAGE_THUNK_DATA) + end; + + PIMAGE_IMPORT_DESCRIPTOR = ^IMAGE_IMPORT_DESCRIPTOR; + {$EXTERNALSYM PIMAGE_IMPORT_DESCRIPTOR} + _IMAGE_IMPORT_DESCRIPTOR = record + Union: TIIDUnion; + TimeDateStamp: DWORD; // 0 if not bound, + // -1 if bound, and real date\time stamp + // in IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (new BIND) + // O.W. date/time stamp of DLL bound to (Old BIND) + + ForwarderChain: DWORD; // -1 if no forwarders + Name: DWORD; + FirstThunk: DWORD; // RVA to IAT (if bound this IAT has actual addresses) + end; + {$EXTERNALSYM _IMAGE_IMPORT_DESCRIPTOR} + IMAGE_IMPORT_DESCRIPTOR = _IMAGE_IMPORT_DESCRIPTOR; + {$EXTERNALSYM IMAGE_IMPORT_DESCRIPTOR} + TImageImportDecriptor = IMAGE_IMPORT_DESCRIPTOR; + PImageImportDecriptor = PIMAGE_IMPORT_DESCRIPTOR; + +// +// New format import descriptors pointed to by DataDirectory[ IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT ] +// + +type + PIMAGE_BOUND_IMPORT_DESCRIPTOR = ^IMAGE_BOUND_IMPORT_DESCRIPTOR; + {$EXTERNALSYM PIMAGE_BOUND_IMPORT_DESCRIPTOR} + _IMAGE_BOUND_IMPORT_DESCRIPTOR = record + TimeDateStamp: DWORD; + OffsetModuleName: Word; + NumberOfModuleForwarderRefs: Word; + // Array of zero or more IMAGE_BOUND_FORWARDER_REF follows + end; + {$EXTERNALSYM _IMAGE_BOUND_IMPORT_DESCRIPTOR} + IMAGE_BOUND_IMPORT_DESCRIPTOR = _IMAGE_BOUND_IMPORT_DESCRIPTOR; + {$EXTERNALSYM IMAGE_BOUND_IMPORT_DESCRIPTOR} + TImageBoundImportDescriptor = IMAGE_BOUND_IMPORT_DESCRIPTOR; + PImageBoundImportDescriptor = PIMAGE_BOUND_IMPORT_DESCRIPTOR; + + PIMAGE_BOUND_FORWARDER_REF = ^IMAGE_BOUND_FORWARDER_REF; + {$EXTERNALSYM PIMAGE_BOUND_FORWARDER_REF} + _IMAGE_BOUND_FORWARDER_REF = record + TimeDateStamp: DWORD; + OffsetModuleName: Word; + Reserved: Word; + end; + {$EXTERNALSYM _IMAGE_BOUND_FORWARDER_REF} + IMAGE_BOUND_FORWARDER_REF = _IMAGE_BOUND_FORWARDER_REF; + {$EXTERNALSYM IMAGE_BOUND_FORWARDER_REF} + TImageBoundForwarderRef = IMAGE_BOUND_FORWARDER_REF; + PImageBoundForwarderRef = PIMAGE_BOUND_FORWARDER_REF; + +// +// Resource Format. +// + +// +// Resource directory consists of two counts, following by a variable length +// array of directory entries. The first count is the number of entries at +// beginning of the array that have actual names associated with each entry. +// The entries are in ascending order, case insensitive strings. The second +// count is the number of entries that immediately follow the named entries. +// This second count identifies the number of entries that have 16-bit integer +// Ids as their name. These entries are also sorted in ascending order. +// +// This structure allows fast lookup by either name or number, but for any +// given resource entry only one form of lookup is supported, not both. +// This is consistant with the syntax of the .RC file and the .RES file. +// + + PIMAGE_RESOURCE_DIRECTORY = ^IMAGE_RESOURCE_DIRECTORY; + {$EXTERNALSYM PIMAGE_RESOURCE_DIRECTORY} + _IMAGE_RESOURCE_DIRECTORY = record + Characteristics: DWORD; + TimeDateStamp: DWORD; + MajorVersion: Word; + MinorVersion: Word; + NumberOfNamedEntries: Word; + NumberOfIdEntries: Word; + // IMAGE_RESOURCE_DIRECTORY_ENTRY DirectoryEntries[]; + end; + {$EXTERNALSYM _IMAGE_RESOURCE_DIRECTORY} + IMAGE_RESOURCE_DIRECTORY = _IMAGE_RESOURCE_DIRECTORY; + {$EXTERNALSYM IMAGE_RESOURCE_DIRECTORY} + TImageResourceDirectory = IMAGE_RESOURCE_DIRECTORY; + PImageResourceDirectory = PIMAGE_RESOURCE_DIRECTORY; + +const + IMAGE_RESOURCE_NAME_IS_STRING = DWORD($80000000); + {$EXTERNALSYM IMAGE_RESOURCE_NAME_IS_STRING} + IMAGE_RESOURCE_DATA_IS_DIRECTORY = DWORD($80000000); + {$EXTERNALSYM IMAGE_RESOURCE_DATA_IS_DIRECTORY} + +// +// Each directory contains the 32-bit Name of the entry and an offset, +// relative to the beginning of the resource directory of the data associated +// with this directory entry. If the name of the entry is an actual text +// string instead of an integer Id, then the high order bit of the name field +// is set to one and the low order 31-bits are an offset, relative to the +// beginning of the resource directory of the string, which is of type +// IMAGE_RESOURCE_DIRECTORY_STRING. Otherwise the high bit is clear and the +// low-order 16-bits are the integer Id that identify this resource directory +// entry. If the directory entry is yet another resource directory (i.e. a +// subdirectory), then the high order bit of the offset field will be +// set to indicate this. Otherwise the high bit is clear and the offset +// field points to a resource data entry. +// + +type + TIRDEName = record + case Integer of + 0: ( + NameOffset: DWORD); // 0..30: NameOffset; 31: NameIsString + 1: ( + Name: DWORD); + 2: ( + Id: WORD); + end; + + TIRDEDirectory = record + case Integer of + 0: ( + OffsetToData: DWORD); + 1: ( + OffsetToDirectory: DWORD); // 0..30: OffsetToDirectory; 31: DataIsDirectory + end; + + PIMAGE_RESOURCE_DIRECTORY_ENTRY = ^IMAGE_RESOURCE_DIRECTORY_ENTRY; + {$EXTERNALSYM PIMAGE_RESOURCE_DIRECTORY_ENTRY} + _IMAGE_RESOURCE_DIRECTORY_ENTRY = record + Name: TIRDEName; + Directory: TIRDEDirectory; + end; + {$EXTERNALSYM _IMAGE_RESOURCE_DIRECTORY_ENTRY} + IMAGE_RESOURCE_DIRECTORY_ENTRY = _IMAGE_RESOURCE_DIRECTORY_ENTRY; + {$EXTERNALSYM IMAGE_RESOURCE_DIRECTORY_ENTRY} + TImageResourceDirectoryEntry = IMAGE_RESOURCE_DIRECTORY_ENTRY; + PImageResourceDirectoryEntry = PIMAGE_RESOURCE_DIRECTORY_ENTRY; + +// +// For resource directory entries that have actual string names, the Name +// field of the directory entry points to an object of the following type. +// All of these string objects are stored together after the last resource +// directory entry and before the first resource data object. This minimizes +// the impact of these variable length objects on the alignment of the fixed +// size directory entry objects. +// + +type + PIMAGE_RESOURCE_DIRECTORY_STRING = ^IMAGE_RESOURCE_DIRECTORY_STRING; + {$EXTERNALSYM PIMAGE_RESOURCE_DIRECTORY_STRING} + _IMAGE_RESOURCE_DIRECTORY_STRING = record + Length: Word; + NameString: array [0..0] of CHAR; + end; + {$EXTERNALSYM _IMAGE_RESOURCE_DIRECTORY_STRING} + IMAGE_RESOURCE_DIRECTORY_STRING = _IMAGE_RESOURCE_DIRECTORY_STRING; + {$EXTERNALSYM IMAGE_RESOURCE_DIRECTORY_STRING} + TImageResourceDirectoryString = IMAGE_RESOURCE_DIRECTORY_STRING; + PImageResourceDirectoryString = PIMAGE_RESOURCE_DIRECTORY_STRING; + + PIMAGE_RESOURCE_DIR_STRING_U = ^IMAGE_RESOURCE_DIR_STRING_U; + {$EXTERNALSYM PIMAGE_RESOURCE_DIR_STRING_U} + _IMAGE_RESOURCE_DIR_STRING_U = record + Length: Word; + NameString: array [0..0] of WCHAR; + end; + {$EXTERNALSYM _IMAGE_RESOURCE_DIR_STRING_U} + IMAGE_RESOURCE_DIR_STRING_U = _IMAGE_RESOURCE_DIR_STRING_U; + {$EXTERNALSYM IMAGE_RESOURCE_DIR_STRING_U} + TImageResourceDirStringU = IMAGE_RESOURCE_DIR_STRING_U; + PImageResourceDirStringU = PIMAGE_RESOURCE_DIR_STRING_U; + +// +// Each resource data entry describes a leaf node in the resource directory +// tree. It contains an offset, relative to the beginning of the resource +// directory of the data for the resource, a size field that gives the number +// of bytes of data at that offset, a CodePage that should be used when +// decoding code point values within the resource data. Typically for new +// applications the code page would be the unicode code page. +// + + PIMAGE_RESOURCE_DATA_ENTRY = ^IMAGE_RESOURCE_DATA_ENTRY; + {$EXTERNALSYM PIMAGE_RESOURCE_DATA_ENTRY} + _IMAGE_RESOURCE_DATA_ENTRY = record + OffsetToData: DWORD; + Size: DWORD; + CodePage: DWORD; + Reserved: DWORD; + end; + {$EXTERNALSYM _IMAGE_RESOURCE_DATA_ENTRY} + IMAGE_RESOURCE_DATA_ENTRY = _IMAGE_RESOURCE_DATA_ENTRY; + {$EXTERNALSYM IMAGE_RESOURCE_DATA_ENTRY} + TImageResourceDataEntry = IMAGE_RESOURCE_DATA_ENTRY; + PImageResourceDataEntry = PIMAGE_RESOURCE_DATA_ENTRY; + +// +// Load Configuration Directory Entry +// + +type + PIMAGE_LOAD_CONFIG_DIRECTORY32 = ^IMAGE_LOAD_CONFIG_DIRECTORY32; + {$EXTERNALSYM PIMAGE_LOAD_CONFIG_DIRECTORY32} + IMAGE_LOAD_CONFIG_DIRECTORY32 = record + Size: DWORD; + TimeDateStamp: DWORD; + MajorVersion: WORD; + MinorVersion: WORD; + GlobalFlagsClear: DWORD; + GlobalFlagsSet: DWORD; + CriticalSectionDefaultTimeout: DWORD; + DeCommitFreeBlockThreshold: DWORD; + DeCommitTotalFreeThreshold: DWORD; + LockPrefixTable: DWORD; // VA + MaximumAllocationSize: DWORD; + VirtualMemoryThreshold: DWORD; + ProcessHeapFlags: DWORD; + ProcessAffinityMask: DWORD; + CSDVersion: WORD; + Reserved1: WORD; + EditList: DWORD; // VA + SecurityCookie: DWORD; // VA + SEHandlerTable: DWORD; // VA + SEHandlerCount: DWORD; + end; + {$EXTERNALSYM IMAGE_LOAD_CONFIG_DIRECTORY32} + TImageLoadConfigDirectory32 = IMAGE_LOAD_CONFIG_DIRECTORY32; + PImageLoadConfigDirectory32 = PIMAGE_LOAD_CONFIG_DIRECTORY32; + + PIMAGE_LOAD_CONFIG_DIRECTORY64 = ^IMAGE_LOAD_CONFIG_DIRECTORY64; + {$EXTERNALSYM PIMAGE_LOAD_CONFIG_DIRECTORY64} + IMAGE_LOAD_CONFIG_DIRECTORY64 = record + Size: DWORD; + TimeDateStamp: DWORD; + MajorVersion: WORD; + MinorVersion: WORD; + GlobalFlagsClear: DWORD; + GlobalFlagsSet: DWORD; + CriticalSectionDefaultTimeout: DWORD; + DeCommitFreeBlockThreshold: ULONGLONG; + DeCommitTotalFreeThreshold: ULONGLONG; + LockPrefixTable: ULONGLONG; // VA + MaximumAllocationSize: ULONGLONG; + VirtualMemoryThreshold: ULONGLONG; + ProcessAffinityMask: ULONGLONG; + ProcessHeapFlags: DWORD; + CSDVersion: WORD; + Reserved1: WORD; + EditList: ULONGLONG; // VA + SecurityCookie: ULONGLONG; // VA + SEHandlerTable: ULONGLONG; // VA + SEHandlerCount: ULONGLONG; + end; + {$EXTERNALSYM IMAGE_LOAD_CONFIG_DIRECTORY64} + TImageLoadConfigDirectory64 = IMAGE_LOAD_CONFIG_DIRECTORY64; + PImageLoadConfigDirectory64 = PIMAGE_LOAD_CONFIG_DIRECTORY64; + + IMAGE_LOAD_CONFIG_DIRECTORY = IMAGE_LOAD_CONFIG_DIRECTORY32; + {$EXTERNALSYM IMAGE_LOAD_CONFIG_DIRECTORY} + PIMAGE_LOAD_CONFIG_DIRECTORY = PIMAGE_LOAD_CONFIG_DIRECTORY32; + {$EXTERNALSYM PIMAGE_LOAD_CONFIG_DIRECTORY} + TImageLoadConfigDirectory = TImageLoadConfigDirectory32; + PImageLoadConfigDirectory = PImageLoadConfigDirectory32; + +// +// WIN CE Exception table format +// + +// +// Function table entry format. Function table is pointed to by the +// IMAGE_DIRECTORY_ENTRY_EXCEPTION directory entry. +// + +type + PIMAGE_CE_RUNTIME_FUNCTION_ENTRY = ^IMAGE_CE_RUNTIME_FUNCTION_ENTRY; + {$EXTERNALSYM PIMAGE_CE_RUNTIME_FUNCTION_ENTRY} + _IMAGE_CE_RUNTIME_FUNCTION_ENTRY = record + FuncStart: DWORD; + Flags: DWORD; + //DWORD PrologLen : 8; + //DWORD FuncLen : 22; + //DWORD ThirtyTwoBit : 1; + //DWORD ExceptionFlag : 1; + end; + {$EXTERNALSYM _IMAGE_CE_RUNTIME_FUNCTION_ENTRY} + IMAGE_CE_RUNTIME_FUNCTION_ENTRY = _IMAGE_CE_RUNTIME_FUNCTION_ENTRY; + {$EXTERNALSYM IMAGE_CE_RUNTIME_FUNCTION_ENTRY} + TImageCERuntimeFunctionEntry = IMAGE_CE_RUNTIME_FUNCTION_ENTRY; + PImageCERuntimeFunctionEntry = PIMAGE_CE_RUNTIME_FUNCTION_ENTRY; + +// +// Debug Format +// + +type + PIMAGE_DEBUG_DIRECTORY = ^IMAGE_DEBUG_DIRECTORY; + {$EXTERNALSYM PIMAGE_DEBUG_DIRECTORY} + _IMAGE_DEBUG_DIRECTORY = record + Characteristics: DWORD; + TimeDateStamp: DWORD; + MajorVersion: Word; + MinorVersion: Word; + Type_: DWORD; + SizeOfData: DWORD; + AddressOfRawData: DWORD; + PointerToRawData: DWORD; + end; + {$EXTERNALSYM _IMAGE_DEBUG_DIRECTORY} + IMAGE_DEBUG_DIRECTORY = _IMAGE_DEBUG_DIRECTORY; + {$EXTERNALSYM IMAGE_DEBUG_DIRECTORY} + TImageDebugDirectory = IMAGE_DEBUG_DIRECTORY; + PImageDebugDirectory = PIMAGE_DEBUG_DIRECTORY; + +const + IMAGE_DEBUG_TYPE_UNKNOWN = 0; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_UNKNOWN} + IMAGE_DEBUG_TYPE_COFF = 1; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_COFF} + IMAGE_DEBUG_TYPE_CODEVIEW = 2; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_CODEVIEW} + IMAGE_DEBUG_TYPE_FPO = 3; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_FPO} + IMAGE_DEBUG_TYPE_MISC = 4; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_MISC} + IMAGE_DEBUG_TYPE_EXCEPTION = 5; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_EXCEPTION} + IMAGE_DEBUG_TYPE_FIXUP = 6; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_FIXUP} + IMAGE_DEBUG_TYPE_OMAP_TO_SRC = 7; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_OMAP_TO_SRC} + IMAGE_DEBUG_TYPE_OMAP_FROM_SRC = 8; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_OMAP_FROM_SRC} + IMAGE_DEBUG_TYPE_BORLAND = 9; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_BORLAND} + IMAGE_DEBUG_TYPE_RESERVED10 = 10; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_RESERVED10} + IMAGE_DEBUG_TYPE_CLSID = 11; + {$EXTERNALSYM IMAGE_DEBUG_TYPE_CLSID} + +type + PIMAGE_COFF_SYMBOLS_HEADER = ^IMAGE_COFF_SYMBOLS_HEADER; + {$EXTERNALSYM PIMAGE_COFF_SYMBOLS_HEADER} + _IMAGE_COFF_SYMBOLS_HEADER = record + NumberOfSymbols: DWORD; + LvaToFirstSymbol: DWORD; + NumberOfLinenumbers: DWORD; + LvaToFirstLinenumber: DWORD; + RvaToFirstByteOfCode: DWORD; + RvaToLastByteOfCode: DWORD; + RvaToFirstByteOfData: DWORD; + RvaToLastByteOfData: DWORD; + end; + {$EXTERNALSYM _IMAGE_COFF_SYMBOLS_HEADER} + IMAGE_COFF_SYMBOLS_HEADER = _IMAGE_COFF_SYMBOLS_HEADER; + {$EXTERNALSYM IMAGE_COFF_SYMBOLS_HEADER} + TImageCoffSymbolsHeader = IMAGE_COFF_SYMBOLS_HEADER; + PImageCoffSymbolsHeader = PIMAGE_COFF_SYMBOLS_HEADER; + +const + FRAME_FPO = 0; + {$EXTERNALSYM FRAME_FPO} + FRAME_TRAP = 1; + {$EXTERNALSYM FRAME_TRAP} + FRAME_TSS = 2; + {$EXTERNALSYM FRAME_TSS} + FRAME_NONFPO = 3; + {$EXTERNALSYM FRAME_NONFPO} + + FPOFLAGS_PROLOG = $00FF; // # bytes in prolog + FPOFLAGS_REGS = $0700; // # regs saved + FPOFLAGS_HAS_SEH = $0800; // TRUE if SEH in func + FPOFLAGS_USE_BP = $1000; // TRUE if EBP has been allocated + FPOFLAGS_RESERVED = $2000; // reserved for future use + FPOFLAGS_FRAME = $C000; // frame type + +type + PFPO_DATA = ^FPO_DATA; + {$EXTERNALSYM PFPO_DATA} + _FPO_DATA = record + ulOffStart: DWORD; // offset 1st byte of function code + cbProcSize: DWORD; // # bytes in function + cdwLocals: DWORD; // # bytes in locals/4 + cdwParams: WORD; // # bytes in params/4 + Flags: WORD; + end; + {$EXTERNALSYM _FPO_DATA} + FPO_DATA = _FPO_DATA; + {$EXTERNALSYM FPO_DATA} + TFpoData = FPO_DATA; + PFpoData = PFPO_DATA; + +const + SIZEOF_RFPO_DATA = 16; + {$EXTERNALSYM SIZEOF_RFPO_DATA} + + IMAGE_DEBUG_MISC_EXENAME = 1; + {$EXTERNALSYM IMAGE_DEBUG_MISC_EXENAME} + +type + PIMAGE_DEBUG_MISC = ^IMAGE_DEBUG_MISC; + {$EXTERNALSYM PIMAGE_DEBUG_MISC} + _IMAGE_DEBUG_MISC = record + DataType: DWORD; // type of misc data, see defines + Length: DWORD; // total length of record, rounded to four byte multiple. + Unicode: ByteBool; // TRUE if data is unicode string + Reserved: array [0..2] of Byte; + Data: array [0..0] of Byte; // Actual data + end; + {$EXTERNALSYM _IMAGE_DEBUG_MISC} + IMAGE_DEBUG_MISC = _IMAGE_DEBUG_MISC; + {$EXTERNALSYM IMAGE_DEBUG_MISC} + TImageDebugMisc = IMAGE_DEBUG_MISC; + PImageDebugMisc = PIMAGE_DEBUG_MISC; + +// +// Function table extracted from MIPS/ALPHA/IA64 images. Does not contain +// information needed only for runtime support. Just those fields for +// each entry needed by a debugger. +// + + PIMAGE_FUNCTION_ENTRY = ^IMAGE_FUNCTION_ENTRY; + {$EXTERNALSYM PIMAGE_FUNCTION_ENTRY} + _IMAGE_FUNCTION_ENTRY = record + StartingAddress: DWORD; + EndingAddress: DWORD; + EndOfPrologue: DWORD; + end; + {$EXTERNALSYM _IMAGE_FUNCTION_ENTRY} + IMAGE_FUNCTION_ENTRY = _IMAGE_FUNCTION_ENTRY; + {$EXTERNALSYM IMAGE_FUNCTION_ENTRY} + TImageFunctionEntry = IMAGE_FUNCTION_ENTRY; + PImageFunctionEntry = PIMAGE_FUNCTION_ENTRY; + + PIMAGE_FUNCTION_ENTRY64 = ^IMAGE_FUNCTION_ENTRY64; + {$EXTERNALSYM PIMAGE_FUNCTION_ENTRY64} + _IMAGE_FUNCTION_ENTRY64 = record + StartingAddress: ULONGLONG; + EndingAddress: ULONGLONG; + case Integer of + 0: (EndOfPrologue: ULONGLONG); + 1: (UnwindInfoAddress: ULONGLONG); + end; + {$EXTERNALSYM _IMAGE_FUNCTION_ENTRY64} + IMAGE_FUNCTION_ENTRY64 = _IMAGE_FUNCTION_ENTRY64; + {$EXTERNALSYM IMAGE_FUNCTION_ENTRY64} + TImageFunctionEntry64 = IMAGE_FUNCTION_ENTRY64; + PImageFunctionEntry64 = PIMAGE_FUNCTION_ENTRY64; + +// +// Debugging information can be stripped from an image file and placed +// in a separate .DBG file, whose file name part is the same as the +// image file name part (e.g. symbols for CMD.EXE could be stripped +// and placed in CMD.DBG). This is indicated by the IMAGE_FILE_DEBUG_STRIPPED +// flag in the Characteristics field of the file header. The beginning of +// the .DBG file contains the following structure which captures certain +// information from the image file. This allows a debug to proceed even if +// the original image file is not accessable. This header is followed by +// zero of more IMAGE_SECTION_HEADER structures, followed by zero or more +// IMAGE_DEBUG_DIRECTORY structures. The latter structures and those in +// the image file contain file offsets relative to the beginning of the +// .DBG file. +// +// If symbols have been stripped from an image, the IMAGE_DEBUG_MISC structure +// is left in the image file, but not mapped. This allows a debugger to +// compute the name of the .DBG file, from the name of the image in the +// IMAGE_DEBUG_MISC structure. +// + + PIMAGE_SEPARATE_DEBUG_HEADER = ^IMAGE_SEPARATE_DEBUG_HEADER; + {$EXTERNALSYM PIMAGE_SEPARATE_DEBUG_HEADER} + _IMAGE_SEPARATE_DEBUG_HEADER = record + Signature: Word; + Flags: Word; + Machine: Word; + Characteristics: Word; + TimeDateStamp: DWORD; + CheckSum: DWORD; + ImageBase: DWORD; + SizeOfImage: DWORD; + NumberOfSections: DWORD; + ExportedNamesSize: DWORD; + DebugDirectorySize: DWORD; + SectionAlignment: DWORD; + Reserved: array [0..1] of DWORD; + end; + {$EXTERNALSYM _IMAGE_SEPARATE_DEBUG_HEADER} + IMAGE_SEPARATE_DEBUG_HEADER = _IMAGE_SEPARATE_DEBUG_HEADER; + {$EXTERNALSYM IMAGE_SEPARATE_DEBUG_HEADER} + TImageSeparateDebugHeader = IMAGE_SEPARATE_DEBUG_HEADER; + PImageSeparateDebugHeader = PIMAGE_SEPARATE_DEBUG_HEADER; + + _NON_PAGED_DEBUG_INFO = record + Signature: WORD; + Flags: WORD; + Size: DWORD; + Machine: WORD; + Characteristics: WORD; + TimeDateStamp: DWORD; + CheckSum: DWORD; + SizeOfImage: DWORD; + ImageBase: ULONGLONG; + //DebugDirectorySize + //IMAGE_DEBUG_DIRECTORY + end; + {$EXTERNALSYM _NON_PAGED_DEBUG_INFO} + NON_PAGED_DEBUG_INFO = _NON_PAGED_DEBUG_INFO; + {$EXTERNALSYM NON_PAGED_DEBUG_INFO} + PNON_PAGED_DEBUG_INFO = ^NON_PAGED_DEBUG_INFO; + {$EXTERNALSYM PNON_PAGED_DEBUG_INFO} + +const + IMAGE_SEPARATE_DEBUG_SIGNATURE = $4944; + {$EXTERNALSYM IMAGE_SEPARATE_DEBUG_SIGNATURE} + NON_PAGED_DEBUG_SIGNATURE = $494E; + {$EXTERNALSYM NON_PAGED_DEBUG_SIGNATURE} + + IMAGE_SEPARATE_DEBUG_FLAGS_MASK = $8000; + {$EXTERNALSYM IMAGE_SEPARATE_DEBUG_FLAGS_MASK} + IMAGE_SEPARATE_DEBUG_MISMATCH = $8000; // when DBG was updated, the old checksum didn't match. + {$EXTERNALSYM IMAGE_SEPARATE_DEBUG_MISMATCH} + +// +// The .arch section is made up of headers, each describing an amask position/value +// pointing to an array of IMAGE_ARCHITECTURE_ENTRY's. Each "array" (both the header +// and entry arrays) are terminiated by a quadword of 0xffffffffL. +// +// NOTE: There may be quadwords of 0 sprinkled around and must be skipped. +// + +const + IAHMASK_VALUE = $00000001; // 1 -> code section depends on mask bit + // 0 -> new instruction depends on mask bit + IAHMASK_MBZ7 = $000000FE; // MBZ + IAHMASK_SHIFT = $0000FF00; // Amask bit in question for this fixup + IAHMASK_MBZ16 = DWORD($FFFF0000); // MBZ + +type + PIMAGE_ARCHITECTURE_HEADER = ^IMAGE_ARCHITECTURE_HEADER; + {$EXTERNALSYM PIMAGE_ARCHITECTURE_HEADER} + _ImageArchitectureHeader = record + Mask: DWORD; + FirstEntryRVA: DWORD; // RVA into .arch section to array of ARCHITECTURE_ENTRY's + end; + {$EXTERNALSYM _ImageArchitectureHeader} + IMAGE_ARCHITECTURE_HEADER = _ImageArchitectureHeader; + {$EXTERNALSYM IMAGE_ARCHITECTURE_HEADER} + TImageArchitectureHeader = IMAGE_ARCHITECTURE_HEADER; + PImageArchitectureHeader = PIMAGE_ARCHITECTURE_HEADER; + + PIMAGE_ARCHITECTURE_ENTRY = ^IMAGE_ARCHITECTURE_ENTRY; + {$EXTERNALSYM PIMAGE_ARCHITECTURE_ENTRY} + _ImageArchitectureEntry = record + FixupInstRVA: DWORD; // RVA of instruction to fixup + NewInst: DWORD; // fixup instruction (see alphaops.h) + end; + {$EXTERNALSYM _ImageArchitectureEntry} + IMAGE_ARCHITECTURE_ENTRY = _ImageArchitectureEntry; + {$EXTERNALSYM IMAGE_ARCHITECTURE_ENTRY} + TImageArchitectureEntry = IMAGE_ARCHITECTURE_ENTRY; + PImageArchitectureEntry = PIMAGE_ARCHITECTURE_ENTRY; + +// #include "poppack.h" // Back to the initial value + +// The following structure defines the new import object. Note the values of the first two fields, +// which must be set as stated in order to differentiate old and new import members. +// Following this structure, the linker emits two null-terminated strings used to recreate the +// import at the time of use. The first string is the import's name, the second is the dll's name. + +const + IMPORT_OBJECT_HDR_SIG2 = $ffff; + {$EXTERNALSYM IMPORT_OBJECT_HDR_SIG2} + +const + IOHFLAGS_TYPE = $0003; // IMPORT_TYPE + IAHFLAGS_NAMETYPE = $001C; // IMPORT_NAME_TYPE + IAHFLAGS_RESERVED = $FFE0; // Reserved. Must be zero. + +type + PImportObjectHeader = ^IMPORT_OBJECT_HEADER; + IMPORT_OBJECT_HEADER = record + Sig1: WORD; // Must be IMAGE_FILE_MACHINE_UNKNOWN + Sig2: WORD; // Must be IMPORT_OBJECT_HDR_SIG2. + Version: WORD; + Machine: WORD; + TimeDateStamp: DWORD; // Time/date stamp + SizeOfData: DWORD; // particularly useful for incremental links + OrdinalOrHint: record + case Integer of + 0: (Ordinal: WORD); // if grf & IMPORT_OBJECT_ORDINAL + 1: (Flags: DWORD); + end; + Flags: WORD; + //WORD Type : 2; // IMPORT_TYPE + //WORD NameType : 3; // IMPORT_NAME_TYPE + //WORD Reserved : 11; // Reserved. Must be zero. + end; + {$EXTERNALSYM IMPORT_OBJECT_HEADER} + TImportObjectHeader = IMPORT_OBJECT_HEADER; + + IMPORT_OBJECT_TYPE = (IMPORT_OBJECT_CODE, IMPORT_OBJECT_DATA, IMPORT_OBJECT_CONST); + {$EXTERNALSYM IMPORT_OBJECT_TYPE} + TImportObjectType = IMPORT_OBJECT_TYPE; + + IMPORT_OBJECT_NAME_TYPE = ( + IMPORT_OBJECT_ORDINAL, // Import by ordinal + IMPORT_OBJECT_NAME, // Import name == public symbol name. + IMPORT_OBJECT_NAME_NO_PREFIX, // Import name == public symbol name skipping leading ?, @, or optionally _. + IMPORT_OBJECT_NAME_UNDECORATE); // Import name == public symbol name skipping leading ?, @, or optionally _ + // and truncating at first @ + {$EXTERNALSYM IMPORT_OBJECT_NAME_TYPE} + TImportObjectNameType = IMPORT_OBJECT_NAME_TYPE; + + ReplacesCorHdrNumericDefines = DWORD; + {$EXTERNALSYM ReplacesCorHdrNumericDefines} + +const + +// COM+ Header entry point flags. + + COMIMAGE_FLAGS_ILONLY = $00000001; + {$EXTERNALSYM COMIMAGE_FLAGS_ILONLY} + COMIMAGE_FLAGS_32BITREQUIRED = $00000002; + {$EXTERNALSYM COMIMAGE_FLAGS_32BITREQUIRED} + COMIMAGE_FLAGS_IL_LIBRARY = $00000004; + {$EXTERNALSYM COMIMAGE_FLAGS_IL_LIBRARY} + COMIMAGE_FLAGS_STRONGNAMESIGNED = $00000008; + {$EXTERNALSYM COMIMAGE_FLAGS_STRONGNAMESIGNED} + COMIMAGE_FLAGS_TRACKDEBUGDATA = $00010000; + {$EXTERNALSYM COMIMAGE_FLAGS_TRACKDEBUGDATA} + +// Version flags for image. + + COR_VERSION_MAJOR_V2 = 2; + {$EXTERNALSYM COR_VERSION_MAJOR_V2} + COR_VERSION_MAJOR = COR_VERSION_MAJOR_V2; + {$EXTERNALSYM COR_VERSION_MAJOR} + COR_VERSION_MINOR = 0; + {$EXTERNALSYM COR_VERSION_MINOR} + COR_DELETED_NAME_LENGTH = 8; + {$EXTERNALSYM COR_DELETED_NAME_LENGTH} + COR_VTABLEGAP_NAME_LENGTH = 8; + {$EXTERNALSYM COR_VTABLEGAP_NAME_LENGTH} + +// Maximum size of a NativeType descriptor. + + NATIVE_TYPE_MAX_CB = 1; + {$EXTERNALSYM NATIVE_TYPE_MAX_CB} + COR_ILMETHOD_SECT_SMALL_MAX_DATASIZE= $FF; + {$EXTERNALSYM COR_ILMETHOD_SECT_SMALL_MAX_DATASIZE} + +// #defines for the MIH FLAGS + + IMAGE_COR_MIH_METHODRVA = $01; + {$EXTERNALSYM IMAGE_COR_MIH_METHODRVA} + IMAGE_COR_MIH_EHRVA = $02; + {$EXTERNALSYM IMAGE_COR_MIH_EHRVA} + IMAGE_COR_MIH_BASICBLOCK = $08; + {$EXTERNALSYM IMAGE_COR_MIH_BASICBLOCK} + +// V-table constants + + COR_VTABLE_32BIT = $01; // V-table slots are 32-bits in size. + {$EXTERNALSYM COR_VTABLE_32BIT} + COR_VTABLE_64BIT = $02; // V-table slots are 64-bits in size. + {$EXTERNALSYM COR_VTABLE_64BIT} + COR_VTABLE_FROM_UNMANAGED = $04; // If set, transition from unmanaged. + {$EXTERNALSYM COR_VTABLE_FROM_UNMANAGED} + COR_VTABLE_CALL_MOST_DERIVED = $10; // Call most derived method described by + {$EXTERNALSYM COR_VTABLE_CALL_MOST_DERIVED} + +// EATJ constants + + IMAGE_COR_EATJ_THUNK_SIZE = 32; // Size of a jump thunk reserved range. + {$EXTERNALSYM IMAGE_COR_EATJ_THUNK_SIZE} + +// Max name lengths +// Change to unlimited name lengths. + + MAX_CLASS_NAME = 1024; + {$EXTERNALSYM MAX_CLASS_NAME} + MAX_PACKAGE_NAME = 1024; + {$EXTERNALSYM MAX_PACKAGE_NAME} + +// COM+ 2.0 header structure. + +type + IMAGE_COR20_HEADER = record + + // Header versioning + + cb: DWORD; + MajorRuntimeVersion: WORD; + MinorRuntimeVersion: WORD; + + // Symbol table and startup information + + MetaData: IMAGE_DATA_DIRECTORY; + Flags: DWORD; + EntryPointToken: DWORD; + + // Binding information + + Resources: IMAGE_DATA_DIRECTORY; + StrongNameSignature: IMAGE_DATA_DIRECTORY; + + // Regular fixup and binding information + + CodeManagerTable: IMAGE_DATA_DIRECTORY; + VTableFixups: IMAGE_DATA_DIRECTORY; + ExportAddressTableJumps: IMAGE_DATA_DIRECTORY; + + // Precompiled image info (internal use only - set to zero) + + ManagedNativeHeader: IMAGE_DATA_DIRECTORY; + end; + {$EXTERNALSYM IMAGE_COR20_HEADER} + PIMAGE_COR20_HEADER = ^IMAGE_COR20_HEADER; + {$EXTERNALSYM PIMAGE_COR20_HEADER} + TImageCor20Header = IMAGE_COR20_HEADER; + PImageCor20Header = PIMAGE_COR20_HEADER; + +// +// End Image Format +// + +type + SLIST_ENTRY = SINGLE_LIST_ENTRY; + {$EXTERNALSYM SLIST_ENTRY} + _SLIST_ENTRY = _SINGLE_LIST_ENTRY; + {$EXTERNALSYM _SLIST_ENTRY} + PSLIST_ENTRY = PSINGLE_LIST_ENTRY; + {$EXTERNALSYM PSLIST_ENTRY} + TSListEntry = SLIST_ENTRY; + PSListEntry = PSLIST_ENTRY; + +type + _SLIST_HEADER = record + case Integer of + 0: ( + Alignment: ULONGLONG); + 1: ( + Next: SLIST_ENTRY; + Depth: WORD; + Sequence: WORD); + end; + {$EXTERNALSYM _SLIST_HEADER} + SLIST_HEADER = _SLIST_HEADER; + {$EXTERNALSYM SLIST_HEADER} + PSLIST_HEADER = ^SLIST_HEADER; + {$EXTERNALSYM PSLIST_HEADER} + TSListHeader = SLIST_HEADER; + PSListHeader = PSLIST_HEADER; + +procedure RtlInitializeSListHead(ListHead: PSLIST_HEADER); stdcall; +{$EXTERNALSYM RtlInitializeSListHead} +function RtlFirstEntrySList(ListHead: PSLIST_HEADER): PSLIST_ENTRY; stdcall; +{$EXTERNALSYM RtlFirstEntrySList} +function RtlInterlockedPopEntrySList(ListHead: PSLIST_HEADER): PSLIST_ENTRY; stdcall; +{$EXTERNALSYM RtlInterlockedPopEntrySList} +function RtlInterlockedPushEntrySList(ListHead, ListEntry: PSLIST_HEADER): PSLIST_ENTRY; stdcall; +{$EXTERNALSYM RtlInterlockedPushEntrySList} +function RtlInterlockedFlushSList(ListHead: PSLIST_HEADER): PSLIST_ENTRY; stdcall; +{$EXTERNALSYM RtlInterlockedFlushSList} +function RtlQueryDepthSList(ListHead: PSLIST_HEADER): WORD; stdcall; +{$EXTERNALSYM RtlQueryDepthSList} + +const + HEAP_NO_SERIALIZE = $00000001; + {$EXTERNALSYM HEAP_NO_SERIALIZE} + HEAP_GROWABLE = $00000002; + {$EXTERNALSYM HEAP_GROWABLE} + HEAP_GENERATE_EXCEPTIONS = $00000004; + {$EXTERNALSYM HEAP_GENERATE_EXCEPTIONS} + HEAP_ZERO_MEMORY = $00000008; + {$EXTERNALSYM HEAP_ZERO_MEMORY} + HEAP_REALLOC_IN_PLACE_ONLY = $00000010; + {$EXTERNALSYM HEAP_REALLOC_IN_PLACE_ONLY} + HEAP_TAIL_CHECKING_ENABLED = $00000020; + {$EXTERNALSYM HEAP_TAIL_CHECKING_ENABLED} + HEAP_FREE_CHECKING_ENABLED = $00000040; + {$EXTERNALSYM HEAP_FREE_CHECKING_ENABLED} + HEAP_DISABLE_COALESCE_ON_FREE = $00000080; + {$EXTERNALSYM HEAP_DISABLE_COALESCE_ON_FREE} + HEAP_CREATE_ALIGN_16 = $00010000; + {$EXTERNALSYM HEAP_CREATE_ALIGN_16} + HEAP_CREATE_ENABLE_TRACING = $00020000; + {$EXTERNALSYM HEAP_CREATE_ENABLE_TRACING} + HEAP_MAXIMUM_TAG = $0FFF; + {$EXTERNALSYM HEAP_MAXIMUM_TAG} + HEAP_PSEUDO_TAG_FLAG = $8000; + {$EXTERNALSYM HEAP_PSEUDO_TAG_FLAG} + HEAP_TAG_SHIFT = 18; + {$EXTERNALSYM HEAP_TAG_SHIFT} + +function HEAP_MAKE_TAG_FLAGS(b, o: DWORD): DWORD; +{$EXTERNALSYM HEAP_MAKE_TAG_FLAGS} + +procedure RtlCaptureContext(ContextRecord: PCONTEXT); stdcall; +{$EXTERNALSYM RtlCaptureContext} + +const + IS_TEXT_UNICODE_ASCII16 = $0001; + {$EXTERNALSYM IS_TEXT_UNICODE_ASCII16} + IS_TEXT_UNICODE_REVERSE_ASCII16 = $0010; + {$EXTERNALSYM IS_TEXT_UNICODE_REVERSE_ASCII16} + + IS_TEXT_UNICODE_STATISTICS = $0002; + {$EXTERNALSYM IS_TEXT_UNICODE_STATISTICS} + IS_TEXT_UNICODE_REVERSE_STATISTICS = $0020; + {$EXTERNALSYM IS_TEXT_UNICODE_REVERSE_STATISTICS} + + IS_TEXT_UNICODE_CONTROLS = $0004; + {$EXTERNALSYM IS_TEXT_UNICODE_CONTROLS} + IS_TEXT_UNICODE_REVERSE_CONTROLS = $0040; + {$EXTERNALSYM IS_TEXT_UNICODE_REVERSE_CONTROLS} + + IS_TEXT_UNICODE_SIGNATURE = $0008; + {$EXTERNALSYM IS_TEXT_UNICODE_SIGNATURE} + IS_TEXT_UNICODE_REVERSE_SIGNATURE = $0080; + {$EXTERNALSYM IS_TEXT_UNICODE_REVERSE_SIGNATURE} + + IS_TEXT_UNICODE_ILLEGAL_CHARS = $0100; + {$EXTERNALSYM IS_TEXT_UNICODE_ILLEGAL_CHARS} + IS_TEXT_UNICODE_ODD_LENGTH = $0200; + {$EXTERNALSYM IS_TEXT_UNICODE_ODD_LENGTH} + IS_TEXT_UNICODE_DBCS_LEADBYTE = $0400; + {$EXTERNALSYM IS_TEXT_UNICODE_DBCS_LEADBYTE} + IS_TEXT_UNICODE_NULL_BYTES = $1000; + {$EXTERNALSYM IS_TEXT_UNICODE_NULL_BYTES} + + IS_TEXT_UNICODE_UNICODE_MASK = $000F; + {$EXTERNALSYM IS_TEXT_UNICODE_UNICODE_MASK} + IS_TEXT_UNICODE_REVERSE_MASK = $00F0; + {$EXTERNALSYM IS_TEXT_UNICODE_REVERSE_MASK} + IS_TEXT_UNICODE_NOT_UNICODE_MASK = $0F00; + {$EXTERNALSYM IS_TEXT_UNICODE_NOT_UNICODE_MASK} + IS_TEXT_UNICODE_NOT_ASCII_MASK = $F000; + {$EXTERNALSYM IS_TEXT_UNICODE_NOT_ASCII_MASK} + + COMPRESSION_FORMAT_NONE = $0000; + {$EXTERNALSYM COMPRESSION_FORMAT_NONE} + COMPRESSION_FORMAT_DEFAULT = $0001; + {$EXTERNALSYM COMPRESSION_FORMAT_DEFAULT} + COMPRESSION_FORMAT_LZNT1 = $0002; + {$EXTERNALSYM COMPRESSION_FORMAT_LZNT1} + COMPRESSION_ENGINE_STANDARD = $0000; + {$EXTERNALSYM COMPRESSION_ENGINE_STANDARD} + COMPRESSION_ENGINE_MAXIMUM = $0100; + {$EXTERNALSYM COMPRESSION_ENGINE_MAXIMUM} + COMPRESSION_ENGINE_HIBER = $0200; + {$EXTERNALSYM COMPRESSION_ENGINE_HIBER} + +function RtlCompareMemory(const Source1, Source2: Pointer; Length: SIZE_T): SIZE_T; stdcall; +{$EXTERNALSYM RtlCompareMemory} + +type + PMESSAGE_RESOURCE_ENTRY = ^MESSAGE_RESOURCE_ENTRY; + {$EXTERNALSYM PMESSAGE_RESOURCE_ENTRY} + _MESSAGE_RESOURCE_ENTRY = record + Length: Word; + Flags: Word; + Text: array [0..0] of Byte; + end; + {$EXTERNALSYM _MESSAGE_RESOURCE_ENTRY} + MESSAGE_RESOURCE_ENTRY = _MESSAGE_RESOURCE_ENTRY; + {$EXTERNALSYM MESSAGE_RESOURCE_ENTRY} + TMessageResourceEntry = MESSAGE_RESOURCE_ENTRY; + PMessageResourceEntry = PMESSAGE_RESOURCE_ENTRY; + +const + MESSAGE_RESOURCE_UNICODE = $0001; + {$EXTERNALSYM MESSAGE_RESOURCE_UNICODE} + +type + PMESSAGE_RESOURCE_BLOCK = ^MESSAGE_RESOURCE_BLOCK; + {$EXTERNALSYM PMESSAGE_RESOURCE_BLOCK} + _MESSAGE_RESOURCE_BLOCK = record + LowId: DWORD; + HighId: DWORD; + OffsetToEntries: DWORD; + end; + {$EXTERNALSYM _MESSAGE_RESOURCE_BLOCK} + MESSAGE_RESOURCE_BLOCK = _MESSAGE_RESOURCE_BLOCK; + {$EXTERNALSYM MESSAGE_RESOURCE_BLOCK} + TMessageResourceBlock = MESSAGE_RESOURCE_BLOCK; + PMessageResourceBlock = PMESSAGE_RESOURCE_BLOCK; + + PMESSAGE_RESOURCE_DATA = ^MESSAGE_RESOURCE_DATA; + {$EXTERNALSYM PMESSAGE_RESOURCE_DATA} + _MESSAGE_RESOURCE_DATA = record + NumberOfBlocks: DWORD; + Blocks: array [0..0] of MESSAGE_RESOURCE_BLOCK; + end; + {$EXTERNALSYM _MESSAGE_RESOURCE_DATA} + MESSAGE_RESOURCE_DATA = _MESSAGE_RESOURCE_DATA; + {$EXTERNALSYM MESSAGE_RESOURCE_DATA} + TMessageResourceData = MESSAGE_RESOURCE_DATA; + PMessageResourceData = PMESSAGE_RESOURCE_DATA; + + LPOSVERSIONINFOA = ^OSVERSIONINFOA; + {$EXTERNALSYM LPOSVERSIONINFOA} + _OSVERSIONINFOA = record + dwOSVersionInfoSize: DWORD; + dwMajorVersion: DWORD; + dwMinorVersion: DWORD; + dwBuildNumber: DWORD; + dwPlatformId: DWORD; + szCSDVersion: array [0..127] of CHAR; // Maintenance string for PSS usage + end; + {$EXTERNALSYM _OSVERSIONINFOA} + OSVERSIONINFOA = _OSVERSIONINFOA; + {$EXTERNALSYM OSVERSIONINFOA} + TOsVersionInfoA = OSVERSIONINFOA; + POsVersionInfoA = LPOSVERSIONINFOA; + + LPOSVERSIONINFOW = ^OSVERSIONINFOW; + {$EXTERNALSYM LPOSVERSIONINFOW} + _OSVERSIONINFOW = record + dwOSVersionInfoSize: DWORD; + dwMajorVersion: DWORD; + dwMinorVersion: DWORD; + dwBuildNumber: DWORD; + dwPlatformId: DWORD; + szCSDVersion: array [0..127] of WCHAR; // Maintenance string for PSS usage + end; + {$EXTERNALSYM _OSVERSIONINFOW} + OSVERSIONINFOW = _OSVERSIONINFOW; + {$EXTERNALSYM OSVERSIONINFOW} + TOsVersionInfoW = OSVERSIONINFOW; + POsVersionInfoW = LPOSVERSIONINFOW; + + {$IFDEF UNICODE} + OSVERSIONINFO = OSVERSIONINFOW; + {$EXTERNALSYM OSVERSIONINFO} + POSVERSIONINFO = POSVERSIONINFOW; + {$EXTERNALSYM POSVERSIONINFO} + LPOSVERSIONINFO = LPOSVERSIONINFOW; + {$EXTERNALSYM LPOSVERSIONINFO} + TOSVersionInfo = TOSVersionInfoW; + {$ELSE} + OSVERSIONINFO = OSVERSIONINFOA; + {$EXTERNALSYM OSVERSIONINFO} + POSVERSIONINFO = POSVERSIONINFOA; + {$EXTERNALSYM POSVERSIONINFO} + LPOSVERSIONINFO = LPOSVERSIONINFOA; + {$EXTERNALSYM LPOSVERSIONINFO} + TOSVersionInfo = TOSVersionInfoA; + {$ENDIF UNICODE} + +type + POSVERSIONINFOEXA = ^OSVERSIONINFOEXA; + {$EXTERNALSYM POSVERSIONINFOEXA} + _OSVERSIONINFOEXA = record + dwOSVersionInfoSize: DWORD; + dwMajorVersion: DWORD; + dwMinorVersion: DWORD; + dwBuildNumber: DWORD; + dwPlatformId: DWORD; + szCSDVersion: array [0..127] of CHAR; // Maintenance string for PSS usage + wServicePackMajor: WORD; + wServicePackMinor: WORD; + wSuiteMask: WORD; + wProductType: BYTE; + wReserved: BYTE; + end; + {$EXTERNALSYM _OSVERSIONINFOEXA} + OSVERSIONINFOEXA = _OSVERSIONINFOEXA; + {$EXTERNALSYM OSVERSIONINFOEXA} + LPOSVERSIONINFOEXA = ^OSVERSIONINFOEXA; + {$EXTERNALSYM LPOSVERSIONINFOEXA} + TOSVersionInfoExA = _OSVERSIONINFOEXA; + + POSVERSIONINFOEXW = ^OSVERSIONINFOEXW; + {$EXTERNALSYM POSVERSIONINFOEXW} + _OSVERSIONINFOEXW = record + dwOSVersionInfoSize: DWORD; + dwMajorVersion: DWORD; + dwMinorVersion: DWORD; + dwBuildNumber: DWORD; + dwPlatformId: DWORD; + szCSDVersion: array [0..127] of WCHAR; // Maintenance string for PSS usage + wServicePackMajor: WORD; + wServicePackMinor: WORD; + wSuiteMask: WORD; + wProductType: BYTE; + wReserved: BYTE; + end; + {$EXTERNALSYM _OSVERSIONINFOEXW} + OSVERSIONINFOEXW = _OSVERSIONINFOEXW; + {$EXTERNALSYM OSVERSIONINFOEXW} + LPOSVERSIONINFOEXW = ^OSVERSIONINFOEXW; + {$EXTERNALSYM LPOSVERSIONINFOEXW} + RTL_OSVERSIONINFOEXW = _OSVERSIONINFOEXW; + {$EXTERNALSYM RTL_OSVERSIONINFOEXW} + PRTL_OSVERSIONINFOEXW = ^RTL_OSVERSIONINFOEXW; + {$EXTERNALSYM PRTL_OSVERSIONINFOEXW} + TOSVersionInfoExW = _OSVERSIONINFOEXW; + + {$IFDEF UNICODE} + OSVERSIONINFOEX = OSVERSIONINFOEXW; + {$EXTERNALSYM OSVERSIONINFOEX} + POSVERSIONINFOEX = POSVERSIONINFOEXW; + {$EXTERNALSYM POSVERSIONINFOEX} + LPOSVERSIONINFOEX = LPOSVERSIONINFOEXW; + {$EXTERNALSYM LPOSVERSIONINFOEX} + TOSVersionInfoEx = TOSVersionInfoExW; + {$ELSE} + OSVERSIONINFOEX = OSVERSIONINFOEXA; + {$EXTERNALSYM OSVERSIONINFOEX} + POSVERSIONINFOEX = POSVERSIONINFOEXA; + {$EXTERNALSYM POSVERSIONINFOEX} + LPOSVERSIONINFOEX = LPOSVERSIONINFOEXA; + {$EXTERNALSYM LPOSVERSIONINFOEX} + TOSVersionInfoEx = TOSVersionInfoExA; + {$ENDIF UNICODE} + +// +// RtlVerifyVersionInfo() conditions +// + +const + VER_EQUAL = 1; + {$EXTERNALSYM VER_EQUAL} + VER_GREATER = 2; + {$EXTERNALSYM VER_GREATER} + VER_GREATER_EQUAL = 3; + {$EXTERNALSYM VER_GREATER_EQUAL} + VER_LESS = 4; + {$EXTERNALSYM VER_LESS} + VER_LESS_EQUAL = 5; + {$EXTERNALSYM VER_LESS_EQUAL} + VER_AND = 6; + {$EXTERNALSYM VER_AND} + VER_OR = 7; + {$EXTERNALSYM VER_OR} + + VER_CONDITION_MASK = 7; + {$EXTERNALSYM VER_CONDITION_MASK} + VER_NUM_BITS_PER_CONDITION_MASK = 3; + {$EXTERNALSYM VER_NUM_BITS_PER_CONDITION_MASK} + +// +// RtlVerifyVersionInfo() type mask bits +// + + VER_MINORVERSION = $0000001; + {$EXTERNALSYM VER_MINORVERSION} + VER_MAJORVERSION = $0000002; + {$EXTERNALSYM VER_MAJORVERSION} + VER_BUILDNUMBER = $0000004; + {$EXTERNALSYM VER_BUILDNUMBER} + VER_PLATFORMID = $0000008; + {$EXTERNALSYM VER_PLATFORMID} + VER_SERVICEPACKMINOR = $0000010; + {$EXTERNALSYM VER_SERVICEPACKMINOR} + VER_SERVICEPACKMAJOR = $0000020; + {$EXTERNALSYM VER_SERVICEPACKMAJOR} + VER_SUITENAME = $0000040; + {$EXTERNALSYM VER_SUITENAME} + VER_PRODUCT_TYPE = $0000080; + {$EXTERNALSYM VER_PRODUCT_TYPE} + +// +// RtlVerifyVersionInfo() os product type values +// + + VER_NT_WORKSTATION = $0000001; + {$EXTERNALSYM VER_NT_WORKSTATION} + VER_NT_DOMAIN_CONTROLLER = $0000002; + {$EXTERNALSYM VER_NT_DOMAIN_CONTROLLER} + VER_NT_SERVER = $0000003; + {$EXTERNALSYM VER_NT_SERVER} + +// +// dwPlatformId defines: +// + + VER_PLATFORM_WIN32s = 0; + {$EXTERNALSYM VER_PLATFORM_WIN32s} + VER_PLATFORM_WIN32_WINDOWS = 1; + {$EXTERNALSYM VER_PLATFORM_WIN32_WINDOWS} + VER_PLATFORM_WIN32_NT = 2; + {$EXTERNALSYM VER_PLATFORM_WIN32_NT} + +// +// +// VerifyVersionInfo() macro to set the condition mask +// +// For documentation sakes here's the old version of the macro that got +// changed to call an API +// #define VER_SET_CONDITION(_m_,_t_,_c_) _m_=(_m_|(_c_<<(1<<_t_))) +// + +procedure VER_SET_CONDITION(var Mask: DWORDLONG; TypeBitmask, ConditionMask: ULONG); +{$EXTERNALSYM VER_SET_CONDITION} + +function VerSetConditionMask(ConditionMask: ULONGLONG; TypeMask: DWORD; + Condition: BYTE): ULONGLONG; stdcall; +{$EXTERNALSYM VerSetConditionMask} + +type + PRTL_CRITICAL_SECTION_DEBUG = ^RTL_CRITICAL_SECTION_DEBUG; + {$EXTERNALSYM PRTL_CRITICAL_SECTION_DEBUG} + _RTL_CRITICAL_SECTION_DEBUG = record + _Type: WORD; + CreatorBackTraceIndex: WORD; + CriticalSection: PRTL_CRITICAL_SECTION_DEBUG; + ProcessLocksList: LIST_ENTRY; + EntryCount: DWORD; + ContentionCount: DWORD; + Spare: array [0..1] of DWORD; + end; + {$EXTERNALSYM _RTL_CRITICAL_SECTION_DEBUG} + RTL_CRITICAL_SECTION_DEBUG = _RTL_CRITICAL_SECTION_DEBUG; + {$EXTERNALSYM RTL_CRITICAL_SECTION_DEBUG} + TRtlCriticalSectionDebug = RTL_CRITICAL_SECTION_DEBUG; + PRtlCriticalSectionDebug = PRTL_CRITICAL_SECTION_DEBUG; + RTL_RESOURCE_DEBUG = _RTL_CRITICAL_SECTION_DEBUG; + {$EXTERNALSYM RTL_RESOURCE_DEBUG} + PRTL_RESOURCE_DEBUG = RTL_RESOURCE_DEBUG; + {$EXTERNALSYM PRTL_RESOURCE_DEBUG} + TRtlResourceDebug = RTL_CRITICAL_SECTION_DEBUG; + PRtlResourceDebug = PRTL_CRITICAL_SECTION_DEBUG; + +const + RTL_CRITSECT_TYPE = 0; + {$EXTERNALSYM RTL_CRITSECT_TYPE} + RTL_RESOURCE_TYPE = 1; + {$EXTERNALSYM RTL_RESOURCE_TYPE} + +type + PRTL_CRITICAL_SECTION = ^RTL_CRITICAL_SECTION; + {$EXTERNALSYM PRTL_CRITICAL_SECTION} + _RTL_CRITICAL_SECTION = record + DebugInfo: PRTL_CRITICAL_SECTION_DEBUG; + + // + // The following three fields control entering and exiting the critical + // section for the resource + // + + LockCount: LONG; + RecursionCount: LONG; + OwningThread: HANDLE; // from the thread's ClientId->UniqueThread + LockSemaphore: HANDLE; + SpinCount: ULONG_PTR; // force size on 64-bit systems when packed + end; + {$EXTERNALSYM _RTL_CRITICAL_SECTION} + RTL_CRITICAL_SECTION = _RTL_CRITICAL_SECTION; + {$EXTERNALSYM RTL_CRITICAL_SECTION} + TRtlCriticalSection = RTL_CRITICAL_SECTION; + PRtlCriticalSection = PRTL_CRITICAL_SECTION; + + RTL_VERIFIER_DLL_LOAD_CALLBACK = procedure(DllName: PWSTR; DllBase: PVOID; DllSize: SIZE_T; + Reserved: PVOID); stdcall; + {$EXTERNALSYM RTL_VERIFIER_DLL_LOAD_CALLBACK} + + RTL_VERIFIER_DLL_UNLOAD_CALLBACK = procedure(DllName: PWSTR; DllBase: PVOID; DllSize: SIZE_T; + Reserved: PVOID); stdcall; + {$EXTERNALSYM RTL_VERIFIER_DLL_UNLOAD_CALLBACK} + + RTL_VERIFIER_NTDLLHEAPFREE_CALLBACK = procedure(AllocationBase: PVOID; AllocationSize: SIZE_T); stdcall; + {$EXTERNALSYM RTL_VERIFIER_NTDLLHEAPFREE_CALLBACK} + + PRTL_VERIFIER_THUNK_DESCRIPTOR = ^RTL_VERIFIER_THUNK_DESCRIPTOR; + {$EXTERNALSYM PRTL_VERIFIER_THUNK_DESCRIPTOR} + _RTL_VERIFIER_THUNK_DESCRIPTOR = record + ThunkName: PCHAR; + ThunkOldAddress: PVOID; + ThunkNewAddress: PVOID; + end; + {$EXTERNALSYM _RTL_VERIFIER_THUNK_DESCRIPTOR} + RTL_VERIFIER_THUNK_DESCRIPTOR = _RTL_VERIFIER_THUNK_DESCRIPTOR; + {$EXTERNALSYM RTL_VERIFIER_THUNK_DESCRIPTOR} + TRtlVerifierThunkDescriptor = RTL_VERIFIER_THUNK_DESCRIPTOR; + PRtlVerifierThunkDescriptor = PRTL_VERIFIER_THUNK_DESCRIPTOR; + + PRTL_VERIFIER_DLL_DESCRIPTOR = ^RTL_VERIFIER_DLL_DESCRIPTOR; + {$EXTERNALSYM PRTL_VERIFIER_DLL_DESCRIPTOR} + _RTL_VERIFIER_DLL_DESCRIPTOR = record + DllName: PWCHAR; + DllFlags: DWORD; + DllAddress: PVOID; + DllThunks: PRTL_VERIFIER_THUNK_DESCRIPTOR; + end; + {$EXTERNALSYM _RTL_VERIFIER_DLL_DESCRIPTOR} + RTL_VERIFIER_DLL_DESCRIPTOR = _RTL_VERIFIER_DLL_DESCRIPTOR; + {$EXTERNALSYM RTL_VERIFIER_DLL_DESCRIPTOR} + TRtlVerifierDllDescriptor = RTL_VERIFIER_DLL_DESCRIPTOR; + PRtlVerifierDllDescriptor = PRTL_VERIFIER_DLL_DESCRIPTOR; + + PRTL_VERIFIER_PROVIDER_DESCRIPTOR = ^RTL_VERIFIER_PROVIDER_DESCRIPTOR; + {$EXTERNALSYM PRTL_VERIFIER_PROVIDER_DESCRIPTOR} + _RTL_VERIFIER_PROVIDER_DESCRIPTOR = record + // + // Filled by verifier provider DLL + // + Length: DWORD; + ProviderDlls: PRTL_VERIFIER_DLL_DESCRIPTOR; + ProviderDllLoadCallback: RTL_VERIFIER_DLL_LOAD_CALLBACK; + ProviderDllUnloadCallback: RTL_VERIFIER_DLL_UNLOAD_CALLBACK; + // + // Filled by verifier engine + // + VerifierImage: PWSTR; + VerifierFlags: DWORD; + VerifierDebug: DWORD; + + RtlpGetStackTraceAddress: PVOID; + RtlpDebugPageHeapCreate: PVOID; + RtlpDebugPageHeapDestroy: PVOID; + + // + // Filled by verifier provider DLL + // + + ProviderNtdllHeapFreeCallback: RTL_VERIFIER_NTDLLHEAPFREE_CALLBACK; + end; + {$EXTERNALSYM _RTL_VERIFIER_PROVIDER_DESCRIPTOR} + RTL_VERIFIER_PROVIDER_DESCRIPTOR = _RTL_VERIFIER_PROVIDER_DESCRIPTOR; + {$EXTERNALSYM RTL_VERIFIER_PROVIDER_DESCRIPTOR} + TRtlVerifierProviderDescriptor = RTL_VERIFIER_PROVIDER_DESCRIPTOR; + PRtlVerifierProviderDescriptor = PRTL_VERIFIER_PROVIDER_DESCRIPTOR; + +// +// Application verifier standard flags +// + +const + RTL_VRF_FLG_FULL_PAGE_HEAP = $00000001; + {$EXTERNALSYM RTL_VRF_FLG_FULL_PAGE_HEAP} + RTL_VRF_FLG_RESERVED_DONOTUSE = $00000002; // old RTL_VRF_FLG_LOCK_CHECKS + {$EXTERNALSYM RTL_VRF_FLG_RESERVED_DONOTUSE} + RTL_VRF_FLG_HANDLE_CHECKS = $00000004; + {$EXTERNALSYM RTL_VRF_FLG_HANDLE_CHECKS} + RTL_VRF_FLG_STACK_CHECKS = $00000008; + {$EXTERNALSYM RTL_VRF_FLG_STACK_CHECKS} + RTL_VRF_FLG_APPCOMPAT_CHECKS = $00000010; + {$EXTERNALSYM RTL_VRF_FLG_APPCOMPAT_CHECKS} + RTL_VRF_FLG_TLS_CHECKS = $00000020; + {$EXTERNALSYM RTL_VRF_FLG_TLS_CHECKS} + RTL_VRF_FLG_DIRTY_STACKS = $00000040; + {$EXTERNALSYM RTL_VRF_FLG_DIRTY_STACKS} + RTL_VRF_FLG_RPC_CHECKS = $00000080; + {$EXTERNALSYM RTL_VRF_FLG_RPC_CHECKS} + RTL_VRF_FLG_COM_CHECKS = $00000100; + {$EXTERNALSYM RTL_VRF_FLG_COM_CHECKS} + RTL_VRF_FLG_DANGEROUS_APIS = $00000200; + {$EXTERNALSYM RTL_VRF_FLG_DANGEROUS_APIS} + RTL_VRF_FLG_RACE_CHECKS = $00000400; + {$EXTERNALSYM RTL_VRF_FLG_RACE_CHECKS} + RTL_VRF_FLG_DEADLOCK_CHECKS = $00000800; + {$EXTERNALSYM RTL_VRF_FLG_DEADLOCK_CHECKS} + RTL_VRF_FLG_FIRST_CHANCE_EXCEPTION_CHECKS = $00001000; + {$EXTERNALSYM RTL_VRF_FLG_FIRST_CHANCE_EXCEPTION_CHECKS} + RTL_VRF_FLG_VIRTUAL_MEM_CHECKS = $00002000; + {$EXTERNALSYM RTL_VRF_FLG_VIRTUAL_MEM_CHECKS} + RTL_VRF_FLG_ENABLE_LOGGING = $00004000; + {$EXTERNALSYM RTL_VRF_FLG_ENABLE_LOGGING} + RTL_VRF_FLG_FAST_FILL_HEAP = $00008000; + {$EXTERNALSYM RTL_VRF_FLG_FAST_FILL_HEAP} + RTL_VRF_FLG_VIRTUAL_SPACE_TRACKING = $00010000; + {$EXTERNALSYM RTL_VRF_FLG_VIRTUAL_SPACE_TRACKING} + RTL_VRF_FLG_ENABLED_SYSTEM_WIDE = $00020000; + {$EXTERNALSYM RTL_VRF_FLG_ENABLED_SYSTEM_WIDE} + RTL_VRF_FLG_MISCELLANEOUS_CHECKS = $00020000; + {$EXTERNALSYM RTL_VRF_FLG_MISCELLANEOUS_CHECKS} + RTL_VRF_FLG_LOCK_CHECKS = $00040000; + {$EXTERNALSYM RTL_VRF_FLG_LOCK_CHECKS} + +// +// Application verifier standard stop codes +// + + APPLICATION_VERIFIER_INTERNAL_ERROR = DWORD($80000000); + {$EXTERNALSYM APPLICATION_VERIFIER_INTERNAL_ERROR} + APPLICATION_VERIFIER_INTERNAL_WARNING = $40000000; + {$EXTERNALSYM APPLICATION_VERIFIER_INTERNAL_WARNING} + APPLICATION_VERIFIER_NO_BREAK = $20000000; + {$EXTERNALSYM APPLICATION_VERIFIER_NO_BREAK} + APPLICATION_VERIFIER_CONTINUABLE_BREAK = $10000000; + {$EXTERNALSYM APPLICATION_VERIFIER_CONTINUABLE_BREAK} + + APPLICATION_VERIFIER_UNKNOWN_ERROR = $0001; + {$EXTERNALSYM APPLICATION_VERIFIER_UNKNOWN_ERROR} + APPLICATION_VERIFIER_ACCESS_VIOLATION = $0002; + {$EXTERNALSYM APPLICATION_VERIFIER_ACCESS_VIOLATION} + APPLICATION_VERIFIER_UNSYNCHRONIZED_ACCESS = $0003; + {$EXTERNALSYM APPLICATION_VERIFIER_UNSYNCHRONIZED_ACCESS} + APPLICATION_VERIFIER_EXTREME_SIZE_REQUEST = $0004; + {$EXTERNALSYM APPLICATION_VERIFIER_EXTREME_SIZE_REQUEST} + APPLICATION_VERIFIER_BAD_HEAP_HANDLE = $0005; + {$EXTERNALSYM APPLICATION_VERIFIER_BAD_HEAP_HANDLE} + APPLICATION_VERIFIER_SWITCHED_HEAP_HANDLE = $0006; + {$EXTERNALSYM APPLICATION_VERIFIER_SWITCHED_HEAP_HANDLE} + APPLICATION_VERIFIER_DOUBLE_FREE = $0007; + {$EXTERNALSYM APPLICATION_VERIFIER_DOUBLE_FREE} + APPLICATION_VERIFIER_CORRUPTED_HEAP_BLOCK = $0008; + {$EXTERNALSYM APPLICATION_VERIFIER_CORRUPTED_HEAP_BLOCK} + APPLICATION_VERIFIER_DESTROY_PROCESS_HEAP = $0009; + {$EXTERNALSYM APPLICATION_VERIFIER_DESTROY_PROCESS_HEAP} + APPLICATION_VERIFIER_UNEXPECTED_EXCEPTION = $000A; + {$EXTERNALSYM APPLICATION_VERIFIER_UNEXPECTED_EXCEPTION} + APPLICATION_VERIFIER_STACK_OVERFLOW = $000B; + {$EXTERNALSYM APPLICATION_VERIFIER_STACK_OVERFLOW} + + APPLICATION_VERIFIER_TERMINATE_THREAD_CALL = $0100; + {$EXTERNALSYM APPLICATION_VERIFIER_TERMINATE_THREAD_CALL} + APPLICATION_VERIFIER_INVALID_EXIT_PROCESS_CALL = $0101; + {$EXTERNALSYM APPLICATION_VERIFIER_INVALID_EXIT_PROCESS_CALL} + + APPLICATION_VERIFIER_EXIT_THREAD_OWNS_LOCK = $0200; + {$EXTERNALSYM APPLICATION_VERIFIER_EXIT_THREAD_OWNS_LOCK} + APPLICATION_VERIFIER_LOCK_IN_UNLOADED_DLL = $0201; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_IN_UNLOADED_DLL} + APPLICATION_VERIFIER_LOCK_IN_FREED_HEAP = $0202; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_IN_FREED_HEAP} + APPLICATION_VERIFIER_LOCK_DOUBLE_INITIALIZE = $0203; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_DOUBLE_INITIALIZE} + APPLICATION_VERIFIER_LOCK_IN_FREED_MEMORY = $0204; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_IN_FREED_MEMORY} + APPLICATION_VERIFIER_LOCK_CORRUPTED = $0205; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_CORRUPTED} + APPLICATION_VERIFIER_LOCK_INVALID_OWNER = $0206; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_INVALID_OWNER} + APPLICATION_VERIFIER_LOCK_INVALID_RECURSION_COUNT = $0207; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_INVALID_RECURSION_COUNT} + APPLICATION_VERIFIER_LOCK_INVALID_LOCK_COUNT = $0208; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_INVALID_LOCK_COUNT} + APPLICATION_VERIFIER_LOCK_OVER_RELEASED = $0209; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_OVER_RELEASED} + APPLICATION_VERIFIER_LOCK_NOT_INITIALIZED = $0210; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_NOT_INITIALIZED} + APPLICATION_VERIFIER_LOCK_ALREADY_INITIALIZED = $0211; + {$EXTERNALSYM APPLICATION_VERIFIER_LOCK_ALREADY_INITIALIZED} + + APPLICATION_VERIFIER_INVALID_HANDLE = $0300; + {$EXTERNALSYM APPLICATION_VERIFIER_INVALID_HANDLE} + APPLICATION_VERIFIER_INVALID_TLS_VALUE = $0301; + {$EXTERNALSYM APPLICATION_VERIFIER_INVALID_TLS_VALUE} + APPLICATION_VERIFIER_INCORRECT_WAIT_CALL = $0302; + {$EXTERNALSYM APPLICATION_VERIFIER_INCORRECT_WAIT_CALL} + APPLICATION_VERIFIER_NULL_HANDLE = $0303; + {$EXTERNALSYM APPLICATION_VERIFIER_NULL_HANDLE} + APPLICATION_VERIFIER_WAIT_IN_DLLMAIN = $0304; + {$EXTERNALSYM APPLICATION_VERIFIER_WAIT_IN_DLLMAIN} + + APPLICATION_VERIFIER_COM_ERROR = $0400; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_ERROR} + APPLICATION_VERIFIER_COM_API_IN_DLLMAIN = $0401; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_API_IN_DLLMAIN} + APPLICATION_VERIFIER_COM_UNHANDLED_EXCEPTION = $0402; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_UNHANDLED_EXCEPTION} + APPLICATION_VERIFIER_COM_UNBALANCED_COINIT = $0403; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_UNBALANCED_COINIT} + APPLICATION_VERIFIER_COM_UNBALANCED_OLEINIT = $0404; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_UNBALANCED_OLEINIT} + APPLICATION_VERIFIER_COM_UNBALANCED_SWC = $0405; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_UNBALANCED_SWC} + APPLICATION_VERIFIER_COM_NULL_DACL = $0406; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_NULL_DACL} + APPLICATION_VERIFIER_COM_UNSAFE_IMPERSONATION = $0407; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_UNSAFE_IMPERSONATION} + APPLICATION_VERIFIER_COM_SMUGGLED_WRAPPER = $0408; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_SMUGGLED_WRAPPER} + APPLICATION_VERIFIER_COM_SMUGGLED_PROXY = $0409; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_SMUGGLED_PROXY} + APPLICATION_VERIFIER_COM_CF_SUCCESS_WITH_NULL = $040A; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_CF_SUCCESS_WITH_NULL} + APPLICATION_VERIFIER_COM_GCO_SUCCESS_WITH_NULL = $040B; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_GCO_SUCCESS_WITH_NULL} + APPLICATION_VERIFIER_COM_OBJECT_IN_FREED_MEMORY = $040C; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_OBJECT_IN_FREED_MEMORY} + APPLICATION_VERIFIER_COM_OBJECT_IN_UNLOADED_DLL = $040D; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_OBJECT_IN_UNLOADED_DLL} + APPLICATION_VERIFIER_COM_VTBL_IN_FREED_MEMORY = $040E; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_VTBL_IN_FREED_MEMORY} + APPLICATION_VERIFIER_COM_VTBL_IN_UNLOADED_DLL = $040F; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_VTBL_IN_UNLOADED_DLL} + APPLICATION_VERIFIER_COM_HOLDING_LOCKS_ON_CALL = $0410; + {$EXTERNALSYM APPLICATION_VERIFIER_COM_HOLDING_LOCKS_ON_CALL} + + APPLICATION_VERIFIER_RPC_ERROR = $0500; + {$EXTERNALSYM APPLICATION_VERIFIER_RPC_ERROR} + + APPLICATION_VERIFIER_INVALID_FREEMEM = $0600; + {$EXTERNALSYM APPLICATION_VERIFIER_INVALID_FREEMEM} + APPLICATION_VERIFIER_INVALID_ALLOCMEM = $0601; + {$EXTERNALSYM APPLICATION_VERIFIER_INVALID_ALLOCMEM} + APPLICATION_VERIFIER_INVALID_MAPVIEW = $0602; + {$EXTERNALSYM APPLICATION_VERIFIER_INVALID_MAPVIEW} + APPLICATION_VERIFIER_PROBE_INVALID_ADDRESS = $0603; + {$EXTERNALSYM APPLICATION_VERIFIER_PROBE_INVALID_ADDRESS} + APPLICATION_VERIFIER_PROBE_FREE_MEM = $0604; + {$EXTERNALSYM APPLICATION_VERIFIER_PROBE_FREE_MEM} + APPLICATION_VERIFIER_PROBE_GUARD_PAGE = $0605; + {$EXTERNALSYM APPLICATION_VERIFIER_PROBE_GUARD_PAGE} + APPLICATION_VERIFIER_PROBE_NULL = $0606; + {$EXTERNALSYM APPLICATION_VERIFIER_PROBE_NULL} + APPLICATION_VERIFIER_PROBE_INVALID_START_OR_SIZE = $0607; + {$EXTERNALSYM APPLICATION_VERIFIER_PROBE_INVALID_START_OR_SIZE} + +(* TODO +#define VERIFIER_STOP(Code, Msg, P1, S1, P2, S2, P3, S3, P4, S4) { \ + RtlApplicationVerifierStop ((Code), \ + (Msg), \ + (ULONG_PTR)(P1),(S1), \ + (ULONG_PTR)(P2),(S2), \ + (ULONG_PTR)(P3),(S3), \ + (ULONG_PTR)(P4),(S4)); \ + } + +VOID NTAPI +RtlApplicationVerifierStop ( + ULONG_PTR Code, + PCHAR Message, + ULONG_PTR Param1, PCHAR Description1, + ULONG_PTR Param2, PCHAR Description2, + ULONG_PTR Param3, PCHAR Description3, + ULONG_PTR Param4, PCHAR Description4 + ); +*) + +type + PVECTORED_EXCEPTION_HANDLER = function(ExceptionInfo: PEXCEPTION_POINTERS): LONG; stdcall; + {$EXTERNALSYM PVECTORED_EXCEPTION_HANDLER} + PVectoredExceptionHandler = PVECTORED_EXCEPTION_HANDLER; + +const + SEF_DACL_AUTO_INHERIT = $01; + {$EXTERNALSYM SEF_DACL_AUTO_INHERIT} + SEF_SACL_AUTO_INHERIT = $02; + {$EXTERNALSYM SEF_SACL_AUTO_INHERIT} + SEF_DEFAULT_DESCRIPTOR_FOR_OBJECT = $04; + {$EXTERNALSYM SEF_DEFAULT_DESCRIPTOR_FOR_OBJECT} + SEF_AVOID_PRIVILEGE_CHECK = $08; + {$EXTERNALSYM SEF_AVOID_PRIVILEGE_CHECK} + SEF_AVOID_OWNER_CHECK = $10; + {$EXTERNALSYM SEF_AVOID_OWNER_CHECK} + SEF_DEFAULT_OWNER_FROM_PARENT = $20; + {$EXTERNALSYM SEF_DEFAULT_OWNER_FROM_PARENT} + SEF_DEFAULT_GROUP_FROM_PARENT = $40; + {$EXTERNALSYM SEF_DEFAULT_GROUP_FROM_PARENT} + +type + _HEAP_INFORMATION_CLASS = (HeapCompatibilityInformation); + {$EXTERNALSYM _HEAP_INFORMATION_CLASS} + HEAP_INFORMATION_CLASS = _HEAP_INFORMATION_CLASS; + {$EXTERNALSYM HEAP_INFORMATION_CLASS} + THeapInformationClass = HEAP_INFORMATION_CLASS; + +{ TODO +DWORD NTAPI +RtlSetHeapInformation ( + IN PVOID HeapHandle, + IN HEAP_INFORMATION_CLASS HeapInformationClass, + IN PVOID HeapInformation OPTIONAL, + IN SIZE_T HeapInformationLength OPTIONAL + ); + +DWORD NTAPI +RtlQueryHeapInformation ( + IN PVOID HeapHandle, + IN HEAP_INFORMATION_CLASS HeapInformationClass, + OUT PVOID HeapInformation OPTIONAL, + IN SIZE_T HeapInformationLength OPTIONAL, + OUT PSIZE_T ReturnLength OPTIONAL + ); + +// +// Multiple alloc-free APIS +// + +DWORD +NTAPI +RtlMultipleAllocateHeap ( + IN PVOID HeapHandle, + IN DWORD Flags, + IN SIZE_T Size, + IN DWORD Count, + OUT PVOID * Array + ); + +DWORD +NTAPI +RtlMultipleFreeHeap ( + IN PVOID HeapHandle, + IN DWORD Flags, + IN DWORD Count, + OUT PVOID * Array + ); +} + +const + WT_EXECUTEDEFAULT = $00000000; + {$EXTERNALSYM WT_EXECUTEDEFAULT} + WT_EXECUTEINIOTHREAD = $00000001; + {$EXTERNALSYM WT_EXECUTEINIOTHREAD} + WT_EXECUTEINUITHREAD = $00000002; + {$EXTERNALSYM WT_EXECUTEINUITHREAD} + WT_EXECUTEINWAITTHREAD = $00000004; + {$EXTERNALSYM WT_EXECUTEINWAITTHREAD} + WT_EXECUTEONLYONCE = $00000008; + {$EXTERNALSYM WT_EXECUTEONLYONCE} + WT_EXECUTEINTIMERTHREAD = $00000020; + {$EXTERNALSYM WT_EXECUTEINTIMERTHREAD} + WT_EXECUTELONGFUNCTION = $00000010; + {$EXTERNALSYM WT_EXECUTELONGFUNCTION} + WT_EXECUTEINPERSISTENTIOTHREAD = $00000040; + {$EXTERNALSYM WT_EXECUTEINPERSISTENTIOTHREAD} + WT_EXECUTEINPERSISTENTTHREAD = $00000080; + {$EXTERNALSYM WT_EXECUTEINPERSISTENTTHREAD} + WT_TRANSFER_IMPERSONATION = $00000100; + {$EXTERNALSYM WT_TRANSFER_IMPERSONATION} + +function WT_SET_MAX_THREADPOOL_THREADS(var Flags: DWORD; Limit: DWORD): DWORD; +{$EXTERNALSYM WT_SET_MAX_THREADPOOL_THREADS} + +type + WAITORTIMERCALLBACKFUNC = procedure(P: PVOID; B: ByteBool); stdcall; + {$EXTERNALSYM WAITORTIMERCALLBACKFUNC} + WORKERCALLBACKFUNC = procedure(P: PVOID); stdcall; + {$EXTERNALSYM WORKERCALLBACKFUNC} + APC_CALLBACK_FUNCTION = procedure(D: DWORD; P1, P2: PVOID); stdcall; + {$EXTERNALSYM APC_CALLBACK_FUNCTION} + +const + WT_EXECUTEINLONGTHREAD = $00000010; + {$EXTERNALSYM WT_EXECUTEINLONGTHREAD} + WT_EXECUTEDELETEWAIT = $00000008; + {$EXTERNALSYM WT_EXECUTEDELETEWAIT} + +type + _ACTIVATION_CONTEXT_INFO_CLASS = DWORD; + {$EXTERNALSYM _ACTIVATION_CONTEXT_INFO_CLASS} + ACTIVATION_CONTEXT_INFO_CLASS = _ACTIVATION_CONTEXT_INFO_CLASS; + {$EXTERNALSYM ACTIVATION_CONTEXT_INFO_CLASS} + TActivationContextInfoClass = ACTIVATION_CONTEXT_INFO_CLASS; + +const + ActivationContextBasicInformation = 1; + {$EXTERNALSYM ActivationContextBasicInformation} + ActivationContextDetailedInformation = 2; + {$EXTERNALSYM ActivationContextDetailedInformation} + AssemblyDetailedInformationInActivationContxt = 3; + {$EXTERNALSYM AssemblyDetailedInformationInActivationContxt} + FileInformationInAssemblyOfAssemblyInActivationContxt = 4; + {$EXTERNALSYM FileInformationInAssemblyOfAssemblyInActivationContxt} + MaxActivationContextInfoClass = 5; + {$EXTERNALSYM MaxActivationContextInfoClass} + +type + PACTIVATION_CONTEXT_QUERY_INDEX = ^ACTIVATION_CONTEXT_QUERY_INDEX; + {$EXTERNALSYM PACTIVATION_CONTEXT_QUERY_INDEX} + _ACTIVATION_CONTEXT_QUERY_INDEX = record + ulAssemblyIndex: DWORD; + ulFileIndexInAssembly: DWORD; + end; + {$EXTERNALSYM _ACTIVATION_CONTEXT_QUERY_INDEX} + ACTIVATION_CONTEXT_QUERY_INDEX = _ACTIVATION_CONTEXT_QUERY_INDEX; + {$EXTERNALSYM ACTIVATION_CONTEXT_QUERY_INDEX} + TActivationContextQueryIndex = ACTIVATION_CONTEXT_QUERY_INDEX; + PActivationContextQueryIndex = PACTIVATION_CONTEXT_QUERY_INDEX; + +const + ACTIVATION_CONTEXT_PATH_TYPE_NONE = 1; + {$EXTERNALSYM ACTIVATION_CONTEXT_PATH_TYPE_NONE} + ACTIVATION_CONTEXT_PATH_TYPE_WIN32_FILE = 2; + {$EXTERNALSYM ACTIVATION_CONTEXT_PATH_TYPE_WIN32_FILE} + ACTIVATION_CONTEXT_PATH_TYPE_URL = 3; + {$EXTERNALSYM ACTIVATION_CONTEXT_PATH_TYPE_URL} + ACTIVATION_CONTEXT_PATH_TYPE_ASSEMBLYREF = 4; + {$EXTERNALSYM ACTIVATION_CONTEXT_PATH_TYPE_ASSEMBLYREF} + +type + PASSEMBLY_FILE_DETAILED_INFORMATION = ^ASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION; + {$EXTERNALSYM PASSEMBLY_FILE_DETAILED_INFORMATION} + _ASSEMBLY_FILE_DETAILED_INFORMATION = record + ulFlags: DWORD; + ulFilenameLength: DWORD; + ulPathLength: DWORD; + lpFileName: LPCWSTR; + lpFilePath: LPCWSTR; + end; + {$EXTERNALSYM _ASSEMBLY_FILE_DETAILED_INFORMATION} + ASSEMBLY_FILE_DETAILED_INFORMATION = _ASSEMBLY_FILE_DETAILED_INFORMATION; + {$EXTERNALSYM ASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION} + PCASSEMBLY_FILE_DETAILED_INFORMATION = PASSEMBLY_FILE_DETAILED_INFORMATION; + {$EXTERNALSYM PCASSEMBLY_FILE_DETAILED_INFORMATION} + TAssemblyFileDetailedInformation = ASSEMBLY_FILE_DETAILED_INFORMATION; + PAssemblyFileDetailedInformation = PASSEMBLY_FILE_DETAILED_INFORMATION; + +// +// compatibility with old names +// The new names use "file" consistently. +// + + _ASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION = _ASSEMBLY_FILE_DETAILED_INFORMATION; + {$EXTERNALSYM _ASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION} + ASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION = ASSEMBLY_FILE_DETAILED_INFORMATION; + {$EXTERNALSYM ASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION} + PASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION = PASSEMBLY_FILE_DETAILED_INFORMATION; + {$EXTERNALSYM PASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION} + PCASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION = PCASSEMBLY_FILE_DETAILED_INFORMATION; + {$EXTERNALSYM PCASSEMBLY_DLL_REDIRECTION_DETAILED_INFORMATION} + TAssemblyDllRedirectionDetailedInformation = TAssemblyFileDetailedInformation; + PAssemblyDllRedirectionDetailedInformation = PAssemblyFileDetailedInformation; + + PACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION = ^ACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION; + {$EXTERNALSYM PACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION} + _ACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION = record + ulFlags: DWORD; + ulEncodedAssemblyIdentityLength: DWORD; // in bytes + ulManifestPathType: DWORD; // ACTIVATION_CONTEXT_PATH_TYPE_* + ulManifestPathLength: DWORD; // in bytes + liManifestLastWriteTime: LARGE_INTEGER; // FILETIME + ulPolicyPathType: DWORD; // ACTIVATION_CONTEXT_PATH_TYPE_* + ulPolicyPathLength: DWORD; // in bytes + liPolicyLastWriteTime: LARGE_INTEGER; // FILETIME + ulMetadataSatelliteRosterIndex: DWORD; + ulManifestVersionMajor: DWORD; // 1 + ulManifestVersionMinor: DWORD; // 0 + ulPolicyVersionMajor: DWORD; // 0 + ulPolicyVersionMinor: DWORD; // 0 + ulAssemblyDirectoryNameLength: DWORD; // in bytes + lpAssemblyEncodedAssemblyIdentity: LPCWSTR; + lpAssemblyManifestPath: LPCWSTR; + lpAssemblyPolicyPath: LPCWSTR; + lpAssemblyDirectoryName: LPCWSTR; + ulFileCount: DWORD; + end; + {$EXTERNALSYM _ACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION} + ACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION = _ACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION; + {$EXTERNALSYM ACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION} + TActivationContextAssemblyDetailedInformation = ACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION; + PActivationContextAssemblyDetailedInformation = PACTIVATION_CONTEXT_ASSEMBLY_DETAILED_INFORMATION; + + PACTIVATION_CONTEXT_DETAILED_INFORMATION = ^ACTIVATION_CONTEXT_DETAILED_INFORMATION; + {$EXTERNALSYM PACTIVATION_CONTEXT_DETAILED_INFORMATION} + _ACTIVATION_CONTEXT_DETAILED_INFORMATION = record + dwFlags: DWORD; + ulFormatVersion: DWORD; + ulAssemblyCount: DWORD; + ulRootManifestPathType: DWORD; + ulRootManifestPathChars: DWORD; + ulRootConfigurationPathType: DWORD; + ulRootConfigurationPathChars: DWORD; + ulAppDirPathType: DWORD; + ulAppDirPathChars: DWORD; + lpRootManifestPath: LPCWSTR; + lpRootConfigurationPath: LPCWSTR; + lpAppDirPath: LPCWSTR; + end; + {$EXTERNALSYM _ACTIVATION_CONTEXT_DETAILED_INFORMATION} + ACTIVATION_CONTEXT_DETAILED_INFORMATION = _ACTIVATION_CONTEXT_DETAILED_INFORMATION; + {$EXTERNALSYM ACTIVATION_CONTEXT_DETAILED_INFORMATION} + TActivationContextDetailedInformation = ACTIVATION_CONTEXT_DETAILED_INFORMATION; + PActivationContextDetailedInformation = PACTIVATION_CONTEXT_DETAILED_INFORMATION; + +const + DLL_PROCESS_ATTACH = 1; + {$EXTERNALSYM DLL_PROCESS_ATTACH} + DLL_THREAD_ATTACH = 2; + {$EXTERNALSYM DLL_THREAD_ATTACH} + DLL_THREAD_DETACH = 3; + {$EXTERNALSYM DLL_THREAD_DETACH} + DLL_PROCESS_DETACH = 0; + {$EXTERNALSYM DLL_PROCESS_DETACH} + DLL_PROCESS_VERIFIER = 4; + {$EXTERNALSYM DLL_PROCESS_VERIFIER} + +// +// Defines for the READ flags for Eventlogging +// + + EVENTLOG_SEQUENTIAL_READ = $0001; + {$EXTERNALSYM EVENTLOG_SEQUENTIAL_READ} + EVENTLOG_SEEK_READ = $0002; + {$EXTERNALSYM EVENTLOG_SEEK_READ} + EVENTLOG_FORWARDS_READ = $0004; + {$EXTERNALSYM EVENTLOG_FORWARDS_READ} + EVENTLOG_BACKWARDS_READ = $0008; + {$EXTERNALSYM EVENTLOG_BACKWARDS_READ} + +// +// The types of events that can be logged. +// + + EVENTLOG_SUCCESS = $0000; + {$EXTERNALSYM EVENTLOG_SUCCESS} + EVENTLOG_ERROR_TYPE = $0001; + {$EXTERNALSYM EVENTLOG_ERROR_TYPE} + EVENTLOG_WARNING_TYPE = $0002; + {$EXTERNALSYM EVENTLOG_WARNING_TYPE} + EVENTLOG_INFORMATION_TYPE = $0004; + {$EXTERNALSYM EVENTLOG_INFORMATION_TYPE} + EVENTLOG_AUDIT_SUCCESS = $0008; + {$EXTERNALSYM EVENTLOG_AUDIT_SUCCESS} + EVENTLOG_AUDIT_FAILURE = $0010; + {$EXTERNALSYM EVENTLOG_AUDIT_FAILURE} + +// +// Defines for the WRITE flags used by Auditing for paired events +// These are not implemented in Product 1 +// + + EVENTLOG_START_PAIRED_EVENT = $0001; + {$EXTERNALSYM EVENTLOG_START_PAIRED_EVENT} + EVENTLOG_END_PAIRED_EVENT = $0002; + {$EXTERNALSYM EVENTLOG_END_PAIRED_EVENT} + EVENTLOG_END_ALL_PAIRED_EVENTS = $0004; + {$EXTERNALSYM EVENTLOG_END_ALL_PAIRED_EVENTS} + EVENTLOG_PAIRED_EVENT_ACTIVE = $0008; + {$EXTERNALSYM EVENTLOG_PAIRED_EVENT_ACTIVE} + EVENTLOG_PAIRED_EVENT_INACTIVE = $0010; + {$EXTERNALSYM EVENTLOG_PAIRED_EVENT_INACTIVE} + +// +// Structure that defines the header of the Eventlog record. This is the +// fixed-sized portion before all the variable-length strings, binary +// data and pad bytes. +// +// TimeGenerated is the time it was generated at the client. +// TimeWritten is the time it was put into the log at the server end. +// + +type + PEventlogrecord = ^EVENTLOGRECORD; + _EVENTLOGRECORD = record + Length: DWORD; // Length of full record + Reserved: DWORD; // Used by the service + RecordNumber: DWORD; // Absolute record number + TimeGenerated: DWORD; // Seconds since 1-1-1970 + TimeWritten: DWORD; // Seconds since 1-1-1970 + EventID: DWORD; + EventType: Word; + NumStrings: Word; + EventCategory: Word; + ReservedFlags: Word; // For use with paired events (auditing) + ClosingRecordNumber: DWORD; // For use with paired events (auditing) + StringOffset: DWORD; // Offset from beginning of record + UserSidLength: DWORD; + UserSidOffset: DWORD; + DataLength: DWORD; + DataOffset: DWORD; // Offset from beginning of record + // + // Then follow: + // + // WCHAR SourceName[] + // WCHAR Computername[] + // SID UserSid + // WCHAR Strings[] + // BYTE Data[] + // CHAR Pad[] + // DWORD Length; + // + end; + {$EXTERNALSYM _EVENTLOGRECORD} + EVENTLOGRECORD = _EVENTLOGRECORD; + {$EXTERNALSYM EVENTLOGRECORD} + TEventlogrecord = EVENTLOGRECORD; + +const + MAXLOGICALLOGNAMESIZE = 256; + {$EXTERNALSYM MAXLOGICALLOGNAMESIZE} + +type + PEventsForLogFile = ^EVENTSFORLOGFILE; + _EVENTSFORLOGFILE = record + ulSize: DWORD; + szLogicalLogFile: array [0..MAXLOGICALLOGNAMESIZE - 1] of WCHAR; // name of the logical file-security/application/system + ulNumRecords: DWORD; + pEventLogRecords: array [0..0] of EVENTLOGRECORD; + end; + {$EXTERNALSYM _EVENTSFORLOGFILE} + EVENTSFORLOGFILE = _EVENTSFORLOGFILE; + {$EXTERNALSYM EVENTSFORLOGFILE} + TEventsForLogFile = EVENTSFORLOGFILE; + + PPackedEventInfo = ^PACKEDEVENTINFO; + _PACKEDEVENTINFO = record + ulSize: DWORD; // total size of the structure + ulNumEventsForLogFile: DWORD; // number of EventsForLogFile structure that follow + ulOffsets: array [0..0] of DWORD; // the offsets from the start of this structure to the EVENTSFORLOGFILE structure + end; + {$EXTERNALSYM _PACKEDEVENTINFO} + PACKEDEVENTINFO = _PACKEDEVENTINFO; + {$EXTERNALSYM PACKEDEVENTINFO} + TPackedEventInfo = PACKEDEVENTINFO; + +// +// Registry Specific Access Rights. +// + +const + KEY_QUERY_VALUE = $0001; + {$EXTERNALSYM KEY_QUERY_VALUE} + KEY_SET_VALUE = $0002; + {$EXTERNALSYM KEY_SET_VALUE} + KEY_CREATE_SUB_KEY = $0004; + {$EXTERNALSYM KEY_CREATE_SUB_KEY} + KEY_ENUMERATE_SUB_KEYS = $0008; + {$EXTERNALSYM KEY_ENUMERATE_SUB_KEYS} + KEY_NOTIFY = $0010; + {$EXTERNALSYM KEY_NOTIFY} + KEY_CREATE_LINK = $0020; + {$EXTERNALSYM KEY_CREATE_LINK} + KEY_WOW64_32KEY = $0200; + {$EXTERNALSYM KEY_WOW64_32KEY} + KEY_WOW64_64KEY = $0100; + {$EXTERNALSYM KEY_WOW64_64KEY} + KEY_WOW64_RES = $0300; + {$EXTERNALSYM KEY_WOW64_RES} + + KEY_READ = STANDARD_RIGHTS_READ or KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS or + KEY_NOTIFY and (not SYNCHRONIZE); + {$EXTERNALSYM KEY_READ} + + KEY_WRITE = STANDARD_RIGHTS_WRITE or KEY_SET_VALUE or KEY_CREATE_SUB_KEY and + (not SYNCHRONIZE); + {$EXTERNALSYM KEY_WRITE} + + KEY_EXECUTE = KEY_READ and (not SYNCHRONIZE); + {$EXTERNALSYM KEY_EXECUTE} + + KEY_ALL_ACCESS = STANDARD_RIGHTS_ALL or KEY_QUERY_VALUE or KEY_SET_VALUE or + KEY_CREATE_SUB_KEY or KEY_ENUMERATE_SUB_KEYS or KEY_NOTIFY or + KEY_CREATE_LINK and (not SYNCHRONIZE); + {$EXTERNALSYM KEY_ALL_ACCESS} + +// +// Open/Create Options +// + + REG_OPTION_RESERVED = $00000000; // Parameter is reserved + {$EXTERNALSYM REG_OPTION_RESERVED} + + REG_OPTION_NON_VOLATILE = $00000000; // Key is preserved when system is rebooted + {$EXTERNALSYM REG_OPTION_NON_VOLATILE} + + REG_OPTION_VOLATILE = $00000001; // Key is not preserved when system is rebooted + {$EXTERNALSYM REG_OPTION_VOLATILE} + + REG_OPTION_CREATE_LINK = $00000002; // Created key is a symbolic link + {$EXTERNALSYM REG_OPTION_CREATE_LINK} + + REG_OPTION_BACKUP_RESTORE = $00000004; // open for backup or restore + {$EXTERNALSYM REG_OPTION_BACKUP_RESTORE} + // special access rules + // privilege required + + REG_OPTION_OPEN_LINK = $00000008; // Open symbolic link + {$EXTERNALSYM REG_OPTION_OPEN_LINK} + + REG_LEGAL_OPTION = REG_OPTION_RESERVED or REG_OPTION_NON_VOLATILE or + REG_OPTION_VOLATILE or REG_OPTION_CREATE_LINK or REG_OPTION_BACKUP_RESTORE or + REG_OPTION_OPEN_LINK; + {$EXTERNALSYM REG_LEGAL_OPTION} + +// +// Key creation/open disposition +// + + REG_CREATED_NEW_KEY = $00000001; // New Registry Key created + {$EXTERNALSYM REG_CREATED_NEW_KEY} + REG_OPENED_EXISTING_KEY = $00000002; // Existing Key opened + {$EXTERNALSYM REG_OPENED_EXISTING_KEY} + +// +// hive format to be used by Reg(Nt)SaveKeyEx +// + + REG_STANDARD_FORMAT = 1; + {$EXTERNALSYM REG_STANDARD_FORMAT} + REG_LATEST_FORMAT = 2; + {$EXTERNALSYM REG_LATEST_FORMAT} + REG_NO_COMPRESSION = 4; + {$EXTERNALSYM REG_NO_COMPRESSION} + +// +// Key restore flags +// + + REG_WHOLE_HIVE_VOLATILE = $00000001; // Restore whole hive volatile + {$EXTERNALSYM REG_WHOLE_HIVE_VOLATILE} + REG_REFRESH_HIVE = $00000002; // Unwind changes to last flush + {$EXTERNALSYM REG_REFRESH_HIVE} + REG_NO_LAZY_FLUSH = $00000004; // Never lazy flush this hive + {$EXTERNALSYM REG_NO_LAZY_FLUSH} + REG_FORCE_RESTORE = $00000008; // Force the restore process even when we have open handles on subkeys + {$EXTERNALSYM REG_FORCE_RESTORE} + +// +// Unload Flags +// + + REG_FORCE_UNLOAD = 1; + {$EXTERNALSYM REG_FORCE_UNLOAD} + +// end_ntddk end_wdm end_nthal + +// +// Notify filter values +// + + REG_NOTIFY_CHANGE_NAME = $00000001; // Create or delete (child) + {$EXTERNALSYM REG_NOTIFY_CHANGE_NAME} + REG_NOTIFY_CHANGE_ATTRIBUTES = $00000002; + {$EXTERNALSYM REG_NOTIFY_CHANGE_ATTRIBUTES} + REG_NOTIFY_CHANGE_LAST_SET = $00000004; // time stamp + {$EXTERNALSYM REG_NOTIFY_CHANGE_LAST_SET} + REG_NOTIFY_CHANGE_SECURITY = $00000008; + {$EXTERNALSYM REG_NOTIFY_CHANGE_SECURITY} + + REG_LEGAL_CHANGE_FILTER = REG_NOTIFY_CHANGE_NAME or REG_NOTIFY_CHANGE_ATTRIBUTES or + REG_NOTIFY_CHANGE_LAST_SET or REG_NOTIFY_CHANGE_SECURITY; + {$EXTERNALSYM REG_LEGAL_CHANGE_FILTER} + +// +// +// Predefined Value Types. +// + + REG_NONE = 0; // No value type + {$EXTERNALSYM REG_NONE} + REG_SZ = 1; // Unicode nul terminated string + {$EXTERNALSYM REG_SZ} + REG_EXPAND_SZ = 2; // Unicode nul terminated string + {$EXTERNALSYM REG_EXPAND_SZ} + // (with environment variable references) + REG_BINARY = 3; // Free form binary + {$EXTERNALSYM REG_BINARY} + REG_DWORD = 4; // 32-bit number + {$EXTERNALSYM REG_DWORD} + REG_DWORD_LITTLE_ENDIAN = 4; // 32-bit number (same as REG_DWORD) + {$EXTERNALSYM REG_DWORD_LITTLE_ENDIAN} + REG_DWORD_BIG_ENDIAN = 5; // 32-bit number + {$EXTERNALSYM REG_DWORD_BIG_ENDIAN} + REG_LINK = 6; // Symbolic Link (unicode) + {$EXTERNALSYM REG_LINK} + REG_MULTI_SZ = 7; // Multiple Unicode strings + {$EXTERNALSYM REG_MULTI_SZ} + REG_RESOURCE_LIST = 8; // Resource list in the resource map + {$EXTERNALSYM REG_RESOURCE_LIST} + REG_FULL_RESOURCE_DESCRIPTOR = 9; // Resource list in the hardware description + {$EXTERNALSYM REG_FULL_RESOURCE_DESCRIPTOR} + REG_RESOURCE_REQUIREMENTS_LIST = 10; + {$EXTERNALSYM REG_RESOURCE_REQUIREMENTS_LIST} + REG_QWORD = 11; // 64-bit number + {$EXTERNALSYM REG_QWORD} + REG_QWORD_LITTLE_ENDIAN = 11; // 64-bit number (same as REG_QWORD) + {$EXTERNALSYM REG_QWORD_LITTLE_ENDIAN} + +// +// Service Types (Bit Mask) +// + + SERVICE_KERNEL_DRIVER = $00000001; + {$EXTERNALSYM SERVICE_KERNEL_DRIVER} + SERVICE_FILE_SYSTEM_DRIVER = $00000002; + {$EXTERNALSYM SERVICE_FILE_SYSTEM_DRIVER} + SERVICE_ADAPTER = $00000004; + {$EXTERNALSYM SERVICE_ADAPTER} + SERVICE_RECOGNIZER_DRIVER = $00000008; + {$EXTERNALSYM SERVICE_RECOGNIZER_DRIVER} + + SERVICE_DRIVER = SERVICE_KERNEL_DRIVER or SERVICE_FILE_SYSTEM_DRIVER or + SERVICE_RECOGNIZER_DRIVER; + {$EXTERNALSYM SERVICE_DRIVER} + + SERVICE_WIN32_OWN_PROCESS = $00000010; + {$EXTERNALSYM SERVICE_WIN32_OWN_PROCESS} + SERVICE_WIN32_SHARE_PROCESS = $00000020; + {$EXTERNALSYM SERVICE_WIN32_SHARE_PROCESS} + + SERVICE_WIN32 = SERVICE_WIN32_OWN_PROCESS or SERVICE_WIN32_SHARE_PROCESS; + {$EXTERNALSYM SERVICE_WIN32} + + SERVICE_INTERACTIVE_PROCESS = $00000100; + {$EXTERNALSYM SERVICE_INTERACTIVE_PROCESS} + + SERVICE_TYPE_ALL = SERVICE_WIN32 or SERVICE_ADAPTER or SERVICE_DRIVER or + SERVICE_INTERACTIVE_PROCESS; + {$EXTERNALSYM SERVICE_TYPE_ALL} + +// +// Start Type +// + + SERVICE_BOOT_START = $00000000; + {$EXTERNALSYM SERVICE_BOOT_START} + SERVICE_SYSTEM_START = $00000001; + {$EXTERNALSYM SERVICE_SYSTEM_START} + SERVICE_AUTO_START = $00000002; + {$EXTERNALSYM SERVICE_AUTO_START} + SERVICE_DEMAND_START = $00000003; + {$EXTERNALSYM SERVICE_DEMAND_START} + SERVICE_DISABLED = $00000004; + {$EXTERNALSYM SERVICE_DISABLED} + +// +// Error control type +// + + SERVICE_ERROR_IGNORE = $00000000; + {$EXTERNALSYM SERVICE_ERROR_IGNORE} + SERVICE_ERROR_NORMAL = $00000001; + {$EXTERNALSYM SERVICE_ERROR_NORMAL} + SERVICE_ERROR_SEVERE = $00000002; + {$EXTERNALSYM SERVICE_ERROR_SEVERE} + SERVICE_ERROR_CRITICAL = $00000003; + {$EXTERNALSYM SERVICE_ERROR_CRITICAL} + +// +// Define the registry driver node enumerations +// + +const + +//SERVICE_NODE_TYPE + + DriverType = SERVICE_KERNEL_DRIVER; + FileSystemType = SERVICE_FILE_SYSTEM_DRIVER; + Win32ServiceOwnProcess = SERVICE_WIN32_OWN_PROCESS; + Win32ServiceShareProcess = SERVICE_WIN32_SHARE_PROCESS; + AdapterType = SERVICE_ADAPTER; + RecognizerType = SERVICE_RECOGNIZER_DRIVER; + +//SERVICE_LOAD_TYPE + + BootLoad = SERVICE_BOOT_START; + SystemLoad = SERVICE_SYSTEM_START; + AutoLoad = SERVICE_AUTO_START; + DemandLoad = SERVICE_DEMAND_START; + DisableLoad = SERVICE_DISABLED; + +//SERVICE_ERROR_TYPE + + IgnoreError = SERVICE_ERROR_IGNORE; + NormalError = SERVICE_ERROR_NORMAL; + SevereError = SERVICE_ERROR_SEVERE; + CriticalError = SERVICE_ERROR_CRITICAL; + +// +// IOCTL_TAPE_ERASE definitions +// + +type + SERVICE_NODE_TYPE = DWORD; + {$EXTERNALSYM SERVICE_NODE_TYPE} + TServiceNodeType = SERVICE_NODE_TYPE; + SERVICE_LOAD_TYPE = DWORD; + {$EXTERNALSYM SERVICE_LOAD_TYPE} + TServiceLoadType = SERVICE_LOAD_TYPE; + SERVICE_ERROR_TYPE = DWORD; + {$EXTERNALSYM SERVICE_ERROR_TYPE} + TServiceErrorType = SERVICE_ERROR_TYPE; + +const + TAPE_ERASE_SHORT = 0; + {$EXTERNALSYM TAPE_ERASE_SHORT} + TAPE_ERASE_LONG = 1; + {$EXTERNALSYM TAPE_ERASE_LONG} + +type + PTAPE_ERASE = ^TAPE_ERASE; + {$EXTERNALSYM PTAPE_ERASE} + _TAPE_ERASE = record + Type_: DWORD; + Immediate: ByteBool; + end; + {$EXTERNALSYM _TAPE_ERASE} + TAPE_ERASE = _TAPE_ERASE; + {$EXTERNALSYM TAPE_ERASE} + TTapeErase = TAPE_ERASE; + PTapeErase = PTAPE_ERASE; + +// +// IOCTL_TAPE_PREPARE definitions +// + +const + TAPE_LOAD = 0; + {$EXTERNALSYM TAPE_LOAD} + TAPE_UNLOAD = 1; + {$EXTERNALSYM TAPE_UNLOAD} + TAPE_TENSION = 2; + {$EXTERNALSYM TAPE_TENSION} + TAPE_LOCK = 3; + {$EXTERNALSYM TAPE_LOCK} + TAPE_UNLOCK = 4; + {$EXTERNALSYM TAPE_UNLOCK} + TAPE_FORMAT = 5; + {$EXTERNALSYM TAPE_FORMAT} + +type + PTAPE_PREPARE = ^TAPE_PREPARE; + {$EXTERNALSYM PTAPE_PREPARE} + _TAPE_PREPARE = record + Operation: DWORD; + Immediate: ByteBool; + end; + {$EXTERNALSYM _TAPE_PREPARE} + TAPE_PREPARE = _TAPE_PREPARE; + {$EXTERNALSYM TAPE_PREPARE} + TTapePrepare = TAPE_PREPARE; + PTapePrepare = PTAPE_PREPARE; + +// +// IOCTL_TAPE_WRITE_MARKS definitions +// + +const + TAPE_SETMARKS = 0; + {$EXTERNALSYM TAPE_SETMARKS} + TAPE_FILEMARKS = 1; + {$EXTERNALSYM TAPE_FILEMARKS} + TAPE_SHORT_FILEMARKS = 2; + {$EXTERNALSYM TAPE_SHORT_FILEMARKS} + TAPE_LONG_FILEMARKS = 3; + {$EXTERNALSYM TAPE_LONG_FILEMARKS} + +type + PTAPE_WRITE_MARKS = ^TAPE_WRITE_MARKS; + {$EXTERNALSYM PTAPE_WRITE_MARKS} + _TAPE_WRITE_MARKS = record + Type_: DWORD; + Count: DWORD; + Immediate: ByteBool; + end; + {$EXTERNALSYM _TAPE_WRITE_MARKS} + TAPE_WRITE_MARKS = _TAPE_WRITE_MARKS; + {$EXTERNALSYM TAPE_WRITE_MARKS} + TTapeWriteMarks = TAPE_WRITE_MARKS; + PTapeWriteMarks = PTAPE_WRITE_MARKS; + +// +// IOCTL_TAPE_GET_POSITION definitions +// + +const + TAPE_ABSOLUTE_POSITION = 0; + {$EXTERNALSYM TAPE_ABSOLUTE_POSITION} + TAPE_LOGICAL_POSITION = 1; + {$EXTERNALSYM TAPE_LOGICAL_POSITION} + TAPE_PSEUDO_LOGICAL_POSITION = 2; + {$EXTERNALSYM TAPE_PSEUDO_LOGICAL_POSITION} + +type + PTAPE_GET_POSITION = ^TAPE_GET_POSITION; + {$EXTERNALSYM PTAPE_GET_POSITION} + _TAPE_GET_POSITION = record + Type_: DWORD; + Partition: DWORD; + Offset: LARGE_INTEGER; + end; + {$EXTERNALSYM _TAPE_GET_POSITION} + TAPE_GET_POSITION = _TAPE_GET_POSITION; + {$EXTERNALSYM TAPE_GET_POSITION} + TTapeGetPosition = TAPE_GET_POSITION; + PTapeGetPosition = PTAPE_GET_POSITION; + +// +// IOCTL_TAPE_SET_POSITION definitions +// + +const + TAPE_REWIND = 0; + {$EXTERNALSYM TAPE_REWIND} + TAPE_ABSOLUTE_BLOCK = 1; + {$EXTERNALSYM TAPE_ABSOLUTE_BLOCK} + TAPE_LOGICAL_BLOCK = 2; + {$EXTERNALSYM TAPE_LOGICAL_BLOCK} + TAPE_PSEUDO_LOGICAL_BLOCK = 3; + {$EXTERNALSYM TAPE_PSEUDO_LOGICAL_BLOCK} + TAPE_SPACE_END_OF_DATA = 4; + {$EXTERNALSYM TAPE_SPACE_END_OF_DATA} + TAPE_SPACE_RELATIVE_BLOCKS = 5; + {$EXTERNALSYM TAPE_SPACE_RELATIVE_BLOCKS} + TAPE_SPACE_FILEMARKS = 6; + {$EXTERNALSYM TAPE_SPACE_FILEMARKS} + TAPE_SPACE_SEQUENTIAL_FMKS = 7; + {$EXTERNALSYM TAPE_SPACE_SEQUENTIAL_FMKS} + TAPE_SPACE_SETMARKS = 8; + {$EXTERNALSYM TAPE_SPACE_SETMARKS} + TAPE_SPACE_SEQUENTIAL_SMKS = 9; + {$EXTERNALSYM TAPE_SPACE_SEQUENTIAL_SMKS} + +type + PTAPE_SET_POSITION = ^TAPE_SET_POSITION; + {$EXTERNALSYM PTAPE_SET_POSITION} + _TAPE_SET_POSITION = record + Method: DWORD; + Partition: DWORD; + Offset: LARGE_INTEGER; + Immediate: ByteBool; + end; + {$EXTERNALSYM _TAPE_SET_POSITION} + TAPE_SET_POSITION = _TAPE_SET_POSITION; + {$EXTERNALSYM TAPE_SET_POSITION} + TTapeSetPosition = TAPE_SET_POSITION; + PTapeSetPosition = PTAPE_SET_POSITION; + +// +// IOCTL_TAPE_GET_DRIVE_PARAMS definitions +// + +// +// Definitions for FeaturesLow parameter +// + +const + TAPE_DRIVE_FIXED = $00000001; + {$EXTERNALSYM TAPE_DRIVE_FIXED} + TAPE_DRIVE_SELECT = $00000002; + {$EXTERNALSYM TAPE_DRIVE_SELECT} + TAPE_DRIVE_INITIATOR = $00000004; + {$EXTERNALSYM TAPE_DRIVE_INITIATOR} + + TAPE_DRIVE_ERASE_SHORT = $00000010; + {$EXTERNALSYM TAPE_DRIVE_ERASE_SHORT} + TAPE_DRIVE_ERASE_LONG = $00000020; + {$EXTERNALSYM TAPE_DRIVE_ERASE_LONG} + TAPE_DRIVE_ERASE_BOP_ONLY = $00000040; + {$EXTERNALSYM TAPE_DRIVE_ERASE_BOP_ONLY} + TAPE_DRIVE_ERASE_IMMEDIATE = $00000080; + {$EXTERNALSYM TAPE_DRIVE_ERASE_IMMEDIATE} + + TAPE_DRIVE_TAPE_CAPACITY = $00000100; + {$EXTERNALSYM TAPE_DRIVE_TAPE_CAPACITY} + TAPE_DRIVE_TAPE_REMAINING = $00000200; + {$EXTERNALSYM TAPE_DRIVE_TAPE_REMAINING} + TAPE_DRIVE_FIXED_BLOCK = $00000400; + {$EXTERNALSYM TAPE_DRIVE_FIXED_BLOCK} + TAPE_DRIVE_VARIABLE_BLOCK = $00000800; + {$EXTERNALSYM TAPE_DRIVE_VARIABLE_BLOCK} + + TAPE_DRIVE_WRITE_PROTECT = $00001000; + {$EXTERNALSYM TAPE_DRIVE_WRITE_PROTECT} + TAPE_DRIVE_EOT_WZ_SIZE = $00002000; + {$EXTERNALSYM TAPE_DRIVE_EOT_WZ_SIZE} + + TAPE_DRIVE_ECC = $00010000; + {$EXTERNALSYM TAPE_DRIVE_ECC} + TAPE_DRIVE_COMPRESSION = $00020000; + {$EXTERNALSYM TAPE_DRIVE_COMPRESSION} + TAPE_DRIVE_PADDING = $00040000; + {$EXTERNALSYM TAPE_DRIVE_PADDING} + TAPE_DRIVE_REPORT_SMKS = $00080000; + {$EXTERNALSYM TAPE_DRIVE_REPORT_SMKS} + + TAPE_DRIVE_GET_ABSOLUTE_BLK = $00100000; + {$EXTERNALSYM TAPE_DRIVE_GET_ABSOLUTE_BLK} + TAPE_DRIVE_GET_LOGICAL_BLK = $00200000; + {$EXTERNALSYM TAPE_DRIVE_GET_LOGICAL_BLK} + TAPE_DRIVE_SET_EOT_WZ_SIZE = $00400000; + {$EXTERNALSYM TAPE_DRIVE_SET_EOT_WZ_SIZE} + + TAPE_DRIVE_EJECT_MEDIA = $01000000; + {$EXTERNALSYM TAPE_DRIVE_EJECT_MEDIA} + TAPE_DRIVE_CLEAN_REQUESTS = $02000000; + {$EXTERNALSYM TAPE_DRIVE_CLEAN_REQUESTS} + TAPE_DRIVE_SET_CMP_BOP_ONLY = $04000000; + {$EXTERNALSYM TAPE_DRIVE_SET_CMP_BOP_ONLY} + + TAPE_DRIVE_RESERVED_BIT = DWORD($80000000); // don't use this bit! + {$EXTERNALSYM TAPE_DRIVE_RESERVED_BIT} + // //can't be a low features bit! +// //reserved; high features only + +// +// Definitions for FeaturesHigh parameter +// + + TAPE_DRIVE_LOAD_UNLOAD = DWORD($80000001); + {$EXTERNALSYM TAPE_DRIVE_LOAD_UNLOAD} + TAPE_DRIVE_TENSION = DWORD($80000002); + {$EXTERNALSYM TAPE_DRIVE_TENSION} + TAPE_DRIVE_LOCK_UNLOCK = DWORD($80000004); + {$EXTERNALSYM TAPE_DRIVE_LOCK_UNLOCK} + TAPE_DRIVE_REWIND_IMMEDIATE = DWORD($80000008); + {$EXTERNALSYM TAPE_DRIVE_REWIND_IMMEDIATE} + + TAPE_DRIVE_SET_BLOCK_SIZE = DWORD($80000010); + {$EXTERNALSYM TAPE_DRIVE_SET_BLOCK_SIZE} + TAPE_DRIVE_LOAD_UNLD_IMMED = DWORD($80000020); + {$EXTERNALSYM TAPE_DRIVE_LOAD_UNLD_IMMED} + TAPE_DRIVE_TENSION_IMMED = DWORD($80000040); + {$EXTERNALSYM TAPE_DRIVE_TENSION_IMMED} + TAPE_DRIVE_LOCK_UNLK_IMMED = DWORD($80000080); + {$EXTERNALSYM TAPE_DRIVE_LOCK_UNLK_IMMED} + + TAPE_DRIVE_SET_ECC = DWORD($80000100); + {$EXTERNALSYM TAPE_DRIVE_SET_ECC} + TAPE_DRIVE_SET_COMPRESSION = DWORD($80000200); + {$EXTERNALSYM TAPE_DRIVE_SET_COMPRESSION} + TAPE_DRIVE_SET_PADDING = DWORD($80000400); + {$EXTERNALSYM TAPE_DRIVE_SET_PADDING} + TAPE_DRIVE_SET_REPORT_SMKS = DWORD($80000800); + {$EXTERNALSYM TAPE_DRIVE_SET_REPORT_SMKS} + + TAPE_DRIVE_ABSOLUTE_BLK = DWORD($80001000); + {$EXTERNALSYM TAPE_DRIVE_ABSOLUTE_BLK} + TAPE_DRIVE_ABS_BLK_IMMED = DWORD($80002000); + {$EXTERNALSYM TAPE_DRIVE_ABS_BLK_IMMED} + TAPE_DRIVE_LOGICAL_BLK = DWORD($80004000); + {$EXTERNALSYM TAPE_DRIVE_LOGICAL_BLK} + TAPE_DRIVE_LOG_BLK_IMMED = DWORD($80008000); + {$EXTERNALSYM TAPE_DRIVE_LOG_BLK_IMMED} + + TAPE_DRIVE_END_OF_DATA = DWORD($80010000); + {$EXTERNALSYM TAPE_DRIVE_END_OF_DATA} + TAPE_DRIVE_RELATIVE_BLKS = DWORD($80020000); + {$EXTERNALSYM TAPE_DRIVE_RELATIVE_BLKS} + TAPE_DRIVE_FILEMARKS = DWORD($80040000); + {$EXTERNALSYM TAPE_DRIVE_FILEMARKS} + TAPE_DRIVE_SEQUENTIAL_FMKS = DWORD($80080000); + {$EXTERNALSYM TAPE_DRIVE_SEQUENTIAL_FMKS} + + TAPE_DRIVE_SETMARKS = DWORD($80100000); + {$EXTERNALSYM TAPE_DRIVE_SETMARKS} + TAPE_DRIVE_SEQUENTIAL_SMKS = DWORD($80200000); + {$EXTERNALSYM TAPE_DRIVE_SEQUENTIAL_SMKS} + TAPE_DRIVE_REVERSE_POSITION = DWORD($80400000); + {$EXTERNALSYM TAPE_DRIVE_REVERSE_POSITION} + TAPE_DRIVE_SPACE_IMMEDIATE = DWORD($80800000); + {$EXTERNALSYM TAPE_DRIVE_SPACE_IMMEDIATE} + + TAPE_DRIVE_WRITE_SETMARKS = DWORD($81000000); + {$EXTERNALSYM TAPE_DRIVE_WRITE_SETMARKS} + TAPE_DRIVE_WRITE_FILEMARKS = DWORD($82000000); + {$EXTERNALSYM TAPE_DRIVE_WRITE_FILEMARKS} + TAPE_DRIVE_WRITE_SHORT_FMKS = DWORD($84000000); + {$EXTERNALSYM TAPE_DRIVE_WRITE_SHORT_FMKS} + TAPE_DRIVE_WRITE_LONG_FMKS = DWORD($88000000); + {$EXTERNALSYM TAPE_DRIVE_WRITE_LONG_FMKS} + + TAPE_DRIVE_WRITE_MARK_IMMED = DWORD($90000000); + {$EXTERNALSYM TAPE_DRIVE_WRITE_MARK_IMMED} + TAPE_DRIVE_FORMAT = DWORD($A0000000); + {$EXTERNALSYM TAPE_DRIVE_FORMAT} + TAPE_DRIVE_FORMAT_IMMEDIATE = DWORD($C0000000); + {$EXTERNALSYM TAPE_DRIVE_FORMAT_IMMEDIATE} + TAPE_DRIVE_HIGH_FEATURES = DWORD($80000000); // mask for high features flag + {$EXTERNALSYM TAPE_DRIVE_HIGH_FEATURES} + +type + PTAPE_GET_DRIVE_PARAMETERS = ^TAPE_GET_DRIVE_PARAMETERS; + {$EXTERNALSYM PTAPE_GET_DRIVE_PARAMETERS} + _TAPE_GET_DRIVE_PARAMETERS = record + ECC: ByteBool; + Compression: ByteBool; + DataPadding: ByteBool; + ReportSetmarks: ByteBool; + DefaultBlockSize: DWORD; + MaximumBlockSize: DWORD; + MinimumBlockSize: DWORD; + MaximumPartitionCount: DWORD; + FeaturesLow: DWORD; + FeaturesHigh: DWORD; + EOTWarningZoneSize: DWORD; + end; + {$EXTERNALSYM _TAPE_GET_DRIVE_PARAMETERS} + TAPE_GET_DRIVE_PARAMETERS = _TAPE_GET_DRIVE_PARAMETERS; + {$EXTERNALSYM TAPE_GET_DRIVE_PARAMETERS} + TTapeGetDriveParameters = TAPE_GET_DRIVE_PARAMETERS; + PTapeGetDriveParameters = PTAPE_GET_DRIVE_PARAMETERS; + +// +// IOCTL_TAPE_SET_DRIVE_PARAMETERS definitions +// + + PTAPE_SET_DRIVE_PARAMETERS = ^TAPE_SET_DRIVE_PARAMETERS; + {$EXTERNALSYM PTAPE_SET_DRIVE_PARAMETERS} + _TAPE_SET_DRIVE_PARAMETERS = record + ECC: ByteBool; + Compression: ByteBool; + DataPadding: ByteBool; + ReportSetmarks: ByteBool; + EOTWarningZoneSize: DWORD; + end; + {$EXTERNALSYM _TAPE_SET_DRIVE_PARAMETERS} + TAPE_SET_DRIVE_PARAMETERS = _TAPE_SET_DRIVE_PARAMETERS; + {$EXTERNALSYM TAPE_SET_DRIVE_PARAMETERS} + TTapeSetDriveParameters = TAPE_SET_DRIVE_PARAMETERS; + PTapeSetDriveParameters = PTAPE_SET_DRIVE_PARAMETERS; + +// +// IOCTL_TAPE_GET_MEDIA_PARAMETERS definitions +// + + PTAPE_GET_MEDIA_PARAMETERS = ^TAPE_GET_MEDIA_PARAMETERS; + {$EXTERNALSYM PTAPE_GET_MEDIA_PARAMETERS} + _TAPE_GET_MEDIA_PARAMETERS = record + Capacity: LARGE_INTEGER; + Remaining: LARGE_INTEGER; + BlockSize: DWORD; + PartitionCount: DWORD; + WriteProtected: ByteBool; + end; + {$EXTERNALSYM _TAPE_GET_MEDIA_PARAMETERS} + TAPE_GET_MEDIA_PARAMETERS = _TAPE_GET_MEDIA_PARAMETERS; + {$EXTERNALSYM TAPE_GET_MEDIA_PARAMETERS} + TTapeGetMediaParameters = TAPE_GET_MEDIA_PARAMETERS; + PTapeGetMediaParameters = PTAPE_GET_MEDIA_PARAMETERS; + +// +// IOCTL_TAPE_SET_MEDIA_PARAMETERS definitions +// + + PTAPE_SET_MEDIA_PARAMETERS = ^TAPE_SET_MEDIA_PARAMETERS; + {$EXTERNALSYM PTAPE_SET_MEDIA_PARAMETERS} + _TAPE_SET_MEDIA_PARAMETERS = record + BlockSize: DWORD; + end; + {$EXTERNALSYM _TAPE_SET_MEDIA_PARAMETERS} + TAPE_SET_MEDIA_PARAMETERS = _TAPE_SET_MEDIA_PARAMETERS; + {$EXTERNALSYM TAPE_SET_MEDIA_PARAMETERS} + TTapeSetMediaParameters = TAPE_SET_MEDIA_PARAMETERS; + PTapeSetMediaParameters = PTAPE_SET_MEDIA_PARAMETERS; + +// +// IOCTL_TAPE_CREATE_PARTITION definitions +// + +const + TAPE_FIXED_PARTITIONS = 0; + {$EXTERNALSYM TAPE_FIXED_PARTITIONS} + TAPE_SELECT_PARTITIONS = 1; + {$EXTERNALSYM TAPE_SELECT_PARTITIONS} + TAPE_INITIATOR_PARTITIONS = 2; + {$EXTERNALSYM TAPE_INITIATOR_PARTITIONS} + +type + PTAPE_CREATE_PARTITION = ^TAPE_CREATE_PARTITION; + {$EXTERNALSYM PTAPE_CREATE_PARTITION} + _TAPE_CREATE_PARTITION = record + Method: DWORD; + Count: DWORD; + Size: DWORD; + end; + {$EXTERNALSYM _TAPE_CREATE_PARTITION} + TAPE_CREATE_PARTITION = _TAPE_CREATE_PARTITION; + {$EXTERNALSYM TAPE_CREATE_PARTITION} + TTapeCreatePartition = TAPE_CREATE_PARTITION; + PTapeCreatePartition = PTAPE_CREATE_PARTITION; + +// +// WMI Methods +// + +const + TAPE_QUERY_DRIVE_PARAMETERS = 0; + {$EXTERNALSYM TAPE_QUERY_DRIVE_PARAMETERS} + TAPE_QUERY_MEDIA_CAPACITY = 1; + {$EXTERNALSYM TAPE_QUERY_MEDIA_CAPACITY} + TAPE_CHECK_FOR_DRIVE_PROBLEM = 2; + {$EXTERNALSYM TAPE_CHECK_FOR_DRIVE_PROBLEM} + TAPE_QUERY_IO_ERROR_DATA = 3; + {$EXTERNALSYM TAPE_QUERY_IO_ERROR_DATA} + TAPE_QUERY_DEVICE_ERROR_DATA = 4; + {$EXTERNALSYM TAPE_QUERY_DEVICE_ERROR_DATA} + +type + _TAPE_WMI_OPERATIONS = record + Method: DWORD; + DataBufferSize: DWORD; + DataBuffer: PVOID; + end; + {$EXTERNALSYM _TAPE_WMI_OPERATIONS} + TAPE_WMI_OPERATIONS = _TAPE_WMI_OPERATIONS; + {$EXTERNALSYM TAPE_WMI_OPERATIONS} + PTAPE_WMI_OPERATIONS = ^TAPE_WMI_OPERATIONS; + {$EXTERNALSYM PTAPE_WMI_OPERATIONS} + TTapeWMIOperations = TAPE_WMI_OPERATIONS; + PTapeWMIOperations = PTAPE_WMI_OPERATIONS; + +// +// Type of drive errors +// + + _TAPE_DRIVE_PROBLEM_TYPE = ( + TapeDriveProblemNone, TapeDriveReadWriteWarning, + TapeDriveReadWriteError, TapeDriveReadWarning, + TapeDriveWriteWarning, TapeDriveReadError, + TapeDriveWriteError, TapeDriveHardwareError, + TapeDriveUnsupportedMedia, TapeDriveScsiConnectionError, + TapeDriveTimetoClean, TapeDriveCleanDriveNow, + TapeDriveMediaLifeExpired, TapeDriveSnappedTape); + {$EXTERNALSYM _TAPE_DRIVE_PROBLEM_TYPE} + TAPE_DRIVE_PROBLEM_TYPE = _TAPE_DRIVE_PROBLEM_TYPE; + TTapeDriveProblemType = TAPE_DRIVE_PROBLEM_TYPE; + +const + ACTIVATION_CONTEXT_SECTION_ASSEMBLY_INFORMATION = 1; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_ASSEMBLY_INFORMATION} + ACTIVATION_CONTEXT_SECTION_DLL_REDIRECTION = 2; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_DLL_REDIRECTION} + ACTIVATION_CONTEXT_SECTION_WINDOW_CLASS_REDIRECTION = 3; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_WINDOW_CLASS_REDIRECTION} + ACTIVATION_CONTEXT_SECTION_COM_SERVER_REDIRECTION = 4; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_COM_SERVER_REDIRECTION} + ACTIVATION_CONTEXT_SECTION_COM_INTERFACE_REDIRECTION = 5; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_COM_INTERFACE_REDIRECTION} + ACTIVATION_CONTEXT_SECTION_COM_TYPE_LIBRARY_REDIRECTION = 6; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_COM_TYPE_LIBRARY_REDIRECTION} + ACTIVATION_CONTEXT_SECTION_COM_PROGID_REDIRECTION = 7; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_COM_PROGID_REDIRECTION} + ACTIVATION_CONTEXT_SECTION_GLOBAL_OBJECT_RENAME_TABLE = 8; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_GLOBAL_OBJECT_RENAME_TABLE} + ACTIVATION_CONTEXT_SECTION_CLR_SURROGATES = 9; + {$EXTERNALSYM ACTIVATION_CONTEXT_SECTION_CLR_SURROGATES} + +implementation + +const + ntdll = 'ntdll.dll'; + kernel32 = 'kernel32.dll'; + +function WT_SET_MAX_THREADPOOL_THREADS(var Flags: DWORD; Limit: DWORD): DWORD; +begin + Flags := Flags or (Limit shl 16); + Result := Flags; +end; + +function VALID_IMPERSONATION_LEVEL(L: TSecurityImpersonationLevel): BOOL; +begin + Result := (L >= SECURITY_MIN_IMPERSONATION_LEVEL) and (L <= SECURITY_MAX_IMPERSONATION_LEVEL); +end; + +{ +function VALID_TOKEN_AUDIT_POLICY_ELEMENT(P: TOKEN_AUDIT_POLICY_ELEMENT): BOOL; +begin + Result := ((P.PolicyMask and (not VALID_AUDIT_POLICY_BITS) = 0) and (P.Category <= AuditEventMaxType); +// ((((P).PolicyMask & ~VALID_AUDIT_POLICY_BITS) == 0) && \ +// ((P).Category <= AuditEventMaxType)) +end; +} + +function PER_USER_AUDITING_POLICY_SIZE(p: PTOKEN_AUDIT_POLICY): DWORD; +begin + Result := SizeOf(TOKEN_AUDIT_POLICY); + if p^.PolicyCount > ANYSIZE_ARRAY then + Result := Result + SizeOf(TOKEN_AUDIT_POLICY_ELEMENT) * (P^.PolicyCount - ANYSIZE_ARRAY); +// ( sizeof(TOKEN_AUDIT_POLICY) + (((p)->PolicyCount > ANYSIZE_ARRAY) ? (sizeof(TOKEN_AUDIT_POLICY_ELEMENT) * ((p)->PolicyCount - ANYSIZE_ARRAY)) : 0) ) +end; + +function PER_USER_AUDITING_POLICY_SIZE_BY_COUNT(C: DWORD): DWORD; +begin + Result := SizeOf(TOKEN_AUDIT_POLICY); + if C > ANYSIZE_ARRAY then + Result := Result + SizeOf(TOKEN_AUDIT_POLICY_ELEMENT) * (C - ANYSIZE_ARRAY); +// ( sizeof(TOKEN_AUDIT_POLICY) + (((C) > ANYSIZE_ARRAY) ? (sizeof(TOKEN_AUDIT_POLICY_ELEMENT) * ((C) - ANYSIZE_ARRAY)) : 0) ) +end; + +function NtCurrentTeb: PNT_TIB; +asm + MOV EAX, FS:[0] +end; + +function GetFiberData: PVOID; +asm + MOV EAX, FS:[$10] + MOV EAX, [EAX] +end; + +function GetCurrentFiber: PVOID; +asm + MOV EAX, FS:[$10] +end; + +function Int32x32To64(a, b: LONG): LONGLONG; +begin + Result := a * b; +end; + +function UInt32x32To64(a, b: DWORD): ULONGLONG; +begin + Result := a * b; +end; + +function MAKELANGID(PrimaryLang, SubLang: USHORT): WORD; +begin + Result := (SubLang shl 10) or PrimaryLang; +end; + +function PRIMARYLANGID(LangId: WORD): WORD; +begin + Result := LangId and $3FF; +end; + +function SUBLANGID(LangId: WORD): WORD; +begin + Result := LangId shr 10; +end; + +function MAKELCID(LangId, SortId: WORD): DWORD; +begin + Result := (DWORD(SortId) shl 16) or DWORD(LangId); +end; + +function MAKESORTLCID(LangId, SortId, SortVersion: WORD): DWORD; +begin + Result := MAKELCID(LangId, SortId) or (SortVersion shl 20); +end; + +function LANGIDFROMLCID(LocaleId: LCID): WORD; +begin + Result := WORD(LocaleId); +end; + +function SORTIDFROMLCID(LocaleId: LCID): WORD; +begin + Result := WORD((DWORD(LocaleId) shr 16) and $F); +end; + +function SORTVERSIONFROMLCID(LocaleId: LCID): WORD; +begin + Result := WORD((DWORD(LocaleId) shr 20) and $F); +end; + +function LANG_SYSTEM_DEFAULT: WORD; +begin + Result := MAKELANGID(LANG_NEUTRAL, SUBLANG_SYS_DEFAULT); +end; + +function LANG_USER_DEFAULT: WORD; +begin + Result := MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT); +end; + +function LOCALE_SYSTEM_DEFAULT: DWORD; +begin + Result := MAKELCID(LANG_SYSTEM_DEFAULT, SORT_DEFAULT); +end; + +function LOCALE_USER_DEFAULT: DWORD; +begin + Result := MAKELCID(LANG_USER_DEFAULT, SORT_DEFAULT); +end; + +function LOCALE_NEUTRAL: DWORD; +begin + Result := MAKELCID(MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL), SORT_DEFAULT); +end; + +function LOCALE_INVARIANT: DWORD; +begin + Result := MAKELCID(MAKELANGID(LANG_INVARIANT, SUBLANG_NEUTRAL), SORT_DEFAULT); +end; + +function IsReparseTagMicrosoft(Tag: ULONG): Boolean; +begin + Result := (Tag and ULONG($80000000)) <> 0; +end; + +function IsReparseTagHighLatency(Tag: ULONG): Boolean; +begin + Result := (Tag and ULONG($40000000)) <> 0; +end; + +function IsReparseTagNameSurrogate(Tag: ULONG): Boolean; +begin + Result := (Tag and ULONG($20000000)) <> 0; +end; + +// IMAGE_FIRST_SECTION by Nico Bendlin - supplied by Markus Fuchs + +function FieldOffset(const Struc; const Field): Cardinal; +begin + Result := Cardinal(@Field) - Cardinal(@Struc); +end; + +function IMAGE_FIRST_SECTION(NtHeader: PImageNtHeaders): PImageSectionHeader; +begin + Result := PImageSectionHeader(Cardinal(NtHeader) + + FieldOffset(NtHeader^, NtHeader^.OptionalHeader) + + NtHeader^.FileHeader.SizeOfOptionalHeader); +end; + +function BTYPE(x: DWORD): DWORD; +begin + Result := x and N_BTMASK; +end; + +function ISPTR(x: DWORD): Boolean; +begin + Result := (x and N_TMASK) = (IMAGE_SYM_DTYPE_POINTER shl N_BTSHFT); +end; + +function ISFCN(x: DWORD): Boolean; +begin + Result := (x and N_TMASK) = (IMAGE_SYM_DTYPE_FUNCTION shl N_BTSHFT); +end; + +function ISARY(x: DWORD): Boolean; +begin + Result := (x and N_TMASK) = (IMAGE_SYM_DTYPE_ARRAY shl N_BTSHFT); +end; + +function ISTAG(x: DWORD): Boolean; +begin + Result := (x = IMAGE_SYM_CLASS_STRUCT_TAG) or (x = IMAGE_SYM_CLASS_UNION_TAG) or + (x = IMAGE_SYM_CLASS_ENUM_TAG); +end; + +function IMAGE_ORDINAL64(Ordinal: ULONGLONG): ULONGLONG; +begin + Result := (Ordinal and $ffff); +end; + +function IMAGE_ORDINAL32(Ordinal: DWORD): DWORD; +begin + Result := (Ordinal and $ffff); +end; + +function IMAGE_ORDINAL(Ordinal: DWORD): DWORD; +begin + Result := (Ordinal and $ffff); +end; + +function IMAGE_SNAP_BY_ORDINAL64(Ordinal: ULONGLONG): Boolean; +begin + Result := ((Ordinal and IMAGE_ORDINAL_FLAG64) <> 0); +end; + +function IMAGE_SNAP_BY_ORDINAL32(Ordinal: DWORD): Boolean; +begin + Result := ((Ordinal and IMAGE_ORDINAL_FLAG32) <> 0); +end; + +function IMAGE_SNAP_BY_ORDINAL(Ordinal: DWORD): Boolean; +begin + Result := ((Ordinal and IMAGE_ORDINAL_FLAG32) <> 0); +end; + +function HEAP_MAKE_TAG_FLAGS(b, o: DWORD): DWORD; +begin + Result := b + (o shl 18); +end; + +procedure VER_SET_CONDITION(var Mask: DWORDLONG; TypeBitmask, ConditionMask: ULONG); +begin + Mask := VerSetConditionMask(Mask, TypeBitmask, ConditionMask); +end; + +{$IFDEF DYNAMIC_LINK} + +var + _RtlCaptureContext: Pointer; + +procedure RtlCaptureContext; +begin + GetProcedureAddress(_RtlCaptureContext, ntdll, 'RtlCaptureContext'); + asm + MOV ESP, EBP + POP EBP + JMP [_RtlCaptureContext] + end; +end; + +var + _RtlCompareMemory: Pointer; + +function RtlCompareMemory; +begin + GetProcedureAddress(_RtlCompareMemory, ntdll, 'RtlCompareMemory'); + asm + MOV ESP, EBP + POP EBP + JMP [_RtlCompareMemory] + end; +end; + +var + _VerSetConditionMask: Pointer; + +function VerSetConditionMask; +begin + GetProcedureAddress(_VerSetConditionMask, kernel32, 'VerSetConditionMask'); + asm + MOV ESP, EBP + POP EBP + JMP [_VerSetConditionMask] + end; +end; + +var + _RtlInitializeSListHead: Pointer; + +procedure RtlInitializeSListHead; +begin + GetProcedureAddress(_RtlInitializeSListHead, 'ntdll.dll', 'RtlInitializeSListHead'); + asm + MOV ESP, EBP + POP EBP + JMP [_RtlInitializeSListHead] + end; +end; + +var + _RtlFirstEntrySList: Pointer; + +function RtlFirstEntrySList; +begin + GetProcedureAddress(_RtlFirstEntrySList, 'ntdll.dll', 'RtlFirstEntrySList'); + asm + MOV ESP, EBP + POP EBP + JMP [_RtlFirstEntrySList] + end; +end; + +var + _RtlInterlockedPopEntrySList: Pointer; + +function RtlInterlockedPopEntrySList; +begin + GetProcedureAddress(_RtlInterlockedPopEntrySList, 'ntdll.dll', 'RtlInterlockedPopEntrySList'); + asm + MOV ESP, EBP + POP EBP + JMP [_RtlInterlockedPopEntrySList] + end; +end; + +var + _RtlInterlockedPushEntrySList: Pointer; + +function RtlInterlockedPushEntrySList; +begin + GetProcedureAddress(_RtlInterlockedPushEntrySList, 'ntdll.dll', 'RtlInterlockedPushEntrySList'); + asm + MOV ESP, EBP + POP EBP + JMP [_RtlInterlockedPushEntrySList] + end; +end; + +var + _RtlInterlockedFlushSList: Pointer; + +function RtlInterlockedFlushSList; +begin + GetProcedureAddress(_RtlInterlockedFlushSList, 'ntdll.dll', 'RtlInterlockedFlushSList'); + asm + MOV ESP, EBP + POP EBP + JMP [_RtlInterlockedFlushSList] + end; +end; + +var + _RtlQueryDepthSList: Pointer; + +function RtlQueryDepthSList; +begin + GetProcedureAddress(_RtlQueryDepthSList, 'ntdll.dll', 'RtlQueryDepthSList'); + asm + MOV ESP, EBP + POP EBP + JMP [_RtlQueryDepthSList] + end; +end; + +{$ELSE} + +procedure RtlCaptureContext; external ntdll name 'RtlCaptureContext'; +function RtlCompareMemory; external ntdll name 'RtlCompareMemory'; +function VerSetConditionMask; external kernel32 name 'VerSetConditionMask'; +procedure RtlInitializeSListHead; external 'ntdll.dll' name 'RtlInitializeSListHead'; +function RtlFirstEntrySList; external 'ntdll.dll' name 'RtlFirstEntrySList'; +function RtlInterlockedPopEntrySList; external 'ntdll.dll' name 'RtlInterlockedPopEntrySList'; +function RtlInterlockedPushEntrySList; external 'ntdll.dll' name 'RtlInterlockedPushEntrySList'; +function RtlInterlockedFlushSList; external 'ntdll.dll' name 'RtlInterlockedFlushSList'; +function RtlQueryDepthSList; external 'ntdll.dll' name 'RtlQueryDepthSList'; + +{$ENDIF DYNAMIC_LINK} + +end. + + diff --git a/Tocsg.Lib/VCL/Other/EM.jwawintype.pas b/Tocsg.Lib/VCL/Other/EM.jwawintype.pas new file mode 100644 index 00000000..a2516f36 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.jwawintype.pas @@ -0,0 +1,1816 @@ +{******************************************************************************} +{ } +{ Windows Base Types API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ The original file is: basetsd.h, released August 2001. The original Pascal } +{ code is: WinType.pas, released December 2000. The initial developer of the } +{ Pascal code is Marcel van Brakel (brakelm att chello dott nl). } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI } +{ APILIB home page, located at http://jedi-apilib.sourceforge.net } +{ } +{ 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. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License 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 LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + + +unit EM.JwaWinType; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "BaseTsd.h"'} +{$HPPEMIT '#include "BaseTyps.h"'} +{$HPPEMIT '#include "NtDef.h"'} +{$HPPEMIT '#include "WinDef.h"'} +{$HPPEMIT ''} +{$HPPEMIT 'typedef LPVOID *LPLPVOID'} +{$HPPEMIT 'typedef GUID TGUID'} +{$HPPEMIT 'typedef GUID *LPGUID'} +{$HPPEMIT 'typedef GUID CLSID'} +{$HPPEMIT 'typedef HMODULE *PHMODULE'} +{$HPPEMIT ''} + +//{$I jediapilib.inc} + +interface + +{$DEFINE USE_DELPHI_TYPES} + +uses + {$IFDEF USE_DELPHI_TYPES} + Windows, + {$ENDIF USE_DELPHI_TYPES} + SysUtils; // TODO + +type + EJwaError = class(Exception); + EJwaLoadLibraryError = class(EJwaError); + EJwaGetProcAddressError = class(EJwaError); + +procedure GetProcedureAddress(var P: Pointer; const ModuleName, ProcName: AnsiString); + +// ntdef.h + +type +//typedef double DOUBLE; + + PQuad = ^TQuad; + _QUAD = record // QUAD is for those times we want + DoNotUseThisField: Double; // an 8 byte aligned 8 byte long structure + end; // which is NOT really a floating point + {$EXTERNALSYM _QUAD} // number. Use DOUBLE if you want an FP number. + QUAD = _QUAD; + {$EXTERNALSYM QUAD} + TQuad = _QUAD; + +// +// Unsigned Basics +// + + UCHAR = {$IFDEF USE_DELPHI_TYPES} Windows.UCHAR {$ELSE} Byte {$ENDIF}; + {$EXTERNALSYM UCHAR} + USHORT = Word; + {$EXTERNALSYM USHORT} + ULONG = {$IFDEF USE_DELPHI_TYPES} Windows.ULONG {$ELSE} Cardinal {$ENDIF}; + {$EXTERNALSYM ULONG} + UQUAD = QUAD; + {$EXTERNALSYM UQUAD} + +// +// __int64 is only supported by 2.0 and later midl. +// __midl is set by the 2.0 midl and not by 1.0 midl. +// + +type + LONGLONG = {$IFDEF USE_DELPHI_TYPES} Windows.LONGLONG {$ELSE} Int64 {$ENDIF}; + {$EXTERNALSYM LONGLONG} + ULONGLONG = Int64; + {$EXTERNALSYM ULONGLONG} + +const + MAXLONGLONG = $7fffffffffffffff; + {$EXTERNALSYM MAXLONGLONG} + +type + PLONGLONG = ^LONGLONG; + {$EXTERNALSYM PLONGLONG} + PULONGLONG = ^ULONGLONG; + {$EXTERNALSYM PULONGLONG} + + BOOL = {$IFDEF USE_DELPHI_TYPES} Windows.BOOL {$ELSE} LongBool {$ENDIF}; + {$EXTERNALSYM BOOL} + + DWORD = {$IFDEF USE_DELPHI_TYPES} Windows.DWORD {$ELSE} Longword {$ENDIF}; + {$EXTERNALSYM DWORD} + +const + ANYSIZE_ARRAY = 1; + {$EXTERNALSYM ANYSIZE_ARRAY} + + MAX_NATURAL_ALIGNMENT = SizeOf(ULONG); + {$EXTERNALSYM MAX_NATURAL_ALIGNMENT} + +// +// Void +// + +type + PVOID = Pointer; + {$EXTERNALSYM PVOID} + PPVOID = ^PVOID; + {$EXTERNALSYM PPVOID} + PVOID64 = Pointer; + {$EXTERNALSYM PVOID64} + +// +// Basics +// + + SHORT = {$IFDEF USE_DELPHI_TYPES} Windows.SHORT {$ELSE} Smallint {$ENDIF}; + {$EXTERNALSYM SHORT} + LONG = Longint; + {$EXTERNALSYM LONG} + +// +// UNICODE (Wide Character) types +// + + WCHAR = {$IFDEF USE_DELPHI_TYPES} Windows.WCHAR {$ELSE} WideChar {$ENDIF}; + {$EXTERNALSYM WCHAR} + + PWCHAR = {$IFDEF USE_DELPHI_TYPES} Windows.PWChar {$ELSE} PWideChar {$ENDIF}; + {$EXTERNALSYM PWCHAR} + LPWCH = ^WCHAR; + {$EXTERNALSYM LPWCH} + PWCH = ^WCHAR; + {$EXTERNALSYM PWCH} + LPCWCH = ^WCHAR; + {$EXTERNALSYM LPCWCH} + PCWCH = ^WCHAR; + {$EXTERNALSYM PCWCH} + NWPSTR = ^WCHAR; + {$EXTERNALSYM NWPSTR} + LPWSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPWSTR {$ELSE} PWideChar {$ENDIF}; + {$EXTERNALSYM LPWSTR} + LPCWSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPCWSTR {$ELSE} PWideChar {$ENDIF}; + {$EXTERNALSYM LPCWSTR} + PWSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPWSTR {$ELSE} PWideChar {$ENDIF}; + {$EXTERNALSYM PWSTR} + LPUWSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPWSTR {$ELSE} PWideChar {$ENDIF}; + {$EXTERNALSYM LPUWSTR} + PUWSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPWSTR {$ELSE} PWideChar {$ENDIF}; + {$EXTERNALSYM PUWSTR} + LCPUWSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPWSTR {$ELSE} PWideChar {$ENDIF}; + {$EXTERNALSYM LCPUWSTR} + PCUWSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPWSTR {$ELSE} PWideChar {$ENDIF}; + {$EXTERNALSYM PCUWSTR} + +// +// ANSI (Multi-byte Character) types +// + + LPCH = ^Char; + {$EXTERNALSYM LPCH} + PCH = ^Char; + {$EXTERNALSYM PCH} + + LPCCH = ^Char; + {$EXTERNALSYM LPCCH} + PCCH = ^Char; + {$EXTERNALSYM PCCH} + NPSTR = ^Char; + {$EXTERNALSYM NPSTR} + LPSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPSTR {$ELSE} PAnsiChar {$ENDIF}; + {$EXTERNALSYM LPSTR} + PSTR = PChar; + {$EXTERNALSYM PSTR} + LPCSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPCSTR {$ELSE} PAnsiChar {$ENDIF}; + {$EXTERNALSYM LPCSTR} + PCSTR = PChar; + {$EXTERNALSYM PCSTR} + +// (rom) moved down to have LPSTR etc always declared +type + LPLPSTR = ^LPSTR; + {$NODEFINE LPLPSTR} + LPLPCSTR = ^LPCSTR; + {$NODEFINE LPLPCSTR} + LPLPCWSTR = ^LPCWSTR; + {$NODEFINE LPLPCWSTR} + LPLPWSTR = ^LPWSTR; + {$NODEFINE LPLPWSTR} + + PPTSTR = ^PTSTR; + PPChar = ^PChar; + PPWideChar = ^PWideChar; + PPointer = ^Pointer; + + GUID = TGUID; + {$NODEFINE GUID} + LPGUID = ^GUID; + {$NODEFINE LPGUID} + CLSID = TGUID; + {$NODEFINE CLSID} + +// +// Neutral ANSI/UNICODE types and macros +// + +{$IFDEF UNICODE} + + TCHAR = WCHAR; + {$EXTERNALSYM TCHAR} + PTCHAR = PWideChar; + {$EXTERNALSYM PTCHAR} + TUCHAR = WCHAR; + {$EXTERNALSYM TUCHAR} + PTUCHAR = ^TUCHAR; + {$EXTERNALSYM PTUCHAR} + + LPCTCH = LPWSTR; + LPTCH = LPWSTR; + {$EXTERNALSYM LPTCH} + PTCH = LPWSTR; + {$EXTERNALSYM PTCH} + PTSTR = LPWSTR; + {$EXTERNALSYM PTSTR} + LPTSTR = {$IFDEF USE_DELPHI_TYPES} Windows.LPWSTR {$ELSE} LPWSTR {$ENDIF}; + {$EXTERNALSYM LPTSTR} + PCTSTR = LPTSTR; + {$EXTERNALSYM PCTSTR} + LPCTSTR = LPTSTR; + {$EXTERNALSYM LPCTSTR} + + PCUTSTR = PTUCHAR; + {$EXTERNALSYM PCUTSTR} + LPCUTSTR = PTUCHAR; + {$EXTERNALSYM LPCUTSTR} + PUTSTR = PTUCHAR; + {$EXTERNALSYM PUTSTR} + LPUTSTR = PTUCHAR; + {$EXTERNALSYM LPUTSTR} + + __TEXT = WideString; + {$EXTERNALSYM __TEXT} + + {$ELSE} + + TCHAR = Char; + {$EXTERNALSYM TCHAR} + PTCHAR = PChar; + {$EXTERNALSYM PTCHAR} + TUCHAR = Byte; + {$EXTERNALSYM TUCHAR} + PTUCHAR = ^TUCHAR; + {$EXTERNALSYM PTUCHAR} + + LPCTCH = LPSTR; + LPTCH = LPSTR; + {$EXTERNALSYM LPTCH} + PTCH = LPSTR; + {$EXTERNALSYM PTCH} + PTSTR = LPSTR; + {$EXTERNALSYM PTSTR} + LPTSTR = LPSTR; + {$EXTERNALSYM LPTSTR} + PCTSTR = LPCSTR; + {$EXTERNALSYM PCTSTR} + LPCTSTR = LPCSTR; + {$EXTERNALSYM LPCTSTR} + + PCUTSTR = PTUCHAR; + {$EXTERNALSYM PCUTSTR} + LPCUTSTR = PTUCHAR; + {$EXTERNALSYM LPCUTSTR} + PUTSTR = PTUCHAR; + {$EXTERNALSYM PUTSTR} + LPUTSTR = PTUCHAR; + {$EXTERNALSYM LPUTSTR} + + __TEXT = AnsiString; + {$EXTERNALSYM __TEXT} + +{$ENDIF UNICODE} + + TEXT = __TEXT; + {$EXTERNALSYM TEXT} + +// +// Pointer to Basics +// + + PSHORT = ^SHORT; + {$EXTERNALSYM PSHORT} + PLONG = ^LONG; + {$EXTERNALSYM PLONG} + +// +// Pointer to Unsigned Basics +// + + PUCHAR = {$IFDEF USE_DELPHI_TYPES} Windows.PUCHAR {$ELSE} ^Byte {$ENDIF}; + {$EXTERNALSYM PUCHAR} + PUSHORT = ^USHORT; + {$EXTERNALSYM PUSHORT} + PULONG = {$IFDEF USE_DELPHI_TYPES} Windows.PULONG {$ELSE} ^ULONG {$ENDIF}; + {$EXTERNALSYM PULONG} + PUQUAD = ^UQUAD; + {$EXTERNALSYM PUQUAD} + +// +// Signed characters +// + + SCHAR = Shortint; + {$EXTERNALSYM SCHAR} + PSCHAR = ^SCHAR; + {$EXTERNALSYM PSCHAR} + +// +// Handle to an Object +// + + HANDLE = {$IFDEF USE_DELPHI_TYPES} Windows.THandle {$ELSE} Longword {$ENDIF}; + {$EXTERNALSYM HANDLE} + PHANDLE = {$IFDEF USE_DELPHI_TYPES} Windows.PHandle {$ELSE} ^HANDLE {$ENDIF}; + {$EXTERNALSYM PHANDLE} + THandle = {$IFDEF USE_DELPHI_TYPES} Windows.THandle {$ELSE} HANDLE {$ENDIF}; + +// +// Flag (bit) fields +// + + FCHAR = UCHAR; + {$EXTERNALSYM FCHAR} + FSHORT = USHORT; + {$EXTERNALSYM FSHORT} + FLONG = ULONG; + {$EXTERNALSYM FLONG} + +// Component Object Model defines, and macros + + HRESULT = System.HRESULT; // LONG; + {$EXTERNALSYM HRESULT} + +// +// Low order two bits of a handle are ignored by the system and available +// for use by application code as tag bits. The remaining bits are opaque +// and used to store a serial number and table index. +// + +const + OBJ_HANDLE_TAGBITS = $00000003; + {$EXTERNALSYM OBJ_HANDLE_TAGBITS} + +// +// Cardinal Data Types [0 - 2**N-2) +// + +type + CCHAR = Char; + {$EXTERNALSYM CCHAR} + CSHORT = Shortint; + {$EXTERNALSYM CSHORT} + CLONG = ULONG; + {$EXTERNALSYM CLONG} + + PCCHAR = ^CCHAR; + {$EXTERNALSYM PCCHAR} + PCSHORT = ^CSHORT; + {$EXTERNALSYM PCSHORT} + PCLONG = ^CLONG; + {$EXTERNALSYM PCLONG} + +// +// NLS basics (Locale and Language Ids) +// + + LCID = {$IFDEF USE_DELPHI_TYPES} Windows.LCID {$ELSE} DWORD {$ENDIF}; + {$EXTERNALSYM LCID} + PLCID = ^LCID; + {$EXTERNALSYM PLCID} + LANGID = {$IFDEF USE_DELPHI_TYPES} Windows.LANGID {$ELSE} Word {$ENDIF}; + {$EXTERNALSYM LANGID} + PLANGID = ^LANGID; // TODO Not in original header (used in MSI) + +// +// Logical Data Type - These are 32-bit logical values. +// + + LOGICAL = ULONG; + {$EXTERNALSYM LOGICAL} + PLOGICAL = ^ULONG; + {$EXTERNALSYM PLOGICAL} + +// +// NTSTATUS +// + + NTSTATUS = LONG; + {$EXTERNALSYM NTSTATUS} + PNTSTATUS = ^NTSTATUS; + {$EXTERNALSYM PNTSTATUS} + TNTStatus = NTSTATUS; + +// +// Status values are 32 bit values layed out as follows: +// +// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 +// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 +// +---+-+-------------------------+-------------------------------+ +// |Sev|C| Facility | Code | +// +---+-+-------------------------+-------------------------------+ +// +// where +// +// Sev - is the severity code +// +// 00 - Success +// 01 - Informational +// 10 - Warning +// 11 - Error +// +// C - is the Customer code flag +// +// Facility - is the facility code +// +// Code - is the facility's status code +// + +// +// Generic test for success on any status value (non-negative numbers +// indicate success). +// + +function NT_SUCCESS(Status: NTSTATUS): BOOL; +{$EXTERNALSYM NT_SUCCESS} + +// +// Generic test for information on any status value. +// + +function NT_INFORMATION(Status: NTSTATUS): BOOL; +{$EXTERNALSYM NT_INFORMATION} + +// +// Generic test for warning on any status value. +// + +function NT_WARNING(Status: NTSTATUS): BOOL; +{$EXTERNALSYM NT_WARNING} + +// +// Generic test for error on any status value. +// + +function NT_ERROR(Status: NTSTATUS): BOOL; +{$EXTERNALSYM NT_ERROR} + +const + APPLICATION_ERROR_MASK = $20000000; + {$EXTERNALSYM APPLICATION_ERROR_MASK} + ERROR_SEVERITY_SUCCESS = $00000000; + {$EXTERNALSYM ERROR_SEVERITY_SUCCESS} + ERROR_SEVERITY_INFORMATIONAL = $40000000; + {$EXTERNALSYM ERROR_SEVERITY_INFORMATIONAL} + ERROR_SEVERITY_WARNING = DWORD($80000000); + {$EXTERNALSYM ERROR_SEVERITY_WARNING} + ERROR_SEVERITY_ERROR = DWORD($C0000000); + {$EXTERNALSYM ERROR_SEVERITY_ERROR} + +// +// Large (64-bit) integer types and operations +// + +type + LPLARGE_INTEGER = ^LARGE_INTEGER; + {$EXTERNALSYM LPLARGE_INTEGER} + + {$IFDEF USE_DELPHI_TYPES} + _LARGE_INTEGER = Windows._LARGE_INTEGER; + LARGE_INTEGER = Windows.LARGE_INTEGER; + TLargeInteger = Windows.TLargeInteger; + {$ELSE} + _LARGE_INTEGER = record + case Integer of + 0: ( + LowPart: DWORD; + HighPart: LONG); + 1: ( + QuadPart: LONGLONG); + end; + {$EXTERNALSYM _LARGE_INTEGER} + LARGE_INTEGER = _LARGE_INTEGER; + {$EXTERNALSYM LARGE_INTEGER} + TLargeInteger = LARGE_INTEGER; + {$ENDIF USE_DELPHI_TYPES} + + PLARGE_INTEGER = ^LARGE_INTEGER; + {$EXTERNALSYM PLARGE_INTEGER} + PLargeInteger = LPLARGE_INTEGER; + + LPULARGE_INTEGER = ^ULARGE_INTEGER; + {$EXTERNALSYM LPULARGE_INTEGER} + + {$IFDEF USE_DELPHI_TYPES} + ULARGE_INTEGER = Windows.ULARGE_INTEGER; + TULargeInteger = Windows.TULargeInteger; + PULargeInteger = Windows.PULargeInteger; + {$ELSE} + ULARGE_INTEGER = record + case Integer of + 0: ( + LowPart: DWORD; + HighPart: DWORD); + 1: ( + QuadPart: LONGLONG); + end; + {$EXTERNALSYM ULARGE_INTEGER} + TULargeInteger = ULARGE_INTEGER; + PULargeInteger = LPULARGE_INTEGER; + {$ENDIF USE_DELPHI_TYPES} + + PULARGE_INTEGER = ^ULARGE_INTEGER; + {$EXTERNALSYM PULARGE_INTEGER} + + TIME = LARGE_INTEGER; + {$EXTERNALSYM TIME} + _TIME = _LARGE_INTEGER; + {$EXTERNALSYM _TIME} + PTIME = PLARGE_INTEGER; + {$EXTERNALSYM PTIME} + +// +// _M_IX86 included so that EM CONTEXT structure compiles with +// x86 programs. *** TBD should this be for all architectures? +// + +// +// 16 byte aligned type for 128 bit floats +// + +// +// For we define a 128 bit structure and use __declspec(align(16)) pragma to +// align to 128 bits. +// + +type + PFloat128 = ^TFloat128; + _FLOAT128 = record + LowPart: Int64; + HighPart: Int64; + end; + {$EXTERNALSYM _FLOAT128} + FLOAT128 = _FLOAT128; + {$EXTERNALSYM FLOAT128} + TFloat128 = FLOAT128; + +// Update Sequence Number + + USN = LONGLONG; + {$EXTERNALSYM USN} + +// +// Locally Unique Identifier +// + +type + PLuid = ^LUID; + _LUID = record + LowPart: DWORD; + HighPart: LONG; + end; + {$EXTERNALSYM _LUID} + LUID = _LUID; + {$EXTERNALSYM LUID} + TLuid = LUID; + + DWORDLONG = ULONGLONG; + {$EXTERNALSYM DWORDLONG} + PDWORDLONG = ^DWORDLONG; + {$EXTERNALSYM PDWORDLONG} + +// +// Physical address. +// + + PHYSICAL_ADDRESS = LARGE_INTEGER; + {$EXTERNALSYM PHYSICAL_ADDRESS} + PPHYSICAL_ADDRESS = ^LARGE_INTEGER; + {$EXTERNALSYM PPHYSICAL_ADDRESS} + +// +// Define operations to logically shift an int64 by 0..31 bits and to multiply +// 32-bits by 32-bits to form a 64-bit product. +// + +// +// The x86 C compiler understands inline assembler. Therefore, inline functions +// that employ inline assembler are used for shifts of 0..31. The multiplies +// rely on the compiler recognizing the cast of the multiplicand to int64 to +// generate the optimal code inline. +// + +function Int32x32To64(a, b: LONG): LONGLONG; +{$EXTERNALSYM Int32x32To64} +function UInt32x32To64(a, b: DWORD): ULONGLONG; +{$EXTERNALSYM UInt32x32To64} + +function Int64ShllMod32(Value: ULONGLONG; ShiftCount: DWORD): ULONGLONG; + +{$EXTERNALSYM Int64ShllMod32} +function Int64ShraMod32(Value: LONGLONG; ShiftCount: DWORD): LONGLONG; +{$EXTERNALSYM Int64ShraMod32} +function Int64ShrlMod32(Value: ULONGLONG; ShiftCount: DWORD): ULONGLONG; +{$EXTERNALSYM Int64ShrlMod32} + +// +// Event type +// + +type + _EVENT_TYPE = (NotificationEvent, SynchronizationEvent); + {$EXTERNALSYM _EVENT_TYPE} + EVENT_TYPE = _EVENT_TYPE; + {$EXTERNALSYM EVENT_TYPE} + TEventType = _EVENT_TYPE; + +// +// Timer type +// + + _TIMER_TYPE = (NotificationTimer, SynchronizationTimer); + {$EXTERNALSYM _TIMER_TYPE} + TIMER_TYPE = _TIMER_TYPE; + {$EXTERNALSYM TIMER_TYPE} + +// +// Wait type +// + + _WAIT_TYPE = (WaitAll, WaitAny); + {$EXTERNALSYM _WAIT_TYPE} + WAIT_TYPE = _WAIT_TYPE; + {$EXTERNALSYM WAIT_TYPE} + +// +// Pointer to an Asciiz string +// + + PSZ = ^CHAR; + {$EXTERNALSYM PSZ} + PCSZ = ^CHAR; + {$EXTERNALSYM PCSZ} + +// +// Counted String +// + + PString = ^TString; + _STRING = record + Length: USHORT; + MaximumLength: USHORT; + Buffer: PCHAR; + end; + {$EXTERNALSYM _STRING} + TString = _STRING; + + ANSI_STRING = _STRING; + {$EXTERNALSYM ANSI_STRING} + PANSI_STRING = PSTRING; + {$EXTERNALSYM PANSI_STRING} + + OEM_STRING = _STRING; + {$EXTERNALSYM OEM_STRING} + POEM_STRING = PSTRING; + {$EXTERNALSYM POEM_STRING} + +// +// CONSTCounted String +// + + PCString = ^CSTRING; + _CSTRING = record + Length: USHORT; + MaximumLength: USHORT; + Buffer: PCHAR; + end; + {$EXTERNALSYM _CSTRING} + CSTRING = _CSTRING; + {$EXTERNALSYM CSTRING} + TCString = CSTRING; + +const + ANSI_NULL = CHAR(0); + {$EXTERNALSYM ANSI_NULL} + UNICODE_NULL = WCHAR(0); + {$EXTERNALSYM UNICODE_NULL} + UNICODE_STRING_MAX_BYTES = WORD(65534); + {$EXTERNALSYM UNICODE_STRING_MAX_BYTES} + UNICODE_STRING_MAX_CHARS = 32767; + {$EXTERNALSYM UNICODE_STRING_MAX_CHARS} + +type + CANSI_STRING = _STRING; + {$EXTERNALSYM CANSI_STRING} + PCANSI_STRING = PSTRING; + {$EXTERNALSYM PCANSI_STRING} + +// +// Unicode strings are counted 16-bit character strings. If they are +// NULL terminated, Length does not include trailing NULL. +// + +type + PUNICODE_STRING = ^UNICODE_STRING; + {$EXTERNALSYM PUNICODE_STRING} + _UNICODE_STRING = record + Length: USHORT; + MaximumLength: USHORT; + Buffer: PWSTR; + end; + {$EXTERNALSYM _UNICODE_STRING} + UNICODE_STRING = _UNICODE_STRING; + {$EXTERNALSYM UNICODE_STRING} + PCUNICODE_STRING = ^UNICODE_STRING; + {$EXTERNALSYM PCUNICODE_STRING} + TUnicodeString = UNICODE_STRING; + PUnicodeString = PUNICODE_STRING; + +// +// Boolean +// + +type +//typedef UCHAR BOOLEAN; + PBOOLEAN = ^ByteBool; + {$EXTERNALSYM PBOOLEAN} + +// +// Doubly linked list structure. Can be used as either a list head, or +// as link words. +// + +type + PLIST_ENTRY = ^LIST_ENTRY; + {$EXTERNALSYM PLIST_ENTRY} + + {$IFDEF USE_DELPHI_TYPES} + _LIST_ENTRY = Windows._LIST_ENTRY; + LIST_ENTRY = Windows.LIST_ENTRY; + TListEntry = Windows.TListEntry; + PListEntry = Windows.PListEntry; + {$ELSE} + _LIST_ENTRY = record + Flink: PLIST_ENTRY; + Blink: PLIST_ENTRY; + end; + {$EXTERNALSYM _LIST_ENTRY} + LIST_ENTRY = _LIST_ENTRY; + {$EXTERNALSYM LIST_ENTRY} + TListEntry = LIST_ENTRY; + PListEntry = PLIST_ENTRY; + {$ENDIF USE_DELPHI_TYPES} + + PRLIST_ENTRY = ^LIST_ENTRY; + {$EXTERNALSYM PLIST_ENTRY} + +// +// Singly linked list structure. Can be used as either a list head, or +// as link words. +// + + PSINGLE_LIST_ENTRY = ^SINGLE_LIST_ENTRY; + {$EXTERNALSYM PSINGLE_LIST_ENTRY} + _SINGLE_LIST_ENTRY = record + Next: PSINGLE_LIST_ENTRY; + end; + {$EXTERNALSYM _SINGLE_LIST_ENTRY} + SINGLE_LIST_ENTRY = _SINGLE_LIST_ENTRY; + {$EXTERNALSYM SINGLE_LIST_ENTRY} + TSingleListEntry = SINGLE_LIST_ENTRY; + PSingleListEntry = PSINGLE_LIST_ENTRY; + +// +// These are needed for portable debugger support. +// + + PLIST_ENTRY32 = ^LIST_ENTRY32; + {$EXTERNALSYM PLIST_ENTRY32} + {$EXTERNALSYM PLIST_ENTRY32} + LIST_ENTRY32 = record + Flink: DWORD; + Blink: DWORD; + end; + {$EXTERNALSYM LIST_ENTRY32} + TListEntry32 = LIST_ENTRY32; + PListEntry32 = PLIST_ENTRY32; + + PLIST_ENTRY64 = ^LIST_ENTRY64; + {$EXTERNALSYM PLIST_ENTRY64} + LIST_ENTRY64 = record + Flink: ULONGLONG; + Blink: ULONGLONG; + end; + {$EXTERNALSYM LIST_ENTRY64} + TListEntry64 = LIST_ENTRY64; + PListEntry64 = PLIST_ENTRY64; + +procedure ListEntry32To64(l32: PLIST_ENTRY32; l64: PLIST_ENTRY64); +{$EXTERNALSYM ListEntry32To64} + +procedure ListEntry64To32(l64: PLIST_ENTRY64; l32: PLIST_ENTRY32); +{$EXTERNALSYM ListEntry64To32} + +// +// These macros are used to walk lists on a target system +// + +{ +#define CONTAINING_RECORD32(address, type, field) ( \ + (ULONG_PTR)(address) - \ + (ULONG_PTR)(&((type *)0)->field)) + +#define CONTAINING_RECORD64(address, type, field) ( \ + (ULONGLONG)(address) - \ + (ULONGLONG)(&((type *)0)->field)) +} + +type + PString32 = ^STRING32; + _STRING32 = record + Length: USHORT; + MaximumLength: USHORT; + Buffer: ULONG; + end; + {$EXTERNALSYM _STRING32} + STRING32 = _STRING32; + {$EXTERNALSYM STRING32} + TString32 = STRING32; + + UNICODE_STRING32 = STRING32; + {$EXTERNALSYM UNICODE_STRING32} + PUNICODE_STRING32 = ^UNICODE_STRING32; + {$EXTERNALSYM PUNICODE_STRING32} + + ANSI_STRING32 = STRING32; + {$EXTERNALSYM ANSI_STRING32} + PANSI_STRING32 = ^ANSI_STRING32; + {$EXTERNALSYM PANSI_STRING32} + + PString64 = ^STRING64; + _STRING64 = record + Length: USHORT; + MaximumLength: USHORT; + Buffer: ULONGLONG; + end; + {$EXTERNALSYM _STRING64} + STRING64 = _STRING64; + {$EXTERNALSYM STRING64} + TString64 = STRING64; + + UNICODE_STRING64 = STRING64; + {$EXTERNALSYM UNICODE_STRING64} + PUNICODE_STRING64 = ^UNICODE_STRING64; + {$EXTERNALSYM PUNICODE_STRING64} + + ANSI_STRING64 = STRING64; + {$EXTERNALSYM ANSI_STRING64} + PANSI_STRING64 = ^ANSI_STRING64; + {$EXTERNALSYM PANSI_STRING64} + +// +// Valid values for the Attributes field +// + +const + OBJ_INHERIT = $00000002; + {$EXTERNALSYM OBJ_INHERIT} + OBJ_PERMANENT = $00000010; + {$EXTERNALSYM OBJ_PERMANENT} + OBJ_EXCLUSIVE = $00000020; + {$EXTERNALSYM OBJ_EXCLUSIVE} + OBJ_CASE_INSENSITIVE = $00000040; + {$EXTERNALSYM OBJ_CASE_INSENSITIVE} + OBJ_OPENIF = $00000080; + {$EXTERNALSYM OBJ_OPENIF} + OBJ_OPENLINK = $00000100; + {$EXTERNALSYM OBJ_OPENLINK} + OBJ_KERNEL_HANDLE = $00000200; + {$EXTERNALSYM OBJ_KERNEL_HANDLE} + OBJ_VALID_ATTRIBUTES = $000003F2; + {$EXTERNALSYM OBJ_VALID_ATTRIBUTES} + +// +// Object Attributes structure +// + +type + POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES; + {$EXTERNALSYM POBJECT_ATTRIBUTES} + _OBJECT_ATTRIBUTES = record + Length: ULONG; + RootDirectory: HANDLE; + ObjectName: PUNICODE_STRING; + Attributes: ULONG; + SecurityDescriptor: PVOID; // Points to type SECURITY_DESCRIPTOR + SecurityQualityOfService: PVOID; // Points to type SECURITY_QUALITY_OF_SERVICE + end; + {$EXTERNALSYM _OBJECT_ATTRIBUTES} + OBJECT_ATTRIBUTES = _OBJECT_ATTRIBUTES; + {$EXTERNALSYM OBJECT_ATTRIBUTES} + TObjectAttributes = OBJECT_ATTRIBUTES; + PObjectAttributes = POBJECT_ATTRIBUTES; + +procedure InitializeObjectAttributes(p: POBJECT_ATTRIBUTES; n: PUNICODE_STRING; + a: ULONG; r: HANDLE; s: PVOID{PSECURITY_DESCRIPTOR}); +{$EXTERNALSYM InitializeObjectAttributes} + +// +// Constants +// + +const + +//#define FALSE 0 +//#define TRUE 1 + + NULL = 0; + {$EXTERNALSYM NULL} + NULL64 = 0; + {$EXTERNALSYM NULL64} + +//#include <guiddef.h> + +type + PObjectId = ^OBJECTID; + _OBJECTID = record // size is 20 + Lineage: GUID; + Uniquifier: ULONG; + end; + {$EXTERNALSYM _OBJECTID} + OBJECTID = _OBJECTID; + {$EXTERNALSYM OBJECTID} + TObjectId = OBJECTID; + +const + MINCHAR = $80; + {$EXTERNALSYM MINCHAR} + MAXCHAR = $7f; + {$EXTERNALSYM MAXCHAR} + MINSHORT = $8000; + {$EXTERNALSYM MINSHORT} + MAXSHORT = $7fff; + {$EXTERNALSYM MAXSHORT} + MINLONG = DWORD($80000000); + {$EXTERNALSYM MINLONG} + MAXLONG = $7fffffff; + {$EXTERNALSYM MAXLONG} + MAXUCHAR = $ff; + {$EXTERNALSYM MAXUCHAR} + MAXUSHORT = $ffff; + {$EXTERNALSYM MAXUSHORT} + MAXULONG = DWORD($ffffffff); + {$EXTERNALSYM MAXULONG} + +// +// Useful Helper Macros +// + +// +// Determine if an argument is present by testing the value of the pointer +// to the argument value. +// + +function ARGUMENT_PRESENT(ArgumentPointer: Pointer): BOOL; +{$EXTERNALSYM ARGUMENT_PRESENT} + +// +// Exception handler routine definition. +// + +// struct _CONTEXT; +// struct _EXCEPTION_RECORD; + +//type +// PEXCEPTION_ROUTINE = function(ExceptionRecord: LP_EXCEPTION_RECORD; +// EstablisherFrame: PVOID; ContextRecord: LPCONTEXT; +// DispatcherContext: PVOID): EXCEPTION_DISPOSITION; stdcall; +// {$EXTERNALSYM PEXCEPTION_ROUTINE} + +// +// Interrupt Request Level (IRQL) +// + +type + KIRQL = UCHAR; + {$EXTERNALSYM KIRQL} + PKIRQL = ^KIRQL; + {$EXTERNALSYM PKIRQL} + +// +// Product types +// + + _NT_PRODUCT_TYPE = (Filler0, NtProductWinNt, NtProductLanManNt, NtProductServer); + {$EXTERNALSYM _NT_PRODUCT_TYPE} + NT_PRODUCT_TYPE = _NT_PRODUCT_TYPE; + {$EXTERNALSYM NT_PRODUCT_TYPE} + PNT_PRODUCT_TYPE = ^NT_PRODUCT_TYPE; + TNtProductType = _NT_PRODUCT_TYPE; + +// +// the bit mask, SharedUserData->SuiteMask, is a ULONG +// so there can be a maximum of 32 entries +// in this enum. +// + +type + _SUITE_TYPE = ( + SmallBusiness, + Enterprise, + BackOffice, + CommunicationServer, + TerminalServer, + SmallBusinessRestricted, + EmbeddedNT, + DataCenter, + SingleUserTS, + MaxSuiteType); + {$EXTERNALSYM _SUITE_TYPE} + SUITE_TYPE = _SUITE_TYPE; + {$EXTERNALSYM SUITE_TYPE} + TSuiteType = SUITE_TYPE; + +const + VER_SERVER_NT = DWORD($80000000); + {$EXTERNALSYM VER_SERVER_NT} + VER_WORKSTATION_NT = $40000000; + {$EXTERNALSYM VER_WORKSTATION_NT} + VER_SUITE_SMALLBUSINESS = $00000001; + {$EXTERNALSYM VER_SUITE_SMALLBUSINESS} + VER_SUITE_ENTERPRISE = $00000002; + {$EXTERNALSYM VER_SUITE_ENTERPRISE} + VER_SUITE_BACKOFFICE = $00000004; + {$EXTERNALSYM VER_SUITE_BACKOFFICE} + VER_SUITE_COMMUNICATIONS = $00000008; + {$EXTERNALSYM VER_SUITE_COMMUNICATIONS} + VER_SUITE_TERMINAL = $00000010; + {$EXTERNALSYM VER_SUITE_TERMINAL} + VER_SUITE_SMALLBUSINESS_RESTRICTED = $00000020; + {$EXTERNALSYM VER_SUITE_SMALLBUSINESS_RESTRICTED} + VER_SUITE_EMBEDDEDNT = $00000040; + {$EXTERNALSYM VER_SUITE_EMBEDDEDNT} + VER_SUITE_DATACENTER = $00000080; + {$EXTERNALSYM VER_SUITE_DATACENTER} + VER_SUITE_SINGLEUSERTS = $00000100; + {$EXTERNALSYM VER_SUITE_SINGLEUSERTS} + VER_SUITE_PERSONAL = $00000200; + {$EXTERNALSYM VER_SUITE_PERSONAL} + VER_SUITE_BLADE = $00000400; + {$EXTERNALSYM VER_SUITE_BLADE} + +// ntdef.h + +type + error_status_t = Longword; + {$EXTERNALSYM error_status_t} + wchar_t = Word; + {$EXTERNALSYM wchar_t} + +// +// The following types are guaranteed to be signed and 32 bits wide. +// + +type + INT_PTR = Integer; + {$EXTERNALSYM INT_PTR} + PINT_PTR = ^INT_PTR; + {$EXTERNALSYM PINT_PTR} + UINT_PTR = Longword; + {$EXTERNALSYM UINT_PTR} + PUINT_PTR = ^UINT_PTR; + {$EXTERNALSYM PUINT_PTR} + LONG_PTR = Longint; + {$EXTERNALSYM LONG_PTR} + PLONG_PTR = ^LONG_PTR; + {$EXTERNALSYM PLONG_PTR} + ULONG_PTR = Longword; + {$EXTERNALSYM ULONG_PTR} + PULONG_PTR = ^ULONG_PTR; + {$EXTERNALSYM PULONG_PTR} + + LONG32 = Integer; + {$EXTERNALSYM LONG32} + PLONG32 = ^LONG32; + {$EXTERNALSYM PLONG32} + INT32 = Integer; + {$EXTERNALSYM INT32} + PINT32 = ^INT32; + {$EXTERNALSYM PINT32} + +// +// The following types are guaranteed to be unsigned and 32 bits wide. +// + + ULONG32 = Longword; + {$EXTERNALSYM ULONG32} + PULONG32 = ^ULONG32; + {$EXTERNALSYM PULONG32} + DWORD32 = Longword; + {$EXTERNALSYM DWORD32} + PDWORD32 = ^DWORD32; + {$EXTERNALSYM PDWORD32} + UINT32 = Longword; + {$EXTERNALSYM UINT32} + PUINT32 = ^UINT32; + {$EXTERNALSYM PUINT32} + +const + MAX_PATH = 260; + {$EXTERNALSYM MAX_PATH} + +type + +//unsigned char BYTE; +//unsigned short WORD; + + FLOAT = Single; + {$EXTERNALSYM FLOAT} + PFLOAT = ^FLOAT; + {$EXTERNALSYM PFLOAT} + PBOOL = {$IFDEF USE_DELPHI_TYPES} Windows.PBOOL {$ELSE} ^BOOL {$ENDIF}; + {$EXTERNALSYM PBOOL} + LPBOOL = {$IFDEF USE_DELPHI_TYPES} Windows.PBOOL {$ELSE} ^BOOL {$ENDIF}; + {$EXTERNALSYM LPBOOL} + PBYTE = {$IFDEF USE_DELPHI_TYPES} Windows.PBYTE {$ELSE} ^Byte {$ENDIF}; + {$EXTERNALSYM PBYTE} + LPBYTE = {$IFDEF USE_DELPHI_TYPES} Windows.PBYTE {$ELSE} ^Byte {$ENDIF}; + {$EXTERNALSYM LPBYTE} + PINT = {$IFDEF USE_DELPHI_TYPES} Windows.PINT {$ELSE} ^INT {$ENDIF}; + {$EXTERNALSYM PINT} + PUINT = {$IFDEF USE_DELPHI_TYPES} Windows.PUINT {$ELSE} ^UINT {$ENDIF}; + {$EXTERNALSYM PUINT} + LPUINT = {$IFDEF USE_DELPHI_TYPES} Windows.PUINT {$ELSE} ^UINT {$ENDIF}; + {$EXTERNALSYM LPUINT} + LPINT = {$IFDEF USE_DELPHI_TYPES} Windows.PINT {$ELSE} ^INT {$ENDIF}; + {$EXTERNALSYM LPINT} + PWORD = {$IFDEF USE_DELPHI_TYPES} Windows.PWORD {$ELSE} ^WORD {$ENDIF}; + {$EXTERNALSYM PWORD} + LPWORD = {$IFDEF USE_DELPHI_TYPES} Windows.PWORD {$ELSE} ^WORD {$ENDIF}; + {$EXTERNALSYM LPWORD} + LPLONG = ^LONG; + {$EXTERNALSYM LPLONG} + PDWORD = {$IFDEF USE_DELPHI_TYPES} Windows.PDWORD {$ELSE} ^DWORD {$ENDIF}; + {$EXTERNALSYM PDWORD} + LPDWORD = {$IFDEF USE_DELPHI_TYPES} Windows.LPDWORD {$ELSE} ^DWORD {$ENDIF}; + {$EXTERNALSYM LPDWORD} + LPVOID = Pointer; + {$EXTERNALSYM LPVOID} + LPCVOID = Pointer; + {$EXTERNALSYM LPCVOID} + LPLPVOID = ^LPVOID; + {$NODEFINE LPVOID} + + INT = Integer; + {$EXTERNALSYM INT} + UINT = {$IFDEF USE_DELPHI_TYPES} Windows.UINT {$ELSE} Longword {$ENDIF}; + {$EXTERNALSYM UINT} + +// Types use for passing & returning polymorphic values + + WPARAM = {$IFDEF USE_DELPHI_TYPES} Windows.WPARAM {$ELSE} UINT_PTR {$ENDIF}; + {$EXTERNALSYM WPARAM} + LPARAM = {$IFDEF USE_DELPHI_TYPES} Windows.LPARAM {$ELSE} LONG_PTR {$ENDIF}; + {$EXTERNALSYM LPARAM} + LRESULT = {$IFDEF USE_DELPHI_TYPES} Windows.LRESULT {$ELSE} LONG_PTR {$ENDIF}; + {$EXTERNALSYM LRESULT} + +function MAKEWORD(a, b: BYTE): WORD; +{$EXTERNALSYM MAKEWORD} +function MAKELONG(a, b: WORD): DWORD; +{$EXTERNALSYM MAKELONG} + +function LOWORD(L: DWORD): WORD; +{$EXTERNALSYM LOWORD} +function HIWORD(L: DWORD): WORD; +{$EXTERNALSYM HIWORD} +function LOBYTE(W: WORD): BYTE; +{$EXTERNALSYM LOBYTE} +function HIBYTE(W: WORD): BYTE; +{$EXTERNALSYM HIBYTE} + +type + HWND = {$IFDEF USE_DELPHI_TYPES} Windows.HWND {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HWND} + LPHWND = ^HWND; + {$EXTERNALSYM LPHWND} + HHOOK = {$IFDEF USE_DELPHI_TYPES} Windows.HHOOK {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HHOOK} + LPHHOOK = ^HHOOK; + {$EXTERNALSYM LPHHOOK} + HEVENT = HANDLE; + {$EXTERNALSYM HEVENT} + + ATOM = {$IFDEF USE_DELPHI_TYPES} Windows.ATOM {$ELSE} WORD {$ENDIF}; + {$EXTERNALSYM ATOM} + + SPHANDLE = ^HANDLE; + {$EXTERNALSYM SPHANDLE} + LPHANDLE = ^HANDLE; + {$EXTERNALSYM LPHANDLE} + HGLOBAL = {$IFDEF USE_DELPHI_TYPES} Windows.HGLOBAL {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HGLOBAL} + HLOCAL = {$IFDEF USE_DELPHI_TYPES} Windows.HLOCAL {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HLOCAL} + GLOBALHANDLE = HANDLE; + {$EXTERNALSYM GLOBALHANDLE} + //LOCALHANDLE = HANDLE; // todo clashes with WinBase.LocalHandle function + //{$EXTERNALSYM LOCALHANDLE} + FARPROC = {$IFDEF USE_DELPHI_TYPES} Windows.FARPROC {$ELSE} function: Integer; stdcall {$ENDIF}; + {$EXTERNALSYM FARPROC} + NEARPROC = function: Integer; stdcall; + {$EXTERNALSYM NEARPROC} + PROC = function: Integer; stdcall; + {$EXTERNALSYM PROC} + + HGDIOBJ = {$IFDEF USE_DELPHI_TYPES} Windows.HGDIOBJ {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HGDIOBJ} + + HKEY = {$IFDEF USE_DELPHI_TYPES} Windows.HKEY {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HKEY} + PHKEY = {$IFDEF USE_DELPHI_TYPES} Windows.PHKEY {$ELSE} ^HKEY {$ENDIF}; + {$EXTERNALSYM PHKEY} + + HACCEL = {$IFDEF USE_DELPHI_TYPES} Windows.HACCEL {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HACCEL} + + HBITMAP = {$IFDEF USE_DELPHI_TYPES} Windows.HBITMAP {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HBITMAP} + HBRUSH = {$IFDEF USE_DELPHI_TYPES} Windows.HBRUSH {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HBRUSH} + + HCOLORSPACE = {$IFDEF USE_DELPHI_TYPES} Windows.HCOLORSPACE {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HCOLORSPACE} + + HDC = {$IFDEF USE_DELPHI_TYPES} Windows.HDC {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HDC} + HGLRC = {$IFDEF USE_DELPHI_TYPES} Windows.HGLRC {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HGLRC} + HDESK = {$IFDEF USE_DELPHI_TYPES} Windows.HDESK {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HDESK} + HENHMETAFILE = {$IFDEF USE_DELPHI_TYPES} Windows.HENHMETAFILE {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HENHMETAFILE} + HFONT = {$IFDEF USE_DELPHI_TYPES} Windows.HFONT {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HFONT} + HICON = {$IFDEF USE_DELPHI_TYPES} Windows.HICON {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HICON} + HMENU = {$IFDEF USE_DELPHI_TYPES} Windows.HMENU {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HMENU} + HMETAFILE = {$IFDEF USE_DELPHI_TYPES} Windows.HMETAFILE {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HMETAFILE} + HINSTANCE = {$IFDEF USE_DELPHI_TYPES} Windows.HINST {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HINSTANCE} + HMODULE = {$IFDEF USE_DELPHI_TYPES} Windows.HMODULE {$ELSE} HINSTANCE {$ENDIF}; + {$EXTERNALSYM HMODULE} + HPALETTE = {$IFDEF USE_DELPHI_TYPES} Windows.HPALETTE {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HPALETTE} + HPEN = {$IFDEF USE_DELPHI_TYPES} Windows.HPEN {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HPEN} + HRGN = {$IFDEF USE_DELPHI_TYPES} Windows.HRGN {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HRGN} + HRSRC = {$IFDEF USE_DELPHI_TYPES} Windows.HRSRC {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HRSRC} + HSTR = {$IFDEF USE_DELPHI_TYPES} Windows.HSTR {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HSTR} + HTASK = {$IFDEF USE_DELPHI_TYPES} Windows.HTASK {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HTASK} + HWINSTA = {$IFDEF USE_DELPHI_TYPES} Windows.HWINSTA {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HWINSTA} + HKL = {$IFDEF USE_DELPHI_TYPES} Windows.HKL {$ELSE} HANDLE {$ENDIF}; + {$EXTERNALSYM HKL} + PHKL = {$IFDEF USE_DELPHI_TYPES} ^HKL {$ELSE} ^HANDLE {$ENDIF}; + {$EXTERNALSYM PHKL} + + HMONITOR = HANDLE; + {$EXTERNALSYM HMONITOR} + HWINEVENTHOOK = HANDLE; + {$EXTERNALSYM HWINEVENTHOOK} + HUMPD = HANDLE; + {$EXTERNALSYM HUMPD} + + HFILE = {$IFDEF USE_DELPHI_TYPES} Windows.HFILE {$ELSE} Longword {$ENDIF}; + {$EXTERNALSYM HFILE} + HCURSOR = {$IFDEF USE_DELPHI_TYPES} Windows.HCURSOR {$ELSE} HICON {$ENDIF}; + {$EXTERNALSYM HCURSOR} + + COLORREF = {$IFDEF USE_DELPHI_TYPES} Windows.COLORREF {$ELSE} DWORD {$ENDIF}; + {$EXTERNALSYM COLORREF} + LPCOLORREF = ^COLORREF; + {$EXTERNALSYM LPCOLORREF} + + PHMODULE = ^HMODULE; + {$NODEFINE PHMODULE} + +const + HFILE_ERROR = HFILE(-1); + {$EXTERNALSYM HFILE_ERROR} + +type + LPRECT = ^RECT; + {$EXTERNALSYM LPRECT} + tagRECT = record + left: LONG; + top: LONG; + right: LONG; + bottom: LONG; + end; + {$EXTERNALSYM tagRECT} + RECT = {$IFDEF USE_DELPHI_TYPES} Windows.TRect {$ELSE} tagRECT {$ENDIF}; + {$EXTERNALSYM RECT} + NPRECT = ^RECT; + {$EXTERNALSYM NPRECT} + LPCRECT = ^RECT; + {$EXTERNALSYM LPCRECT} + TRect = {$IFDEF USE_DELPHI_TYPES} Windows.TRect {$ELSE} RECT {$ENDIF}; + PRect = {$IFDEF USE_DELPHI_TYPES} Windows.PRect {$ELSE} LPRECT {$ENDIF}; + + LPRECTL = ^RECTL; + {$EXTERNALSYM LPRECTL} + _RECTL = record + left: LONG; + top: LONG; + right: LONG; + bottom: LONG; + end; + {$EXTERNALSYM _RECTL} + RECTL = _RECTL; + {$EXTERNALSYM RECTL} + LPCRECTL = ^_RECTL; + {$EXTERNALSYM LPCRECTL} + TRectl = RECTL; + PRectl = LPRECTL; + + LPPOINT = ^POINT; + {$EXTERNALSYM LPPOINT} + tagPOINT = record + x: LONG; + y: LONG; + end; + {$EXTERNALSYM tagPOINT} + NPPOINT = ^tagPoint; + {$EXTERNALSYM NPPOINT} + POINT = tagPOINT; + {$EXTERNALSYM tagPOINT} + TPoint = {$IFDEF USE_DELPHI_TYPES} Windows.TPoint {$ELSE} POINT {$ENDIF}; + PPoint = {$IFDEF USE_DELPHI_TYPES} Windows.PPoint {$ELSE} LPPOINT {$ENDIF}; + + PPointl = ^POINTL; + _POINTL = record + x: LONG; + y: LONG; + end; + {$EXTERNALSYM _POINTL} + POINTL = _POINTL; + {$EXTERNALSYM POINTL} + TPointl = POINTL; + + LPSIZE = ^TSize; + {$EXTERNALSYM LPSIZE} + + {$IFDEF USE_DELPHI_TYPES} + TSize = Windows.TSize; + PSize = Windows.PSize; + {$ELSE} + tagSIZE = record + cx: LONG; + cy: LONG; + end; + {$EXTERNALSYM tagSIZE} + TSize = tagSIZE; + PSize = LPSIZE; + {$ENDIF USE_DELPHI_TYPES} + + SIZE = TSize; + {$EXTERNALSYM SIZE} + SIZEL = TSize; + {$EXTERNALSYM SIZEL} + PSIZEL = PSize; + {$EXTERNALSYM PSIZEL} + LPSIZEL = PSize; + {$EXTERNALSYM LPSIZEL} + + LPPOINTS = ^POINTS; + {$EXTERNALSYM LPPOINTS} + tagPOINTS = record + x: SHORT; + y: SHORT; + end; + {$EXTERNALSYM tagPOINTS} + POINTS = tagPOINTS; + {$EXTERNALSYM POINTS} + TPoints = POINTS; + PPoints = LPPOINTS; + +// +// File System time stamps are represented with the following structure: +// + + _FILETIME = record + dwLowDateTime: DWORD; + dwHighDateTime: DWORD; + end; + {$EXTERNALSYM _FILETIME} + FILETIME = _FILETIME; + {$EXTERNALSYM FILETIME} + PFILETIME = ^FILETIME; + {$EXTERNALSYM PFILETIME} + LPFILETIME = PFILETIME; + {$EXTERNALSYM LPFILETIME} + TFileTime = FILETIME; + +// mode selections for the device mode function + +const + DM_UPDATE = 1; + {$EXTERNALSYM DM_UPDATE} + DM_COPY = 2; + {$EXTERNALSYM DM_COPY} + DM_PROMPT = 4; + {$EXTERNALSYM DM_PROMPT} + DM_MODIFY = 8; + {$EXTERNALSYM DM_MODIFY} + + DM_IN_BUFFER = DM_MODIFY; + {$EXTERNALSYM DM_IN_BUFFER} + DM_IN_PROMPT = DM_PROMPT; + {$EXTERNALSYM DM_IN_PROMPT} + DM_OUT_BUFFER = DM_COPY; + {$EXTERNALSYM DM_OUT_BUFFER} + DM_OUT_DEFAULT = DM_UPDATE; + {$EXTERNALSYM DM_OUT_DEFAULT} + +// device capabilities indices + + DC_FIELDS = 1; + {$EXTERNALSYM DC_FIELDS} + DC_PAPERS = 2; + {$EXTERNALSYM DC_PAPERS} + DC_PAPERSIZE = 3; + {$EXTERNALSYM DC_PAPERSIZE} + DC_MINEXTENT = 4; + {$EXTERNALSYM DC_MINEXTENT} + DC_MAXEXTENT = 5; + {$EXTERNALSYM DC_MAXEXTENT} + DC_BINS = 6; + {$EXTERNALSYM DC_BINS} + DC_DUPLEX = 7; + {$EXTERNALSYM DC_DUPLEX} + DC_SIZE = 8; + {$EXTERNALSYM DC_SIZE} + DC_EXTRA = 9; + {$EXTERNALSYM DC_EXTRA} + DC_VERSION = 10; + {$EXTERNALSYM DC_VERSION} + DC_DRIVER = 11; + {$EXTERNALSYM DC_DRIVER} + DC_BINNAMES = 12; + {$EXTERNALSYM DC_BINNAMES} + DC_ENUMRESOLUTIONS = 13; + {$EXTERNALSYM DC_ENUMRESOLUTIONS} + DC_FILEDEPENDENCIES = 14; + {$EXTERNALSYM DC_FILEDEPENDENCIES} + DC_TRUETYPE = 15; + {$EXTERNALSYM DC_TRUETYPE} + DC_PAPERNAMES = 16; + {$EXTERNALSYM DC_PAPERNAMES} + DC_ORIENTATION = 17; + {$EXTERNALSYM DC_ORIENTATION} + DC_COPIES = 18; + {$EXTERNALSYM DC_COPIES} + +// +// HALF_PTR is half the size of a pointer it intended for use with +// within strcuture which contain a pointer and two small fields. +// UHALF_PTR is the unsigned variation. +// + +const + ADDRESS_TAG_BIT = DWORD($80000000); + {$EXTERNALSYM ADDRESS_TAG_BIT} + +type + UHALF_PTR = Byte; + {$EXTERNALSYM UHALF_PTR} + PUHALF_PTR = ^UHALF_PTR; + {$EXTERNALSYM PUHALF_PTR} + HALF_PTR = Shortint; + {$EXTERNALSYM HALF_PTR} + PHALF_PTR = ^HALF_PTR; + {$EXTERNALSYM PHALF_PTR} + + SHANDLE_PTR = Longint; + {$EXTERNALSYM SHANDLE_PTR} + HANDLE_PTR = Longint; + {$EXTERNALSYM HANDLE_PTR} + +// +// SIZE_T used for counts or ranges which need to span the range of +// of a pointer. SSIZE_T is the signed variation. +// + + SIZE_T = ULONG_PTR; + {$EXTERNALSYM SIZE_T} + PSIZE_T = ^SIZE_T; + {$EXTERNALSYM PSIZE_T} + SSIZE_T = LONG_PTR; + {$EXTERNALSYM SSIZE_T} + PSSIZE_T = ^SSIZE_T; + {$EXTERNALSYM PSSIZE_T} + +// +// Add Windows flavor DWORD_PTR types +// + + DWORD_PTR = ULONG_PTR; + {$EXTERNALSYM DWORD_PTR} + PDWORD_PTR = ^DWORD_PTR; + {$EXTERNALSYM PDWORD_PTR} + +// +// The following types are guaranteed to be signed and 64 bits wide. +// + + LONG64 = Int64; + {$EXTERNALSYM LONG64} + PLONG64 = ^LONG64; + {$EXTERNALSYM PLONG64} + + PINT64 = ^Int64; + {$EXTERNALSYM PINT64} + +// +// The following types are guaranteed to be unsigned and 64 bits wide. +// + + ULONG64 = Int64; + {$EXTERNALSYM ULONG64} + PULONG64 = ^ULONG64; + {$EXTERNALSYM PULONG64} + DWORD64 = Int64; + {$EXTERNALSYM DWORD64} + PDWORD64 = ^DWORD64; + {$EXTERNALSYM PDWORD64} + UINT64 = Int64; + {$EXTERNALSYM UINT64} + PUINT64 = ^UINT64; + {$EXTERNALSYM PUINT64} + +const + MAXUINT_PTR = not UINT_PTR(0); + {$EXTERNALSYM MAXUINT_PTR} + MAXINT_PTR = INT_PTR((MAXUINT_PTR shr 1)); + {$EXTERNALSYM MAXINT_PTR} + MININT_PTR = not MAXINT_PTR; + {$EXTERNALSYM MININT_PTR} + + MAXULONG_PTR = not ULONG_PTR(0); + {$EXTERNALSYM MAXULONG_PTR} + MAXLONG_PTR = LONG_PTR(MAXULONG_PTR shr 1); + {$EXTERNALSYM MAXLONG_PTR} + MINLONG_PTR = not MAXLONG_PTR; + {$EXTERNALSYM MINLONG_PTR} + + MAXUHALF_PTR = UHALF_PTR( not 0); + {$EXTERNALSYM MAXUHALF_PTR} + MAXHALF_PTR = HALF_PTR(MAXUHALF_PTR shr 1); + {$EXTERNALSYM MAXHALF_PTR} + MINHALF_PTR = not MAXHALF_PTR; + {$EXTERNALSYM MINHALF_PTR} + +// basetsd + +type + INT8 = Shortint; + {$EXTERNALSYM INT8} + PINT8 = ^INT8; + {$EXTERNALSYM PINT8} + INT16 = Smallint; + {$EXTERNALSYM INT16} + PINT16 = ^INT16; + {$EXTERNALSYM PINT16} + UINT8 = Byte; + {$EXTERNALSYM UINT8} + PUINT8 = ^UINT8; + {$EXTERNALSYM PUINT8} + UINT16 = Word; + {$EXTERNALSYM UINT16} + PUINT16 = ^UINT16; + {$EXTERNALSYM PUINT16} + +// +// Thread affinity. +// + + KAFFINITY = ULONG_PTR; + {$EXTERNALSYM KAFFINITY} + PKAFFINITY = ^KAFFINITY; + {$EXTERNALSYM PKAFFINITY} + + // (rom) missing types + LPCASTR = ^AnsiChar; + LPASTR = ^AnsiChar; + PCASTR = ^AnsiChar; + PASTR = ^AnsiChar; + + PPCWSTR = ^LPCWSTR; + PPCASTR = ^LPCASTR; + PPCSTR = ^LPCTSTR; + PPWSTR = ^LPWSTR; + PPASTR = ^LPASTR; + PPSTR = ^LPTSTR; + PPTCHAR = ^PTCHAR; + LPLPCTSTR = ^LPCTSTR; + +implementation + +uses + EM.JwaWinNT; + +{$IFNDEF USE_DELPHI_TYPES} +const + kernel32 = 'kernel32.dll'; +{$ENDIF !USE_DELPHI_TYPES} + +function Int32x32To64(a, b: LONG): LONGLONG; +begin + Result := a * b; +end; + +function UInt32x32To64(a, b: DWORD): ULONGLONG; +begin + Result := a * b; +end; + +function Int64ShllMod32(Value: ULONGLONG; ShiftCount: DWORD): ULONGLONG; +asm + MOV ECX, ShiftCount + MOV EAX, DWORD PTR [Value] + MOV EDX, DWORD PTR [Value + 4] + SHLD EDX, EAX, CL + SHL EAX, CL +end; + +function Int64ShraMod32(Value: LONGLONG; ShiftCount: DWORD): LONGLONG; +asm + MOV ECX, ShiftCount + MOV EAX, DWORD PTR [Value] + MOV EDX, DWORD PTR [Value + 4] + SHRD EAX, EDX, CL + SAR EDX, CL +end; + +function Int64ShrlMod32(Value: ULONGLONG; ShiftCount: DWORD): ULONGLONG; +asm + MOV ECX, ShiftCount + MOV EAX, DWORD PTR [Value] + MOV EDX, DWORD PTR [Value + 4] + SHRD EAX, EDX, CL + SHR EDX, CL +end; + +procedure ListEntry32To64(l32: PLIST_ENTRY32; l64: PLIST_ENTRY64); +begin + l64^.Flink := l32^.Flink; + l64^.Blink := l32^.Blink; +end; + +procedure ListEntry64To32(l64: PLIST_ENTRY64; l32: PLIST_ENTRY32); +begin + l32^.Flink := ULONG(l64^.Flink); + l32^.Blink := ULONG(l64^.Blink); +end; + +function NT_SUCCESS(Status: NTSTATUS): BOOL; +begin + Result := Status >= 0; +end; + +function NT_INFORMATION(Status: NTSTATUS): BOOL; +begin + Result := (ULONG(Status) shr 30) = 1; +end; + +function NT_WARNING(Status: NTSTATUS): BOOL; +begin + Result := (ULONG(Status) shr 30) = 2; +end; + +function NT_ERROR(Status: NTSTATUS): BOOL; +begin + Result := (ULONG(Status) shr 30) = 3; +end; + +procedure InitializeObjectAttributes(p: POBJECT_ATTRIBUTES; n: PUNICODE_STRING; + a: ULONG; r: HANDLE; s: PVOID{PSECURITY_DESCRIPTOR}); +begin + p^.Length := SizeOf(OBJECT_ATTRIBUTES); + p^.RootDirectory := r; + p^.Attributes := a; + p^.ObjectName := n; + p^.SecurityDescriptor := s; + p^.SecurityQualityOfService := nil; +end; + +function ARGUMENT_PRESENT(ArgumentPointer: Pointer): BOOL; +begin + Result := ArgumentPointer <> nil; +end; + +function MAKEWORD(a, b: BYTE): WORD; +begin + Result := (b shl 8) or a; +end; + +function MAKELONG(a, b: WORD): DWORD; +begin + Result := (b shl 16) or a; +end; + +function LOWORD(L: DWORD): WORD; +begin + Result := L and $0000FFFF; +end; + +function HIWORD(L: DWORD): WORD; +begin + Result := L shr 16; +end; + +function LOBYTE(W: WORD): BYTE; +begin + Result := W and $FF; +end; + +function HIBYTE(W: WORD): BYTE; +begin + Result := W shr 8; +end; + +function GetModuleHandle(lpModuleName: LPCSTR): HMODULE; stdcall; external kernel32 name 'GetModuleHandleA'; +function LoadLibrary(lpLibFileName: LPCSTR): HMODULE; stdcall; external kernel32 name 'LoadLibraryA'; +function GetProcAddress(hModule: HMODULE; lpProcName: LPCSTR): FARPROC; stdcall; external kernel32 name 'GetProcAddress'; + +resourcestring + RsELibraryNotFound = 'Library not found: %s'; + RsEFunctionNotFound = 'Function not found: %s.%s'; + +procedure GetProcedureAddress(var P: Pointer; const ModuleName, ProcName: Ansistring); +var + ModuleHandle: HMODULE; +begin + if not Assigned(P) then + begin + ModuleHandle := GetModuleHandle(PAnsiChar(ModuleName)); + if ModuleHandle = 0 then + begin + ModuleHandle := LoadLibrary(PAnsiChar(ModuleName)); + if ModuleHandle = 0 then + raise EJwaLoadLibraryError.CreateResFmt(@RsELibraryNotFound, [ModuleName]); + end; + P := Pointer(GetProcAddress(ModuleHandle, PAnsiChar(ProcName))); + if not Assigned(P) then + raise EJwaGetProcAddressError.CreateResFmt(@RsEFunctionNotFound, [ModuleName, ProcName]); + end; +end; + +end. + diff --git a/Tocsg.Lib/VCL/Other/EM.nduCType.pas b/Tocsg.Lib/VCL/Other/EM.nduCType.pas new file mode 100644 index 00000000..165d6925 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.nduCType.pas @@ -0,0 +1,83 @@ +{*------------------------------------------------------------------------------ + C Typen Deklaration (?ersetztung der Variabeln von C in Delphi) + @Author nitschchedu + @Version 1 Alpha + @Todo C Typen Convertation +-------------------------------------------------------------------------------} + +unit EM.nduCType; + +interface + +uses + Windows, Classes; + +type + //*** ?ersetztung der Variabeln von C in Delphi ***// + //*** ------------------------------------------ ***// + //C //Delphi //Komentar + //*** ------------------------------------------ ***// + Bool = LongBool; ///C Bool + Int = Integer; ///C Int + unsigned_short = Word; ///C unsigned short + ushort = Word; ///C ushort + short = Smallint; ///C short + signed_short = Smallint; ///C signed short + UINT = Cardinal; ///C UINT + DWORD = Cardinal; ///C DWORD + unsigned_long = Cardinal; ///C unsigned short + unsigned_long_int = Cardinal; ///C unsigned short int + ulong = Cardinal; ///C ULong + long = Longint; ///C Long + signed_char = Shortint; ///C signed char + unsigned_char = Byte; ///C unsigned char + uchar = Byte; ///C UChar + LPSTR = PChar; ///C LPSTR + PSTR = PChar; ///C PSTR + //C Void (Gibt es nicht in Delphi) (ist ne procedure) + //void = Pointer; + PVOID = Pointer; ///C PVoid + PPVOID = ^PVOID; ///C ppvoid + float = Single; ///C float + long_double = Extended; ///C long double + wchar = WideChar; ///C WChar + ulonglong = TLargeInteger; ///C ulonglong + LPCTSTR = PWideChar; ///C LPCTSTR + Handle = THandle; ///C Handle + LPByte = PByte; ///C LPByte + PLPCWSTR = ^LPCWSTR; ///C PLPCWSTR + PPByte = ^PByte; ///C PPByte + unsigned_int = Cardinal; ///C unsigned int + Punsigned_int = ^unsigned_int; ///C unsigned int * + unsigned = Cardinal; ///C unsigned + LPVOID = Pointer; ///C LPVOID + ULONG_PTR = LongWord; ///C ULONG_PTR + PTSTR = LPWSTR; ///C PTSTR + PPTSTR = ^PTSTR; ///C PPTSTR + int32 = Longint; ///C int32 + //*** ------------------------------------------ ***// + //*** ------------------------------------------ ***// + + + //*** ------------------------------------------ ***// + //*** crtdefs.h ***// + Tndu_time32_t = long; ///C time32_t aus der crtdefs.h + Tndu_errno_t = Integer; ///C errno_t aus der crtdefs.h + Tndu_size_t = Int64; ///C size_t aus der crtdefs.h + //*** ------------------------------------------ ***// + //*** ------------------------------------------ ***// + + + + + _SecHandle = record + dwLower: ULONG_PTR; + dwUpper: ULONG_PTR; + end; + + SecHandle = _SecHandle; + PSecHandle = ^SecHandle; + +implementation + +end. diff --git a/Tocsg.Lib/VCL/Other/EM.nduEapTypes.pas b/Tocsg.Lib/VCL/Other/EM.nduEapTypes.pas new file mode 100644 index 00000000..e66e520a --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.nduEapTypes.pas @@ -0,0 +1,79 @@ +unit EM.nduEapTypes; + +interface + +uses + EM.nduCType, Classes, Windows; + +const + NDU_eapPropCipherSuiteNegotiation = $00000001; + NDU_eapPropMutualAuth = $00000002; + NDU_eapPropIntegrity = $00000004; + NDU_eapPropReplayProtection = $00000008; + NDU_eapPropConfidentiality = $00000010; + NDU_eapPropKeyDerivation = $00000020; + NDU_eapPropKeyStrength64 = $00000040; + NDU_eapPropKeyStrength128 = $00000080; + NDU_eapPropKeyStrength256 = $00000100; + NDU_eapPropKeyStrength512 = $00000200; + NDU_eapPropKeyStrength1024 = $00000400; + NDU_eapPropDictionaryAttackResistance = $00000800; + NDU_eapPropFastReconnect = $00001000; + NDU_eapPropCryptoBinding = $00002000; + NDU_eapPropSessionDependence = $00004000; + NDU_eapPropFragmentation = $00008000; + NDU_eapPropChannelBinding = $00010000; + NDU_eapPropNap = $00020000; + NDU_eapPropStandalone = $00040000; + NDU_eapPropMppeEncryption = $00080000; + NDU_eapPropTunnelMethod = $00100000; + NDU_eapPropSupportsConfig = $00200000; + NDU_eapPropReserved = $80000000; + + NDU_EAP_VALUENAME_PROPERTIES = 'Properties'; + +type + NDU_EAP_SESSIONID = DWORD; + + Tndu_EAP_TYPE = record + atype: Byte; + dwVendorId: DWORD; + dwVendorType: DWORD; + end; + + Tndu_EAP_METHOD_TYPE = record + eapType: Tndu_EAP_TYPE; + dwAuthorId: DWORD; + end; + + Pndu_EAP_METHOD_INFO = ^Tndu_EAP_METHOD_INFO; + Tndu_EAP_METHOD_INFO = record + eaptype: Tndu_EAP_METHOD_TYPE; + pwszAuthorName: LPWSTR; + pwszFriendlyName: LPWSTR; + eapProperties: DWORD; + pInnerMethodInfo: Pndu_EAP_METHOD_INFO; + end; + + Tndu_EAP_METHOD_INFO_ARRAY = record + dwNumberOfMethods: DWORD; + pEapMethods: Pndu_EAP_METHOD_INFO; + end; + + Tndu_EAP_ERROR = record + dwWinError: DWORD; + atype: Tndu_EAP_METHOD_TYPE; + dwReasonCode: DWORD; + rootCauseGuid: TGUID; + repairGuid: TGUID; + helpLinkGuid: TGUID; + + pRootCauseString: LPWSTR; + pRepairString: LPWSTR; + end; + + //.... + +implementation + +end. diff --git a/Tocsg.Lib/VCL/Other/EM.nduL2cmn.pas b/Tocsg.Lib/VCL/Other/EM.nduL2cmn.pas new file mode 100644 index 00000000..854002b8 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.nduL2cmn.pas @@ -0,0 +1,75 @@ +{ + ?ersetzt aus l2cmn.h vom Windows SDK +} + +unit EM.nduL2cmn; + +interface + +uses + EM.nduCType; + +const + //Profil Name Max L?ge, in Char Zeichen + NDU_L2_PROFILE_MAX_NAME_LENGTH = 256; + + NDU_L2_NOTIFICATION_SOURCE_NONE = 0; + NDU_L2_NOTIFICATION_SOURCE_DOT3_AUTO_CONFIG = $00000001; + NDU_L2_NOTIFICATION_SOURCE_SECURITY = $00000002; + NDU_L2_NOTIFICATION_SOURCE_ONEX = $00000004; + NDU_L2_NOTIFICATION_SOURCE_WLAN_ACM = $00000008; + NDU_L2_NOTIFICATION_SOURCE_WLAN_MSM = $00000010; + NDU_L2_NOTIFICATION_SOURCE_WLAN_SECURITY = $00000020; + NDU_L2_NOTIFICATION_SOURCE_WLAN_IHV = $00000040; + + NDU_L2_NOTIFICATION_SOURCE_ALL = $0000FFFF; + NDU_L2_NOTIFICATION_CODE_PUBLIC_BEGIN = $00000000; + + + NDU_L2_REASON_CODE_GROUP_SIZE = $10000; + NDU_L2_REASON_CODE_GEN_BASE = $10000; + + NDU_L2_REASON_CODE_DOT11_AC_BASE = + (NDU_L2_REASON_CODE_GEN_BASE + NDU_L2_REASON_CODE_GROUP_SIZE); + + NDU_L2_REASON_CODE_DOT11_MSM_BASE = + (NDU_L2_REASON_CODE_DOT11_AC_BASE + NDU_L2_REASON_CODE_GROUP_SIZE); + + NDU_L2_REASON_CODE_DOT11_SECURITY_BASE = + (NDU_L2_REASON_CODE_DOT11_MSM_BASE + NDU_L2_REASON_CODE_GROUP_SIZE); + + NDU_L2_REASON_CODE_ONEX_BASE = + (NDU_L2_REASON_CODE_DOT11_SECURITY_BASE + NDU_L2_REASON_CODE_GROUP_SIZE); + + NDU_L2_REASON_CODE_DOT3_AC_BASE = + (NDU_L2_REASON_CODE_ONEX_BASE + NDU_L2_REASON_CODE_GROUP_SIZE); + + NDU_L2_REASON_CODE_DOT3_MSM_BASE = + (NDU_L2_REASON_CODE_DOT3_AC_BASE + NDU_L2_REASON_CODE_GROUP_SIZE); + + NDU_L2_REASON_CODE_PROFILE_BASE = + (NDU_L2_REASON_CODE_DOT3_MSM_BASE + NDU_L2_REASON_CODE_GROUP_SIZE); + + NDU_L2_REASON_CODE_IHV_BASE = + (NDU_L2_REASON_CODE_PROFILE_BASE + NDU_L2_REASON_CODE_GROUP_SIZE); + + NDU_L2_REASON_CODE_SUCCESS = 0; + + NDU_L2_REASON_CODE_UNKNOWN = + (NDU_L2_REASON_CODE_GEN_BASE + 1); + + NDU_L2_REASON_CODE_PROFILE_MISSING = $00000001; + +type + Pndu_L2_NOTIFICATION_DATA = ^Tndu_L2_NOTIFICATION_DATA; + Tndu_L2_NOTIFICATION_DATA = record + NotificationSource: DWORD; + NotificationCode: DWORD; + InterfaceGuid: TGUID; + dwDataSize: DWORD; + pData: PVOID; + end; + +implementation + +end. diff --git a/Tocsg.Lib/VCL/Other/EM.nduNtDDNdis.pas b/Tocsg.Lib/VCL/Other/EM.nduNtDDNdis.pas new file mode 100644 index 00000000..ccbb9f33 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.nduNtDDNdis.pas @@ -0,0 +1,18 @@ +unit EM.nduNtDDNdis; + +interface + +uses + EM.nduCType; + +type + Pndu_NDIS_OBJECT_HEADER = ^Tndu_NDIS_OBJECT_HEADER; + Tndu_NDIS_OBJECT_HEADER = packed record + aType: uchar; + Revision: uchar; + Size: ushort; + end; + +implementation + +end. diff --git a/Tocsg.Lib/VCL/Other/EM.nduWinDot11.pas b/Tocsg.Lib/VCL/Other/EM.nduWinDot11.pas new file mode 100644 index 00000000..f0f4c67e --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.nduWinDot11.pas @@ -0,0 +1,54 @@ +unit EM.nduWinDot11; + +interface + +uses + EM.nduCType, EM.nduWlanTypes, EM.nduNtDDNdis; + +type + Tndu_DOT11_MAC_ADDRESS = array[0..5] of uchar; + Pndu_DOT11_MAC_ADDRESS = ^Tndu_DOT11_MAC_ADDRESS; + + Pndu_DOT11_BSSID_LIST = ^Tndu_DOT11_BSSID_LIST; + Tndu_DOT11_BSSID_LIST = record + //const NDU_DOT11_BSSID_LIST_REVISION_1 = 1; + Header: Tndu_NDIS_OBJECT_HEADER; + uNumOfEntries: ulong; + uTotalNumOfEntries: ulong; + BSSIDs: array[0..0] of Tndu_DOT11_MAC_ADDRESS; + end; + + {$MINENUMSIZE 4} +// Pndu_DOT11_PHY_TYPE = ^Tndu_DOT11_PHY_TYPE; +// Tndu_DOT11_PHY_TYPE = ( +// dot11_phy_type_unknown = 0, +// dot11_phy_type_any = dot11_phy_type_unknown, +// dot11_phy_type_fhss = 1, +// dot11_phy_type_dsss = 2, +// dot11_phy_type_irbaseband = 3, +// dot11_phy_type_ofdm = 4, +// dot11_phy_type_hrdsss = 5, +// dot11_phy_type_erp = 6, +// dot11_phy_type_ht = 7, +// dot11_phy_type_vht = 8, +// dot11_phy_type_IHV_start = $80000000, +// dot11_phy_type_IHV_end = $ffffffff); + +const + NDU_DOT11_RATE_SET_MAX_LENGTH = 126; // 126 bytes + +type + Pndu_DOT11_RATE_SET = ^Tndu_DOT11_RATE_SET; + Tndu_DOT11_RATE_SET = record + uRateSetLength: ulong; + ucRateSet: array[0..NDU_DOT11_RATE_SET_MAX_LENGTH - 1] of uchar; + end; + + Tndu_DOT11_COUNTRY_OR_REGION_STRING = array[0..2] of uchar; + Pndu_DOT11_COUNTRY_OR_REGION_STRING = ^Tndu_DOT11_COUNTRY_OR_REGION_STRING; + + //.. wird noch weiter gehen + +implementation + +end. diff --git a/Tocsg.Lib/VCL/Other/EM.nduWinNT.pas b/Tocsg.Lib/VCL/Other/EM.nduWinNT.pas new file mode 100644 index 00000000..80fac945 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.nduWinNT.pas @@ -0,0 +1,29 @@ +{ ?ersetztung aus der WinNT.h +} +unit EM.nduWinNT; + +interface + +const + //... + NDU_DELETE = $00010000; + NDU_READ_CONTROL = $00020000; + + NDU_STANDARD_RIGHTS_READ = (NDU_READ_CONTROL); + NDU_STANDARD_RIGHTS_WRITE = (NDU_READ_CONTROL); + NDU_STANDARD_RIGHTS_EXECUTE = (NDU_READ_CONTROL); + + //.. + + NDU_FILE_READ_DATA = $0001; // file & pipe + NDU_FILE_EXECUTE = $0020; + + //.. + + NDU_FILE_WRITE_DATA = $0002; + NDU_WRITE_DAC = $00040000; + + +implementation + +end. diff --git a/Tocsg.Lib/VCL/Other/EM.nduWlanAPI.pas b/Tocsg.Lib/VCL/Other/EM.nduWlanAPI.pas new file mode 100644 index 00000000..f784e784 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.nduWlanAPI.pas @@ -0,0 +1,952 @@ +unit EM.nduWlanAPI; +interface +uses + EM.nduCType, EM.nduL2cmn, EM.nduWlanTypes, EM.nduWinDot11, EM.nduWinNT, Windows, EM.nduEapTypes; +const + NDU_WLAN_API_VERSION = 1; + NDU_WLAN_MAX_NAME_LENGTH = NDU_L2_PROFILE_MAX_NAME_LENGTH; + //Profil Flags + NDU_WLAN_PROFILE_GROUP_POLICY = $00000001; + NDU_WLAN_PROFILE_USER = $00000002; + WLAN_SET_EAPHOST_DATA_ALL_USERS = $00000001; + WLAN_MAX_PHY_TYPE_NUMBER = 8; +type + Pndu_WLAN_PROFILE_INFO = ^Tndu_WLAN_PROFILE_INFO; + Tndu_WLAN_PROFILE_INFO = record + strProfileName: array[0..NDU_WLAN_MAX_NAME_LENGTH - 1] of wchar; + dwFlags: DWORD; + end; + Pndu_DOT11_NETWORK = ^Tndu_DOT11_NETWORK; + Tndu_DOT11_NETWORK = record + dot11Ssid: Tndu_DOT11_SSID; + dot11BssType: Tndu_DOT11_BSS_TYPE; + end; +const + NDU_DOT11_PSD_IE_MAX_DATA_SIZE = 220; // 255 - 6 - 2 - FORMAT ID + NDU_DOT11_PSD_IE_MAX_ENTRY_NUMBER = 10; // 10 enties at most +type + Pndu_WLAN_RAW_DATA = ^Tndu_WLAN_RAW_DATA; + Tndu_WLAN_RAW_DATA = record + dwDataSize: DWORD; + DataBlob: array[0..0] of Byte; + end; + Pndu_WLAN_RAW_DATA_LIST = ^Tndu_WLAN_RAW_DATA_LIST; + PPndu_WLAN_RAW_DATA_LIST = ^Pndu_WLAN_RAW_DATA_LIST; + Tndu_WLAN_RAW_DATA_LIST = record + dwTotalSize: DWORD; + dwNumberOfItems: DWORD; + case Integer of + 0: (dwDataOffset: DWORD); + 1: (dwDataSize: DWORD); + end; + {$MINENUMSIZE 4} + Pndu_WLAN_CONNECTION_MODE = ^Tndu_WLAN_CONNECTION_MODE; + Tndu_WLAN_CONNECTION_MODE = ( + wlan_connection_mode_profile = 0, + wlan_connection_mode_temporary_profile, + wlan_connection_mode_discovery_secure, + wlan_connection_mode_discovery_unsecure, + wlan_connection_mode_auto, + wlan_connection_mode_invalid); + Tndu_WLAN_REASON_CODE = DWORD; + Pndu_WLAN_REASON_CODE = ^Tndu_WLAN_REASON_CODE; +const + NDU_WLAN_REASON_CODE_SUCCESS = NDU_L2_REASON_CODE_SUCCESS; + NDU_WLAN_REASON_CODE_UNKNOWN = NDU_L2_REASON_CODE_UNKNOWN; + NDU_WLAN_REASON_CODE_RANGE_SIZE = NDU_L2_REASON_CODE_GROUP_SIZE; + NDU_WLAN_REASON_CODE_BASE = NDU_L2_REASON_CODE_DOT11_AC_BASE; + NDU_WLAN_REASON_CODE_AC_BASE = NDU_L2_REASON_CODE_DOT11_AC_BASE; + NDU_WLAN_REASON_CODE_AC_CONNECT_BASE = + (NDU_WLAN_REASON_CODE_AC_BASE + NDU_WLAN_REASON_CODE_RANGE_SIZE div 2); + NDU_WLAN_REASON_CODE_AC_END = + (NDU_WLAN_REASON_CODE_AC_BASE + NDU_WLAN_REASON_CODE_RANGE_SIZE - 1); + + NDU_WLAN_REASON_CODE_PROFILE_BASE = NDU_L2_REASON_CODE_PROFILE_BASE; + NDU_WLAN_REASON_CODE_PROFILE_CONNECT_BASE = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + NDU_WLAN_REASON_CODE_RANGE_SIZE div 2); + NDU_WLAN_REASON_CODE_PROFILE_END = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + NDU_WLAN_REASON_CODE_RANGE_SIZE - 1); + // range for MSM + // + NDU_WLAN_REASON_CODE_MSM_BASE = NDU_L2_REASON_CODE_DOT11_MSM_BASE; + NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE = + (NDU_WLAN_REASON_CODE_MSM_BASE + NDU_WLAN_REASON_CODE_RANGE_SIZE div 2); + NDU_WLAN_REASON_CODE_MSM_END = + (NDU_WLAN_REASON_CODE_MSM_BASE + NDU_WLAN_REASON_CODE_RANGE_SIZE - 1); + // range for MSMSEC + // + NDU_WLAN_REASON_CODE_MSMSEC_BASE = + NDU_L2_REASON_CODE_DOT11_SECURITY_BASE; + NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + NDU_WLAN_REASON_CODE_RANGE_SIZE div 2); + NDU_WLAN_REASON_CODE_MSMSEC_END = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + NDU_WLAN_REASON_CODE_RANGE_SIZE - 1); + // AC network incompatible reason codes + // + NDU_WLAN_REASON_CODE_NETWORK_NOT_COMPATIBLE = + (NDU_WLAN_REASON_CODE_AC_BASE + 1); + NDU_WLAN_REASON_CODE_PROFILE_NOT_COMPATIBLE = + (NDU_WLAN_REASON_CODE_AC_BASE + 2); + // AC connect reason code + // + NDU_WLAN_REASON_CODE_NO_AUTO_CONNECTION = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 1); + NDU_WLAN_REASON_CODE_NOT_VISIBLE = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 2); + NDU_WLAN_REASON_CODE_GP_DENIED = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 3); + NDU_WLAN_REASON_CODE_USER_DENIED = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 4); + NDU_WLAN_REASON_CODE_BSS_TYPE_NOT_ALLOWED = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 5); + NDU_WLAN_REASON_CODE_IN_FAILED_LIST = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 6); + NDU_WLAN_REASON_CODE_IN_BLOCKED_LIST = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 7); + NDU_WLAN_REASON_CODE_SSID_LIST_TOO_LONG = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 8); + NDU_WLAN_REASON_CODE_CONNECT_CALL_FAIL = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 9); + NDU_WLAN_REASON_CODE_SCAN_CALL_FAIL = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 10); + NDU_WLAN_REASON_CODE_NETWORK_NOT_AVAILABLE = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 11); + NDU_WLAN_REASON_CODE_PROFILE_CHANGED_OR_DELETED = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 12); + NDU_WLAN_REASON_CODE_KEY_MISMATCH = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 13); + NDU_WLAN_REASON_CODE_USER_NOT_RESPOND = + (NDU_WLAN_REASON_CODE_AC_CONNECT_BASE + 14); + // Profile validation errors + // + NDU_WLAN_REASON_CODE_INVALID_PROFILE_SCHEMA = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 1); + NDU_WLAN_REASON_CODE_PROFILE_MISSING = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 2); + NDU_WLAN_REASON_CODE_INVALID_PROFILE_NAME = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 3); + NDU_WLAN_REASON_CODE_INVALID_PROFILE_TYPE = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 4); + NDU_WLAN_REASON_CODE_INVALID_PHY_TYPE = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 5); + NDU_WLAN_REASON_CODE_MSM_SECURITY_MISSING = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 6); + NDU_WLAN_REASON_CODE_IHV_SECURITY_NOT_SUPPORTED = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 7); + NDU_WLAN_REASON_CODE_IHV_OUI_MISMATCH = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 8); + NDU_WLAN_REASON_CODE_IHV_OUI_MISSING = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 9); + NDU_WLAN_REASON_CODE_IHV_SETTINGS_MISSING = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 10); + NDU_WLAN_REASON_CODE_CONFLICT_SECURITY = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 11); + NDU_WLAN_REASON_CODE_SECURITY_MISSING = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 12); + NDU_WLAN_REASON_CODE_INVALID_BSS_TYPE = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 13); + NDU_WLAN_REASON_CODE_INVALID_ADHOC_CONNECTION_MODE = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 14); + NDU_WLAN_REASON_CODE_NON_BROADCAST_SET_FOR_ADHOC = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 15); + NDU_WLAN_REASON_CODE_AUTO_SWITCH_SET_FOR_ADHOC = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 16); + NDU_WLAN_REASON_CODE_AUTO_SWITCH_SET_FOR_MANUAL_CONNECTION = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 17); + NDU_WLAN_REASON_CODE_IHV_SECURITY_ONEX_MISSING = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 18); + NDU_WLAN_REASON_CODE_PROFILE_SSID_INVALID = + (NDU_WLAN_REASON_CODE_PROFILE_BASE + 19); + // MSM network incompatible reasons + // + NDU_WLAN_REASON_CODE_UNSUPPORTED_SECURITY_SET_BY_OS = + (NDU_WLAN_REASON_CODE_MSM_BASE + 1); + NDU_WLAN_REASON_CODE_UNSUPPORTED_SECURITY_SET = + (NDU_WLAN_REASON_CODE_MSM_BASE + 2); + NDU_WLAN_REASON_CODE_BSS_TYPE_UNMATCH = + (NDU_WLAN_REASON_CODE_MSM_BASE + 3); + NDU_WLAN_REASON_CODE_PHY_TYPE_UNMATCH = + (NDU_WLAN_REASON_CODE_MSM_BASE + 4); + NDU_WLAN_REASON_CODE_DATARATE_UNMATCH = + (NDU_WLAN_REASON_CODE_MSM_BASE + 5); + // MSM connection failure reasons, to be defined + // failure reason codes + // + NDU_WLAN_REASON_CODE_USER_CANCELLED = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 1); + NDU_WLAN_REASON_CODE_ASSOCIATION_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 2); + NDU_WLAN_REASON_CODE_ASSOCIATION_TIMEOUT = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 3); + NDU_WLAN_REASON_CODE_PRE_SECURITY_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 4); + NDU_WLAN_REASON_CODE_START_SECURITY_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 5); + NDU_WLAN_REASON_CODE_SECURITY_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 6); + NDU_WLAN_REASON_CODE_SECURITY_TIMEOUT = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 7); + NDU_WLAN_REASON_CODE_ROAMING_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 8); + NDU_WLAN_REASON_CODE_ROAMING_SECURITY_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 9); + NDU_WLAN_REASON_CODE_ADHOC_SECURITY_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 10); + NDU_WLAN_REASON_CODE_DRIVER_DISCONNECTED = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 11); + NDU_WLAN_REASON_CODE_DRIVER_OPERATION_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 12); + NDU_WLAN_REASON_CODE_IHV_NOT_AVAILABLE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 13); + NDU_WLAN_REASON_CODE_IHV_NOT_RESPONDING = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 14); + NDU_WLAN_REASON_CODE_DISCONNECT_TIMEOUT = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 15); + NDU_WLAN_REASON_CODE_INTERNAL_FAILURE = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 16); + NDU_WLAN_REASON_CODE_UI_REQUEST_TIMEOUT = + (NDU_WLAN_REASON_CODE_MSM_CONNECT_BASE + 17); + // MSMSEC reason codes + // + NDU_WLAN_REASON_CODE_MSMSEC_MIN = NDU_WLAN_REASON_CODE_MSMSEC_BASE; + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_INVALID_KEY_INDEX = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 1); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_PSK_PRESENT = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 2); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_KEY_LENGTH = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 3); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_PSK_LENGTH = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 4); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_NO_AUTH_CIPHER_SPECIFIED = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 5); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_TOO_MANY_AUTH_CIPHER_SPECIFIED = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 6); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_DUPLICATE_AUTH_CIPHER = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 7); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_RAWDATA_INVALID = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 8); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_INVALID_AUTH_CIPHER = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 9); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_ONEX_DISABLED = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 10); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_ONEX_ENABLED = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 11); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_INVALID_PMKCACHE_MODE = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 12); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_INVALID_PMKCACHE_SIZE = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 13); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_INVALID_PMKCACHE_TTL = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 14); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_INVALID_PREAUTH_MODE = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 15); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_INVALID_PREAUTH_THROTTLE = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 16); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_PREAUTH_ONLY_ENABLED = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 17); + NDU_WLAN_REASON_CODE_MSMSEC_CAPABILITY_NETWORK = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 18); + NDU_WLAN_REASON_CODE_MSMSEC_CAPABILITY_NIC = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 19); + NDU_WLAN_REASON_CODE_MSMSEC_CAPABILITY_PROFILE = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 20); + NDU_WLAN_REASON_CODE_MSMSEC_CAPABILITY_DISCOVERY = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 21); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_PASSPHRASE_CHAR = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 22); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_KEYMATERIAL_CHAR = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 23); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_WRONG_KEYTYPE = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 24); + NDU_WLAN_REASON_CODE_MSMSEC_MIXED_CELL = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 25); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_AUTH_TIMERS_INVALID = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 26); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_INVALID_GKEY_INTV = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 27); + NDU_WLAN_REASON_CODE_MSMSEC_TRANSITION_NETWORK = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 28); + NDU_WLAN_REASON_CODE_MSMSEC_PROFILE_KEY_UNMAPPED_CHAR = + (NDU_WLAN_REASON_CODE_MSMSEC_BASE + 29); + + NDU_WLAN_REASON_CODE_MSMSEC_UI_REQUEST_FAILURE = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 1); + NDU_WLAN_REASON_CODE_MSMSEC_AUTH_START_TIMEOUT = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 2); + NDU_WLAN_REASON_CODE_MSMSEC_AUTH_SUCCESS_TIMEOUT = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 3); + NDU_WLAN_REASON_CODE_MSMSEC_KEY_START_TIMEOUT = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 4); + NDU_WLAN_REASON_CODE_MSMSEC_KEY_SUCCESS_TIMEOUT = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 5); + NDU_WLAN_REASON_CODE_MSMSEC_M3_MISSING_KEY_DATA = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 6); + NDU_WLAN_REASON_CODE_MSMSEC_M3_MISSING_IE = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 7); + NDU_WLAN_REASON_CODE_MSMSEC_M3_MISSING_GRP_KEY = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 8); + NDU_WLAN_REASON_CODE_MSMSEC_PR_IE_MATCHING = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 9); + NDU_WLAN_REASON_CODE_MSMSEC_SEC_IE_MATCHING = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 10); + NDU_WLAN_REASON_CODE_MSMSEC_NO_PAIRWISE_KEY = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 11); + NDU_WLAN_REASON_CODE_MSMSEC_G1_MISSING_KEY_DATA = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 12); + NDU_WLAN_REASON_CODE_MSMSEC_G1_MISSING_GRP_KEY = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 13); + NDU_WLAN_REASON_CODE_MSMSEC_PEER_INDICATED_INSECURE = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 14); + NDU_WLAN_REASON_CODE_MSMSEC_NO_AUTHENTICATOR = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 15); + NDU_WLAN_REASON_CODE_MSMSEC_NIC_FAILURE = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 16); + NDU_WLAN_REASON_CODE_MSMSEC_CANCELLED = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 17); + NDU_WLAN_REASON_CODE_MSMSEC_KEY_FORMAT = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 18); + NDU_WLAN_REASON_CODE_MSMSEC_DOWNGRADE_DETECTED = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 19); + NDU_WLAN_REASON_CODE_MSMSEC_PSK_MISMATCH_SUSPECTED = + (NDU_WLAN_REASON_CODE_MSMSEC_CONNECT_BASE + 20); + NDU_WLAN_REASON_CODE_MSMSEC_MAX = NDU_WLAN_REASON_CODE_MSMSEC_END; +type + Tndu_WLAN_SIGNAL_QUALITY = ulong; + Pndu_WLAN_SIGNAL_QUALITY = ^Tndu_WLAN_SIGNAL_QUALITY; +const + NDU_WLAN_AVAILABLE_NETWORK_CONNECTED = $00000001; + NDU_WLAN_AVAILABLE_NETWORK_HAS_PROFILE = $00000002; + NDU_WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES = $00000001; + NDU_WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_MANUAL_HIDDEN_PROFILES = $00000002; +type + Pndu_WLAN_RATE_SET = ^Tndu_WLAN_RATE_SET; + Tndu_WLAN_RATE_SET = record + uRateSetLength: ulong; + usRateSet: array[0..NDU_DOT11_RATE_SET_MAX_LENGTH - 1] of ushort; + end; + Pndu_WLAN_AVAILABLE_NETWORK = ^Tndu_WLAN_AVAILABLE_NETWORK; + { + Tndu_WLAN_AVAILABLE_NETWORK = record + strProfileName: array[0..NDU_WLAN_MAX_NAME_LENGTH - 1] of wchar; + dot11Ssid: Tndu_DOT11_SSID; + dot11BssType: Tndu_DOT11_BSS_TYPE; + uNumberOfBssids: ulong; + bNetworkConnectable: Bool; + wlanNotConnectableReason: Tndu_WLAN_REASON_CODE; + uDot11PhyType: ulong; + wlanSignalQuality: Tndu_WLAN_SIGNAL_QUALITY; + dot11RateSet: Tndu_DOT11_RATE_SET; + bSecurityEnabled: Bool; + dot11DefaultAuthAlgorithm: Tndu_DOT11_AUTH_ALGORITHM; + dot11DefaultCipherAlgorithm: Tndu_DOT11_CIPHER_ALGORITHM; + dwFlags: DWORD; + dwReserved: DWORD; + end;} + Tndu_WLAN_AVAILABLE_NETWORK = record + strProfileName: array[0..NDU_WLAN_MAX_NAME_LENGTH - 1] of wchar; + dot11Ssid: Tndu_DOT11_SSID; + dot11BssType: Tndu_DOT11_BSS_TYPE; + uNumberOfBssids: ulong; + bNetworkConnectable: Bool; + wlanNotConnectableReason: Tndu_WLAN_REASON_CODE; + uNumberOfPhyTypes: ulong; + dot11PhyTypes: array[0..WLAN_MAX_PHY_TYPE_NUMBER -1] of DWORD; //Tndu_DOT11_PHY_TYPE; + bMorePhyTypes: Bool; + wlanSignalQuality: Tndu_WLAN_SIGNAL_QUALITY; + bSecurityEnabled: Bool; + dot11DefaultAuthAlgorithm: DWORD; //Tndu_DOT11_AUTH_ALGORITHM; + dot11DefaultCipherAlgorithm: DWORD; //Tndu_DOT11_CIPHER_ALGORITHM; + dwFlags: DWORD; + dwReserved: DWORD; + end; + Pndu_WLAN_BSS_ENTRY = ^Tndu_WLAN_BSS_ENTRY; + Tndu_WLAN_BSS_ENTRY = record + dot11Ssid: Tndu_DOT11_SSID; + uPhyId: ulong; + dot11Bssid: Tndu_DOT11_MAC_ADDRESS; + dot11BssType: Tndu_DOT11_BSS_TYPE; + dot11BssPhyType: DWORD; //Tndu_DOT11_PHY_TYPE; + lRssi: long; + uLinkQuality: ulong; + bInRegDomain: Boolean; + usBeaconPeriod: ushort; + ullTimestamp: ulonglong; + ullHostTimestamp: ulonglong; + usCapabilityInformation: ushort; + ulChCenterFrequency: ulong; + wlanRateSet: Tndu_WLAN_RATE_SET; + ulIeOffset: ulong; + ulIeSize: ulong; + end; + Pndu_WLAN_BSS_LIST = ^Tndu_WLAN_BSS_LIST; + PPndu_WLAN_BSS_LIST = ^Pndu_WLAN_BSS_LIST; + Tndu_WLAN_BSS_LIST = record + dwTotalSize: DWORD; + dwNumberOfItems: DWORD; + wlanBssEntries: array[0..0] of Tndu_WLAN_BSS_ENTRY; + end; + {$MINENUMSIZE 4} + Pndu_WLAN_INTERFACE_STATE = ^Tndu_WLAN_INTERFACE_STATE; + Tndu_WLAN_INTERFACE_STATE = ( + wlan_interface_state_not_ready = 0, + wlan_interface_state_connected, + wlan_interface_state_ad_hoc_network_formed, + wlan_interface_state_disconnecting, + wlan_interface_state_disconnected, + wlan_interface_state_associating, + wlan_interface_state_discovering, + wlan_interface_state_authenticating); + Pndu_WLAN_INTERFACE_INFO = ^Tndu_WLAN_INTERFACE_INFO; + Tndu_WLAN_INTERFACE_INFO = record + InterfaceGuid: TGUID; + strInterfaceDescription: array[0..NDU_WLAN_MAX_NAME_LENGTH - 1] of wchar; + isState: Tndu_WLAN_INTERFACE_STATE; + end; + Pndu_WLAN_ASSOCIATION_ATTRIBUTES = ^Tndu_WLAN_ASSOCIATION_ATTRIBUTES; + Tndu_WLAN_ASSOCIATION_ATTRIBUTES = record + dot11Ssid: Tndu_DOT11_SSID; + dot11BssType: Tndu_DOT11_BSS_TYPE; + dot11Bssid: Tndu_DOT11_MAC_ADDRESS; + dot11PhyType: DWORD; //Tndu_DOT11_PHY_TYPE; + uDot11PhyIndex: ulong; + wlanSignalQuality: Tndu_WLAN_SIGNAL_QUALITY; + ulRxRate: ulong; + ulTxRate: ulong; + end; + Pndu_WLAN_SECURITY_ATTRIBUTES = ^Tndu_WLAN_SECURITY_ATTRIBUTES; + Tndu_WLAN_SECURITY_ATTRIBUTES = record + bSecurityEnabled: Bool; + bOneXEnabled: Bool; + dot11AuthAlgorithm: DWORD; //Tndu_DOT11_AUTH_ALGORITHM; + dot11CipherAlgorithm: DWORD; //Tndu_DOT11_CIPHER_ALGORITHM; + end; + + Pndu_WLAN_CONNECTION_ATTRIBUTES = ^Tndu_WLAN_CONNECTION_ATTRIBUTES; + Tndu_WLAN_CONNECTION_ATTRIBUTES = record + isState: Tndu_WLAN_INTERFACE_STATE; + wlanConnectionMode: Tndu_WLAN_CONNECTION_MODE; + strProfileName: array[0..NDU_WLAN_MAX_NAME_LENGTH - 1] of wchar; + wlanAssociationAttributes: Tndu_WLAN_ASSOCIATION_ATTRIBUTES; + wlanSecurityAttributes: Tndu_WLAN_SECURITY_ATTRIBUTES; + end; + {$MINENUMSIZE 4} + Pndu_DOT11_RADIO_STATE = ^Tndu_DOT11_RADIO_STATE; + Tndu_DOT11_RADIO_STATE = ( + dot11_radio_state_unknown = 0, + dot11_radio_state_on, + dot11_radio_state_off); +const + // the maximum number of PHYs supported by a NIC + NDU_WLAN_MAX_PHY_INDEX = 63; +type + Pndu_WLAN_PHY_RADIO_STATE = ^Tndu_WLAN_PHY_RADIO_STATE; + Tndu_WLAN_PHY_RADIO_STATE = record + dwPhyIndex: DWORD; + dot11SoftwareRadioState: Tndu_DOT11_RADIO_STATE; + dot11HardwareRadioState: Tndu_DOT11_RADIO_STATE; + end; + Pndu_WLAN_RADIO_STATE = ^Tndu_WLAN_RADIO_STATE; + Tndu_WLAN_RADIO_STATE = record + dwNumberOfPhys: DWORD; + PhyRadioState: array[0..NDU_WLAN_MAX_PHY_INDEX - 1] of Tndu_WLAN_PHY_RADIO_STATE; + end; + {$MINENUMSIZE 4} + Pndu_WLAN_INTERFACE_TYPE = ^Tndu_WLAN_INTERFACE_TYPE; + Tndu_WLAN_INTERFACE_TYPE = ( + wlan_interface_type_emulated_802_11 = 0, + wlan_interface_type_native_802_11, + wlan_interface_type_invalid); + Pndu_WLAN_INTERFACE_CAPABILITY = ^Tndu_WLAN_INTERFACE_CAPABILITY; + PPndu_WLAN_INTERFACE_CAPABILITY = ^Pndu_WLAN_INTERFACE_CAPABILITY; + Tndu_WLAN_INTERFACE_CAPABILITY = record + interfaceType: Tndu_WLAN_INTERFACE_TYPE; + bDot11DSupported: Bool; + dwMaxDesiredSsidListSize: DWORD; + dwMaxDesiredBssidListSize: DWORD; + dwNumberOfSupportedPhys: DWORD; + dot11PhyTypes: array[0..NDU_WLAN_MAX_PHY_INDEX - 1] of DWORD; //Tndu_DOT11_PHY_TYPE; + end; + Pndu_WLAN_AUTH_CIPHER_PAIR_LIST = ^Tndu_WLAN_AUTH_CIPHER_PAIR_LIST; + Tndu_WLAN_AUTH_CIPHER_PAIR_LIST = record + pAuthCipherPairList: array[0..0] of Tndu_DOT11_AUTH_CIPHER_PAIR; + end; + Pndu_WLAN_COUNTRY_OR_REGION_STRING_LIST = ^Tndu_WLAN_COUNTRY_OR_REGION_STRING_LIST; + Tndu_WLAN_COUNTRY_OR_REGION_STRING_LIST = record + pCountryOrRegionStringList: array[0..0] of Tndu_DOT11_COUNTRY_OR_REGION_STRING; + end; + Pndu_WLAN_PROFILE_INFO_LIST = ^Tndu_WLAN_PROFILE_INFO_LIST; + PPndu_WLAN_PROFILE_INFO_LIST = ^Pndu_WLAN_PROFILE_INFO_LIST; + Tndu_WLAN_PROFILE_INFO_LIST = record + dwNumberOfItems: DWORD; + dwIndex: DWORD; + ProfileInfo: array[0..0] of Tndu_WLAN_PROFILE_INFO; + end; + Pndu_WLAN_AVAILABLE_NETWORK_LIST = ^Tndu_WLAN_AVAILABLE_NETWORK_LIST; + PPndu_WLAN_AVAILABLE_NETWORK_LIST = ^Pndu_WLAN_AVAILABLE_NETWORK_LIST; + Tndu_WLAN_AVAILABLE_NETWORK_LIST = record + dwNumberOfItems: DWORD; + dwIndex: DWORD; + Network: array[0..0] of Tndu_WLAN_AVAILABLE_NETWORK; + end; + Pndu_WLAN_INTERFACE_INFO_LIST = ^Tndu_WLAN_INTERFACE_INFO_LIST; + PPndu_WLAN_INTERFACE_INFO_LIST = ^Pndu_WLAN_INTERFACE_INFO_LIST; + Tndu_WLAN_INTERFACE_INFO_LIST = record + dwNumberOfItems: DWORD; + dwIndex: DWORD; + InterfaceInfo: array[0..0] of Tndu_WLAN_INTERFACE_INFO; + end; + Pndu_DOT11_NETWORK_LIST = ^Tndu_DOT11_NETWORK_LIST; + PPndu_DOT11_NETWORK_LIST = ^Pndu_DOT11_NETWORK_LIST; + Tndu_DOT11_NETWORK_LIST = record + dwNumberOfItems: DWORD; + dwIndex: DWORD; + Network: array[0..0] of Tndu_DOT11_NETWORK; + end; + {$MINENUMSIZE 4} + Pndu_WLAN_POWER_SETTING = ^Tndu_WLAN_POWER_SETTING; + Tndu_WLAN_POWER_SETTING = ( + wlan_power_setting_no_saving = 0, + wlan_power_setting_low_saving, + wlan_power_setting_medium_saving, + wlan_power_setting_maximum_saving, + wlan_power_setting_invalid); +const + NDU_WLAN_CONNECTION_HIDDEN_NETWORK = $00000001; + NDU_WLAN_CONNECTION_ADHOC_JOIN_ONLY = $00000002; +type + Pndu_WLAN_CONNECTION_PARAMETERS = ^Tndu_WLAN_CONNECTION_PARAMETERS; + Tndu_WLAN_CONNECTION_PARAMETERS = record + wlanConnectionMode: Tndu_WLAN_CONNECTION_MODE; + strProfile: LPCTSTR; + pDot11Ssid: Pndu_DOT11_SSID; + pDesiredBssidList: Pndu_DOT11_BSSID_LIST; + dot11BssType: Tndu_DOT11_BSS_TYPE; + dwFlags: DWORD; + end; + Pndu_WLAN_MSM_NOTIFICATION_DATA = ^Tndu_WLAN_MSM_NOTIFICATION_DATA; + Tndu_WLAN_MSM_NOTIFICATION_DATA = record + wlanConnectionMode: Tndu_WLAN_CONNECTION_MODE; + strProfileName: array[0..NDU_WLAN_MAX_NAME_LENGTH - 1] of wchar; + dot11Ssid: Tndu_DOT11_SSID; + dot11BssType: Tndu_DOT11_BSS_TYPE; + dot11MacAddr: Tndu_DOT11_MAC_ADDRESS; + bSecurityEnabled: Bool; + bFirstPeer: Bool; + bLastPeer: Bool; + wlanReasonCode: Tndu_WLAN_REASON_CODE; + end; + Pndu_WLAN_CONNECTION_NOTIFICATION_DATA = ^Tndu_WLAN_CONNECTION_NOTIFICATION_DATA; + Tndu_WLAN_CONNECTION_NOTIFICATION_DATA = record + wlanConnectionMode: Tndu_WLAN_CONNECTION_MODE; + strProfileName: array[0..NDU_WLAN_MAX_NAME_LENGTH - 1] of wchar; + dot11Ssid: Tndu_DOT11_SSID; + dot11BssType: Tndu_DOT11_BSS_TYPE; + bSecurityEnabled: Bool; + wlanReasonCode: Tndu_WLAN_REASON_CODE; + strProfileXml: array[0..0] of wchar; + end; +const + NDU_WLAN_NOTIFICATION_SOURCE_NONE = NDU_L2_NOTIFICATION_SOURCE_NONE; + NDU_WLAN_NOTIFICATION_SOURCE_ALL = NDU_L2_NOTIFICATION_SOURCE_ALL; + NDU_WLAN_NOTIFICATION_SOURCE_ACM = NDU_L2_NOTIFICATION_SOURCE_WLAN_ACM; + NDU_WLAN_NOTIFICATION_SOURCE_MSM = NDU_L2_NOTIFICATION_SOURCE_WLAN_MSM; + NDU_WLAN_NOTIFICATION_SOURCE_SECURITY = NDU_L2_NOTIFICATION_SOURCE_WLAN_SECURITY; + NDU_WLAN_NOTIFICATION_SOURCE_IHV = NDU_L2_NOTIFICATION_SOURCE_WLAN_IHV; +type + {$MINENUMSIZE 4} + Pndu_WLAN_NOTIFICATION_ACM = ^Tndu_WLAN_NOTIFICATION_ACM; + Tndu_WLAN_NOTIFICATION_ACM = ( + wlan_notification_acm_start = NDU_L2_NOTIFICATION_CODE_PUBLIC_BEGIN, + wlan_notification_acm_autoconf_enabled, + wlan_notification_acm_autoconf_disabled, + wlan_notification_acm_background_scan_enabled, + wlan_notification_acm_background_scan_disabled, + wlan_notification_acm_bss_type_change, + wlan_notification_acm_power_setting_change, + wlan_notification_acm_scan_complete, + wlan_notification_acm_scan_fail, + wlan_notification_acm_connection_start, + wlan_notification_acm_connection_complete, + wlan_notification_acm_connection_attempt_fail, + wlan_notification_acm_filter_list_change, + wlan_notification_acm_interface_arrival, + wlan_notification_acm_interface_removal, + wlan_notification_acm_profile_change, + wlan_notification_acm_profile_name_change, + wlan_notification_acm_profiles_exhausted, + wlan_notification_acm_network_not_available, + wlan_notification_acm_network_available, + wlan_notification_acm_disconnecting, + wlan_notification_acm_disconnected, + wlan_notification_acm_end); + {$MINENUMSIZE 4} + Pndu_WLAN_NOTIFICATION_MSM = ^Tndu_WLAN_NOTIFICATION_MSM; + Tndu_WLAN_NOTIFICATION_MSM = ( + wlan_notification_msm_start = NDU_L2_NOTIFICATION_CODE_PUBLIC_BEGIN, + wlan_notification_msm_associating, + wlan_notification_msm_associated, + wlan_notification_msm_authenticating, + wlan_notification_msm_connected, + wlan_notification_msm_roaming_start, + wlan_notification_msm_roaming_end, + wlan_notification_msm_radio_state_change, + wlan_notification_msm_signal_quality_change, + wlan_notification_msm_disassociating, + wlan_notification_msm_disconnected, + wlan_notification_msm_peer_join, + wlan_notification_msm_peer_leave, + wlan_notification_msm_end); + {$MINENUMSIZE 4} + Pndu_WLAN_NOTIFICATION_SECURITY = ^Tndu_WLAN_NOTIFICATION_SECURITY; + Tndu_WLAN_NOTIFICATION_SECURITY = ( + wlan_notification_security_start = NDU_L2_NOTIFICATION_CODE_PUBLIC_BEGIN, + wlan_notification_security_end); + Tndu_WLAN_NOTIFICATION_DATA = Tndu_L2_NOTIFICATION_DATA; + Pndu_WLAN_NOTIFICATION_DATA = ^Tndu_WLAN_NOTIFICATION_DATA; + Tndu_WLAN_NOTIFICATION_CALLBACK = PVOID; + Pndu_WLAN_NOTIFICATION_CALLBACK = PVOID; + {$MINENUMSIZE 4} + Pndu_WLAN_OPCODE_VALUE_TYPE = ^Tndu_WLAN_OPCODE_VALUE_TYPE; + Tndu_WLAN_OPCODE_VALUE_TYPE = ( + wlan_opcode_value_type_query_only = 0, + wlan_opcode_value_type_set_by_group_policy, + wlan_opcode_value_type_set_by_user, + wlan_opcode_value_type_invalid); + {$MINENUMSIZE 4} + Pndu_WLAN_INTF_OPCODE = ^Tndu_WLAN_INTF_OPCODE; + Tndu_WLAN_INTF_OPCODE = ( + wlan_intf_opcode_autoconf_start = $000000000, + wlan_intf_opcode_autoconf_enabled, + wlan_intf_opcode_background_scan_enabled, + wlan_intf_opcode_media_streaming_mode, + wlan_intf_opcode_radio_state, + wlan_intf_opcode_bss_type, + wlan_intf_opcode_interface_state, + wlan_intf_opcode_current_connection, + wlan_intf_opcode_channel_number, + wlan_intf_opcode_supported_infrastructure_auth_cipher_pairs, + wlan_intf_opcode_supported_adhoc_auth_cipher_pairs, + wlan_intf_opcode_supported_country_or_region_string_list, + wlan_intf_opcode_autoconf_end = $0fffffff, + wlan_intf_opcode_msm_start = $10000100, + wlan_intf_opcode_statistics, + wlan_intf_opcode_rssi, + wlan_intf_opcode_msm_end = $1fffffff, + wlan_intf_opcode_security_start = $20010000, + wlan_intf_opcode_security_end = $2fffffff, + wlan_intf_opcode_ihv_start = $30000000, + wlan_intf_opcode_ihv_end = $3fffffff); + {$MINENUMSIZE 4} + Pndu_WLAN_AUTOCONF_OPCODE = ^Tndu_WLAN_AUTOCONF_OPCODE; + Tndu_WLAN_AUTOCONF_OPCODE = ( + wlan_autoconf_opcode_start = 0, + wlan_autoconf_opcode_show_denied_networks, + wlan_autoconf_opcode_power_setting, + wlan_autoconf_opcode_connect_with_all_user_profile_only, + wlan_autoconf_opcode_end); + {$MINENUMSIZE 4} + Pndu_WLAN_IHV_CONTROL_TYPE = ^Tndu_WLAN_IHV_CONTROL_TYPE; + Tndu_WLAN_IHV_CONTROL_TYPE = ( + wlan_ihv_control_type_service, + wlan_ihv_control_type_driver); + {$MINENUMSIZE 4} + Pndu_WLAN_FILTER_LIST_TYPE = ^Tndu_WLAN_FILTER_LIST_TYPE; + Tndu_WLAN_FILTER_LIST_TYPE = ( + wlan_filter_list_type_gp_permit, + wlan_filter_list_type_gp_deny, + wlan_filter_list_type_user_permit, + wlan_filter_list_type_user_deny); + Pndu_WLAN_PHY_FRAME_STATISTICS = ^Tndu_WLAN_PHY_FRAME_STATISTICS; + Tndu_WLAN_PHY_FRAME_STATISTICS = record + ullTransmittedFrameCount: ulonglong; + ullMulticastTransmittedFrameCount: ulonglong; + ullFailedCount: ulonglong; + ullRetryCount: ulonglong; + ullMultipleRetryCount: ulonglong; + ullMaxTXLifetimeExceededCount: ulonglong; + ullTransmittedFragmentCount: ulonglong; + ullRTSSuccessCount: ulonglong; + ullRTSFailureCount: ulonglong; + ullACKFailureCount: ulonglong; + ullReceivedFrameCount: ulonglong; + ullMulticastReceivedFrameCount: ulonglong; + ullPromiscuousReceivedFrameCount: ulonglong; + ullMaxRXLifetimeExceededCount: ulonglong; + ullFrameDuplicateCount: ulonglong; + ullReceivedFragmentCount: ulonglong; + ullPromiscuousReceivedFragmentCount: ulonglong; + ullFCSErrorCount: ulonglong; + end; + Pndu_WLAN_MAC_FRAME_STATISTICS = ^Tndu_WLAN_MAC_FRAME_STATISTICS; + Tndu_WLAN_MAC_FRAME_STATISTICS = record + ullTransmittedFrameCount: ulonglong; + ullReceivedFrameCount: ulonglong; + ullWEPExcludedCount: ulonglong; + ullTKIPLocalMICFailures: ulonglong; + ullTKIPReplays: ulonglong; + ullTKIPICVErrorCount: ulonglong; + ullCCMPReplays: ulonglong; + ullCCMPDecryptErrors: ulonglong; + ullWEPUndecryptableCount: ulonglong; + ullWEPICVErrorCount: ulonglong; + ullDecryptSuccessCount: ulonglong; + ullDecryptFailureCount: ulonglong; + end; + Pndu_WLAN_STATISTICS = ^Tndu_WLAN_STATISTICS; + Tndu_WLAN_STATISTICS = record + ullFourWayHandshakeFailures: ulonglong; + ullTKIPCounterMeasuresInvoked: ulonglong; + ullReserved: ulonglong; + MacUcastCounters: Tndu_WLAN_MAC_FRAME_STATISTICS; + MacMcastCounters: Tndu_WLAN_MAC_FRAME_STATISTICS; + dwNumberOfPhys: DWORD; + PhyCounters: array[0..0] of Tndu_WLAN_PHY_FRAME_STATISTICS; + end; +const + NDU_WLAN_READ_ACCESS = (NDU_STANDARD_RIGHTS_READ or NDU_FILE_READ_DATA); + NDU_WLAN_EXECUTE_ACCESS = (NDU_WLAN_READ_ACCESS or + NDU_STANDARD_RIGHTS_EXECUTE or NDU_FILE_EXECUTE); + NDU_WLAN_WRITE_ACCESS = (NDU_WLAN_READ_ACCESS or NDU_WLAN_EXECUTE_ACCESS or + NDU_STANDARD_RIGHTS_WRITE or NDU_FILE_WRITE_DATA or NDU_DELETE or + NDU_WRITE_DAC); +type + {$MINENUMSIZE 4} + Pndu_WLAN_SECURABLE_OBJECT = ^Tndu_WLAN_SECURABLE_OBJECT; + Tndu_WLAN_SECURABLE_OBJECT = ( + wlan_secure_permit_list = 0, + wlan_secure_deny_list, + wlan_secure_ac_enabled, + wlan_secure_bc_scan_enabled, + wlan_secure_bss_type, + wlan_secure_show_denied, + wlan_secure_interface_properties, + wlan_secure_ihv_control, + wlan_secure_all_user_profiles_order, + wlan_secure_sso, + wlan_secure_add_new_all_user_profiles, + wlan_secure_add_new_per_user_profiles, + wlan_secure_manual_connect_single_user, + wlan_secure_manual_connect_multi_user, + wlan_secure_media_streaming_mode_enabled, + NDU_WLAN_SECURABLE_OBJECT_COUNT); +const + wlan_api_dll = 'wlanapi.dll'; + function WlanOpenHandle(dwClientVersion: DWORD; pReserved: PVOID; + pdwNegotiatedVersion: PWord; phClientHandle: PHandle): DWORD; stdcall; + function WlanCloseHandle(hClientHandle: Handle; + pReserved: PVOID): DWORD; stdcall; + function WlanEnumInterfaces(hClientHandle: Handle; + pReserved: PVOID; ppInterfaceList: PPndu_WLAN_INTERFACE_INFO_LIST + ): DWORD; stdcall; + function WlanSetAutoConfigParameter(hClientHandle: Handle; + OpCode: Tndu_WLAN_AUTOCONF_OPCODE; dwDataSize: DWORD; + const pData: PVOID; pReserved: PVOID): DWORD; stdcall; + function WlanQueryAutoConfigParameter(hClientHandle: Handle; + OpCode: Tndu_WLAN_AUTOCONF_OPCODE; pReserved: PVOID; + pdwDataSize: PDWORD; ppData: PPVOID; + pWlanOpcodeValueType: Pndu_WLAN_OPCODE_VALUE_TYPE): DWORD; stdcall; + function WlanGetInterfaceCapability(hClientHandle: Handle; + const pInterfaceGuid: PGUID; pReserved: PVOID; + ppCapability: PPndu_WLAN_INTERFACE_CAPABILITY): DWORD; stdcall; + function WlanSetInterface(hClientHandle: Handle; + const pInterfaceGuid: PGUID; OpCode: Tndu_WLAN_INTF_OPCODE; + dwDataSize: DWORD; const pData: PVOID; pReserved: PVOID): DWORD; stdcall; + function WlanQueryInterface(hClientHandle: Handle; + const pInterfaceGuid: PGUID; OpCode: Tndu_WLAN_INTF_OPCODE; + pReserved: PVOID; pdwDataSize: PDWORD; ppData: PPVOID; + pWlanOpcodeValueType: Pndu_WLAN_OPCODE_VALUE_TYPE): DWORD; stdcall; + function WlanIhvControl(hClientHandle: Handle; + const pInterfaceGuid: PGUID; aType: Tndu_WLAN_IHV_CONTROL_TYPE; + dwInBufferSize: DWORD; pInBuffer: pvoid; dwOutBufferSize: DWORD; + pOutBuffer: PVOID): DWORD; stdcall; + function WlanScan(hClientHandle: Handle; + const pInterfaceGuid: PGUID; const pDot11Ssid: Pndu_DOT11_SSID; + const pIeData: Pndu_WLAN_RAW_DATA; pReserved: PVOID): DWORD; stdcall; + function WlanGetAvailableNetworkList(hClientHandle: Handle; + const pInterfaceGuid: PGUID; dwFlags: DWORD; pReserved: PVOID; + var pAvailableNetworkList: Pndu_WLAN_AVAILABLE_NETWORK_LIST): DWORD; stdcall; + function WlanGetNetworkBssList(hClientHandle: Handle; + const pInterfaceGuid: PGUID; const pDot11Ssid: Pndu_DOT11_SSID; + dot11BssType: Tndu_DOT11_BSS_TYPE; bSecurityEnabled: BOOL; + pReserved: PVOID; ppWlanBssList: PPndu_WLAN_BSS_LIST): DWORD; stdcall; + function WlanConnect(hClientHandle: Handle; const pInterfaceGuid: PGUID; + const pConnectionParameters: Pndu_WLAN_CONNECTION_PARAMETERS; + pReserved: PVOID): DWORD; stdcall; + function WlanDisconnect(hClientHandle: Handle; + const pInterfaceGuid: PGUID; pReserved: PVOID): DWORD; stdcall; + function WlanRegisterNotification(hClientHandle: Handle; + dwNotifSource: DWORD; bIgnoreDuplicate: Bool; + funcCallback: Tndu_WLAN_NOTIFICATION_CALLBACK; + pCallbackContext: PVOID; pReserved: PVOID; + pdwPrevNotifSource: PDWORD): DWORD; stdcall; + function WlanGetProfile(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strProfileName: LPCWSTR; + pReserved: PVOID; pstrProfileXml: LPWSTR; pdwFlags: PDWORD; + pdwGrantedAccess: PDWORD): DWORD; stdcall; + function WlanSetProfileEapUserData(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strProfileName: LPCWSTR; + eapType: Tndu_EAP_METHOD_TYPE; dwFlags: DWORD; + dwEapUserDataSize: DWORD; const pbEapUserData: LPByte; + pReserved: PVOID): DWORD; stdcall; + function WlanSetProfileEapXMLUserData(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strProfileName: LPCWSTR; + eapType: Tndu_EAP_METHOD_TYPE; dwFlags: DWORD; + strEapXMLUserData: LPCWSTR; pReserved: PVOID): DWORD; stdcall; + function WlanSetProfile(hClientHandle: Handle; + const pInterfaceGuid: PGUID; dwFlags: DWORD; strProfileXml: LPCWSTR; + strAllUserProfileSecurity: LPCWSTR; + bOverwrite: Bool; pReserved: PVOID; + pdwReasonCode: PDWORD): DWORD; stdcall; + function WlanDeleteProfile(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strProfileName: LPCWSTR; + pReserved: PVOID): DWORD; stdcall; + function WlanRenameProfile(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strOldProfileName: LPCWSTR; + strNewProfileName: LPCWSTR; pReserved: PVOID): DWORD; stdcall; + function WlanGetProfileList(hClientHandle: Handle; + const pInterfaceGuid: PGUID; pReserved: PVOID; + ppProfileList: PPndu_WLAN_PROFILE_INFO_LIST): DWORD; stdcall; + function WlanSetProfileList(hClientHandle: Handle; + const pInterfaceGuid: PGUID; dwItems: DWORD; + strProfileNames: LPCWSTR; pReserved: PVOID): DWORD; stdcall; + function WlanSetProfilePosition(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strProfileName: LPCWSTR; + dwPosition: DWORD; pReserved: PVOID): DWORD; stdcall; + function WlanSetProfileCustomUserData(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strProfileName: LPCWSTR; + dwDataSize: DWORD; const pData: LPByte; + pReserved: PVOID): DWORD; stdcall; + function WlanGetProfileCustomUserData(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strProfileName: LPCWSTR; + pReserved: PVOID; pdwDataSize: PDWORD; ppData: PPByte): DWORD; stdcall; + function WlanSetFilterList(hClientHandle: Handle; + wlanFilterListType: Tndu_WLAN_FILTER_LIST_TYPE; + const pNetworkList: Pndu_DOT11_NETWORK_LIST; + pReserved: PVOID): DWORD; stdcall; + function WlanGetFilterList(hClientHandle: Handle; + wlanFilterListType: Tndu_WLAN_FILTER_LIST_TYPE; + pReserved: PVOID; ppNetworkList: PPndu_DOT11_NETWORK_LIST): DWORD; stdcall; + function WlanSetPsdIEDataList(hClientHandle: Handle; strFormat: LPCWSTR; + const pPsdIEDataList: Pndu_WLAN_RAW_DATA_LIST; + pReserved: pvoid): DWORD; stdcall; + function WlanSaveTemporaryProfile(hClientHandle: Handle; + const pInterfaceGuid: PGUID; strProfileName: LPCWSTR; + strAllUserProfileSecurity: LPCWSTR; dwFlags: DWORD; + bOverWrite: Bool; pReserved: PVOID): DWORD; stdcall; + function WlanExtractPsdIEDataList(hClientHandle: Handle; + dwIeDataSize: DWORD; const pRawIeData: PByte; + strFormat: LPCWSTR; pReserved: PVOID; + ppPsdIEDataList: PPndu_WLAN_RAW_DATA_LIST): DWORD; stdcall; + function WlanReasonCodeToString(dwReasonCode: DWORD; + dwBufferSize: DWORD; pStringBuffer: PWChar; + pReserved: PVOID): DWORD; stdcall; + function WlanAllocateMemory(dwMemorySize: DWORD): pvoid; stdcall; + function WlanFreeMemory(pMemory: PVOID): PVOID; stdcall; + function WlanSetSecuritySettings(hClientHandle: Handle; + SecurableObject: Tndu_WLAN_SECURABLE_OBJECT; + strModifiedSDDL: LPCWSTR): DWORD; stdcall; + function WlanGetSecuritySettings(hClientHandle: Handle; + SecurableObject: Tndu_WLAN_SECURABLE_OBJECT; + pstrCurrentSDDL: PLPWSTR; pdwGrantedAccess: PWORD): DWORD; stdcall; +const + NDU_WLAN_UI_API_VERSION = 1; + NDU_WLAN_UI_API_INITIAL_VERSION = 1; +type + Pndu_WL_DISPLAY_PAGES = ^Tndu_WL_DISPLAY_PAGES; + Tndu_WL_DISPLAY_PAGES = ( + WLConnectionPage, + WLSecurityPage); + function WlanUIEditProfile(dwClientVersion: DWORD; + wstrProfileName: LPCWSTR; pInterfaceGuid: PGUID; + hWnd: HWND; wlStartPage: Tndu_WL_DISPLAY_PAGES; + pReserved: PVOID; pWlanReasonCode: Pndu_WLAN_REASON_CODE): DWORD; stdcall; +function DOT11_AUTH_ALGORITHM_To_String(Dummy: DWORD): AnsiString; +function DOT11_CIPHER_ALGORITHM_To_String(Dummy: DWORD): AnsiString; +implementation +function DOT11_AUTH_ALGORITHM_To_String(Dummy: DWORD): AnsiString; +begin + Result := ''; + case Dummy of + NDU_DOT11_AUTH_ALGORITHM_OPEN_SYSTEM: + Result := '80211_OPEN'; + NDU_DOT11_AUTH_ALGORITHM_SHARED_KEY: + Result := '80211_SHARED_KEY'; + NDU_DOT11_AUTH_ALGORITHM_WPA: + Result := 'WPA'; + NDU_DOT11_AUTH_ALGORITHM_WPA_PSK: + Result := 'WPA_PSK'; + NDU_DOT11_AUTH_ALGORITHM_WPA_NONE: + Result := 'WPA_NONE'; + NDU_DOT11_AUTH_ALGORITHM_RSNA: + Result := 'RSNA'; + NDU_DOT11_AUTH_ALGORITHM_RSNA_PSK: + Result := 'RSNA_PSK'; + NDU_DOT11_AUTH_ALGO_IHV_START: + Result := 'IHV_START'; + NDU_DOT11_AUTH_ALGO_IHV_END: + Result := 'IHV_END'; + end; +end; + +function DOT11_CIPHER_ALGORITHM_To_String(Dummy: DWORD): AnsiString; +begin + Result := ''; + case Dummy of + DOT11_CIPHER_ALGO_NONE: + Result := 'NONE'; + DOT11_CIPHER_ALGO_WEP40: + Result := 'WEP40'; + DOT11_CIPHER_ALGO_TKIP: + Result := 'TKIP'; + DOT11_CIPHER_ALGO_CCMP: + Result := 'CCMP'; + DOT11_CIPHER_ALGO_WEP104: + Result := 'WEP104'; + DOT11_CIPHER_ALGO_WPA_USE_GROUP: + Result := 'WPA_USE_GROUP OR RSN_USE_GROUP'; + // DOT11_CIPHER_ALGO_RSN_USE_GROUP : Result:= 'RSN_USE_GROUP'; + DOT11_CIPHER_ALGO_WEP: + Result := 'WEP'; + DOT11_CIPHER_ALGO_IHV_START: + Result := 'IHV_START'; + DOT11_CIPHER_ALGO_IHV_END: + Result := 'IHV_END'; + end; +end; + function WlanOpenHandle; external wlan_api_dll name 'WlanOpenHandle'; + function WlanCloseHandle; external wlan_api_dll name 'WlanCloseHandle'; + function WlanEnumInterfaces; external wlan_api_dll name 'WlanEnumInterfaces'; + function WlanSetAutoConfigParameter; external wlan_api_dll name 'WlanSetAutoConfigParameter'; + function WlanQueryAutoConfigParameter; external wlan_api_dll name 'WlanQueryAutoConfigParameter'; + function WlanGetInterfaceCapability; external wlan_api_dll name 'WlanGetInterfaceCapability'; + function WlanSetInterface; external wlan_api_dll name 'WlanSetInterface'; + function WlanQueryInterface; external wlan_api_dll name 'WlanQueryInterface'; + function WlanIhvControl; external wlan_api_dll name 'WlanIhvControl'; + function WlanScan; external wlan_api_dll name 'WlanScan'; + function WlanGetAvailableNetworkList; external wlan_api_dll name 'WlanGetAvailableNetworkList'; + function WlanGetNetworkBssList; external wlan_api_dll name 'WlanGetNetworkBssList'; + function WlanConnect; external wlan_api_dll name 'WlanConnect'; + function WlanDisconnect; external wlan_api_dll name 'WlanDisconnect'; + function WlanRegisterNotification; external wlan_api_dll name 'WlanRegisterNotification'; + function WlanGetProfile; external wlan_api_dll name 'WlanGetProfile'; + function WlanSetProfileEapUserData; external wlan_api_dll name 'WlanSetProfileEapUserData'; + function WlanSetProfileEapXMLUserData; external wlan_api_dll name 'WlanSetProfileEapXMLUserData'; + function WlanSetProfile; external wlan_api_dll name 'WlanSetProfile'; + function WlanDeleteProfile; external wlan_api_dll name 'WlanDeleteProfile'; + function WlanRenameProfile; external wlan_api_dll name 'WlanRenameProfile'; + function WlanGetProfileList; external wlan_api_dll name 'WlanGetProfileList'; + function WlanSetProfileList; external wlan_api_dll name 'WlanSetProfileList'; + function WlanSetProfilePosition; external wlan_api_dll name 'WlanSetProfilePosition'; + function WlanSetProfileCustomUserData; external wlan_api_dll name 'WlanSetProfileCustomUserData'; + function WlanGetProfileCustomUserData; external wlan_api_dll name 'WlanGetProfileCustomUserData'; + function WlanSetFilterList; external wlan_api_dll name 'WlanSetFilterList'; + function WlanGetFilterList; external wlan_api_dll name 'WlanGetFilterList'; + function WlanSetPsdIEDataList; external wlan_api_dll name 'WlanSetPsdIEDataList'; + function WlanSaveTemporaryProfile; external wlan_api_dll name 'WlanSaveTemporaryProfile'; + function WlanExtractPsdIEDataList; external wlan_api_dll name 'WlanExtractPsdIEDataList'; + function WlanReasonCodeToString; external wlan_api_dll name 'WlanReasonCodeToString'; + function WlanAllocateMemory; external wlan_api_dll name 'WlanAllocateMemory'; + function WlanFreeMemory; external wlan_api_dll name 'WlanFreeMemory'; + function WlanSetSecuritySettings; external wlan_api_dll name 'WlanSetSecuritySettings'; + function WlanGetSecuritySettings; external wlan_api_dll name 'WlanGetSecuritySettings'; + function WlanUIEditProfile; external wlan_api_dll name 'WlanUIEditProfile'; +end. diff --git a/Tocsg.Lib/VCL/Other/EM.nduWlanTypes.pas b/Tocsg.Lib/VCL/Other/EM.nduWlanTypes.pas new file mode 100644 index 00000000..794ba58d --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.nduWlanTypes.pas @@ -0,0 +1,87 @@ +{ + ?ersetzt aus WlanTypes.h vom Windows SDK +} + +unit EM.nduWlanTypes; + +interface + +uses + EM.nduCType; + +const + NDU_DOT11_SSID_MAX_LENGTH = 32; //32 Bytes + +type + {$MINENUMSIZE 4} + Pndu_DOT11_BSS_TYPE = ^Tndu_DOT11_BSS_TYPE; + Tndu_DOT11_BSS_TYPE = ( + dot11_BSS_type_infrastructure = 1, + dot11_BSS_type_independent = 2, + dot11_BSS_type_any = 3); + + Pndu_DOT11_SSID = ^Tndu_DOT11_SSID; + Tndu_DOT11_SSID = record + uSSIDLength: ulong; + ucSSID: array[0..NDU_DOT11_SSID_MAX_LENGTH - 1] of uchar; + end; + + {$MINENUMSIZE 4} +// Pndu_DOT11_AUTH_ALGORITHM = ^Tndu_DOT11_AUTH_ALGORITHM; +// Tndu_DOT11_AUTH_ALGORITHM = ( +// DOT11_AUTH_ALGO_80211_OPEN = 1, +// DOT11_AUTH_ALGO_80211_SHARED_KEY = 2, +// DOT11_AUTH_ALGO_WPA = 3, +// DOT11_AUTH_ALGO_WPA_PSK = 4, +// DOT11_AUTH_ALGO_WPA_NONE = 5, +// DOT11_AUTH_ALGO_RSNA = 6, +// DOT11_AUTH_ALGO_RSNA_PSK = 7, +// DOT11_AUTH_ALGO_IHV_START = $80000000, +// DOT11_AUTH_ALGO_IHV_END = $ffffffff); + +const + NDU_DOT11_AUTH_ALGORITHM_OPEN_SYSTEM = 1; //DOT11_AUTH_ALGO_80211_OPEN; + NDU_DOT11_AUTH_ALGORITHM_SHARED_KEY = 2; //DOT11_AUTH_ALGO_80211_SHARED_KEY; + NDU_DOT11_AUTH_ALGORITHM_WPA = 3; //DOT11_AUTH_ALGO_WPA; + NDU_DOT11_AUTH_ALGORITHM_WPA_PSK = 4; //DOT11_AUTH_ALGO_WPA_PSK; + NDU_DOT11_AUTH_ALGORITHM_WPA_NONE = 5; //DOT11_AUTH_ALGO_WPA_NONE; + NDU_DOT11_AUTH_ALGORITHM_RSNA = 6; //DOT11_AUTH_ALGO_RSNA; + NDU_DOT11_AUTH_ALGORITHM_RSNA_PSK = 7; //DOT11_AUTH_ALGO_RSNA_PSK; + NDU_DOT11_AUTH_ALGO_IHV_START = $80000000; + NDU_DOT11_AUTH_ALGO_IHV_END = $ffffffff; + + DOT11_CIPHER_ALGO_NONE = $00; + DOT11_CIPHER_ALGO_WEP40 = $01; + DOT11_CIPHER_ALGO_TKIP = $02; + DOT11_CIPHER_ALGO_CCMP = $04; + DOT11_CIPHER_ALGO_WEP104 = $05; + DOT11_CIPHER_ALGO_WPA_USE_GROUP = $100; + DOT11_CIPHER_ALGO_RSN_USE_GROUP = $100; + DOT11_CIPHER_ALGO_WEP = $101; + DOT11_CIPHER_ALGO_IHV_START = $80000000; + DOT11_CIPHER_ALGO_IHV_END = $ffffffff; + +type + {$MINENUMSIZE 4} +// Pndu_DOT11_CIPHER_ALGORITHM = ^Tndu_DOT11_CIPHER_ALGORITHM; +// Tndu_DOT11_CIPHER_ALGORITHM = ( +// DOT11_CIPHER_ALGO_NONE = $00, +// DOT11_CIPHER_ALGO_WEP40 = $01, +// DOT11_CIPHER_ALGO_TKIP = $02, +// DOT11_CIPHER_ALGO_CCMP = $04, +// DOT11_CIPHER_ALGO_WEP104 = $05, +// DOT11_CIPHER_ALGO_WPA_USE_GROUP = $100, +// DOT11_CIPHER_ALGO_RSN_USE_GROUP = $100, +// DOT11_CIPHER_ALGO_WEP = $101, +// DOT11_CIPHER_ALGO_IHV_START = $80000000, +// DOT11_CIPHER_ALGO_IHV_END = $ffffffff); + + Pndu_DOT11_AUTH_CIPHER_PAIR = ^Tndu_DOT11_AUTH_CIPHER_PAIR; + Tndu_DOT11_AUTH_CIPHER_PAIR = record + AuthAlgoId: DWORD; //Tndu_DOT11_AUTH_ALGORITHM; + CipherAlgoId: DWORD; // Tndu_DOT11_CIPHER_ALGORITHM; + end; + +implementation + +end. diff --git a/Tocsg.Lib/VCL/Other/EM.winioctl.pas b/Tocsg.Lib/VCL/Other/EM.winioctl.pas new file mode 100644 index 00000000..8bfaf82c --- /dev/null +++ b/Tocsg.Lib/VCL/Other/EM.winioctl.pas @@ -0,0 +1,866 @@ +unit EM.winioctl; + +// John Newbigin +// from winioctl.h + +{$A+,Z+} + +interface + uses WinApi.Windows; + +const + Large0 : _Large_Integer = (LowPart : 0; HighPart : 0) ; + +function div2(a : LongInt; b : LongInt) : LongInt; + +{ function DeviceIoControl(hDevice : THandle; dwIoControlCode : DWORD; + var lpInBuffer; nInBuffer : DWORD; + var lpOutuffer; nOutBuffer : DWORD; + var BytesReturned: DWORD; Overlapped : pOverlapped):BOOL; stdcall; + } + function DeviceIoControl(hDevice : THandle; dwIoControlCode : DWORD; + lpInBuffer : Pointer; nInBuffer : DWORD; + lpOutuffer : Pointer; nOutBuffer : DWORD; + var BytesReturned: DWORD; Overlapped : pOverlapped):BOOL; stdcall; + + function ReadFile2(hFile: THandle; Buffer : Pointer; nNumberOfBytesToRead: DWORD; + var lpNumberOfBytesRead: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; + function WriteFile2(hFile: THandle; Buffer : Pointer; nNumberOfBytesToWrite: DWORD; + var lpNumberOfBytesWritten: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; + + +type + DEVICE_TYPE=DWORD; + + +const + FILE_DEVICE_BEEP = $00000001; + FILE_DEVICE_CD_ROM = $00000002; + FILE_DEVICE_CD_ROM_FILE_SYSTEM = $00000003; + FILE_DEVICE_CONTROLLER = $00000004; + FILE_DEVICE_DATALINK = $00000005; + FILE_DEVICE_DFS = $00000006; + FILE_DEVICE_DISK = $00000007; + FILE_DEVICE_DISK_FILE_SYSTEM = $00000008; + FILE_DEVICE_FILE_SYSTEM = $00000009; + FILE_DEVICE_INPORT_PORT = $0000000a; + FILE_DEVICE_KEYBOARD = $0000000b; + FILE_DEVICE_MAILSLOT = $0000000c; + FILE_DEVICE_MIDI_IN = $0000000d; + FILE_DEVICE_MIDI_OUT = $0000000e; + FILE_DEVICE_MOUSE = $0000000f; + FILE_DEVICE_MULTI_UNC_PROVIDER = $00000010; + FILE_DEVICE_NAMED_PIPE = $00000011; + FILE_DEVICE_NETWORK = $00000012; + FILE_DEVICE_NETWORK_BROWSER = $00000013; + FILE_DEVICE_NETWORK_FILE_SYSTEM= $00000014; + FILE_DEVICE_NULL = $00000015; + FILE_DEVICE_PARALLEL_PORT = $00000016; + FILE_DEVICE_PHYSICAL_NETCARD = $00000017; + FILE_DEVICE_PRINTER = $00000018; + FILE_DEVICE_SCANNER = $00000019; + FILE_DEVICE_SERIAL_MOUSE_PORT = $0000001a; + FILE_DEVICE_SERIAL_PORT = $0000001b; + FILE_DEVICE_SCREEN = $0000001c; + FILE_DEVICE_SOUND = $0000001d; + FILE_DEVICE_STREAMS = $0000001e; + FILE_DEVICE_TAPE = $0000001f; + FILE_DEVICE_TAPE_FILE_SYSTEM = $00000020; + FILE_DEVICE_TRANSPORT = $00000021; + FILE_DEVICE_UNKNOWN = $00000022; + FILE_DEVICE_VIDEO = $00000023; + FILE_DEVICE_VIRTUAL_DISK = $00000024; + FILE_DEVICE_WAVE_IN = $00000025; + FILE_DEVICE_WAVE_OUT = $00000026; + FILE_DEVICE_8042_PORT = $00000027; + FILE_DEVICE_NETWORK_REDIRECTOR = $00000028; + FILE_DEVICE_BATTERY = $00000029; + FILE_DEVICE_BUS_EXTENDER = $0000002a; + FILE_DEVICE_MODEM = $0000002b; + FILE_DEVICE_VDM = $0000002c; + FILE_DEVICE_MASS_STORAGE = $0000002d; + + IOCTL_STORAGE_BASE = FILE_DEVICE_MASS_STORAGE; +{// +// Macro definition for defining IOCTL and FSCTL function control codes. Note +// that function codes 0-2047 are reserved for Microsoft Corporation, and +// 2048-4095 are reserved for customers. +// + +#define CTL_CODE( DeviceType, Function, Method, Access ) ( \ + ((DeviceType) << 16) | ((Access) << 14) | ((Function) << 2) | (Method) \ +) + +// +// Define the method codes for how buffers are passed for I/O and FS controls +//} + +const + METHOD_BUFFERED = 0; + METHOD_IN_DIRECT = 1; + METHOD_OUT_DIRECT = 2; + METHOD_NEITHER = 3; + +// +// Define the access check value for any access +// +// +// The FILE_READ_ACCESS and FILE_WRITE_ACCESS constants are also defined in +// ntioapi.h as FILE_READ_DATA and FILE_WRITE_DATA. The values for these +// constants *MUST* always be in sync. +// + +const + FILE_ANY_ACCESS = $00; + FILE_READ_ACCESS = $01; // file & pipe + FILE_WRITE_ACCESS = $02; // file & pipe + +// end_ntddk end_nthal end_ntifs + +// +// IoControlCode values for disk devices. +// + +const + IOCTL_DISK_GET_DRIVE_GEOMETRY = $00070000; + +// +// Define the partition types returnable by known disk drivers. +// + +const + PARTITION_ENTRY_UNUSED = $00; // Entry unused + PARTITION_FAT_12 = $01; // 12-bit FAT entries + PARTITION_XENIX_1 = $02; // Xenix + PARTITION_XENIX_2 = $03; // Xenix + PARTITION_FAT_16 = $04; // 16-bit FAT entries + PARTITION_EXTENDED = $05; // Extended partition entry + PARTITION_HUGE = $06; // Huge partition MS-DOS V4 + PARTITION_IFS = $07; // IFS Partition + PARTITION_UNIX = $63; // Unix + PARTITION_LINUX_SWAP = $82; // Linux Swap Partition + PARTITION_LINUX = $83; // Linux Native Partition + + VALID_NTFT = $C0; // NTFT uses high order bits + + PARTITION_EXTENDED_LINUX = $85; // Extended partition entry + PARTITION_EXTENDED_WIN98 = $0f; // Extended partition entry + + EXTENDED_PARTITIONS = [ PARTITION_EXTENDED, PARTITION_EXTENDED_LINUX, PARTITION_EXTENDED_WIN98 ]; + +// +// The following macro is used to determine which partitions should be +// assigned drive letters. +// + +//++ +// +// BOOLEAN +// IsRecognizedPartition( +// IN DWORD PartitionType +// ) +// +// Routine Description: +// +// This macro is used to determine to which partitions drive letters +// should be assigned. +// +// Arguments: +// +// PartitionType - Supplies the type of the partition being examined. +// +// Return Value: +// +// The return value is TRUE if the partition type is recognized, +// otherwise FALSE is returned. +// +//-- +{ +#define IsRecognizedPartition( PartitionType ) ( \ + (((PartitionType & ~0xC0) == PARTITION_FAT_12) || \ + ((PartitionType & ~0xC0) == PARTITION_FAT_16) || \ + ((PartitionType & ~0xC0) == PARTITION_IFS) || \ + ((PartitionType & ~0xC0) == PARTITION_HUGE)) ) +} +// +// The high bit of the partition type code indicates that a partition +// is part of an NTFT mirror or striped array. +// + + PARTITION_NTFT = $80; // NTFT partition + +// +// Define the media types supported by the driver. +// + +{typedef enum _MEDIA_TYPE + Unknown, // Format is unknown + F5_1Pt2_512, // 5.25", 1.2MB, 512 bytes/sector + F3_1Pt44_512, // 3.5", 1.44MB, 512 bytes/sector + F3_2Pt88_512, // 3.5", 2.88MB, 512 bytes/sector + F3_20Pt8_512, // 3.5", 20.8MB, 512 bytes/sector + F3_720_512, // 3.5", 720KB, 512 bytes/sector + F5_360_512, // 5.25", 360KB, 512 bytes/sector + F5_320_512, // 5.25", 320KB, 512 bytes/sector + F5_320_1024, // 5.25", 320KB, 1024 bytes/sector + F5_180_512, // 5.25", 180KB, 512 bytes/sector + F5_160_512, // 5.25", 160KB, 512 bytes/sector + RemovableMedia, // Removable media other than floppy + FixedMedia // Fixed hard disk media + MEDIA_TYPE, *PMEDIA_TYPE;} + +const + Media_Type_Unknown = 0; // Format is unknown + Media_Type_F5_1Pt2_512 = 1; // 5.25", 1.2MB, 512 bytes/sector + Media_Type_F3_1Pt44_512 = 2; // 3.5", 1.44MB, 512 bytes/sector + Media_Type_F3_2Pt88_512 = 3; // 3.5", 2.88MB, 512 bytes/sector + Media_Type_F3_20Pt8_512 = 4; // 3.5", 20.8MB, 512 bytes/sector + Media_Type_F3_720_512 = 5; // 3.5", 720KB, 512 bytes/sector + Media_Type_F5_360_512 = 6; // 5.25", 360KB, 512 bytes/sector + Media_Type_F5_320_512 = 7; // 5.25", 320KB, 512 bytes/sector + Media_Type_F5_320_1024 = 8; // 5.25", 320KB, 1024 bytes/sector + Media_Type_F5_180_512 = 9; // 5.25", 180KB, 512 bytes/sector + Media_Type_F5_160_512 = 10; // 5.25", 160KB, 512 bytes/sector + Media_Type_RemovableMedia= 11; // Removable media other than floppy + Media_Type_FixedMedia = 12; // Fixed hard disk media + +// +// Define the input buffer structure for the driver, when +// it is called with IOCTL_DISK_FORMAT_TRACKS. +// + +const + DFP_RECEIVE_DRIVE_DATA = $0007c088; + +type + USHORT = Word; +//----------- IDE Serial 얻기 위한 선언들 (시작).... + PDRIVERSTATUS = ^TDRIVERSTATUS; + TDRIVERSTATUS = packed record + bDriverError : BYTE; // Error code from driver, + // or 0 if no error. + bIDEError : BYTE; // Contents of IDE Error register. + // Only valid when bDriverError + // is SMART_IDE_ERROR. + bReserved : array[0..1] of BYTE; // Reserved for future expansion. + dwReserved : array[0..1] of DWORD; // Reserved for future expansion. + end; +//} DRIVERSTATUS, *PDRIVERSTATUS, *LPDRIVERSTATUS; + + + TSENDCMDOUTPARAMS = packed record + cBufferSize : DWORD; // Size of bBuffer in bytes + DriverStatus : TDRIVERSTATUS; // Driver status structure. + bBuffer : array[0..511] of BYTE; // Buffer of arbitrary length + end; + PIDSECTOR = ^TIDSECTOR; + TIDSECTOR = packed record + wGenConfig : USHORT; + wNumCyls : USHORT; + wReserved : USHORT; + wNumHeads : USHORT; + wBytesPerTrack : USHORT; + wBytesPerSector : USHORT; + wSectorsPerTrack : USHORT; + wVendorUnique : array[0..2] of USHORT; + sSerialNumber : array[0..19] of char; + wBufferType : USHORT; + wBufferSize : USHORT; + wECCSize : USHORT; + sFirmwareRev : array[0..7] of char; + sModelNumber : array[0..39] of char; + wMoreVendorUnique, + wDoubleWordIO, + wCapabilities, + wReserved1, + wPIOTiming, + wDMATiming, + wBS, + wNumCurrentCyls, + wNumCurrentHeads, + wNumCurrentSectorsPerTrack : USHORT; + ulCurrentSectorCapacity : ULONG ; + wMultSectorStuff : USHORT; + ulTotalAddressableSectors : ULONG ; + wSingleWordDMA : USHORT ; + wMultiWordDMA : USHORT ; + bReserved : array[0..127] of BYTE; + end; + + TIDEREGS = packed record + bFeaturesReg, // Used for specifying SMART "commands". + bSectorCountReg, // IDE sector count register + bSectorNumberReg, // IDE sector number register + bCylLowReg, // IDE low order cylinder value + bCylHighReg, // IDE high order cylinder value + bDriveHeadReg, // IDE drive/head register + bCommandReg, // Actual IDE command. + bReserved : BYTE; // reserved for future use. Must be zero. + end; +//} IDEREGS, *PIDEREGS, *LPIDEREGS; + + + PSENDCMDINPARAMS = ^TSENDCMDINPARAMS; + TSENDCMDINPARAMS = packed record + cBufferSize : DWORD; // Buffer size in bytes + irDriveRegs : TIDEREGS; // Structure with drive register values. + bDriveNumber : BYTE; // Physical drive number to send + // command to (0,1,2,3). + bReserved : array[0..2] of BYTE; // Reserved for future expansion. + dwReserved : array[0..3] of DWORD; // For future use. + bBuffer : array[0..0] of BYTE; // Input buffer. + end;// SENDCMDINPARAMS, *PSENDCMDINPARAMS, *LPSENDCMDINPARAMS; + +//----------- IDE Serial 얻기 위한 선언들 (끝).... + + PDISK_EXTENT = ^TDISK_EXTENT; + TDISK_EXTENT = record + DiskNumber : DWORD; + StartingOffset : LARGE_INTEGER ; + ExtentLength : LARGE_INTEGER; + end; + + PVOLUME_DISK_EXTENTS = ^TVOLUME_DISK_EXTENTS; + TVOLUME_DISK_EXTENTS = record + NumberOfDiskExtents : DWORD ; + Extents : array[0..1] of TDISK_EXTENT; + end; + + TFORMAT_PARAMETERS = record + MediaType : DWORD; + StartCylinderNumber : DWORD ; + EndCylinderNumber : DWORD ; + StartHeadNumber : DWORD ; + EndHeadNumber : DWORD ; + end; + PFORMAT_PARAMETERS = ^TFORMAT_PARAMETERS; + +// +// Define the BAD_TRACK_NUMBER type. An array of elements of this type is +// returned by the driver on IOCTL_DISK_FORMAT_TRACKS requests, to indicate +// what tracks were bad during formatting. The length of that array is +// reported in the `Information' field of the I/O Status Block. +// + +//typedef WORD BAD_TRACK_NUMBER; +//typedef WORD *PBAD_TRACK_NUMBER; + +// +// Define the input buffer structure for the driver, when +// it is called with IOCTL_DISK_FORMAT_TRACKS_EX. +// + +type + TFORMAT_EX_PARAMETERS = record + MediaType : DWORD; + StartCylinderNumber : DWORD; + EndCylinderNumber : DWORD; + StartHeadNumber : DWORD; + EndHeadNumber : DWORD; + FormatGapLength : WORD; + SectorsPerTrack : WORD; + SectorNumber : array[0..0] of WORD; + end; + + +// +// The following structure is returned on an IOCTL_DISK_GET_DRIVE_GEOMETRY +// request and an array of them is returned on an IOCTL_DISK_GET_MEDIA_TYPES +// request. +// + +type + TDISK_GEOMETRY = packed record + Cylinders : _LARGE_INTEGER;//TLargeInteger ;//LARGE_INTEGER ; + MediaType : DWord; + TracksPerCylinder : DWORD; + SectorsPerTrack : DWORD; + BytesPerSector : DWORD; + end; + PDISK_GEOMETRY = ^TDISK_GEOMETRY; + + TDISK_GEOMETRY_EX = packed record + Geometry : TDISK_GEOMETRY; // Standard disk geometry: may be faked by driver. + DiskSize : LARGE_INTEGER; // Must always be correct + Data : array[0..0] of BYTE; // Partition, Detect info + + end; + PDISK_GEOMETRY_EX = ^TDISK_GEOMETRY_EX; + +// +// The following structure is passed in on an IOCTL_DISK_VERIFY request. +// The offset and length parameters are both given in bytes. +// +{$ifdef xxx} +typedef struct _VERIFY_INFORMATION { + LARGE_INTEGER StartingOffset; + DWORD Length; +} VERIFY_INFORMATION, *PVERIFY_INFORMATION; + +// +// The following structure is passed in on an IOCTL_DISK_REASSIGN_BLOCKS +// request. +// + +typedef struct _REASSIGN_BLOCKS { + WORD Reserved; + WORD Count; + DWORD BlockNumber[1]; +} REASSIGN_BLOCKS, *PREASSIGN_BLOCKS; + +// +// IOCTL_DISK_MEDIA_REMOVAL disables the mechanism +// on a SCSI device that ejects media. This function +// may or may not be supported on SCSI devices that +// support removable media. +// +// TRUE means prevent media from being removed. +// FALSE means allow media removal. +// + +typedef struct _PREVENT_MEDIA_REMOVAL { + BOOLEAN PreventMediaRemoval; +} PREVENT_MEDIA_REMOVAL, *PPREVENT_MEDIA_REMOVAL; + +/////////////////////////////////////////////////////// +// // +// The following structures define disk debugging // +// capabilities. The IOCTLs are directed to one of // +// the two disk filter drivers. // +// // +// DISKPERF is a utilty for collecting disk request // +// statistics. // +// // +// SIMBAD is a utility for injecting faults in // +// IO requests to disks. // +// // +/////////////////////////////////////////////////////// + +// +// The following structure is exchanged on an IOCTL_DISK_GET_PERFORMANCE +// request. This ioctl collects summary disk request statistics used +// in measuring performance. +// + +typedef struct _DISK_PERFORMANCE { + LARGE_INTEGER BytesRead; + LARGE_INTEGER BytesWritten; + LARGE_INTEGER ReadTime; + LARGE_INTEGER WriteTime; + DWORD ReadCount; + DWORD WriteCount; + DWORD QueueDepth; +} DISK_PERFORMANCE, *PDISK_PERFORMANCE; + +// +// This structure defines the disk logging record. When disk logging +// is enabled, one of these is written to an internal buffer for each +// disk request. +// + +typedef struct _DISK_RECORD { + LARGE_INTEGER ByteOffset; + LARGE_INTEGER StartTime; + LARGE_INTEGER EndTime; + PVOID VirtualAddress; + DWORD NumberOfBytes; + BYTE DeviceNumber; + BOOLEAN ReadRequest; +} DISK_RECORD, *PDISK_RECORD; + +// +// The following structure is exchanged on an IOCTL_DISK_LOG request. +// Not all fields are valid with each function type. +// + +typedef struct _DISK_LOGGING { + BYTE Function; + PVOID BufferAddress; + DWORD BufferSize; +} DISK_LOGGING, *PDISK_LOGGING; + +// +// Disk logging functions +// +// Start disk logging. Only the Function and BufferSize fields are valid. +// + +#define DISK_LOGGING_START 0 + +// +// Stop disk logging. Only the Function field is valid. +// + +#define DISK_LOGGING_STOP 1 + +// +// Return disk log. All fields are valid. Data will be copied from internal +// buffer to buffer specified for the number of bytes requested. +// + +#define DISK_LOGGING_DUMP 2 + +// +// DISK BINNING +// +// DISKPERF will keep counters for IO that falls in each of these ranges. +// The application determines the number and size of the ranges. +// Joe Lin wanted me to keep it flexible as possible, for instance, IO +// sizes are interesting in ranges like 0-4096, 4097-16384, 16385-65536, 65537+. +// + +#define DISK_BINNING 3 + +// +// Bin types +// + +typedef enum _BIN_TYPES { + RequestSize, + RequestLocation +} BIN_TYPES; + +// +// Bin ranges +// + +typedef struct _BIN_RANGE { + LARGE_INTEGER StartValue; + LARGE_INTEGER Length; +} BIN_RANGE, *PBIN_RANGE; + +// +// Bin definition +// + +typedef struct _PERF_BIN { + DWORD NumberOfBins; + DWORD TypeOfBin; + BIN_RANGE BinsRanges[1]; +} PERF_BIN, *PPERF_BIN ; + +// +// Bin count +// + +typedef struct _BIN_COUNT { + BIN_RANGE BinRange; + DWORD BinCount; +} BIN_COUNT, *PBIN_COUNT; + +// +// Bin results +// + +typedef struct _BIN_RESULTS { + DWORD NumberOfBins; + BIN_COUNT BinCounts[1]; +} BIN_RESULTS, *PBIN_RESULTS; + + +#define IOCTL_SERIAL_LSRMST_INSERT CTL_CODE(FILE_DEVICE_SERIAL_PORT,31,METHOD_BUFFERED,FILE_ANY_ACCESS) + + +// +// The following values follow the escape designator in the +// data stream if the LSRMST_INSERT mode has been turned on. +// +#define SERIAL_LSRMST_ESCAPE ((BYTE )0x00) + +// +// Following this value is the contents of the line status +// register, and then the character in the RX hardware when +// the line status register was encountered. +// +#define SERIAL_LSRMST_LSR_DATA ((BYTE )0x01) + +// +// Following this value is the contents of the line status +// register. No error character follows +// +#define SERIAL_LSRMST_LSR_NODATA ((BYTE )0x02) + +// +// Following this value is the contents of the modem status +// register. +// +#define SERIAL_LSRMST_MST ((BYTE )0x03) + + +#define FSCTL_LOCK_VOLUME CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 6, METHOD_BUFFERED, FILE_ANY_ACCESS) +#define FSCTL_UNLOCK_VOLUME CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 7, METHOD_BUFFERED, FILE_ANY_ACCESS) +#define FSCTL_DISMOUNT_VOLUME CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 8, METHOD_BUFFERED, FILE_ANY_ACCESS) +#define FSCTL_MOUNT_DBLS_VOLUME CTL_CODE(FILE_DEVICE_FILE_SYSTEM,13, METHOD_BUFFERED, FILE_ANY_ACCESS) +#define FSCTL_GET_COMPRESSION CTL_CODE(FILE_DEVICE_FILE_SYSTEM,15, METHOD_BUFFERED, FILE_ANY_ACCESS) +#define FSCTL_SET_COMPRESSION CTL_CODE(FILE_DEVICE_FILE_SYSTEM,16, METHOD_BUFFERED, FILE_ANY_ACCESS) +#define FSCTL_READ_COMPRESSION CTL_CODE(FILE_DEVICE_FILE_SYSTEM,17, METHOD_NEITHER, FILE_ANY_ACCESS) +#define FSCTL_WRITE_COMPRESSION CTL_CODE(FILE_DEVICE_FILE_SYSTEM,18, METHOD_NEITHER, FILE_ANY_ACCESS) + + +#endif // _WINIOCTL_ +{$endif} + +// 2010-07-26 추가 sunk +const + FSCTL_GET_NTFS_VOLUME_DATA = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + (25 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_GET_NTFS_VOLUME_DATA} + + FSCTL_GET_NTFS_FILE_RECORD = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + (26 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_GET_NTFS_FILE_RECORD} + +type + PNTFS_VOLUME_DATA_BUFFER = ^NTFS_VOLUME_DATA_BUFFER; + {$EXTERNALSYM PNTFS_VOLUME_DATA_BUFFER} + NTFS_VOLUME_DATA_BUFFER = record + VolumeSerialNumber: LARGE_INTEGER; + NumberSectors: LARGE_INTEGER; + TotalClusters: LARGE_INTEGER; + FreeClusters: LARGE_INTEGER; + TotalReserved: LARGE_INTEGER; + BytesPerSector: DWORD; + BytesPerCluster: DWORD; + BytesPerFileRecordSegment: DWORD; + ClustersPerFileRecordSegment: DWORD; + MftValidDataLength: LARGE_INTEGER; + MftStartLcn: LARGE_INTEGER; + Mft2StartLcn: LARGE_INTEGER; + MftZoneStart: LARGE_INTEGER; + MftZoneEnd: LARGE_INTEGER; + end; + {$EXTERNALSYM NTFS_VOLUME_DATA_BUFFER} + TNtfsVolumeDataBuffer = NTFS_VOLUME_DATA_BUFFER; + PNtfsVolumeDataBuffer = PNTFS_VOLUME_DATA_BUFFER; + + + PNTFS_FILE_RECORD_INPUT_BUFFER = ^NTFS_FILE_RECORD_INPUT_BUFFER; + {$EXTERNALSYM PNTFS_FILE_RECORD_INPUT_BUFFER} + NTFS_FILE_RECORD_INPUT_BUFFER = record + FileReferenceNumber: LARGE_INTEGER; + end; + {$EXTERNALSYM NTFS_FILE_RECORD_INPUT_BUFFER} + TNtfsFileRecordInputBuffer = NTFS_FILE_RECORD_INPUT_BUFFER; + PNtfsFileRecordInputBuffer = PNTFS_FILE_RECORD_INPUT_BUFFER; + + PNTFS_FILE_RECORD_OUTPUT_BUFFER = ^NTFS_FILE_RECORD_OUTPUT_BUFFER; + {$EXTERNALSYM PNTFS_FILE_RECORD_OUTPUT_BUFFER} + NTFS_FILE_RECORD_OUTPUT_BUFFER = record + FileReferenceNumber: LARGE_INTEGER; + FileRecordLength: DWORD; + FileRecordBuffer: array [0..0] of BYTE; + end; + {$EXTERNALSYM NTFS_FILE_RECORD_OUTPUT_BUFFER} + TNtfsFileRecordOutputBuffer = NTFS_FILE_RECORD_OUTPUT_BUFFER; + PNtfsFileRecordOutputBuffer = PNTFS_FILE_RECORD_OUTPUT_BUFFER; + + + _NTFS_RECORD_HEADER = record + Type_ : array[1..4] of AnsiChar; + UsaOffset: WORD; + UsaCount: WORD; + Usn: LONGLONG; + end; + NTFS_RECORD_HEADER = _NTFS_RECORD_HEADER; + PNTFS_RECORD_HEADER = ^NTFS_RECORD_HEADER; + TNtfsRecordHeader = NTFS_RECORD_HEADER; + PNtfsRecordHeader = ^TNtfsRecordHeader; + + _FILE_RECORD_HEADER = record + Ntfs: NTFS_RECORD_HEADER; + SequenceNumber: USHORT; + LinkCount: USHORT; + AttributesOffset: USHORT; + Flags: USHORT; // 0x0001 = InUse, 0x0002 = Directory + BytesInUse: ULONG; + BytesAllocated: ULONG; + BaseFileRecord: ULONGLONG; + NextAttributeNumber: USHORT; + end; + FILE_RECORD_HEADER = _FILE_RECORD_HEADER; + PFILE_RECORD_HEADER = ^FILE_RECORD_HEADER; + TFileRecordHeader = FILE_RECORD_HEADER; + PFileRecordHeader = ^TFileRecordHeader; + +const + //Type d'attribut d'un FILE_RECORD_HEADER + AttributeStandardInformation = $10; + AttributeAttributeList = $20; + AttributeFileName = $30; + AttributeObjectId = $40; + AttributeSecurityDescriptor = $50; + AttributeVolumeName = $60; + AttributeVolumeInformation = $70; + AttributeData = $80; + AttributeIndexRoot = $90; + AttributeIndexAllocation = $A0; + AttributeBitmap = $B0; + AttributeReparsePoint = $C0; + AttributeEAInformation = $D0; + AttributeEA = $E0; + AttributePropertySet = $F0; + AttributeLoggedUtilityStream = $100; + + //Attribut resident d'un FILE_RECORD_HEADER +type + ATTRIBUTE_TYPE = AttributeStandardInformation..AttributeLoggedUtilityStream; + PATTRIBUTE_TYPE = ^ATTRIBUTE_TYPE; + TAttributeType = ATTRIBUTE_TYPE; + + _ATTRIBUTE = record + AttributeType: ATTRIBUTE_TYPE; + Length: ULONG; + Nonresident: ByteBool; + NameLength: UCHAR; + NameOffset: USHORT; + Flags: USHORT; // 0x0001 = Compressed + AttributeNumber: USHORT; + end; + ATTRIBUTE = _ATTRIBUTE; + PATTRIBUTE = ^ATTRIBUTE; + TAttribute = ATTRIBUTE; + + + PPARTITION_INFORMATION = ^PARTITION_INFORMATION; + {$EXTERNALSYM PPARTITION_INFORMATION} + _PARTITION_INFORMATION = record + StartingOffset: LARGE_INTEGER; + PartitionLength: LARGE_INTEGER; + HiddenSectors: DWORD; + PartitionNumber: DWORD; + PartitionType: BYTE; + BootIndicator: ByteBool; + RecognizedPartition: ByteBool; + RewritePartition: ByteBool; + end; + {$EXTERNALSYM _PARTITION_INFORMATION} + PARTITION_INFORMATION = _PARTITION_INFORMATION; + {$EXTERNALSYM PARTITION_INFORMATION} + TPartitionInformation = PARTITION_INFORMATION; + PPartitionInformation = PPARTITION_INFORMATION; + +// +// The following structure is used to change the partition type of a +// specified disk partition using an IOCTL_DISK_SET_PARTITION_INFO +// request. +// + + PSET_PARTITION_INFORMATION = ^SET_PARTITION_INFORMATION; + {$EXTERNALSYM PSET_PARTITION_INFORMATION} + _SET_PARTITION_INFORMATION = record + PartitionType: BYTE; + end; + {$EXTERNALSYM _SET_PARTITION_INFORMATION} + SET_PARTITION_INFORMATION = _SET_PARTITION_INFORMATION; + {$EXTERNALSYM SET_PARTITION_INFORMATION} + TSetPartitionInformation = _SET_PARTITION_INFORMATION; + PSetPartitionInformation = PSET_PARTITION_INFORMATION; + +// +// The following structures is returned on an IOCTL_DISK_GET_DRIVE_LAYOUT +// request and given as input to an IOCTL_DISK_SET_DRIVE_LAYOUT request. +// + + PDRIVE_LAYOUT_INFORMATION = ^DRIVE_LAYOUT_INFORMATION; + {$EXTERNALSYM PDRIVE_LAYOUT_INFORMATION} + _DRIVE_LAYOUT_INFORMATION = record + PartitionCount: DWORD; + Signature: DWORD; + PartitionEntry: array [0..0] of PARTITION_INFORMATION; + end; + {$EXTERNALSYM _DRIVE_LAYOUT_INFORMATION} + DRIVE_LAYOUT_INFORMATION = _DRIVE_LAYOUT_INFORMATION; + {$EXTERNALSYM DRIVE_LAYOUT_INFORMATION} + TDriveLayoutInformation = DRIVE_LAYOUT_INFORMATION; + PDriveLayoutInformation = PDRIVE_LAYOUT_INFORMATION; + +// +// The following structure is passed in on an IOCTL_DISK_VERIFY request. +// The offset and length parameters are both given in bytes. +// + + PVERIFY_INFORMATION = ^VERIFY_INFORMATION; + {$EXTERNALSYM PVERIFY_INFORMATION} + _VERIFY_INFORMATION = record + StartingOffset: LARGE_INTEGER; + Length: DWORD; + end; + {$EXTERNALSYM _VERIFY_INFORMATION} + VERIFY_INFORMATION = _VERIFY_INFORMATION; + {$EXTERNALSYM VERIFY_INFORMATION} + TVerifyInformation = VERIFY_INFORMATION; + PVerifyInformation = PVERIFY_INFORMATION; + +// +// The following structure is passed in on an IOCTL_DISK_REASSIGN_BLOCKS +// request. +// + + PREASSIGN_BLOCKS = ^REASSIGN_BLOCKS; + {$EXTERNALSYM PREASSIGN_BLOCKS} + _REASSIGN_BLOCKS = record + Reserved: WORD; + Count: WORD; + BlockNumber: array [0..0] of DWORD; + end; + {$EXTERNALSYM _REASSIGN_BLOCKS} + REASSIGN_BLOCKS = _REASSIGN_BLOCKS; + {$EXTERNALSYM REASSIGN_BLOCKS} + TReassignBlocks = REASSIGN_BLOCKS; + PReassignBlocks = PREASSIGN_BLOCKS; + + + +function CtlCode(DeviceType : DWORD; Func : DWord; Method : DWord; Access : DWord) : DWORD; +//#define CTL_CODE( DeviceType, Function, Method, Access ) ( \ +// ((DeviceType) << 16) | ((Access) << 14) | ((Function) << 2) | (Method) \ + + +function MediaDescription(Media : Integer) : String; + +implementation + +// like div but rounds up +function div2(a : LongInt; b : LongInt) : LongInt; +begin + Result := a div b; + if (a mod b) > 0 then + begin + Inc(Result); + end; +end; + + + + function CtlCode(DeviceType : DWORD; Func : DWord; Method : DWord; Access : DWord) : DWORD; + begin + result := (DeviceType shl 16) or (Access shl 14) or (Func shl 2) or (Method); + end; + + function DeviceIoControl; external 'kernel32.dll'; + function ReadFile2; external kernel32 name 'ReadFile'; + function WriteFile2; external kernel32 name 'WriteFile'; + +function MediaDescription(Media : Integer) : String; +begin + case Media of + Media_Type_F5_1Pt2_512: Result := '5.25, 1.2MB, 512 bytes/sector'; + Media_Type_F3_1Pt44_512: Result := '3.5, 1.44MB, 512 bytes/sector'; + Media_Type_F3_2Pt88_512: Result := '3.5, 2.88MB, 512 bytes/sector'; + Media_Type_F3_20Pt8_512: Result := '3.5, 20.8MB, 512 bytes/sector'; + Media_Type_F3_720_512: Result := '3.5, 720KB, 512 bytes/sector'; + Media_Type_F5_360_512: Result := '5.25, 360KB, 512 bytes/sector'; + Media_Type_F5_320_512: Result := '5.25, 320KB, 512 bytes/sector'; + Media_Type_F5_320_1024: Result := '5.25, 320KB, 1024 bytes/sector'; + Media_Type_F5_180_512: Result := '5.25, 180KB, 512 bytes/sector'; + Media_Type_F5_160_512: Result := '5.25, 160KB, 512 bytes/sector'; + Media_Type_RemovableMedia: Result := 'Removable media other than floppy'; + Media_Type_FixedMedia: Result := 'Fixed hard disk media'; + else + Result := 'Unknown'; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Other/KDL.Detours.pas b/Tocsg.Lib/VCL/Other/KDL.Detours.pas new file mode 100644 index 00000000..e53aaa42 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/KDL.Detours.pas @@ -0,0 +1,125 @@ +(* Run-time redirection of a function calls inside of the executable module. + Attention: this unit is full of dirty hacks. :) + Copyright (C) 2006 - 2018 Kryvich, Belarusian Linguistic Software team. +*) + +unit KDL.Detours; + +{$IF NOT DEFINED(MSWINDOWS)} + {$Message Fatal 'Only Windows platform is supported,' + + ' If you can do it on other platforms - tell me how.'} +{$IFEND} + +interface + +type + // Dump of original func, pointers to Original & New funcs + TFuncReplacement = class + private + var OrigDump: packed array[0..4] of Byte; + OrigFunc, MyFunc: Pointer; + fReplaced: Boolean; // Is func replaced now + + procedure SetReplaced(aReplaced: Boolean); + public + constructor Create(aOrigFunc, aMyFunc: Pointer); + destructor Destroy; override; + property Replaced: Boolean read fReplaced write SetReplaced; + end; + + +implementation + +uses + SysUtils, Windows; + +type +// Used for Windows 95 + PWin9xDebugThunk = ^TWin9xDebugThunk; + TWin9xDebugThunk = packed record + PUSH: Byte; // PUSH instruction opcode ($68) + Addr: Pointer; // The actual address of the DLL routine + JMP: Byte; // JMP instruction opcode ($E9) + Rel: Integer; // Relative displacement (a Kernel32 address) + end; + +function IsWin9xDebugThunk(AnAddr: Pointer): Boolean; // copied from JclPeImage.pas +{ -> EAX: AnAddr } +asm + TEST EAX, EAX + JZ @@NoThunk + CMP BYTE PTR [EAX].TWin9xDebugThunk.PUSH, $68 + JNE @@NoThunk + CMP BYTE PTR [EAX].TWin9xDebugThunk.JMP, $E9 + JNE @@NoThunk + XOR EAX, EAX + MOV AL, 1 + JMP @@Exit +@@NoThunk: + XOR EAX, EAX +@@Exit: +end; + +type + // Used for packages + PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp; + TAbsoluteIndirectJmp = packed record + // FF25B8A9BD02 jmp dword ptr [$02bda9b8] -- x86 + // 0000000000E31380 FF2522D00000 jmp qword ptr [rel $0000d022] -- x64 + OpCode: Word; + Addr: UInt32; + end; + +function GetActualAddr(Proc: Pointer): Pointer; +begin + if Proc <> nil then begin + if (Win32Platform <> VER_PLATFORM_WIN32_NT) + and IsWin9xDebugThunk(Proc) + then + Proc := PWin9xDebugThunk(Proc).Addr; // !! not tested for x64 + if PAbsoluteIndirectJmp(Proc).OpCode = $25FF then // JMP mem32 + // It's possible in packages + Result := PPointer( + {$IFDEF CPUX64} NativeInt(Proc) + 6 + {$ENDIF} // FF /4 jmp r/m64 + PAbsoluteIndirectJmp(Proc).Addr)^ + else + Result := Proc; + end else + Result := nil; +end; + +{ TFuncReplacement } + +constructor TFuncReplacement.Create(aOrigFunc, aMyFunc: Pointer); +var + OldProtect: DWORD; +begin + OrigFunc := GetActualAddr(aOrigFunc); + MyFunc := aMyFunc; + Move(OrigFunc^, OrigDump[0], 5); + VirtualProtect(OrigFunc, 5, PAGE_EXECUTE_READWRITE, + @OldProtect); +end; + +destructor TFuncReplacement.Destroy; +begin + SetReplaced(False); + inherited; +end; + +procedure TFuncReplacement.SetReplaced(aReplaced: Boolean); +var + Offset: Int32; +begin + if aReplaced = fReplaced then + Exit; + if aReplaced then begin // Set MyFunc + Offset := NativeInt(MyFunc) - NativeInt(OrigFunc) - 5; + Byte(OrigFunc^) := $E9; + Move(Offset, Pointer(NativeInt(OrigFunc)+1)^, 4); + end else // Set OrigFunc + Move(OrigDump[0], OrigFunc^, 5); + fReplaced := aReplaced; +end; + +end. diff --git a/Tocsg.Lib/VCL/Other/KDL.Localizer.pas b/Tocsg.Lib/VCL/Other/KDL.Localizer.pas new file mode 100644 index 00000000..9931016e --- /dev/null +++ b/Tocsg.Lib/VCL/Other/KDL.Localizer.pas @@ -0,0 +1,696 @@ +{ Kryvich's Delphi Localizer Class + Copyright (C) 2006 - 2018 Kryvich, Belarusian Linguistic Software team. +} +unit KDL.Localizer; +//{$I NoRTTI} +{$IFDEF UNICODE} +{$WEAKLINKRTTI ON} +{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} +{$ENDIF} +interface +uses + Classes, KDL.Detours; +{$IFDEF _HE_} + {$DEFINE VCL} +{$ENDIF} +const + KDL_PLATFORM = +{$IF DEFINED(VCL)} 'VCL' +{$ELSEIF DEFINED(FMX)} 'FMX' +{$ELSEIF DEFINED(NOGUI)} 'NOGUI' +{$ELSE} + {$Message Fatal 'One of the following symbols must be defined: VCL, FMX or NOGUI'} +{$IFEND}; +type + // Method of error processing + TErrorProcessing = ( + epSilent, // Just skip errors (default) - use for public releases + epMessage, // Show message to an user - use for beta testing + epException, // Raise exception - use while develop and debug + epDebug, // Use DebugOutputString + epErrors // Append all messages to a string list + ); + // Translated form properties + TResForm = class + public + Name: string; // Form name + Props: TStringList; // Property names + Values: TStringList; // Translated property values + end; + // Events of Localizer + TBeforeLanguageLoadEvent = procedure(Sender: TObject; const OldLanguageFile, + NewLanguageFile: string) of object; + TAfterLanguageLoadEvent = procedure(Sender: TObject; + const LanguageFile: string) of object; + TFreeLocalizer = class + private + fLanguageFile: string; // Loaded language file + ResForms: array of TResForm; // List of all localized forms + fAutoTranslate: Boolean; + fBeforeLanguageLoadEvent: TBeforeLanguageLoadEvent; + fAfterLanguageLoadEvent: TAfterLanguageLoadEvent; + fErrors: TStrings; +{$IF NOT DEFINED(NOGUI)} + InitInheritedRepl: TFuncReplacement; // InitInheritedComponent replacement +{$IFEND} + // Get Humanize settings of a language file + procedure GetEncoding(sl: TStringList; var Humanize: Boolean; + var HumanizedCR, HumanizedCRLF, HumanizedLF: string); + // Delete old translations in ResForms + procedure ClearResForms; + // Load translations from file + procedure LoadLanguageFile(const aLanguageFile: string); +{$IF NOT DEFINED(NOGUI)} + // Set value PropValue for property PropName in Component RootComp + procedure TranslateProp(RootComp: TComponent; const PropName, PropValue: string); + // Translate component (form) as component of class CompClassType + procedure TranslateAs(Comp: TComponent; const CompClassType: TClass); +{$IFEND} + // Enable/disable autotranslation feature + procedure SetAutoTranslate(aAutoTranslate: Boolean); + // Enable/disable translation of resource strings + procedure EnableResStringer(DoEnable: Boolean); + // Called when error encountered + procedure Error(const Mess: string); + // Get error messages from fErrors + function GetErrors: string; + public + LanguageDir: string; // Directory with language files (optional) + ErrorProcessing: TErrorProcessing; + constructor Create; + destructor Destroy; override; +{$IF NOT DEFINED(NOGUI)} + // Translate component (form) + procedure Translate(Comp: TComponent); + // Translate all forms on Screen + procedure TranslateScreen; +{$IFEND} + // Clear error messages in fErrors + procedure ClearErrors; + // Error messages (set ErrorProcessing to epErrors) + property Errors: string read GetErrors; + // Language file name. Set it to load a new translation + property LanguageFile: string read fLanguageFile write LoadLanguageFile; + // Enable/disable translation of resource strings + property TranslateResourceStrings: Boolean write EnableResStringer; + // Auto translate a form after creating + property AutoTranslate: Boolean read fAutoTranslate write SetAutoTranslate; + // Occurs exactly before loading new language file. + // You can call the silent exception (Abort) to abort the operation + property BeforeLanguageLoad: TBeforeLanguageLoadEvent + read fBeforeLanguageLoadEvent write fBeforeLanguageLoadEvent; + // Occurs exactly after a new language was loaded. + // Do here necessary operations such as calling TranslateScreen + // (if AutoTranslate is disabled) and updating of controls state + property AfterLanguageLoad: TAfterLanguageLoadEvent + read fAfterLanguageLoadEvent write fAfterLanguageLoadEvent; + end; +var + FreeLocalizer: TFreeLocalizer; +resourcestring + rsKdlMark = '*KDL*Mark*'; +implementation +uses + Windows, SysUtils, TypInfo, KDL.StringUtils, StrUtils, Tocsg.Trace +{$IF DEFINED(VCL)} + , Vcl.Forms +{$ELSEIF DEFINED(FMX)} + , FMX.Forms, System.UITypes, FMX.DialogService.Sync; +{$ELSEIF DEFINED(NOGUI)} + // No GUI framework used +{$IFEND}; +const + LngHeader = '; Kryvich''s Delphi Localizer Language File.'; + sNewMark = '(!)'; + sDelMark = '(x)'; +{$region 'EKdlError'} +type + EKdlError = class (Exception) + constructor Create(AMessage: string); + end; + EKdlSilentError = class (EKdlError) + constructor Create; + end; +constructor EKdlError.Create(AMessage: string); +begin + inherited Create(AMessage); +end; +constructor EKdlSilentError.Create; +begin + inherited Create(''); +end; +{$endregion} +{$region 'TResStringer'} +type + TResStringer = class + private + LoadResRepl: TFuncReplacement; // LoadResString replacement + ResStrings: TStringList; // Translated resource strings + fEnabled: Boolean; // Do translations of resource strings + fSelfTestMode: Boolean; + // Get resource string + function GetString(Id: Integer; var s: string): Boolean; + // Set translation status + procedure SetEnabled(aEnabled: Boolean); + public + constructor Create; + destructor Destroy; override; + // Read resource strings from sl into ResStrings + procedure LoadResStrings(sl: TStringList; var i: Integer; + Humanize: Boolean; const HumanizedCR, HumanizedCRLF, HumanizedLF: string); + property Enabled: Boolean read fEnabled write SetEnabled; + end; +var + ResStringer: TResStringer; +function MyLoadResString(ResStringRec: PResStringRec): string; + function GetNotTranslated: string; + begin + ResStringer.Enabled := False; + try + Result := System.LoadResString(ResStringRec); + finally + ResStringer.Enabled := True; + end; + end; +begin + if ResStringRec = nil then + Exit; + if Assigned(ResStringer) and ResStringer.Enabled then begin + if ResStringRec.Identifier >= 64*1024 then + Result := PChar(ResStringRec.Identifier) + else if not ResStringer.GetString(ResStringRec.Identifier, Result) then + if ResStringer.fSelfTestMode then + Result := '' + else + Result := GetNotTranslated; + end else + Result := System.LoadResString(ResStringRec); +end; +{ TResStringer } +constructor TResStringer.Create; +begin + LoadResRepl := TFuncReplacement.Create(@System.LoadResString, @MyLoadResString); +end; +destructor TResStringer.Destroy; +begin + Enabled := False; + FreeAndNil(ResStrings); + LoadResRepl.Free; + inherited; +end; +procedure TResStringer.SetEnabled(aEnabled: Boolean); +begin + LoadResRepl.Replaced := aEnabled; + fEnabled := aEnabled; +end; +procedure TResStringer.LoadResStrings(sl: TStringList; var i: Integer; + Humanize: Boolean; const HumanizedCR, HumanizedCRLF, HumanizedLF: string); +const + KdlMarkStringName = 'KDL_Localizer_rsKdlMark'; +var + s, el: string; + id: Integer; + oEnabled: Boolean; + kdlMarkFound: Boolean; +begin + oEnabled := Enabled; + Enabled := False; + if ResStrings <> nil then + ResStrings.Clear + else + ResStrings := TStringList.Create; + kdlMarkFound := False; + while i < sl.Count do begin + s := sl[i]; + if (s <> '') and (s[1] <> ';') then begin + if s[1] = '(' then begin + if Copy(s, 1, Length(sDelMark)) = sDelMark then + FreeLocalizer.Error('Obsolete line in language file:'#13#10'"' + + sl[i] + '"'#13#10'You have to delete it!') + else if Copy(s, 1, Length(sNewMark)) = sNewMark then + FreeLocalizer.Error('Untranslated line in language file:'#13#10'"' + + sl[i] + '"'#13#10'You have to translate it!'); + end else begin + if s[1] = '[' then + Break; + // 65167_ComConst_SOleError='OLE error %.8x' + SplitBy(s, '_', el); + if not TryStrToInt(el, id) then + FreeLocalizer.Error('Bad resource ID in language file: "' + el + '"'); + SplitBy(s, '=', el); + kdlMarkFound := kdlMarkFound or (el = KdlMarkStringName); + s := LngToString(s, Humanize, HumanizedCR, HumanizedCRLF, HumanizedLF, + sLineBreak); + ResStrings.Add(s); + ResStrings.Objects[ResStrings.Count-1] := Pointer(id); + end; + end; + Inc(i); + end; + if not kdlMarkFound then begin + FreeLocalizer.Error('Can''t find the special string ' + KdlMarkStringName + + ' in the loaded language file. This language file is corrupted.'); + ResStrings.Clear; + end else begin + try + fSelfTestMode := True; + Enabled := True; + if rsKdlMark <> '*KDL*Mark*' then begin + ResStrings.Clear; + FreeLocalizer.Error( + 'Strings section in the loaded language file is outdated.'#13#10 + + 'Messages of this application will not be translated.'); + end; + finally + Enabled := False; + fSelfTestMode := False; + end; + end; + Enabled := oEnabled and (ResStrings.Count > 0); +end; +function TResStringer.GetString(Id: Integer; var s: string): Boolean; +var + i0, i1, i2: Integer; +begin + if ResStrings = nil then + Result := False + else begin + i0 := 0; + i2 := ResStrings.Count-1; + while i0 < i2 do begin + i1 := (i0+i2) div 2; + if Id > Integer(ResStrings.Objects[i1]) then + i0 := i1+1 + else + i2 := i1; + end; + Result := (Id = Integer(ResStrings.Objects[i0])); + if Result then + s := ResStrings[i0]; + end; +end; +{$endregion} +{$region 'TFreeLocalizer'} +procedure TFreeLocalizer.ClearErrors; +begin + fErrors.Clear; +end; +procedure TFreeLocalizer.ClearResForms; +var + i: Integer; +begin + for i := 0 to Length(ResForms) - 1 do begin + ResForms[i].Props.Free; + ResForms[i].Values.Free; + ResForms[i].Free; + end; + SetLength(ResForms, 0); +end; +constructor TFreeLocalizer.Create; +begin + fErrors := TStringList.Create; + ResStringer := TResStringer.Create; + ResStringer.Enabled := True; +end; +destructor TFreeLocalizer.Destroy; +begin + SetAutoTranslate(False); + ResStringer.Free; + ClearResForms; + fErrors.Free; + inherited; +end; +procedure TFreeLocalizer.Error(const Mess: string); +begin + case ErrorProcessing of + epMessage: +{$IF DEFINED(VCL)} + Application.MessageBox(pChar(Mess), 'K.D.L. Error', + MB_ICONERROR+MB_OK+MB_DEFBUTTON1+MB_APPLMODAL); +{$ELSEIF DEFINED(FMX)} + TDialogServiceSync.MessageDialog(Mess, TMsgDlgType.mtError, + [TMsgDlgBtn.mbOK], TMsgDlgBtn.mbOK, 0); +{$ELSE} + Writeln('K.D.L. Error: ', Mess); +{$IFEND} + epException: raise EKdlError.Create(Mess); + epDebug: OutputDebugString(pChar(Mess)); + epErrors: fErrors.Append(Mess); + end; +end; +procedure TFreeLocalizer.GetEncoding(sl: TStringList; var Humanize: Boolean; + var HumanizedCR, HumanizedCRLF, HumanizedLF: string); +var + i: Integer; + s: string; +begin + Humanize := False; + HumanizedCR := defHumanizeDivider; + HumanizedCRLF := defHumanizeDivider; + HumanizedLF := defHumanizeDivider; + i := sl.IndexOfName('Humanize'); + if i >= 0 then begin + Humanize := (sl.ValueFromIndex[i] = '1'); + i := sl.IndexOfName('HumanizeDivider'); + if i >= 0 then begin // For backward compatibility + s := sl.ValueFromIndex[i]; + HumanizedCR := s; + HumanizedCRLF := HumanizedCR; + end; + i := sl.IndexOfName('HumanizedCR'); + if i >= 0 then begin + s := sl.ValueFromIndex[i]; + HumanizedCR := s; + end; + i := sl.IndexOfName('HumanizedCRLF'); + if i >= 0 then begin + s := sl.ValueFromIndex[i]; + HumanizedCRLF := s; + end; + i := sl.IndexOfName('HumanizedLF'); + if i >= 0 then begin + s := sl.ValueFromIndex[i]; + HumanizedLF := s; + end; + end; +end; +function TFreeLocalizer.GetErrors: string; +begin + Result := fErrors.Text; +end; +procedure TFreeLocalizer.LoadLanguageFile(const aLanguageFile: string); +const + LngExt = '.dat'; // '.lng'; +var + FullLangFile: string; + sl: TStringList; + i, iResForms: Integer; + s, el: string; + Humanize: Boolean; + HumanizedCR, HumanizedCRLF, HumanizedLF: string; +begin + if Assigned(fBeforeLanguageLoadEvent) then + fBeforeLanguageLoadEvent(Self, LanguageFile, aLanguageFile); + try + ClearResForms; + // Build Full name of language file + FullLangFile := LanguageDir; + if (FullLangFile <> '') + and not CharInSet(FullLangFile[Length(FullLangFile)], ['/', '\']) + then + FullLangFile := FullLangFile + '\'; + FullLangFile := FullLangFile + aLanguageFile; + if not AnsiEndsText(LngExt, FullLangFile) then + FullLangFile := FullLangFile + LngExt; + sl := TStringList.Create; + try + sl.LoadFromFile(FullLangFile, TEncoding.UTF8); + // 헤드 체크 삭제 22_0810 09:49:39 kku +// if (sl.Count <= 0) +// or (sl[0] <> LngHeader) +// then begin +// Error('Bad signature in language file "' + FullLangFile + '"'); +// Exit; +// end; + if sl.Count <= 0 then + exit; + GetEncoding(sl, Humanize, HumanizedCR, HumanizedCRLF, HumanizedLF); + iResForms := -1; + i := 1; + while i < sl.Count do begin + s := sl[i]; + if (s <> '') and (s[1] <> ';') then begin + if s[1] = '[' then begin + if UpperCase(s) = '[RESOURCESTRINGS]' then begin + Inc(i); + ResStringer.LoadResStrings(sl, i, Humanize, HumanizedCR, + HumanizedCRLF, HumanizedLF); + Continue; + end else begin + if Copy(s, 2, Length(sDelMark)) = sDelMark then begin + Error('Deleted component in language file:'#13#10'"' + sl[i] + + '"'#13#10'You have to remove it!'); + Exit; + end; + Inc(iResForms); + SetLength(ResForms, iResForms+1); + ResForms[iResForms] := TResForm.Create; + ResForms[iResForms].Name := Copy(s, 2, Length(s)-2); + ResForms[iResForms].Props := TStringList.Create; + ResForms[iResForms].Values := TStringList.Create; + end; + end else if iResForms >= 0 then begin + if s[1] = '(' then begin + if Copy(s, 1, Length(sDelMark)) = sDelMark then + Error('Obsolete line in language file:'#13#10'"' + sl[i] + + '"'#13#10'You have to remove it!') + else if Copy(s, 1, Length(sNewMark)) = sNewMark then + Error('Untranslated line in language file:'#13#10'"' + sl[i] + + '"'#13#10'You have to translate it!'); + end else begin + SplitBy(s, '=', el); + s := LngToString(s, Humanize, HumanizedCR, HumanizedCRLF, + HumanizedLF, #13); + ResForms[iResForms].Values.Add(s); + // btnNewForm.Caption{1} -> drop version # + SplitBy(el, '{', s); + if s = '' then begin + Error('Bad line in language file: "' + sl[i] + '"'); + Exit; + end; + ResForms[iResForms].Props.Add(s); + end; + end; + end; + Inc(i); + end; + finally + sl.Free; + end; + fLanguageFile := aLanguageFile; +{$IF NOT DEFINED(NOGUI)} + if AutoTranslate then + TranslateScreen; +{$IFEND} + if Assigned(fAfterLanguageLoadEvent) then + fAfterLanguageLoadEvent(Self, fLanguageFile); + except + on E: Exception do + begin + // 여기서 왜 에러가 나는지 모르겠다... + // 디버깅 모드에서는 재현이 안되고 릴리즈 시에만 발생하는데... + // 정상동작은 함 그래서 오류 표시만 숨기고 로그로만 남기도록 기능 보완 22_1213 15:55:07 kku + TTgTrace.T('Error while loading language file "%s"', [FullLangFile]); +// Error('Error while loading language file "' + FullLangFile + '"'#13#10 +// + E.Message); + end; + end; +end; +{$IF NOT DEFINED(NOGUI)} +procedure TFreeLocalizer.TranslateAs(Comp: TComponent; + const CompClassType: TClass); +var + ResForm: TResForm; + ParentClassType: TClass; + i: Integer; +begin + // Whether the component's ancestor can contain localizable controls? + ParentClassType := CompClassType.ClassParent; + if (ParentClassType <> TForm) + and (ParentClassType <> TDataModule) + and (ParentClassType <> TObject) + then + TranslateAs(Comp, ParentClassType) + else begin + // Translate nested frames + for i := 0 to Comp.ComponentCount - 1 do + if Comp.Components[i] is TFrame then + FreeLocalizer.Translate(Comp.Components[i]); + end; + ResForm := Nil; + for i := 0 to Length(ResForms)-1 do + if CompClassType.ClassName = ResForms[i].Name then begin + ResForm := ResForms[i]; + Break; + end; + if ResForm = Nil then Exit; // This component not translated + for i := 0 to ResForm.Props.Count - 1 do + TranslateProp(Comp, ResForm.Props[i], ResForm.Values[i]); +end; +procedure TFreeLocalizer.Translate(Comp: TComponent); +begin + TranslateAs(Comp, Comp.ClassType); +end; +procedure TFreeLocalizer.TranslateProp(RootComp: TComponent; const PropName, + PropValue: string); + procedure SetStringsProp(st: TStrings); + var + i: Integer; + s, el: string; + begin + s := PropValue; + i := 0; + st.BeginUpdate; + try + while s <> '' do begin + SplitBy(s, ListDivider, el); + if i < st.Count then + st[i] := el + else + st.Add(el); + Inc(i); + end; + while st.Count > i do + st.Delete(st.Count-1); + finally + st.EndUpdate; + end; + end; + procedure SetProp(Obj: TObject; const pName: string); + var + PropInfo: PPropInfo; + begin + if Obj is TStrings then + SetStringsProp(Obj as TStrings) + else begin + PropInfo := GetPropInfo(Obj.ClassInfo, pName); + if PropInfo <> Nil then // Property exists + SetPropValue(Obj, PropInfo, PropValue) + else + raise EKdlSilentError.Create; + end; + end; +label + CheckComp, CheckClass; +var + s, el: string; + Comp, cmp, OwnerComp: TComponent; + obj: TObject; + PropInfo: PPropInfo; + i: Integer; +begin + try + OwnerComp := RootComp; + Comp := RootComp; + s := PropName; + repeat + SplitBy(s, '.', el); + CheckComp: + if s = '' then begin // el is property name + SetProp(Comp, el); + Exit; + end; + cmp := Comp.FindComponent(el); + if cmp = Nil then + Break; + Comp := cmp; + if Comp is TFrame then + OwnerComp := Comp; + until False; + // TVirtualStringTree에서 번역 리소스 추출 시 컬럼의 경우 Header 정보까지 가져오지 않는다. + // 그래서 아래처럼 처리함 22_1212 16:23:12 kku + if (Comp <> nil) and (Comp.ClassName = 'TVirtualStringTree') and + (el = 'Columns') then + begin + el := 'Header'; + s := 'Columns.' + s; + end; + // Check for nested classes + obj := Comp; + while Obj is TPersistent do begin + PropInfo := GetPropInfo(obj.ClassInfo, el); + if (PropInfo = Nil) or (PropInfo.PropType^.Kind <> tkClass) then + Break; // Such class property not exists + obj := Pointer(NativeUInt(GetPropValue(Obj, PropInfo))); + CheckClass: + SplitBy(s, '.', el); + if s = '' then begin // el is property name + SetProp(obj, el); + Exit; + end; + if Obj is TCollection then + Break; + end; + // Check for nested TCollection + if (obj is TCollection) + and (Length(el) >= 3) + and (el[1] = '(') + and (el[Length(el)] = ')') + and TryStrToInt(Copy(el, 2, Length(el)-2), i) + then begin + // el = '(0)' s = ...rest of nested classes and properties + obj := (obj as TCollection).Items[i]; + goto CheckClass; + end; + // Try to find out el among components of OwnerComp + if Comp <> OwnerComp then begin + Comp := OwnerComp; + goto CheckComp; + end; + // yet untranslated... + raise EKdlSilentError.Create; + except + on E: EKdlSilentError do + begin + // 사라진 컨트롤 무시 22_1213 14:20:55 kku +// s := 'Unknown property "%s" found in component "%s".'#13#10 +// + 'Remove it from language file'; +// Error(Format(s, [PropName, RootComp.Name])); + end; + + on E: Exception do + begin + s := 'Translation error of property "%s" in component "%s"'#13#10 + + E.Message; + Error(Format(s, [PropName, RootComp.Name])); + end; + end; +end; +procedure TFreeLocalizer.TranslateScreen; +var + i: Integer; +begin + for i := 0 to Screen.FormCount - 1 do Translate(Screen.Forms[i]); +end; +function MyInitInheritedComponent(Instance: TComponent; + RootAncestor: TClass): Boolean; +begin + FreeLocalizer.InitInheritedRepl.Replaced := False; + try + Result := InitInheritedComponent(Instance, RootAncestor); + FreeLocalizer.Translate(Instance); + finally + FreeLocalizer.InitInheritedRepl.Replaced := True; + end; +end; +procedure TFreeLocalizer.SetAutoTranslate(aAutoTranslate: Boolean); +begin + if aAutoTranslate = fAutoTranslate then + Exit; + if aAutoTranslate then begin + InitInheritedRepl := TFuncReplacement.Create( + @Classes.InitInheritedComponent, + @MyInitInheritedComponent); + InitInheritedRepl.Replaced := True; + end else begin + InitInheritedRepl.Free; + end; + fAutoTranslate := aAutoTranslate; +end; +{$ELSE} +procedure TFreeLocalizer.SetAutoTranslate(aAutoTranslate: Boolean); +begin +// 이거 선언 만으로 리소스 추출 가능하도록 추가 22_0810 16:13:34 kku + fAutoTranslate := False; // Auto translation is for GUI only +end; +{$IFEND} +procedure TFreeLocalizer.EnableResStringer(DoEnable: Boolean); +begin + ResStringer.Enabled := DoEnable; +end; +{$endregion} +Initialization + FreeLocalizer := TFreeLocalizer.Create; +Finalization + FreeLocalizer.Free; +end. diff --git a/Tocsg.Lib/VCL/Other/KDL.StringUtils.pas b/Tocsg.Lib/VCL/Other/KDL.StringUtils.pas new file mode 100644 index 00000000..1c621fd4 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/KDL.StringUtils.pas @@ -0,0 +1,434 @@ +{ String manipulation routines. + Copyright (C) 2006 - 2018 Aleg Azarouski. +} + +unit KDL.StringUtils; +//{$I NoRTTI} +{$IFDEF UNICODE} +{$WEAKLINKRTTI ON} +{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} +{$ENDIF} + +interface + +const + ListDivider = #13; // Used in DelphiToStringEx + defHumanizeDivider = '\'; // Used in StringToHumanized + defHumanizedLF = '\#10'; + UnicodeLabel: array[0..2] of Byte = ($EF, $BB, $BF); + +// Split a string by a given divider +// Return in El - left part, in s - rest of a string +procedure SplitBy(var S: string; const Divider: string; var Elem: string); +// Escaped string to string (based on the JEDI Code Library (JCL)) +function StrEscapedToString(const S: string): string; +// Encode string to lng file string +// DividerCR - substitution for #13 +// DividerCRLF - substitution for #13#10 +// DividerLF - substitution for #10 +function StringToLng(const S: string; Humanize: Boolean; const DividerCR, + DividerCRLF, DividerLF: string): string; +// Decode lng file string to string +// DividerCR - substitution for #13 +// DividerCRLF - substitution for #13#10 +// DividerLF - substitution for #10 +// DefaultLineBreak - used when DividerCR = DividerCRLF +function LngToString(const S: string; Humanize: Boolean; const DividerCR, + DividerCRLF, DividerLF, DefaultLineBreak: string): string; + +implementation + +uses + SysUtils, StrUtils; + +{$region 'Delphi string conversions'} +procedure SplitBy(var S: string; const Divider: string; var Elem: string); +var + i: Integer; +begin + i := Pos(Divider, S); + if i <= 0 then begin + Elem := S; + S := ''; + end else begin + Elem := Copy(S, 1, i-1); + Delete(S, 1, i + Length(Divider) - 1); + end; +end; + +// Encode string to delphi style string +function StringToDelphi(const s: string): string; +var + i: Integer; + insideStr: Boolean; + res: string; + ch: Char; + + procedure SwitchStr; // '...' + begin + insideStr := not insideStr; + res := res + ''''; + end; + +begin + insideStr := False; + if s = '' then + res := '''''' + else begin + for i := 1 to Length(s) do begin + ch := s[i]; + case ch of + '''': begin + if insideStr then + res := res + '''''' + else begin + res := res + ''''''''; + insideStr := True; + end; + end; + #0..#31: begin + if insideStr then SwitchStr; + res := res + '#' + IntToStr(ord(ch)); + end; + else begin + if not insideStr then SwitchStr; + res := res + ch; + end; + end; + end; + end; + if insideStr then SwitchStr; + Result := res; +end; + +type + EDelphiToStringError = Class(Exception) + public + iBadChar: Integer; // Bad character position + end; + +// Decode delphi style string to string +function DelphiToString(const s: string): string; +label + Err; +var + i, iOpened: Integer; + res: string; + insideStr, insideCode: Boolean; + ch: Char; + + procedure OpenStr; // '... + begin + insideStr := True; + iOpened := i; + end; + + procedure OpenCode; // #13 + begin + insideCode := True; + iOpened := i; + end; + + function CloseCode: Boolean; + begin + try + res := res + Char(StrToInt(Copy(s, iOpened+1, i-iOpened-1))); + Result := True; + insideCode := False; + except + Result := False; + end; + end; + +var + Ex: EDelphiToStringError; +begin + res := ''; + insideStr := False; + insideCode := False; + // 'Method ''%s'' not supported by automation object' + // 'Exception %s in module %s at %p.'#13#10'%s%s'#13#10 + // '''hallo' -- 'hallo''' + // 'hal'''#13#10'lo' -- 'hallo''hallo' + for i := 1 to Length(s) do begin + ch := s[i]; + if insideStr then begin + // Str opened, code closed + if ch = '''' then + insideStr := False + else + res := res + ch; + end else begin + if insideCode then begin + // Str closed, code opened + case ch of + '''': begin + if not CloseCode then + goto Err; + OpenStr; + end; + '#': begin + if not CloseCode then + goto Err; + OpenCode; + end; + '0'..'9':; + else goto Err; + end; + end else begin + // Str closed, code closed + case ch of + '''': begin + if (i > 1) and (s[i-1] = '''') then + res := res + ''''; + OpenStr; + end; + '#': OpenCode; + else begin + Result := res; + Ex := EDelphiToStringError.Create('Bad decoded string: "' + s + '"'); + Ex.iBadChar := i; + raise Ex; + end; + end; + end; + end; + end; + if insideStr then begin + Err: + raise Exception.Create('Bad decoded string: "' + s + '"'); + end; + if insideCode then CloseCode; + Result := res; +end; + +// Decode delphi style string and stringlist to string +// Stringlist elements delimited by #13 +function DelphiToStringEx(s: string): string; +var + res, s1: string; + + procedure AddResS1; + begin + if res <> '' then + res := res + ListDivider; + res := res + S1; + end; + +var + Ok: Boolean; +begin + res := ''; + repeat + Ok := True; + try + s1 := DelphiToString(s); + except + on E: EDelphiToStringError do begin + AddResS1; + s := Trim(Copy(s, E.iBadChar+1, MaxInt)); + Ok := False; + end; + end; + until Ok; + AddResS1; + Result := res; +end; +{$endregion} + +{$region 'Escaped string conversions'} +function StrEscapedToString(const S: string): string; + + // \x041f --> wide character + procedure HandleHexEscapeSeq(const S: string; var I: Integer; Len: Integer; + var Dest: string); + const + hexDigits = string('0123456789abcdefABCDEF'); + var + startI, val, n: Integer; + begin + startI := I; + val := 0; + while I < StartI + 4 do begin + n := Pos(S[I+1], hexDigits) - 1; + if n < 0 then begin + if startI = I then begin + // '\x' without hex digit following is not escape sequence + Dest := Dest + '\x'; + Exit; + end; + end else begin + Inc(I); + if n >= 16 then + n := n - 6; + val := val * 16 + n; + if val > Ord(High(Char)) then + raise Exception.CreateFmt( + 'Numeric constant too large (%d) at position %d.', [val, startI]); + end; + end; + Dest := Dest + Char(val); + end; + + procedure HandleOctEscapeSeq(const S: string; var I: Integer; Len: Integer; + var Dest: string); + const + octDigits = string('01234567'); + var + startI, val, n: Integer; + begin + startI := I; + // first digit + val := Pos(S[I], octDigits) - 1; + if I < Len then + begin + n := Pos(S[I + 1], octDigits) - 1; + if n >= 0 then + begin + Inc(I); + val := val * 8 + n; + end; + if I < Len then + begin + n := Pos(S[I + 1], octDigits) - 1; + if n >= 0 then + begin + Inc(I); + val := val * 8 + n; + end; + end; + end; + + if val > Ord(High(Char)) then + raise Exception.CreateFmt( + 'Numeric constant too large (%d) at position %d.', [val, startI]); + + Dest := Dest + Char(val); + end; + +const + NativeBell = Char(#7); + NativeBackspace = Char(#8); + NativeTab = Char(#9); + NativeLineFeed = Char(#10); + NativeVerticalTab = Char(#11); + NativeFormFeed = Char(#12); + NativeCarriageReturn = Char(#13); +var + I, Len: Integer; +begin + Result := ''; + I := 1; + Len := Length(S); + while I <= Len do begin + if not ((S[I] = '\') and (I < Len)) then + Result := Result + S[I] + else begin + Inc(I); // Jump over escape character + case S[I] of + 'a': + Result := Result + NativeBell; + 'b': + Result := Result + NativeBackspace; + 'f': + Result := Result + NativeFormFeed; + 'n': + Result := Result + NativeLineFeed; + 'r': + Result := Result + NativeCarriageReturn; + 't': + Result := Result + NativeTab; + 'v': + Result := Result + NativeVerticalTab; + '\': + Result := Result + '\'; + '"': + Result := Result + '"'; + '''': + Result := Result + ''''; // Optionally escaped + '?': + Result := Result + '?'; // Optionally escaped + 'x': + if I < Len then + // Start of hex escape sequence + HandleHexEscapeSeq(S, I, Len, Result) + else + // '\x' at end of string is not escape sequence + Result := Result + '\x'; + '0'..'7': + // start of octal escape sequence + HandleOctEscapeSeq(S, I, Len, Result); + else + // no escape sequence + Result := Result + '\' + S[I]; + end; + end; + Inc(I); + end; +end; +{$endregion} + +{$region 'Humanized string conversions'} +// Encode string to "humanized" style string +// DividerCR - substitution for #13 +// DividerCRLF - substitution for #13#10 +// DividerLF - substitution for #10 +function StringToHumanized(const s: string; const DividerCR, DividerCRLF, + DividerLF: string): string; +begin + if (Pos(DividerCR, s) > 0) + or (Pos(DividerCRLF, s) > 0) + or (Pos(DividerLF, s) > 0) + then + raise Exception.CreateFmt( + 'String "%s" contains a humanize divider "%s", "%s" or "%s" and can''t' + + ' be converted properly.'#13#10 + + 'Try set a different string as the divider for this application.', + [s, DividerCR, DividerCRLF, DividerLF]); + Result := StringReplace( + StringReplace( + StringReplace(s, sLineBreak, DividerCRLF, [rfReplaceAll]), + #13, DividerCR, [rfReplaceAll]), + #10, DividerLF, [rfReplaceAll]); +end; + +// Decode "humanized" style string to string +// DividerCR - substitution for #13 +// DividerCRLF - substitution for #13#10 +// DividerLF - substitution for #10 +// DefaultLineBreak - used when DividerCR = DividerCRLF +function HumanizedToString(const s: string; const DividerCR, DividerCRLF, + DividerLF, DefaultLineBreak: string): string; +begin + if DividerCR = DividerCRLF then + Result := StringReplace(s, DividerCR, DefaultLineBreak, [rfReplaceAll]) + else begin + Result := StringReplace(s, DividerCR, #13, [rfReplaceAll]); + Result := StringReplace(Result, DividerCRLF, sLineBreak, [rfReplaceAll]); + end; + Result := StringReplace(Result, DividerLF, #10, [rfReplaceAll]); +end; +{$endregion} + +{$region 'Lng file string conversions'} +function StringToLng(const S: string; Humanize: Boolean; const DividerCR, + DividerCRLF, DividerLF: string): string; +begin + if Humanize then + Result := StringToHumanized(S, DividerCR, DividerCRLF, DividerLF) + else + Result := StringToDelphi(S); +end; + +function LngToString(const S: string; Humanize: Boolean; const DividerCR, + DividerCRLF, DividerLF, DefaultLineBreak: string): string; +begin + if Humanize then + Result := HumanizedToString(S, DividerCR, DividerCRLF, DividerLF, + DefaultLineBreak) + else + Result := DelphiToStringEx(S); +end; +{$endregion} + +end. diff --git a/Tocsg.Lib/VCL/Other/VirtualTrees.Filter.pas b/Tocsg.Lib/VCL/Other/VirtualTrees.Filter.pas new file mode 100644 index 00000000..5e05f16d --- /dev/null +++ b/Tocsg.Lib/VCL/Other/VirtualTrees.Filter.pas @@ -0,0 +1,1316 @@ +unit VirtualTrees.Filter; + +interface + +//{$DEFINE USE_VTFILTER_COMBOBOX} + +uses + Winapi.Windows, Winapi.oleacc, Winapi.Messages, + + System.SysUtils, System.Variants, System.Classes, System.UITypes, + System.Types, + + Generics.Collections, + Generics.Defaults, + + VirtualTrees, + VirtualTrees.Utils, + + Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls; + +{$IFDEF USE_VTFILTER_COMBOBOX} +const + MAX_COMBO_ITEM = 10; +{$ENDIF} + +type + TFilterDict = class // (TDictionary <Integer, String>) + private + fInnerDict: TDictionary <Integer, String>; + function GetFilter(Index: Integer): String; + procedure SetFilter(Index: Integer; const Value: String); + function GetCount: Integer; + protected + public + constructor Create; + destructor Destroy; override; + + procedure Assign(aFilterDict: TFilterDict); + public + property Filter[Index: Integer]: String read GetFilter write SetFilter; default; + property Count: Integer read GetCount; + end; + + TBlockedColumns = class (TDictionary<TColumnIndex, Boolean>) + private + protected + public + function CheckBlocked(aColumnIndex: TColumnIndex): Boolean; + end; + + TRedirectColumns = class (TDictionary<TColumnIndex, TColumnIndex>) + private + protected + public + function CheckRedirect(aColumnIndex: TColumnIndex): TColumnIndex; + end; + + + TCheckNodeVisibleEvent = function (Sender: TBaseVirtualTree; aNode: PVirtualNode; var ContinueGetText: Boolean): Boolean of Object; + TCheckForceInvisibleEvent = function (Sender: TBaseVirtualTree; aNode: PVirtualNode; var IgnoreTarget: Boolean): Boolean of Object; // 추가 18_0416 10:37:13 sunk + TAfterFilterEvent = procedure (Sender: TBaseVirtualTree) of Object; + + // 필터 라인 + TVtFilterLine = (flTop, flBottom, flRight); + TVtFilterLines = set of TVtFilterLine; + + // 필터 적용 단계 + TVtFilterApplyLevel = (flvRoot, flvAll); + +{$IFDEF USE_VTFILTER_COMBOBOX} + TVtFilterEdit = class (TCustomComboBox) +{$ELSE} + TVtFilterEdit = class (TCustomEdit) +{$ENDIF} + private + FilterDict_: TFilterDict; + FilterLines_: TVtFilterLines; + FilterApplyLevel_: TVtFilterApplyLevel; + NotEditColumns_: TBlockedColumns; + NotFiltedColumns_: TBlockedColumns; + RedirectColumns_: TRedirectColumns; + bUse_Ctrl_F_: Boolean; + + // 자신의 하위 노드의 Visible이 모두 false 인 경우, + // 상위의 Visible도 false로 변경할껀가? 18_0416 10:03:33 sunk + bForceInvisible_: Boolean; + + VT_: TVirtualStringTree; + ColumnIndex_: TColumnIndex; + EvOnCheckNodeVisible_: TCheckNodeVisibleEvent; + EvOnCheckForceInvisible_: TCheckForceInvisibleEvent; + EvOnAfterFilter_: TAfterFilterEvent; + private + procedure CMExit(var Message: TMessage); message CM_EXIT; + procedure CMRelease(var Message: TMessage); message CM_RELEASE; + procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; + {$IFDEF USE_VTFILTER_COMBOBOX} + procedure OnCbKeyPress(Sender: TObject; var Key: Char); + procedure OnCbKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); + {$ELSE} + procedure WMChar(var Message: TWMChar); message WM_CHAR; + procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; + {$ENDIF} + + private + OrgVSTWndProc_: TWndMethod; + FilterBitmap_: TBitmap; + {$IFDEF USE_VTFILTER_COMBOBOX} + sHighOwnerName_: String; + procedure SaveComboBoxItems; + procedure LoadComboBoxItems; + {$ENDIF} + procedure VSTWndProc(var Message: TMessage); + protected + public + constructor Create(aOwner: TComponent; aVST: TVirtualStringTree); reintroduce; + destructor Destroy; override; + + function IsNodeVisible(aNode: PVirtualNode): Boolean; + procedure InitFilter; + procedure ApplyFilter(bSaveInfo: Boolean = true); + procedure Show(aColumnIndex: TColumnIndex; aInvalidateVST: Boolean = false); + procedure Hide(aFocusToVST, aInvalidateVST: Boolean); + + procedure Clear; override; + public + property Dict: TFilterDict read FilterDict_; + property Lines: TVtFilterLines read FilterLines_ write FilterLines_; + property ApplyLevel: TVtFilterApplyLevel read FilterApplyLevel_ write FilterApplyLevel_; + property NotEditColumns: TBlockedColumns read NotEditColumns_; + property NotFiltedColumns: TBlockedColumns read NotFiltedColumns_; + property RedirectColumns: TRedirectColumns read RedirectColumns_; + + property Use_Ctrl_F: Boolean read bUse_Ctrl_F_ write bUse_Ctrl_F_; + property ForceInvisible: Boolean write bForceInvisible_; + + property OnCheckNodeVisible: TCheckNodeVisibleEvent read EvOnCheckNodeVisible_ write EvOnCheckNodeVisible_; + property OnCheckForceInvisibleEvent: TCheckForceInvisibleEvent read EvOnCheckForceInvisible_ write EvOnCheckForceInvisible_; + property OnAfterFilterEvent: TAfterFilterEvent read EvOnAfterFilter_ write EvOnAfterFilter_; + end; + + TVirtualStringTreeHelper = class helper for TBaseVirtualTree + public + function GetFilterEditCtrl: TVtFilterEdit; + function CreateFilterEdit: TVtFilterEdit; + procedure DestroyFilterEdit; + end; + + +implementation + +uses + System.IniFiles, + Tocsg.Safe, + Tocsg.PCRE, Tocsg.Strings, Tocsg.Path, VirtualTrees.Types; + +resourcestring + RS_Q_Clear = '해당 컬럼의 검색 기록을 초기화 하시겠습니까?'; + + +{ TFilterDict } + +constructor TFilterDict.Create; +begin + fInnerDict:= TDictionary <Integer, String>.Create; + +end; + +destructor TFilterDict.Destroy; +begin + FreeAndNil(fInnerDict); + + inherited; +end; + +function TFilterDict.GetCount: Integer; +begin + Result := fInnerDict.Count; +end; + +function TFilterDict.GetFilter(Index: Integer): String; +begin + if fInnerDict.ContainsKey(Index) then + Result := fInnerDict[Index] + else + Result := ''; +end; + +procedure TFilterDict.SetFilter(Index: Integer; const Value: String); +begin + if fInnerDict.ContainsKey(Index) then + begin + if (Value.Length = 0) or (Value = '*') then + fInnerDict.Remove(Index) + else + fInnerDict[Index] := Value; + end else + if (Value.Length > 0) and (Value <> '*') then + begin + fInnerDict.Add(Index, Value); + end; +end; + +procedure TFilterDict.Assign(aFilterDict: TFilterDict); +var + Item: TPair<Integer, String>; +begin + fInnerDict.Clear; + + for Item in aFilterDict.fInnerDict do + fInnerDict.Add(Item.Key, Item.Value); +end; + +{ TBlockedColumns } + +function TBlockedColumns.CheckBlocked(aColumnIndex: TColumnIndex): Boolean; +begin + Result := ContainsKey(aColumnIndex) and Items[aColumnIndex]; +end; + + +{ TRedirectColumns } + +function TRedirectColumns.CheckRedirect(aColumnIndex: TColumnIndex): TColumnIndex; +begin + if ContainsKey(aColumnIndex) then + Result := Items[aColumnIndex] + else + Result := aColumnIndex; +end; + + +{ TVtFilterEdit } + +type + TVirtualTreeDesc = class (TBaseVirtualTree); + TVirtualTreeColumnsDesc = class (TVirtualTreeColumns); + +constructor TVtFilterEdit.Create(aOwner: TComponent; aVST: TVirtualStringTree); +begin + inherited Create(aOwner); + + bForceInvisible_ := false; + FilterDict_:= TFilterDict.Create; + NotEditColumns_:= TBlockedColumns.Create; + NotFiltedColumns_ := TBlockedColumns.Create; + RedirectColumns_:= TRedirectColumns.Create; + + bUse_Ctrl_F_ := true; + + VT_ := aVST; + Visible := False; +{$IFDEF USE_VTFILTER_COMBOBOX} + sHighOwnerName_ := ''; + OnKeyPress := OnCbKeyPress; + OnKeyUp := OnCbKeyUp; + AutoComplete := false; +{$ELSE} + BorderStyle := bsSingle; +{$ENDIF} + AutoSize := False; + + OrgVSTWndProc_ := VT_.WindowProc; + VT_.WindowProc := VSTWndProc; + + FilterBitmap_:= TBitmap.Create; + FilterBitmap_.PixelFormat := pf32Bit; +end; + +destructor TVtFilterEdit.Destroy; +begin + VT_.WindowProc := OrgVSTWndProc_; + + FreeAndNil(FilterBitmap_); + FreeAndNil(FilterDict_); + FreeAndNil(NotEditColumns_); + FreeAndNil(NotFiltedColumns_); + FreeAndNil(RedirectColumns_); + + inherited; +end; + +procedure TVtFilterEdit.CMExit(var Message: TMessage); +begin + if FilterDict_[ColumnIndex_] <> Trim(Text) then + begin + //WriteLn('필터 수정: ', Text); + FilterDict_[ColumnIndex_] := Trim(Text); + + + //if Use_Ctrl_F then VT_.FocusedColumn := ColumnIndex_; + ApplyFilter(); + + Hide(true, false); + end else + Hide(true, true); +end; + +procedure TVtFilterEdit.CMRelease(var Message: TMessage); +begin + Free; +end; + +{$IFDEF USE_VTFILTER_COMBOBOX} +function GetOwnerFormName(aWinControl: TWinControl): String; +var + OwnerCtrl: TComponent; +begin + Result := ''; + + OwnerCtrl := aWinControl.Owner; + while OwnerCtrl <> nil do + begin + if (OwnerCtrl is TForm) or + (OwnerCtrl is TFrame) then + begin + Result := OwnerCtrl.ClassName; + exit; + end; + OwnerCtrl := OwnerCtrl.Owner; + end; +end; + +procedure TVtFilterEdit.SaveComboBoxItems; + + function GetDivStrings(aStrings: TStrings): String; + var + i: Integer; + begin + Result := ''; + for i := 0 to aStrings.Count - 1 do + Result := Result + aStrings[i] + '§'; + end; + +var + ini: TIniFile; + nIdx: Integer; + sTemp: String; + i: Integer; +begin + if (ColumnIndex_ = -1) or + (ColumnIndex_ >= VT_.Header.Columns.Count) then + exit; + + if sHighOwnerName_ = '' then + begin + sHighOwnerName_ := GetOwnerFormName(VT_); + if sHighOwnerName_ = '' then + exit; + sHighOwnerName_ := sHighOwnerName_ + '.' + VT_.Name; + end; + + sTemp := Text; + nIdx := Items.IndexOf(sTemp); + if nIdx <> -1 then + Items.Delete(nIdx); + Items.Insert(0, sTemp); +// 검색 기록 갯수 제한 19_1205 09:43:48 sunk + if Items.Count > MAX_COMBO_ITEM then + for i := Items.Count downto 0 do + begin + Items.Delete(i); + if Items.Count <= MAX_COMBO_ITEM then + break; + end; + ItemIndex := 0; + + Guard(ini, TIniFile.Create(CutFileExt(GetRunExePath) + 'Filters.ini')); + ini.WriteString(sHighOwnerName_, Format('COL%d', [ColumnIndex_]), GetDivStrings(Items)); +end; + +procedure TVtFilterEdit.LoadComboBoxItems; +var + sTemp: String; + ini: TIniFile; +begin + Items.Clear; + if (ColumnIndex_ = -1) or + (ColumnIndex_ >= VT_.Header.Columns.Count) then + exit; + + if sHighOwnerName_ = '' then + begin + sHighOwnerName_ := GetOwnerFormName(VT_); + if sHighOwnerName_ = '' then + exit; + sHighOwnerName_ := sHighOwnerName_ + '.' + VT_.Name; + end; + + sTemp := CutFileExt(GetRunExePath) + 'Filters.ini'; + if FileExists(sTemp) then + begin + Guard(ini, TIniFile.Create(sTemp)); + sTemp := ini.ReadString(sHighOwnerName_, Format('COL%d', [ColumnIndex_]), ''); + SplitString(sTemp, '§', Items); + end; +end; + +// 콤보박스에서는 서브클래싱이 안먹혀서 이렇게 처리 19_1204 15:49:31 sunk +procedure TVtFilterEdit.OnCbKeyPress(Sender: TObject; var Key: Char); +var + Run: TColumnIndex; + + function GetLeftRun: TColumnIndex; + begin + Result := VT_.Header.Columns.GetPreviousColumn(ColumnIndex_); + + while (Result >= 0) and NotEditColumns.CheckBlocked(Result) do + Result := VT_.Header.Columns.GetPreviousColumn(Result); + + //WriteLn(', 이전컬럼 ', Result); + + if Result < 0 then + begin + Result := TVirtualTreeColumnsDesc(VT_.Header.Columns).PositionToIndex[VT_.Header.Columns.Count-1]; + + while (Result >= 0) and NotEditColumns.CheckBlocked(Result) do + Result := VT_.Header.Columns.GetPreviousColumn(Result); + + //WriteLn('되돌이컬럼 : ', Result); + end; + end; + + function GetRightRun: TColumnIndex; + begin + Result := VT_.Header.Columns.GetNextColumn(ColumnIndex_); + + while (Result >= 0) and NotEditColumns.CheckBlocked(Result) do + Result := VT_.Header.Columns.GetNextColumn(Result); + + //WriteLn(', 다음컬럼 ', Run); + + if Result < 0 then + begin + Result := TVirtualTreeColumnsDesc(VT_.Header.Columns).PositionToIndex[0]; + + while (Result >= 0) and NotEditColumns.CheckBlocked(Result) do + Result := VT_.Header.Columns.GetNextColumn(Result); + + //WriteLn('되돌이컬럼 : ', Run); + end; + end; + +begin + case Integer(Key) of + VK_RETURN : + begin + Key := #0; + if FilterDict_[ColumnIndex_] <> Trim(Text) then + begin + //WriteLn('필터 수정: ', Text); + FilterDict_[ColumnIndex_] := Trim(Text); + //if Use_Ctrl_F then VT_.FocusedColumn := ColumnIndex_; + ApplyFilter(); + + Hide(true, false); + end else + Hide(true, true); + end; + + VK_TAB : + begin + //Write('탭키눌림 현재 컬럼 ', ColumnIndex_); + + if GetKeyState(VK_SHIFT) < 0 then + Run := GetLeftRun + else + Run := GetRightRun; + + Perform(CM_EXIT, 0, 0); + + if Run = ColumnIndex_ then + begin + + end else + begin + Show(Run); + end; + end; + + VK_ESCAPE : + begin + Hide(true, true); + end; + end; +end; + +procedure TVtFilterEdit.OnCbKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + case Key of + VK_DELETE : + begin +// if (ssCtrl in Shift) and (ssCtrl in Shift) then // 음... 이렇게 했는데 Ctrl + Del 만으로도 된다...머지 19_1217 15:31:29 sunk + if ssCtrl in Shift then // 그래서 그냥 Ctrl + Del 로만으로 변경 19_1217 15:31:59 sunk + begin + if MessageBox(Handle, PChar(RS_Q_Clear), 'Clear', + MB_ICONQUESTION or MB_YESNO) = IDNO then exit; + + Items.Clear; + SaveComboBoxItems; + end; + end; + end; +end; +{$ELSE} +procedure TVtFilterEdit.WMChar(var Message: TWMChar); +begin +// 엔터 누르면 띠링~ 소리 안나오도록 보완 17_1229 10:26:32 sunk + if Message.CharCode = VK_RETURN then + exit + else + if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then + inherited; +end; + + +procedure TVtFilterEdit.WMKeyDown(var Message: TWMKeyDown); +var + Run: TColumnIndex; + + function GetLeftRun: TColumnIndex; + begin + Result := VT_.Header.Columns.GetPreviousColumn(ColumnIndex_); + + while (Result >= 0) and NotEditColumns.CheckBlocked(Result) do + Result := VT_.Header.Columns.GetPreviousColumn(Result); + + //WriteLn(', 이전컬럼 ', Result); + + if Result < 0 then + begin + Result := TVirtualTreeColumnsDesc(VT_.Header.Columns).PositionToIndex[VT_.Header.Columns.Count-1]; + + while (Result >= 0) and NotEditColumns.CheckBlocked(Result) do + Result := VT_.Header.Columns.GetPreviousColumn(Result); + + //WriteLn('되돌이컬럼 : ', Result); + end; + end; + + function GetRightRun: TColumnIndex; + begin + Result := VT_.Header.Columns.GetNextColumn(ColumnIndex_); + + while (Result >= 0) and NotEditColumns.CheckBlocked(Result) do + Result := VT_.Header.Columns.GetNextColumn(Result); + + //WriteLn(', 다음컬럼 ', Run); + + if Result < 0 then + begin + Result := TVirtualTreeColumnsDesc(VT_.Header.Columns).PositionToIndex[0]; + + while (Result >= 0) and NotEditColumns.CheckBlocked(Result) do + Result := VT_.Header.Columns.GetNextColumn(Result); + + //WriteLn('되돌이컬럼 : ', Run); + end; + end; + +begin + case Message.CharCode of + VK_TAB: + begin + //Write('탭키눌림 현재 컬럼 ', ColumnIndex_); + + if GetKeyState(VK_SHIFT) < 0 then + Run := GetLeftRun + else + Run := GetRightRun; + + Perform(CM_EXIT, 0, 0); + + if Run = ColumnIndex_ then + begin + + end else + begin + Show(Run); + end; + end; + + { + VK_LEFT: + if //(Self.SelLength = 0) and + (Self.SelStart = 0) then + begin + Run := GetLeftRun; + Perform(CM_EXIT, 0, 0); + + if Run = ColumnIndex_ then + begin + + end else + begin + Show(Run); + end; + inherited; + end else + inherited; + + VK_RIGHT: + if //(Self.SelLength = 0) and + (Self.SelStart = Length(Self.Text)) then + begin + Run := GetRightRun; + Perform(CM_EXIT, 0, 0); + + if Run = ColumnIndex_ then + begin + + end else + begin + Show(Run); + end; + inherited; + end else + inherited; + } + + VK_ESCAPE: + begin + Hide(true, true); + end; + + VK_RETURN: + begin + if FilterDict_[ColumnIndex_] <> Trim(Text) then + begin + //WriteLn('필터 수정: ', Text); + FilterDict_[ColumnIndex_] := Trim(Text); + //if Use_Ctrl_F then VT_.FocusedColumn := ColumnIndex_; + ApplyFilter(); + + Hide(true, false); + end else + Hide(true, true); + end; + else + inherited; + end; + + case Message.CharCode of + VK_LEFT: + if (Length(Self.Text) = 0) then + //(Length(Self.Text) = Self.SelLength) then + //(Self.SelStart = 0) then + begin + Run := GetLeftRun; + Perform(CM_EXIT, 0, 0); + + if Run = ColumnIndex_ then + begin + + end else + begin + Show(Run); + end; + end; + + VK_RIGHT: + if (Length(Self.Text) = 0) then + //(Length(Self.Text) = Self.SelLength) then + //(Self.SelStart = Length(Self.Text)) then + begin + Run := GetRightRun; + Perform(CM_EXIT, 0, 0); + + if Run = ColumnIndex_ then + begin + + end else + begin + Show(Run); + end; + end; + end; + +end; +{$ENDIF} + +procedure TVtFilterEdit.WMGetDlgCode(var Message: TWMGetDlgCode); +begin + inherited; + + Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS; +end; + +function MatchFilterStr(sFilterStr, sStr: String): Boolean; +var + FStrList: TStringList; + i, nFind: Integer; + sFindStr: String; + c: Char; +Label + LB_DoFind; +begin + Result := false; + if sStr.Length = 0 then + exit; + + if Pos('#RX:', sFilterStr) = 1 then + begin + // 정규 표현식으로 처리 + Delete(sFilterStr, 1, 4); + if sFilterStr.Length = 0 then + exit; + + Result := TTgPcre.GetMatchValues(sStr, sFilterStr, sFindStr) > 0; + end else begin + Guard(FStrList, TStringList.Create); + SplitString(sFilterStr, ';', FStrList); + + nFind := 0; + FStrList.Text := StringReplace(FStrList.Text, '\SCL', ';', [rfReplaceAll]); + for i := 0 to FStrList.Count - 1 do + begin + sFindStr := FStrList[i]; + c := sFindStr[1]; + case c of + '!', '&' : + begin + if sFindStr.Length = 1 then + goto LB_DoFind; + Delete(sFindStr, 1, 1); + if Pos(sFindStr, sStr) > 0 then + begin + if c = '!' then exit + else Inc(nFind); + end else + begin + if c = '!' then Inc(nFind) + else exit; + end; + end; + else + begin + LB_DoFind : + if Pos(sFindStr, sStr) > 0 then + Inc(nFind); + end; + end; + end; + Result := nFind > 0; + end; +end; + +function TVtFilterEdit.IsNodeVisible(aNode: PVirtualNode): Boolean; +var + ContinueGetText: Boolean; + i: Integer; + ColumnIndex: TColumnIndex; + + FilterStr, + ColumnStr: String; + +begin + Result := true; + ContinueGetText := true; + + // 노드 체크 이벤트가 정의된 경우, 여기서 false라면 필터검사는 생략. + if Assigned(EvOnCheckNodeVisible_) then + begin + Result := EvOnCheckNodeVisible_(VT_, aNode, ContinueGetText); + if not Result then Exit; + if not ContinueGetText then Exit; + end; + + if FilterDict_.Count = 0 then Exit; + + for i := 0 to VT_.Header.Columns.Count-1 do + if not NotEditColumns.CheckBlocked(i) and + not NotFiltedColumns.CheckBlocked(i) then + begin + //RedirectColumns + ColumnIndex := RedirectColumns.CheckRedirect(i); + + FilterStr := UpperCase(FilterDict_[i]); + if FilterStr.Length = 0 then Continue; + + VT_.OnGetText(VT_, aNode, ColumnIndex, ttNormal, ColumnStr); + ColumnStr := UpperCase(ColumnStr); + //if ColumnStr.Length = 0 then Continue; + + // 값이 비어 있는 경우만 볼수 있는 필터 추가 17_1229 10:09:44 sunk + if ((FilterStr = '#NULL') or (FilterStr = '#NIL')) and + (ColumnStr.Length = 0) then continue; + + // 값이 비어있으면 보이지 않도록 수정 17_1229 09:57:31 sunk + if not MatchFilterStr(FilterStr, ColumnStr) then + begin + Result := false; + Exit; + end; + end; +end; + +procedure TVtFilterEdit.InitFilter; +var + Node: PVirtualNode; + ContinueGetText: Boolean; + + + procedure SubNodeProc(aNode: PVirtualNode); + var + SubNode: PVirtualNode; + begin + SubNode := VT_.GetFirstChild(aNode); + while Assigned(SubNode) do + begin + //VT_.IsVisible[SubNode] := IsNodeVisible(SubNode); + //SubNode := VT_.GetNextSibling(SubNode); + if Assigned(EvOnCheckNodeVisible_) then + VT_.IsVisible[SubNode] := EvOnCheckNodeVisible_(VT_, SubNode, ContinueGetText) + else + VT_.IsVisible[SubNode] := true; + + SubNodeProc(SubNode); + + SubNode := VT_.GetNextSibling(SubNode); + end; + end; + + +begin + Hide(false, false); + FilterDict_.fInnerDict.Clear; + + // 필터링된 노드 모두 표시. + VT_.BeginUpdate; + try + // VST 전체 노드를 루프를 돌면서.. + Node := VT_.GetFirst(); + while Assigned(Node) do + begin + // 노드 체크 이벤트가 정의된 경우 + if Assigned(EvOnCheckNodeVisible_) then + VT_.IsVisible[Node] := EvOnCheckNodeVisible_(VT_, Node, ContinueGetText) + else + VT_.IsVisible[Node] := true; + + if ApplyLevel = flvAll then SubNodeProc(Node); + + Node := VT_.GetNextSibling(Node); + end; + finally + VT_.EndUpdate; + end; + + VT_.Invalidate; +end; + + +procedure TVtFilterEdit.ApplyFilter(bSaveInfo: Boolean = true); + +// 추가 18_0416 10:05:45 sunk + function CheckInvisibleSubAll(aNode: PVirtualNode): Boolean; + var + pSubN: PVirtualNode; + begin + Result := true; + + pSubN := aNode.FirstChild; + while pSubN <> nil do + begin + if VT_.IsVisible[pSubN] then + begin + Result := false; + exit; + end; + + pSubN := pSubN.NextSibling; + end; + end; + + procedure SubNodeProc(aNode: PVirtualNode); + var + bIgnoreS, + IsVisible: Boolean; + SubNode: PVirtualNode; + begin + SubNode := VT_.GetFirstChild(aNode); + while Assigned(SubNode) do + begin + IsVisible := IsNodeVisible(SubNode); + VT_.IsVisible[SubNode] := IsVisible; + + if IsVisible then + begin + SubNodeProc(SubNode); + // 하위가 모두 숨겨져 있다면 자신도 숨길지 18_0416 10:05:45 sunk + if bForceInvisible_ then + begin + bIgnoreS := false; + if Assigned(EvOnCheckForceInvisible_) then + begin + // 필터 체크 대상인지 확인해서 대상이라면 제외 시켜줘야 한다. 18_0416 10:30:01 sunk + EvOnCheckForceInvisible_(VT_, SubNode, bIgnoreS); + end; + + if not bIgnoreS then + VT_.IsVisible[SubNode] := not CheckInvisibleSubAll(SubNode); + end; + end; + + SubNode := VT_.GetNextSibling(SubNode); + end; + end; + +var + Node: PVirtualNode; + bIgnore: Boolean; + +begin + if not Assigned(VT_.OnGetText) then + exit; + + if bSaveInfo then + begin + {$IFDEF USE_VTFILTER_COMBOBOX} + SaveComboBoxItems; + {$ENDIF} + end; + + VT_.BeginUpdate; + try + with VT_.Header do + begin + if SortColumn <> -1 then + begin + Columns[SortColumn].Options := Columns[SortColumn].Options + [coParentColor]; + SortColumn := -1; + end; + end; + + // VST 전체 노드를 루프를 돌면서.. + Node := VT_.GetFirst(); + while Assigned(Node) do + begin + VT_.IsVisible[Node] := IsNodeVisible(Node); + + // 서브노드도 처리 + if ApplyLevel = flvAll then + begin + SubNodeProc(Node); + // 하위가 모두 숨겨져 있다면 자신도 숨길지 18_0416 10:05:45 sunk + if bForceInvisible_ then + begin + bIgnore := false; + if Assigned(EvOnCheckForceInvisible_) then + begin + // 필터 체크 대상인지 확인해서 대상이라면 제외 시켜줘야 한다. 18_0416 10:30:01 sunk + EvOnCheckForceInvisible_(VT_, Node, bIgnore); + end; + + if not bIgnore then + VT_.IsVisible[Node] := not CheckInvisibleSubAll(Node); + end; + end; + + Node := VT_.GetNextSibling(Node); + end; + + if Assigned(EvOnAfterFilter_) then + EvOnAfterFilter_(VT_); + finally + VT_.EndUpdate; + end; +end; + + +procedure TVtFilterEdit.Show(aColumnIndex: TColumnIndex; aInvalidateVST: Boolean); +var + //TargetCanvas: TCanvas; + OffsetPos: TPoint; + TargetRect: TRect; +begin + Hide(false, aInvalidateVST); + + if aColumnIndex < 0 then Exit; + if aColumnIndex >= VT_.Header.Columns.Count then Exit; + + if NotEditColumns.CheckBlocked(aColumnIndex) then Exit; + + ColumnIndex_ := aColumnIndex; + VT_.FocusedColumn := ColumnIndex_; + + TargetRect := TVirtualTreeDesc(VT_).HeaderRect; + OffsetPos := TargetRect.TopLeft; + + VT_.Header.Columns.GetColumnBounds(aColumnIndex, TargetRect.Left, TargetRect.Right); + + if TargetRect.Left < 0 then + begin + VT_.OffsetX := VT_.OffsetX - TargetRect.Left; + OffsetRect(TargetRect, -TargetRect.Left, 0); + //OffsetRect(TargetRect, VT_.OffsetX, 0); + end else + if TargetRect.Left + 30 > TVirtualTreeDesc(VT_).HeaderRect.Right then + begin + //VT_.OffsetX := VT_.OffsetX - (TargetRect.Left + TargetRect.Width); + //VT_.OffsetX := VT_.OffsetX - TargetRect.Width; + //VT_.OffsetX := -TargetRect.Right; + VT_.OffsetX := + VT_.OffsetX - + ( + TargetRect.Left - + TVirtualTreeDesc(VT_).HeaderRect.Right + + TargetRect.Width + ); + + //VT_.Header.Columns.GetColumnBounds(aColumnIndex, TargetRect.Left, TargetRect.Right); + OffsetRect( + TargetRect, + -( + TargetRect.Left - + TVirtualTreeDesc(VT_).HeaderRect.Right + + TargetRect.Width + ), + 0 + ); + end; + + if (TargetRect.Right > TVirtualTreeDesc(VT_).HeaderRect.Right) then + TargetRect.Right := TVirtualTreeDesc(VT_).HeaderRect.Right; + + if IsRectEmpty(TargetRect) then Exit; + + OffsetRect(TargetRect, VT_.Left, VT_.Top + VT_.Header.Height); + + Self.Parent := VT_.Parent; + Self.Font.Assign(VT_.Header.Font); + Self.Font.Style := [fsBold]; + with TargetRect do + begin + //fFilterEdit.Height := Height - 2; + Self.Left := Left + 5 + OffsetPos.X; + Self.Width := Width - 10; + Self.Top := + Top + + (Width div 2 - Self.Width div 2) - + OffsetPos.Y - 1; + //fFilterEdit.SetBounds(Left, Top, Width, Height); + + end; + //Self.Text := 'Filter - ' + IntToStr(Run); +{$IFDEF USE_VTFILTER_COMBOBOX} + LoadComboBoxItems; +{$ENDIF} + Self.Text := FilterDict_[aColumnIndex]; + + Self.Visible := true; + Self.SetFocus; + + //ColumnIndex_ := aColumnIndex; +end; + +procedure TVtFilterEdit.Hide(aFocusToVST, aInvalidateVST: Boolean); +begin + if not Visible then Exit; + Visible := false; + + if aFocusToVST then VT_.SetFocus; + if aInvalidateVST then VT_.Invalidate; +end; + +procedure TVtFilterEdit.Clear; +begin + //inherited; + InitFilter; // 음... 결국 이걸 쓰면 되긴했는데... 이왕 이렇게 된거 범용적으로 쓰이는 함수에 연결... 17_1229 10:32:25 sunk +end; + + +procedure TVtFilterEdit.VSTWndProc(var Message: TMessage); +var + DC: HDC; + MPos: TPoint; + + FilterRect: TRect; + //TargetCanvas: TCanvas; + TargetRect: TRect; + DrawTextRect: TRect; + Run: TColumnIndex; + Text: String; +begin + case Message.Msg of + //WM_ERASEBKGND, + WM_PAINT: + begin + FilterRect := TVirtualTreeDesc(VT_).HeaderRect; + OffsetRect(FilterRect, 0, VT_.Header.Height); + + FilterBitmap_.SetSize(FilterRect.Width, FilterRect.Height); + + with FilterBitmap_.Canvas do + begin + Font.Assign(VT_.Header.Font); + Font.Style := [fsBold]; + //Brush.Color := clYellow; + //Brush.Color := clBtnFace; + //Brush.Color := clBtnShadow; + //Brush.Color := clSilver; + //Brush.Color := RGB($CF, $CF, $CF); + Brush.Style := bsSolid; + FillRect(Bounds(0, 0, FilterRect.Width, FilterRect.Height)); + //Brush.Style := bsClear; + + Pen.Color := VT_.Colors.GridLineColor; + + // 윗선 그리기 + if flTop in FilterLines_ then + begin + MoveTo(0, 0); + LineTo(FilterRect.Width, 0); + end; + // 아래선 그리기 + if flBottom in FilterLines_ then + begin + MoveTo(0, FilterRect.Height-1); + LineTo(FilterRect.Width, FilterRect.Height-1); + end; + + TargetRect := Bounds(0 - VT_.OffsetX, 0, 0, FilterRect.Height); + + Run := VT_.Header.Columns.ColumnFromPosition(TargetRect.TopLeft, false); + if Run >= 0 then + VT_.Header.Columns.GetColumnBounds(Run, TargetRect.Left, TargetRect.Right); + + while (Run >= 0) and (TargetRect.Left < VT_.ClientWidth) do + begin + if not NotEditColumns.CheckBlocked(Run) then + begin + //Text := 'Filter - ' + IntToStr(Run); + Text := FilterDict_[Run]; + if Text.Length = 0 then Text := '*'; + + //WriteLn(Run, ': ', TargetRect.Left, ', ', TargetRect.Right); + + //ClipCanvas(fFilterBitmap.Canvas, TargetRect); + + DrawTextRect := TargetRect; + InflateRect(DrawTextRect, -8, 0); + if TextWidth(Text) > DrawTextRect.Width then + Text := ShortenString(Handle, Text, DrawTextRect.Width); + + Winapi.Windows.DrawTextW( + Handle, + PWideChar(Text), + Length(Text), + DrawTextRect, + DT_LEFT or + DT_VCENTER or DT_NOPREFIX or DT_SINGLELINE + ); + end; + + // 우측선 그리기 + if flRight in FilterLines_ then + begin + MoveTo(TargetRect.Right-1, 0); + LineTo(TargetRect.Right-1, TargetRect.Bottom); + end; + Inc(TargetRect.Left, VT_.Header.Columns[Run].Width); + + // 숨겨진 컬럼이 있을경우 밀려서 그려주기 때문에 아래처럼 보완. 18_0102 11:23:24 sunk + Run := VT_.Header.Columns.GetNextVisibleColumn(Run); + + if Run >= 0 then + TargetRect.Right := TargetRect.Left + VT_.Header.Columns[Run].Width; + end; + + DC := GetDCEx(VT_.Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE); + try + BitBlt( + DC, + FilterRect.Left, FilterRect.Top, + FilterBitmap_.Width, + FilterBitmap_.Height, + Handle, + 0, 0, SRCCOPY); + finally + ReleaseDC(VT_.Handle, DC); + end; + + FilterBitmap_.FreeImage; + end; + end; + end; + + OrgVSTWndProc_(Message); + + case Message.Msg of + WM_NCCALCSIZE: + with TWMNCCalcSize(Message) do + begin + // 헤더 높이만큼 필터영역 확보. + Inc( + CalcSize_Params^.rgrc[0].Top, + VT_.Header.Height + ); + end; + + WM_NCHITTEST: + //if Message.Result <> HTCLIENT then + with TWMNCHitTest(Message) do + if Message.Result = Winapi.Windows.HTNOWHERE then + begin + MPos := VT_.ScreenToClient(SmallPointToPoint(Pos)); + if MPos.Y <= 0 then + begin + //WriteLn(GetTickCount, ': ' , Result, ', ', MPos.x, ', ', MPos.y ); + Result := HTBORDER; + end; + end; + + WM_NCLBUTTONDOWN, + WM_NCLBUTTONDBLCLK: + with TWMNCHitMessage(Message) do + begin + MPos := VT_.ScreenToClient(Point(XCursor, YCursor + VT_.Header.Height)); + //Inc(MPos.Y, VST.Header.Height); + //WriteLn('NC 다운 또는 더블클릭 ', MPos.X, ', ', MPos.Y); + //ReleaseCapture;//SetCapture(VST.Handle); + FilterRect := TVirtualTreeDesc(VT_).HeaderRect; + //OffsetRect(FilterRect, 0, -VST.Header.Height); + + Hide(false, false); + + if PtInRect(FilterRect, MPos) then + begin + //VT_.SetFocus; + Self.Visible := false; + + //Write(' 필터 영역 '); + Run := VT_.Header.Columns.ColumnFromPosition(Point(MPos.X - VT_.OffsetX, 0), false); + //WriteLn(Run); + + if Run >= 0 then + begin + ReleaseCapture; + Show(Run); + end; + + VT_.Invalidate; + end; + end; + + { + WM_NCLBUTTONUP: + with TWMNCHitMessage(Message) do + begin + WriteLn('NC 업'); + //ReleaseCapture; + end; + } + + WM_KEYDOWN: + with TWMKeyDown(Message) do + case CharCode of + Ord('F'): + if Use_Ctrl_F then + if GetKeyState(VK_CONTROL) < 0 then + if not NotEditColumns.CheckBlocked(VT_.FocusedColumn) then + begin + //WriteLn('Ctrl+F. 필터단축키 ', VT_.FocusedColumn); + Show(VT_.FocusedColumn); + end; + end; + end; +end; + +{ TVirtualStringTreeHelper } + +function TVirtualStringTreeHelper.GetFilterEditCtrl: TVtFilterEdit; +var + i: Integer; +begin + for i := 0 to ComponentCount - 1 do + if Components[i] is TVtFilterEdit then + begin + Result := TVtFilterEdit(Components[i]); + exit; + end; + Result := nil; +end; + +function TVirtualStringTreeHelper.CreateFilterEdit: TVtFilterEdit; +begin + if (Self is TVirtualStringTree) and (GetFilterEditCtrl = nil) then + begin + Result := TVtFilterEdit.Create(Self, TVirtualStringTree(Self)); + Result.Lines := [flBottom, flRight]; + Result.NotEditColumns.Add(0, true); + + if TVirtualStringTree(Self).DefaultNodeHeight = 18 then + TVirtualStringTree(Self).Header.Height := 24; + end else + Result := nil; +end; + +procedure TVirtualStringTreeHelper.DestroyFilterEdit; +var + VtFilterEdit: TVtFilterEdit; +begin + if Self is TVirtualStringTree then + begin + VtFilterEdit := GetFilterEditCtrl; + if VtFilterEdit <> nil then + begin + VtFilterEdit.InitFilter; // 수동으로 해제 시 필터링된 목록 초기화(Clear) 추가 18_0102 09:54:22 sunk + VtFilterEdit.Free; + TVirtualStringTree(Self).Header.Height := TVirtualStringTree(Self).DefaultNodeHeight; + end; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Other/WindowAnimator.pas b/Tocsg.Lib/VCL/Other/WindowAnimator.pas new file mode 100644 index 00000000..d44713b1 --- /dev/null +++ b/Tocsg.Lib/VCL/Other/WindowAnimator.pas @@ -0,0 +1,209 @@ +unit WindowAnimator; + +interface + +uses + SysUtils, Windows, Types, Classes, Vcl.Forms, Vcl.ExtCtrls; + +type + TWindowAnimator = class(TComponent) + strict private + type + TAxis = (axWidth, axHeight, axWidthLeft); + const + DEFAULT_GAMMA = 10; + DEFAULT_DURATION = 1000 {ms}; + FrameCount = 256; + var + FTimer: TTimer; + FGamma: Integer; + FDuration: Integer {ms}; + FFrames: array[0..FrameCount - 1] of Integer; + FAxis: TAxis; + FTarget: Integer; + FAnimStart, + FAnimEnd: TDateTime; + FForm: TCustomForm; + FBeforeProc, FAfterProc: TProc; + procedure TimerProc(Sender: TObject); + procedure Plot(AFrom, ATo: Integer); + procedure Stop; + procedure Animate(ABeforeProc: TProc = nil; AAfterProc: TProc = nil); + procedure DoBegin; + procedure DoFinish; + public + constructor Create(AOwner: TComponent); override; + procedure AnimateWidth(ANewWidth: Integer; ABeforeProc: TProc = nil; AAfterProc: TProc = nil); + procedure AnimateWidthLeft(ANewWidth: Integer; ABeforeProc: TProc = nil; AAfterProc: TProc = nil); // 왼쪽으로 크기 늘어나게 추가 22_0427 23:16:35 kku + procedure AnimateHeight(ANewHeight: Integer; ABeforeProc: TProc = nil; AAfterProc: TProc = nil); + published + property Gamma: Integer read FGamma write FGamma default DEFAULT_GAMMA; + property Duration {ms}: Integer read FDuration write FDuration default DEFAULT_DURATION; + end; + +procedure Register; + +implementation + +uses + Math, DateUtils; + +procedure Register; +begin + RegisterComponents('Rejbrand 2020', [TWindowAnimator]); +end; + +{ TWindowAnimator } + +procedure TWindowAnimator.Animate(ABeforeProc, AAfterProc: TProc); +begin + + if FForm = nil then + Exit; + + FBeforeProc := ABeforeProc; + FAfterProc := AAfterProc; + + DoBegin; + FAnimStart := Now; + FAnimEnd := IncMilliSecond(FAnimStart, FDuration); + FTimer.Enabled := True; + +end; + +procedure TWindowAnimator.AnimateHeight(ANewHeight: Integer; + ABeforeProc, AAfterProc: TProc); +begin + + if FForm = nil then + Exit; + + Stop; + FAxis := axHeight; + Plot(FForm.Height, ANewHeight); + Animate(ABeforeProc, AAfterProc); + +end; + +procedure TWindowAnimator.AnimateWidth(ANewWidth: Integer; + ABeforeProc, AAfterProc: TProc); +begin + if FForm = nil then + Exit; + + Stop; + FAxis := axWidth; + Plot(FForm.Width, ANewWidth); + Animate(ABeforeProc, AAfterProc); +end; + +procedure TWindowAnimator.AnimateWidthLeft(ANewWidth: Integer; ABeforeProc: TProc = nil; AAfterProc: TProc = nil); +begin + if FForm = nil then + Exit; + + Stop; + FAxis := axWidthLeft; + Plot(FForm.Width, ANewWidth); + Animate(ABeforeProc, AAfterProc); +end; + +constructor TWindowAnimator.Create(AOwner: TComponent); +begin + inherited; + if AOwner is TCustomForm then + FForm := TCustomForm(AOwner); + FGamma := DEFAULT_GAMMA; + FDuration := DEFAULT_DURATION; + FTimer := TTimer.Create(Self); + FTimer.Interval := 30; + FTimer.OnTimer := TimerProc; + FTimer.Enabled := False; +end; + +procedure TWindowAnimator.DoBegin; +begin + if Assigned(FBeforeProc) then + FBeforeProc(); +end; + +procedure TWindowAnimator.DoFinish; +begin + if Assigned(FAfterProc) then + FAfterProc(); +end; + +procedure TWindowAnimator.Plot(AFrom, ATo: Integer); +begin + + FTarget := ATo; + + var F := 1 / ArcTan(Gamma); + + for var i := 0 to High(FFrames) do + begin + var t := i / High(FFrames); // [0, 1] + t := 2*t - 1; // [-1, 1] + t := F*ArcTan(Gamma*t); // sigmoid transformation + t := (t + 1) / 2; // [0, 1] + FFrames[i] := Round((1 - t) * AFrom + t * ATo); + end; + +end; + +procedure TWindowAnimator.Stop; +begin + FTimer.Enabled := False; +end; + +procedure TWindowAnimator.TimerProc(Sender: TObject); +var + nTemp: Integer; +begin + + var LNow := Now; + + if (FForm = nil) or (FAnimEnd = 0.0) then + begin + FTimer.Enabled := False; + Exit; + end; + + if LNow > FAnimEnd then // play it safe + begin + FTimer.Enabled := False; + case FAxis of + axWidth: + FForm.Width := FTarget; + axHeight: + FForm.Height := FTarget; + axWidthLeft: + begin + nTemp := FTarget - FForm.Width; + FForm.Width := FTarget; + FForm.Left := FForm.Left - nTemp; + end; + end; + DoFinish; + Exit; + end; + + var t := MilliSecondsBetween(LNow, FAnimStart) / MilliSecondsBetween(FAnimStart, FAnimEnd); + var i := EnsureRange(Round(t * High(FFrames)), 0, High(FFrames)); + + case FAxis of + axWidth: + FForm.Width := FFrames[i]; + axHeight: + FForm.Height := FFrames[i]; + axWidthLeft: + begin + nTemp := FFrames[i] - FForm.Width; + FForm.Width := FFrames[i]; + FForm.Left := FForm.Left - nTemp; + end; + end; + +end; + +end. diff --git a/Tocsg.Lib/VCL/SQLite3/EM.Old.SQLite3.pas b/Tocsg.Lib/VCL/SQLite3/EM.Old.SQLite3.pas new file mode 100644 index 00000000..218184de --- /dev/null +++ b/Tocsg.Lib/VCL/SQLite3/EM.Old.SQLite3.pas @@ -0,0 +1,653 @@ +unit EM.Old.SQLite3; +{ + Simplified interface for SQLite. + Updated for Sqlite 3 by Tim Anderson (tim@itwriting.com) + Note: NOT COMPLETE for version 3, just minimal functionality + Adapted from file created by Pablo Pissanetzky (pablo@myhtpc.net) + which was based on SQLite.pas by Ben Hochstrasser (bhoc@surfeu.ch) +} +{$IFDEF FPC} + {$MODE DELPHI} + {$H+} (* use AnsiString *) + {$PACKENUM 4} (* use 4-byte enums *) + {$PACKRECORDS C} (* C/C++-compatible record packing *) +{$ELSE} + {$MINENUMSIZE 4} (* use 4-byte enums *) +{$ENDIF} +interface +const +{$IF Defined(MSWINDOWS)} + SQLiteDLL = 'sqlite3.dll'; +{$ELSEIF Defined(DARWIN)} + SQLiteDLL = 'libsqlite3.dylib'; + {$linklib libsqlite3} +{$ELSEIF Defined(UNIX)} + SQLiteDLL = 'sqlite3.so'; +{$IFEND} +// Return values for sqlite3_exec() and sqlite3_step() +const + SQLITE_OK = 0; // Successful result + (* beginning-of-error-codes *) + SQLITE_ERROR = 1; // SQL error or missing database + SQLITE_INTERNAL = 2; // An 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; // (Internal Only) Table or record not found + 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; // Database is empty + SQLITE_SCHEMA = 17; // The database schema changed + SQLITE_TOOBIG = 18; // Too much data for one row of a table + SQLITE_CONSTRAINT = 19; // Abort due to contraint 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; // Auxiliary database format error + SQLITE_RANGE = 25; // 2nd parameter to sqlite3_bind out of range + SQLITE_NOTADB = 26; // File opened that is not a database file + SQLITE_ROW = 100; // sqlite3_step() has another row ready + SQLITE_DONE = 101; // sqlite3_step() has finished executing + SQLITE_INTEGER = 1; + SQLITE_FLOAT = 2; + SQLITE_TEXT = 3; + SQLITE_BLOB = 4; + SQLITE_NULL = 5; + SQLITE_UTF8 = 1; + SQLITE_UTF16 = 2; + SQLITE_UTF16BE = 3; + SQLITE_UTF16LE = 4; + SQLITE_ANY = 5; + SQLITE_STATIC {: TSQLite3Destructor} = Pointer(0); + SQLITE_TRANSIENT {: TSQLite3Destructor} = Pointer(-1); +type + TSQLiteDB = Pointer; + TSQLiteResult = ^PAnsiChar; + TSQLiteStmt = Pointer; +type + PPAnsiCharArray = ^TPAnsiCharArray; + TPAnsiCharArray = array[0 .. (MaxInt div SizeOf(PAnsiChar))-1] of PAnsiChar; + TSQLite3Destructor = procedure(Ptr: Pointer); cdecl; +type + TSQLiteExecCallback = function(UserData: Pointer; NumCols: Integer; ColValues: + PPAnsiCharArray; ColNames: PPAnsiCharArray): Integer; cdecl; + TSQLiteBusyHandlerCallback = function(UserData: Pointer; P2: Integer): Integer; cdecl; + //function prototype for define own collate + TCollateXCompare = function(UserData: Pointer; Buf1Len: Integer; Buf1: Pointer; + Buf2Len: Integer; Buf2: Pointer): Integer; cdecl; + TSQLite3_Open = function(filename: PAnsiChar; var db: TSQLiteDB): Integer; cdecl; + TSQLite3_Close = function(db: TSQLiteDB): Integer; cdecl; + TSQLite3_Exec = function(db: TSQLiteDB; SQLStatement: PAnsiChar; CallbackPtr: TSQLiteExecCallback; UserData: Pointer; var ErrMsg: PAnsiChar): Integer; cdecl; + TSQLite3_Version = function: PAnsiChar; cdecl; + TSQLite3_ErrMsg = function(db: TSQLiteDB): PAnsiChar; cdecl; + TSQLite3_ErrCode = function(db: TSQLiteDB): Integer; cdecl; + TSQlite3_Free = procedure(P: PAnsiChar); cdecl; + TSQLite3_GetTable = function(db: TSQLiteDB; SQLStatement: PAnsiChar; var ResultPtr: TSQLiteResult; var RowCount: Cardinal; var ColCount: Cardinal; var ErrMsg: PAnsiChar): Integer; cdecl; + TSQLite3_FreeTable = procedure(Table: TSQLiteResult); cdecl; + TSQLite3_Complete = function(P: PAnsiChar): Boolean; cdecl; + TSQLite3_LastInsertRowID = function(db: TSQLiteDB): Int64; cdecl; + TSQLite3_Interrupt = procedure(db: TSQLiteDB); cdecl; + TSQLite3_BusyHandler = procedure(db: TSQLiteDB; CallbackPtr: TSQLiteBusyHandlerCallback; UserData: Pointer); cdecl; + TSQLite3_BusyTimeout = procedure(db: TSQLiteDB; TimeOut: Integer); cdecl; + TSQLite3_Changes = function(db: TSQLiteDB): Integer; cdecl; + TSQLite3_TotalChanges = function(db: TSQLiteDB): Integer; cdecl; + TSQLite3_Prepare = function(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: Integer; var hStmt: TSqliteStmt; var pzTail: PAnsiChar): Integer; cdecl; + TSQLite3_Prepare_v2 = function(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: Integer; var hStmt: TSqliteStmt; var pzTail: PAnsiChar): Integer; cdecl; + TSQLite3_ColumnCount = function(hStmt: TSqliteStmt): Integer; cdecl; + TSQLite3_ColumnName = function(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; cdecl; + TSQLite3_ColumnDeclType = function(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; cdecl; + TSQLite3_Step = function(hStmt: TSqliteStmt): Integer; cdecl; + TSQLite3_DataCount = function(hStmt: TSqliteStmt): Integer; cdecl; + TSQLite3_ColumnBlob = function(hStmt: TSqliteStmt; ColNum: Integer): Pointer; cdecl; + TSQLite3_ColumnBytes = function(hStmt: TSqliteStmt; ColNum: Integer): Integer; cdecl; + TSQLite3_ColumnDouble = function(hStmt: TSqliteStmt; ColNum: Integer): Double; cdecl; + TSQLite3_ColumnInt = function(hStmt: TSqliteStmt; ColNum: Integer): Integer; cdecl; + TSQLite3_ColumnText = function(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; cdecl; + TSQLite3_ColumnType = function(hStmt: TSqliteStmt; ColNum: Integer): Integer; cdecl; + TSQLite3_ColumnInt64 = function(hStmt: TSqliteStmt; ColNum: Integer): Int64; cdecl; + TSQLite3_Finalize = function(hStmt: TSqliteStmt): Integer; cdecl; + TSQLite3_Reset = function(hStmt: TSqliteStmt): Integer; cdecl; + Tsqlite3_bind_blob = function(hStmt: TSqliteStmt; ParamNum: Integer; + ptrData: Pointer; numBytes: Integer; ptrDestructor: TSQLite3Destructor): Integer; cdecl; + Tsqlite3_bind_text = function(hStmt: TSqliteStmt; ParamNum: Integer; + Text: PAnsiChar; numBytes: Integer; ptrDestructor: TSQLite3Destructor): Integer; cdecl; + Tsqlite3_bind_double = function(hStmt: TSqliteStmt; ParamNum: Integer; Data: Double): Integer; cdecl; + Tsqlite3_bind_int = function(hStmt: TSqLiteStmt; ParamNum: Integer; Data: Integer): Integer; cdecl; + Tsqlite3_bind_int64 = function(hStmt: TSqliteStmt; ParamNum: Integer; Data: int64): Integer; cdecl; + Tsqlite3_bind_null = function(hStmt: TSqliteStmt; ParamNum: Integer): Integer; cdecl; + Tsqlite3_bind_parameter_index = function(hStmt: TSqliteStmt; zName: PAnsiChar): Integer; cdecl; + Tsqlite3_enable_shared_cache = function(Value: Integer): Integer; cdecl; +//user collate definiton + TSQLite3_create_collation = function(db: TSQLiteDB; Name: PAnsiChar; eTextRep: Integer; + UserData: Pointer; xCompare: TCollateXCompare): Integer; cdecl; + +//function SQLite3_Open(filename: PAnsiChar; var db: TSQLiteDB): Integer; cdecl; external SQLiteDLL name 'sqlite3_open'; +//function SQLite3_Close(db: TSQLiteDB): Integer; cdecl; external SQLiteDLL name 'sqlite3_close'; +//function SQLite3_Exec(db: TSQLiteDB; SQLStatement: PAnsiChar; CallbackPtr: TSQLiteExecCallback; UserData: Pointer; var ErrMsg: PAnsiChar): Integer; cdecl; external SQLiteDLL name 'sqlite3_exec'; +//function SQLite3_Version(): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_libversion'; +//function SQLite3_ErrMsg(db: TSQLiteDB): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_errmsg'; +//function SQLite3_ErrCode(db: TSQLiteDB): Integer; cdecl; external SQLiteDLL name 'sqlite3_errcode'; +//procedure SQlite3_Free(P: PAnsiChar); cdecl; external SQLiteDLL name 'sqlite3_free'; +//function SQLite3_GetTable(db: TSQLiteDB; SQLStatement: PAnsiChar; var ResultPtr: TSQLiteResult; var RowCount: Cardinal; var ColCount: Cardinal; var ErrMsg: PAnsiChar): Integer; cdecl; external SQLiteDLL name 'sqlite3_get_table'; +//procedure SQLite3_FreeTable(Table: TSQLiteResult); cdecl; external SQLiteDLL name 'sqlite3_free_table'; +//function SQLite3_Complete(P: PAnsiChar): boolean; cdecl; external SQLiteDLL name 'sqlite3_complete'; +//function SQLite3_LastInsertRowID(db: TSQLiteDB): int64; cdecl; external SQLiteDLL name 'sqlite3_last_insert_rowid'; +//procedure SQLite3_Interrupt(db: TSQLiteDB); cdecl; external SQLiteDLL name 'sqlite3_interrupt'; +//procedure SQLite3_BusyHandler(db: TSQLiteDB; CallbackPtr: TSQLiteBusyHandlerCallback; UserData: Pointer); cdecl; external SQLiteDLL name 'sqlite3_busy_handler'; +//procedure SQLite3_BusyTimeout(db: TSQLiteDB; TimeOut: Integer); cdecl; external SQLiteDLL name 'sqlite3_busy_timeout'; +//function SQLite3_Changes(db: TSQLiteDB): Integer; cdecl; external SQLiteDLL name 'sqlite3_changes'; +//function SQLite3_TotalChanges(db: TSQLiteDB): Integer; cdecl; external SQLiteDLL name 'sqlite3_total_changes'; +//function SQLite3_Prepare(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: Integer; var hStmt: TSqliteStmt; var pzTail: PAnsiChar): Integer; cdecl; external SQLiteDLL name 'sqlite3_prepare'; +//function SQLite3_Prepare_v2(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: Integer; var hStmt: TSqliteStmt; var pzTail: PAnsiChar): Integer; cdecl; external SQLiteDLL name 'sqlite3_prepare_v2'; +//function SQLite3_ColumnCount(hStmt: TSqliteStmt): Integer; cdecl; external SQLiteDLL name 'sqlite3_column_count'; +//function SQLite3_ColumnName(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_column_name'; +//function SQLite3_ColumnDeclType(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_column_decltype'; +//function SQLite3_Step(hStmt: TSqliteStmt): Integer; cdecl; external SQLiteDLL name 'sqlite3_step'; +//function SQLite3_DataCount(hStmt: TSqliteStmt): Integer; cdecl; external SQLiteDLL name 'sqlite3_data_count'; +// +//function SQLite3_ColumnBlob(hStmt: TSqliteStmt; ColNum: Integer): Pointer; cdecl; external SQLiteDLL name 'sqlite3_column_blob'; +//function SQLite3_ColumnBytes(hStmt: TSqliteStmt; ColNum: Integer): Integer; cdecl; external SQLiteDLL name 'sqlite3_column_bytes'; +//function SQLite3_ColumnDouble(hStmt: TSqliteStmt; ColNum: Integer): Double; cdecl; external SQLiteDLL name 'sqlite3_column_double'; +//function SQLite3_ColumnInt(hStmt: TSqliteStmt; ColNum: Integer): Integer; cdecl; external SQLiteDLL name 'sqlite3_column_int'; +//function SQLite3_ColumnText(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_column_text'; +//function SQLite3_ColumnType(hStmt: TSqliteStmt; ColNum: Integer): Integer; cdecl; external SQLiteDLL name 'sqlite3_column_type'; +//function SQLite3_ColumnInt64(hStmt: TSqliteStmt; ColNum: Integer): Int64; cdecl; external SQLiteDLL name 'sqlite3_column_int64'; +//function SQLite3_Finalize(hStmt: TSqliteStmt): Integer; cdecl; external SQLiteDLL name 'sqlite3_finalize'; +//function SQLite3_Reset(hStmt: TSqliteStmt): Integer; cdecl; external SQLiteDLL name 'sqlite3_reset'; +function SQLite3_Open(filename: PAnsiChar; var db: TSQLiteDB): Integer; +function SQLite3_Close(db: TSQLiteDB): Integer; +function SQLite3_Exec(db: TSQLiteDB; SQLStatement: PAnsiChar; CallbackPtr: TSQLiteExecCallback; UserData: Pointer; var ErrMsg: PAnsiChar): Integer; +function SQLite3_Version: PAnsiChar; +function SQLite3_ErrMsg(db: TSQLiteDB): PAnsiChar; +function SQLite3_ErrCode(db: TSQLiteDB): Integer; +procedure SQlite3_Free(P: PAnsiChar); +function SQLite3_GetTable(db: TSQLiteDB; SQLStatement: PAnsiChar; var ResultPtr: TSQLiteResult; var RowCount: Cardinal; var ColCount: Cardinal; var ErrMsg: PAnsiChar): Integer; +procedure SQLite3_FreeTable(Table: TSQLiteResult); +function SQLite3_Complete(P: PAnsiChar): boolean; +function SQLite3_LastInsertRowID(db: TSQLiteDB): int64; +procedure SQLite3_Interrupt(db: TSQLiteDB); +procedure SQLite3_BusyHandler(db: TSQLiteDB; CallbackPtr: TSQLiteBusyHandlerCallback; UserData: Pointer); +procedure SQLite3_BusyTimeout(db: TSQLiteDB; TimeOut: Integer); +function SQLite3_Changes(db: TSQLiteDB): Integer; +function SQLite3_TotalChanges(db: TSQLiteDB): Integer; +function SQLite3_Prepare(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: Integer; var hStmt: TSqliteStmt; var pzTail: PAnsiChar): Integer; +function SQLite3_Prepare_v2(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: Integer; var hStmt: TSqliteStmt; var pzTail: PAnsiChar): Integer; +function SQLite3_ColumnCount(hStmt: TSqliteStmt): Integer; +function SQLite3_ColumnName(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; +function SQLite3_ColumnDeclType(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; +function SQLite3_Step(hStmt: TSqliteStmt): Integer; +function SQLite3_DataCount(hStmt: TSqliteStmt): Integer; +function SQLite3_ColumnBlob(hStmt: TSqliteStmt; ColNum: Integer): Pointer; +function SQLite3_ColumnBytes(hStmt: TSqliteStmt; ColNum: Integer): Integer; +function SQLite3_ColumnDouble(hStmt: TSqliteStmt; ColNum: Integer): Double; +function SQLite3_ColumnInt(hStmt: TSqliteStmt; ColNum: Integer): Integer; +function SQLite3_ColumnText(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; +function SQLite3_ColumnType(hStmt: TSqliteStmt; ColNum: Integer): Integer; +function SQLite3_ColumnInt64(hStmt: TSqliteStmt; ColNum: Integer): Int64; +function SQLite3_Finalize(hStmt: TSqliteStmt): Integer; +function SQLite3_Reset(hStmt: TSqliteStmt): Integer; +// +// In the SQL strings input to sqlite3_prepare() and sqlite3_prepare16(), +// one or more literals can be replace by a wildcard "?" or ":N:" where +// N is an Integer. These value of these wildcard literals can be set +// using the routines listed below. +// +// In every case, the first parameter is a Pointer to the sqlite3_stmt +// structure returned from sqlite3_prepare(). The second parameter is the +// index of the wildcard. The first "?" has an index of 1. ":N:" wildcards +// use the index N. +// +// The fifth parameter to sqlite3_bind_blob(), sqlite3_bind_text(), and +//sqlite3_bind_text16() is a destructor used to dispose of the BLOB or +//text after SQLite has finished with it. If the fifth argument is the +// special value SQLITE_STATIC, then the library assumes that the information +// is in static, unmanaged space and does not need to be freed. If the +// fifth argument has the value SQLITE_TRANSIENT, then SQLite makes its +// own private copy of the data. +// +// The sqlite3_bind_* routine must be called before sqlite3_step() after +// an sqlite3_prepare() or sqlite3_reset(). Unbound wildcards are interpreted +// as NULL. +// +//function sqlite3_bind_blob(hStmt: TSqliteStmt; ParamNum: Integer; +// ptrData: Pointer; numBytes: Integer; ptrDestructor: TSQLite3Destructor): Integer; +//cdecl; external SQLiteDLL name 'sqlite3_bind_blob'; +//function sqlite3_bind_text(hStmt: TSqliteStmt; ParamNum: Integer; +// Text: PAnsiChar; numBytes: Integer; ptrDestructor: TSQLite3Destructor): Integer; +//cdecl; external SQLiteDLL name 'sqlite3_bind_text'; +//function sqlite3_bind_double(hStmt: TSqliteStmt; ParamNum: Integer; Data: Double): Integer; +// cdecl; external SQLiteDLL name 'sqlite3_bind_double'; +//function sqlite3_bind_int(hStmt: TSqLiteStmt; ParamNum: Integer; Data: Integer): Integer; +// cdecl; external SQLiteDLL name 'sqlite3_bind_int'; +//function sqlite3_bind_int64(hStmt: TSqliteStmt; ParamNum: Integer; Data: int64): Integer; +// cdecl; external SQLiteDLL name 'sqlite3_bind_int64'; +//function sqlite3_bind_null(hStmt: TSqliteStmt; ParamNum: Integer): Integer; +// cdecl; external SQLiteDLL name 'sqlite3_bind_null'; +// +//function sqlite3_bind_parameter_index(hStmt: TSqliteStmt; zName: PAnsiChar): Integer; +// cdecl; external SQLiteDLL name 'sqlite3_bind_parameter_index'; +// +//function sqlite3_enable_shared_cache(Value: Integer): Integer; cdecl; external SQLiteDLL name 'sqlite3_enable_shared_cache'; +// +////user collate definiton +//function SQLite3_create_collation(db: TSQLiteDB; Name: PAnsiChar; eTextRep: Integer; +// UserData: Pointer; xCompare: TCollateXCompare): Integer; cdecl; external SQLiteDLL name 'sqlite3_create_collation'; +function sqlite3_bind_blob(hStmt: TSqliteStmt; ParamNum: Integer; + ptrData: Pointer; numBytes: Integer; ptrDestructor: TSQLite3Destructor): Integer; +function sqlite3_bind_text(hStmt: TSqliteStmt; ParamNum: Integer; + Text: PAnsiChar; numBytes: Integer; ptrDestructor: TSQLite3Destructor): Integer; +function sqlite3_bind_double(hStmt: TSqliteStmt; ParamNum: Integer; Data: Double): Integer; +function sqlite3_bind_int(hStmt: TSqLiteStmt; ParamNum: Integer; Data: Integer): Integer; +function sqlite3_bind_int64(hStmt: TSqliteStmt; ParamNum: Integer; Data: int64): Integer; +function sqlite3_bind_null(hStmt: TSqliteStmt; ParamNum: Integer): Integer; +function sqlite3_bind_parameter_index(hStmt: TSqliteStmt; zName: PAnsiChar): Integer; +function sqlite3_enable_shared_cache(Value: Integer): Integer; +//user collate definiton +function SQLite3_create_collation(db: TSQLiteDB; Name: PAnsiChar; eTextRep: Integer; + UserData: Pointer; xCompare: TCollateXCompare): Integer; +function SQLiteFieldType(SQLiteFieldTypeCode: Integer): AnsiString; +function SQLiteErrorStr(SQLiteErrorCode: Integer): AnsiString; +implementation +uses + SysUtils, Winapi.Windows; +var + _hSql3: THandle = 0; + _SQLite3_Open: TSQLite3_Open = nil; + _SQLite3_Close: TSQLite3_Close = nil; + _SQLite3_Exec: TSQLite3_Exec = nil; + _SQLite3_Version: TSQLite3_Version = nil; + _SQLite3_ErrMsg: TSQLite3_ErrMsg = nil; + _SQLite3_ErrCode: TSQLite3_ErrCode = nil; + _SQlite3_Free: TSQlite3_Free = nil; + _SQLite3_GetTable: TSQLite3_GetTable = nil; + _SQLite3_FreeTable: TSQLite3_FreeTable = nil; + _SQLite3_Complete: TSQLite3_Complete = nil; + _SQLite3_LastInsertRowID: TSQLite3_LastInsertRowID = nil; + _SQLite3_Interrupt: TSQLite3_Interrupt = nil; + _SQLite3_BusyHandler: TSQLite3_BusyHandler = nil; + _SQLite3_BusyTimeout: TSQLite3_BusyTimeout = nil; + _SQLite3_Changes: TSQLite3_Changes = nil; + _SQLite3_TotalChanges: TSQLite3_TotalChanges = nil; + _SQLite3_Prepare: TSQLite3_Prepare = nil; + _SQLite3_Prepare_v2: TSQLite3_Prepare_v2 = nil; + _SQLite3_ColumnCount: TSQLite3_ColumnCount = nil; + _SQLite3_ColumnName: TSQLite3_ColumnName = nil; + _SQLite3_ColumnDeclType: TSQLite3_ColumnDeclType = nil; + _SQLite3_Step: TSQLite3_Step = nil; + _SQLite3_DataCount: TSQLite3_DataCount = nil; + _SQLite3_ColumnBlob: TSQLite3_ColumnBlob = nil; + _SQLite3_ColumnBytes: TSQLite3_ColumnBytes = nil; + _SQLite3_ColumnDouble: TSQLite3_ColumnDouble = nil; + _SQLite3_ColumnInt: TSQLite3_ColumnInt = nil; + _SQLite3_ColumnText: TSQLite3_ColumnText = nil; + _SQLite3_ColumnType: TSQLite3_ColumnType = nil; + _SQLite3_ColumnInt64: TSQLite3_ColumnInt64 = nil; + _SQLite3_Finalize: TSQLite3_Finalize = nil; + _SQLite3_Reset: TSQLite3_Reset = nil; + _sqlite3_bind_blob: Tsqlite3_bind_blob = nil; + _sqlite3_bind_text: Tsqlite3_bind_text = nil; + _sqlite3_bind_double: Tsqlite3_bind_double = nil; + _sqlite3_bind_int: Tsqlite3_bind_int = nil; + _sqlite3_bind_int64: Tsqlite3_bind_int64 = nil; + _sqlite3_bind_null: Tsqlite3_bind_null = nil; + _sqlite3_bind_parameter_index: Tsqlite3_bind_parameter_index = nil; + _sqlite3_enable_shared_cache: Tsqlite3_enable_shared_cache = nil; + _SQLite3_create_collation: TSQLite3_create_collation = nil; +function InitSqlite3Procedure: Boolean; +begin + if _hSql3 = 0 then + begin + _hSql3 := SafeLoadLibrary(SQLiteDLL); + if _hSql3 <> 0 then + begin + @_SQLite3_Open := GetProcAddress(_hSql3, 'sqlite3_open'); + @_SQLite3_Close := GetProcAddress(_hSql3, 'sqlite3_close'); + @_SQLite3_Exec := GetProcAddress(_hSql3, 'sqlite3_exec'); + @_SQLite3_Version := GetProcAddress(_hSql3, 'sqlite3_libversion'); + @_SQLite3_ErrMsg := GetProcAddress(_hSql3, 'sqlite3_errmsg'); + @_SQLite3_ErrCode := GetProcAddress(_hSql3, 'sqlite3_errcode'); + @_SQlite3_Free := GetProcAddress(_hSql3, 'sqlite3_free'); + @_SQLite3_GetTable := GetProcAddress(_hSql3, 'sqlite3_get_table'); + @_SQLite3_FreeTable := GetProcAddress(_hSql3, 'sqlite3_free_table'); + @_SQLite3_Complete := GetProcAddress(_hSql3, 'sqlite3_complete'); + @_SQLite3_LastInsertRowID := GetProcAddress(_hSql3, 'sqlite3_last_insert_rowid'); + @_SQLite3_Interrupt := GetProcAddress(_hSql3, 'sqlite3_interrupt'); + @_SQLite3_BusyHandler := GetProcAddress(_hSql3, 'sqlite3_busy_handler'); + @_SQLite3_BusyTimeout := GetProcAddress(_hSql3, 'sqlite3_busy_timeout'); + @_SQLite3_Changes := GetProcAddress(_hSql3, 'sqlite3_changes'); + @_SQLite3_TotalChanges := GetProcAddress(_hSql3, 'sqlite3_total_changes'); + @_SQLite3_Prepare := GetProcAddress(_hSql3, 'sqlite3_prepare'); + @_SQLite3_Prepare_v2 := GetProcAddress(_hSql3, 'sqlite3_prepare_v2'); + @_SQLite3_ColumnCount := GetProcAddress(_hSql3, 'sqlite3_column_count'); + @_SQLite3_ColumnName := GetProcAddress(_hSql3, 'sqlite3_column_name'); + @_SQLite3_ColumnDeclType := GetProcAddress(_hSql3, 'sqlite3_column_decltype'); + @_SQLite3_Step := GetProcAddress(_hSql3, 'sqlite3_step'); + @_SQLite3_DataCount := GetProcAddress(_hSql3, 'sqlite3_data_count'); + @_SQLite3_ColumnBlob := GetProcAddress(_hSql3, 'sqlite3_column_blob'); + @_SQLite3_ColumnBytes := GetProcAddress(_hSql3, 'sqlite3_column_bytes'); + @_SQLite3_ColumnDouble := GetProcAddress(_hSql3, 'sqlite3_column_double'); + @_SQLite3_ColumnInt := GetProcAddress(_hSql3, 'sqlite3_column_int'); + @_SQLite3_ColumnText := GetProcAddress(_hSql3, 'sqlite3_column_text'); + @_SQLite3_ColumnType := GetProcAddress(_hSql3, 'sqlite3_column_type'); + @_SQLite3_ColumnInt64 := GetProcAddress(_hSql3, 'sqlite3_column_int64'); + @_SQLite3_Finalize := GetProcAddress(_hSql3, 'sqlite3_finalize'); + @_SQLite3_Reset := GetProcAddress(_hSql3, 'sqlite3_reset'); + @_sqlite3_bind_blob := GetProcAddress(_hSql3, 'sqlite3_bind_blob'); + @_sqlite3_bind_text := GetProcAddress(_hSql3, 'sqlite3_bind_text'); + @_sqlite3_bind_double := GetProcAddress(_hSql3, 'sqlite3_bind_double'); + @_sqlite3_bind_int := GetProcAddress(_hSql3, 'sqlite3_bind_int'); + @_sqlite3_bind_int64 := GetProcAddress(_hSql3, 'sqlite3_bind_int64'); + @_sqlite3_bind_null := GetProcAddress(_hSql3, 'sqlite3_bind_null'); + @_sqlite3_bind_parameter_index := GetProcAddress(_hSql3, 'sqlite3_bind_parameter_index'); + @_sqlite3_enable_shared_cache := GetProcAddress(_hSql3, 'sqlite3_enable_shared_cache'); + @_SQLite3_create_collation := GetProcAddress(_hSql3, 'sqlite3_create_collation'); + end; + end; + Result := _hSql3 <> 0; +end; +function SQLite3_Open(filename: PAnsiChar; var db: TSQLiteDB): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Open) then + Result := _SQLite3_Open(filename, db); +end; +function SQLite3_Close(db: TSQLiteDB): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Close) then + Result := _SQLite3_Close(db); +end; +function SQLite3_Exec(db: TSQLiteDB; SQLStatement: PAnsiChar; CallbackPtr: TSQLiteExecCallback; UserData: Pointer; var ErrMsg: PAnsiChar): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Exec) then + Result := _SQLite3_Exec(db, SQLStatement, CallbackPtr, UserData, ErrMsg); +end; +function SQLite3_Version: PAnsiChar; +begin + if InitSqlite3Procedure and Assigned(_SQLite3_Version) then + _SQLite3_Version; +end; +function SQLite3_ErrMsg(db: TSQLiteDB): PAnsiChar; +begin + if InitSqlite3Procedure and Assigned(_SQLite3_ErrMsg) then + _SQLite3_ErrMsg(db); +end; +function SQLite3_ErrCode(db: TSQLiteDB): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_ErrCode) then + Result := _SQLite3_ErrCode(db); +end; +procedure SQlite3_Free(P: PAnsiChar); +begin + if InitSqlite3Procedure and Assigned(_SQlite3_Free) then + _SQlite3_Free(P); +end; +function SQLite3_GetTable(db: TSQLiteDB; SQLStatement: PAnsiChar; var ResultPtr: TSQLiteResult; var RowCount: Cardinal; var ColCount: Cardinal; var ErrMsg: PAnsiChar): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_GetTable) then + Result := _SQLite3_GetTable(db, SQLStatement, ResultPtr, RowCount, ColCount, ErrMsg); +end; +procedure SQLite3_FreeTable(Table: TSQLiteResult); +begin + if InitSqlite3Procedure and Assigned(_SQLite3_FreeTable) then + _SQLite3_FreeTable(Table); +end; +function SQLite3_Complete(P: PAnsiChar): boolean; +begin + if InitSqlite3Procedure and Assigned(_SQLite3_Complete) then + Result := _SQLite3_Complete(P); +end; +function SQLite3_LastInsertRowID(db: TSQLiteDB): Int64; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_LastInsertRowID) then + Result := _SQLite3_LastInsertRowID(db); +end; +procedure SQLite3_Interrupt(db: TSQLiteDB); +begin + if InitSqlite3Procedure and Assigned(_SQLite3_Interrupt) then + _SQLite3_Interrupt(db); +end; +procedure SQLite3_BusyHandler(db: TSQLiteDB; CallbackPtr: TSQLiteBusyHandlerCallback; UserData: Pointer); +begin + if InitSqlite3Procedure and Assigned(_SQLite3_BusyHandler) then + _SQLite3_BusyHandler(db, CallbackPtr, UserData); +end; +procedure SQLite3_BusyTimeout(db: TSQLiteDB; TimeOut: Integer); +begin + if InitSqlite3Procedure and Assigned(_SQLite3_BusyTimeout) then + _SQLite3_BusyTimeout(db, TimeOut); +end; +function SQLite3_Changes(db: TSQLiteDB): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Changes) then + Result := _SQLite3_Changes(db); +end; +function SQLite3_TotalChanges(db: TSQLiteDB): Integer; +begin + if InitSqlite3Procedure and Assigned(_SQLite3_TotalChanges) then + Result := _SQLite3_TotalChanges(db); +end; +function SQLite3_Prepare(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: Integer; var hStmt: TSqliteStmt; var pzTail: PAnsiChar): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Prepare) then + Result := _SQLite3_Prepare(db, SQLStatement, nBytes, hStmt, pzTail); +end; +function SQLite3_Prepare_v2(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: Integer; var hStmt: TSqliteStmt; var pzTail: PAnsiChar): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Prepare_v2) then + Result := _SQLite3_Prepare_v2(db, SQLStatement, nBytes, hStmt, pzTail); +end; +function SQLite3_ColumnCount(hStmt: TSqliteStmt): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnCount) then + Result := _SQLite3_ColumnCount(hStmt); +end; +function SQLite3_ColumnName(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; +begin + Result := nil; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnName) then + Result := _SQLite3_ColumnName(hStmt, ColNum); +end; +function SQLite3_ColumnDeclType(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; +begin + Result := nil; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnDeclType) then + Result := _SQLite3_ColumnDeclType(hStmt, ColNum); +end; +function SQLite3_Step(hStmt: TSqliteStmt): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Step) then + Result := _SQLite3_Step(hStmt); +end; +function SQLite3_DataCount(hStmt: TSqliteStmt): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_DataCount) then + Result := _SQLite3_DataCount(hStmt); +end; +function SQLite3_ColumnBlob(hStmt: TSqliteStmt; ColNum: Integer): Pointer; +begin + Result := nil; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnBlob) then + Result := _SQLite3_ColumnBlob(hStmt, ColNum); +end; +function SQLite3_ColumnBytes(hStmt: TSqliteStmt; ColNum: Integer): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnBytes) then + Result := _SQLite3_ColumnBytes(hStmt, ColNum); +end; +function SQLite3_ColumnDouble(hStmt: TSqliteStmt; ColNum: Integer): Double; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnDouble) then + Result := _SQLite3_ColumnDouble(hStmt, ColNum); +end; +function SQLite3_ColumnInt(hStmt: TSqliteStmt; ColNum: Integer): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnInt) then + Result := _SQLite3_ColumnInt(hStmt, ColNum); +end; +function SQLite3_ColumnText(hStmt: TSqliteStmt; ColNum: Integer): PAnsiChar; +begin + Result := nil; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnText) then + Result := _SQLite3_ColumnText(hStmt, ColNum); +end; +function SQLite3_ColumnType(hStmt: TSqliteStmt; ColNum: Integer): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnType) then + Result := _SQLite3_ColumnType(hStmt, ColNum); +end; +function SQLite3_ColumnInt64(hStmt: TSqliteStmt; ColNum: Integer): Int64; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_ColumnInt64) then + Result := _SQLite3_ColumnInt64(hStmt, ColNum); +end; +function SQLite3_Finalize(hStmt: TSqliteStmt): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Finalize) then + Result := _SQLite3_Finalize(hStmt); +end; +function SQLite3_Reset(hStmt: TSqliteStmt): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_Reset) then + Result := _SQLite3_Reset(hStmt); +end; +function sqlite3_bind_blob(hStmt: TSqliteStmt; ParamNum: Integer; + ptrData: Pointer; numBytes: Integer; ptrDestructor: TSQLite3Destructor): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_sqlite3_bind_blob) then + Result := _sqlite3_bind_blob(hStmt, ParamNum, ptrData, numBytes, ptrDestructor); +end; +function sqlite3_bind_text(hStmt: TSqliteStmt; ParamNum: Integer; + Text: PAnsiChar; numBytes: Integer; ptrDestructor: TSQLite3Destructor): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_sqlite3_bind_text) then + Result := _sqlite3_bind_text(hStmt, ParamNum, Text, numBytes, ptrDestructor); +end; +function sqlite3_bind_double(hStmt: TSqliteStmt; ParamNum: Integer; Data: Double): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_sqlite3_bind_double) then + Result := _sqlite3_bind_double(hStmt, ParamNum, Data); +end; +function sqlite3_bind_int(hStmt: TSqLiteStmt; ParamNum: Integer; Data: Integer): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_sqlite3_bind_int) then + Result := _sqlite3_bind_int(hStmt, ParamNum, Data); +end; +function sqlite3_bind_int64(hStmt: TSqliteStmt; ParamNum: Integer; Data: int64): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_sqlite3_bind_int64) then + Result := _sqlite3_bind_int64(hStmt, ParamNum, Data); +end; +function sqlite3_bind_null(hStmt: TSqliteStmt; ParamNum: Integer): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_sqlite3_bind_null) then + Result := _sqlite3_bind_null(hStmt, ParamNum); +end; +function sqlite3_bind_parameter_index(hStmt: TSqliteStmt; zName: PAnsiChar): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_sqlite3_bind_parameter_index) then + Result := _sqlite3_bind_parameter_index(hStmt, zName); +end; +function sqlite3_enable_shared_cache(Value: Integer): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_sqlite3_enable_shared_cache) then + Result := _sqlite3_enable_shared_cache(Value); +end; +function SQLite3_create_collation(db: TSQLiteDB; Name: PAnsiChar; eTextRep: Integer; + UserData: Pointer; xCompare: TCollateXCompare): Integer; +begin + Result := -1; + if InitSqlite3Procedure and Assigned(_SQLite3_create_collation) then + Result := _SQLite3_create_collation(db, Name, eTextRep, UserData, xCompare); +end; +// ----------------------------------------------------------------------------- +function SQLiteFieldType(SQLiteFieldTypeCode: Integer): AnsiString; +begin + case SQLiteFieldTypeCode of + SQLITE_INTEGER: Result := 'Integer'; + SQLITE_FLOAT: Result := 'Float'; + SQLITE_TEXT: Result := 'Text'; + SQLITE_BLOB: Result := 'Blob'; + SQLITE_NULL: Result := 'Null'; + else + Result := AnsiString('Unknown SQLite Field Type Code "' + IntToStr(SQLiteFieldTypeCode) + '"'); + end; +end; +function SQLiteErrorStr(SQLiteErrorCode: Integer): AnsiString; +begin + case SQLiteErrorCode of + SQLITE_OK: Result := 'Successful result'; + SQLITE_ERROR: Result := 'SQL error or missing database'; + SQLITE_INTERNAL: Result := 'An internal logic error in SQLite'; + SQLITE_PERM: Result := 'Access permission denied'; + SQLITE_ABORT: Result := 'Callback routine requested an abort'; + SQLITE_BUSY: Result := 'The database file is locked'; + SQLITE_LOCKED: Result := 'A table in the database is locked'; + SQLITE_NOMEM: Result := 'A malloc() failed'; + SQLITE_READONLY: Result := 'Attempt to write a readonly database'; + SQLITE_INTERRUPT: Result := 'Operation terminated by sqlite3_interrupt()'; + SQLITE_IOERR: Result := 'Some kind of disk I/O error occurred'; + SQLITE_CORRUPT: Result := 'The database disk image is malformed'; + SQLITE_NOTFOUND: Result := '(Internal Only) Table or record not found'; + SQLITE_FULL: Result := 'Insertion failed because database is full'; + SQLITE_CANTOPEN: Result := 'Unable to open the database file'; + SQLITE_PROTOCOL: Result := 'Database lock protocol error'; + SQLITE_EMPTY: Result := 'Database is empty'; + SQLITE_SCHEMA: Result := 'The database schema changed'; + SQLITE_TOOBIG: Result := 'Too much data for one row of a table'; + SQLITE_CONSTRAINT: Result := 'Abort due to contraint violation'; + SQLITE_MISMATCH: Result := 'Data type mismatch'; + SQLITE_MISUSE: Result := 'Library used incorrectly'; + SQLITE_NOLFS: Result := 'Uses OS features not supported on host'; + SQLITE_AUTH: Result := 'Authorization denied'; + SQLITE_FORMAT: Result := 'Auxiliary database format error'; + SQLITE_RANGE: Result := '2nd parameter to sqlite3_bind out of range'; + SQLITE_NOTADB: Result := 'File opened that is not a database file'; + SQLITE_ROW: Result := 'sqlite3_step() has another row ready'; + SQLITE_DONE: Result := 'sqlite3_step() has finished executing'; + else + Result := AnsiString('Unknown SQLite Error Code "' + IntToStr(SQLiteErrorCode) + '"'); + end; +end; +function ColValueToStr(Value: PAnsiChar): AnsiString; +begin + if (Value = nil) then + Result := 'NULL' + else + Result := Value; +end; + +end. diff --git a/Tocsg.Lib/VCL/SQLite3/EM.SQLite3.pas b/Tocsg.Lib/VCL/SQLite3/EM.SQLite3.pas new file mode 100644 index 00000000..a37d3a36 --- /dev/null +++ b/Tocsg.Lib/VCL/SQLite3/EM.SQLite3.pas @@ -0,0 +1,899 @@ +// 아래에서 가져옴 19_0115 12:47:54 sunk +// https://github.com/plashenkov/SQLite3-Delphi-FPC/tree/master/Source +{* + * SQLite for Delphi and FreePascal/Lazarus + * + * This unit contains complete SQLite3 API translation + * Version of SQLite: 3.6.22 + * + * Copyright 2010-2013 Yury Plashenkov + * http://plashenkov.github.io/sqlite/ + * + * The MIT License (MIT) + * + * 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 EM.SQLite3; + +// 인덱스 등 스키마 오류가 나면서 테이블을 열 수 없을때... +// 아래처럼 쿼리를 주면 복구(?) 된다. 21_1105 08:27:32 sunk +// 에러메시지 >> 'malformed database schema (idx_chatlogs_next_msg_missing) - near "(": syntax error' + +// sQuery := 'PRAGMA writable_schema=ON;' + +// 'DELETE FROM sqlite_master WHERE name LIKE ''if'';' + +// 'PRAGMA writable_schema=OFF;'; +// if SQLite3_Exec(db, PAnsiChar(sQuery), nil, nil, @pErrMsg) <> SQLITE_OK then + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +{ $DEFINE SQLITE_DEPRECATED} // Enable deprecated functions +{ $DEFINE SQLITE_EXPERIMENTAL} // Enable experimental functions + +{$DEFINE SQLITE_ENABLE_COLUMN_METADATA} // Enable functions to work with + // column metadata: + // table name, DB name, etc. + +{$DEFINE SQLITE_ENABLE_UNLOCK_NOTIFY} // Enable sqlite3_unlock_notify() + // function to receive DB unlock + // notification + +{ $DEFINE SQLITE_DEBUG} // Enable sqlite3_mutex_held() and + // sqlite3_mutex_notheld() functions + +interface + +type + PPAnsiCharArray = ^TPAnsiCharArray; + TPAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar) - 1] of PAnsiChar; + +const + FixQuery: AnsiString = 'PRAGMA writable_schema=ON;' + + 'DELETE FROM sqlite_master WHERE name LIKE ''if'';' + + 'PRAGMA writable_schema=OFF;'; + +{$IFDEF MSWINDOWS} + {$IFDEF WIN64} + sqlite3_lib = 'sqlite3-64.dll'; + {$ELSE} + sqlite3_lib = 'sqlite3.dll'; + {$ENDIF} +{$ENDIF} +{$IFDEF UNIX} + sqlite3_lib = 'sqlite3.so'; +{$ENDIF} +{$IFDEF DARWIN} + sqlite3_lib = 'libsqlite3.dylib'; +{$ENDIF} + +//var sqlite3_version: PAnsiChar; +function sqlite3_libversion: PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_sourceid: PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_libversion_number: Integer; cdecl; external sqlite3_lib; + +function sqlite3_threadsafe: Integer; cdecl; external sqlite3_lib; + +type + PSQLite3 = type Pointer; + +function sqlite3_close(db: PSQLite3): Integer; cdecl; external sqlite3_lib; + +type + TSQLite3Callback = function(pArg: Pointer; nCol: Integer; argv: PPAnsiCharArray; colv: PPAnsiCharArray): Integer; cdecl; + +function sqlite3_exec(db: PSQLite3; const sql: PAnsiChar; callback: TSQLite3Callback; pArg: Pointer; errmsg: PPAnsiChar): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_OK = 0; + SQLITE_ERROR = 1; + SQLITE_INTERNAL = 2; + SQLITE_PERM = 3; + SQLITE_ABORT = 4; + SQLITE_BUSY = 5; + SQLITE_LOCKED = 6; + SQLITE_NOMEM = 7; + SQLITE_READONLY = 8; + SQLITE_INTERRUPT = 9; + SQLITE_IOERR = 10; + SQLITE_CORRUPT = 11; + SQLITE_NOTFOUND = 12; + SQLITE_FULL = 13; + SQLITE_CANTOPEN = 14; + SQLITE_PROTOCOL = 15; + SQLITE_EMPTY = 16; + SQLITE_SCHEMA = 17; + SQLITE_TOOBIG = 18; + SQLITE_CONSTRAINT = 19; + SQLITE_MISMATCH = 20; + SQLITE_MISUSE = 21; + SQLITE_NOLFS = 22; + SQLITE_AUTH = 23; + SQLITE_FORMAT = 24; + SQLITE_RANGE = 25; + SQLITE_NOTADB = 26; + SQLITE_ROW = 100; + SQLITE_DONE = 101; + +const + SQLITE_IOERR_READ = SQLITE_IOERR or (1 shl 8); + SQLITE_IOERR_SHORT_READ = SQLITE_IOERR or (2 shl 8); + SQLITE_IOERR_WRITE = SQLITE_IOERR or (3 shl 8); + SQLITE_IOERR_FSYNC = SQLITE_IOERR or (4 shl 8); + SQLITE_IOERR_DIR_FSYNC = SQLITE_IOERR or (5 shl 8); + SQLITE_IOERR_TRUNCATE = SQLITE_IOERR or (6 shl 8); + SQLITE_IOERR_FSTAT = SQLITE_IOERR or (7 shl 8); + SQLITE_IOERR_UNLOCK = SQLITE_IOERR or (8 shl 8); + SQLITE_IOERR_RDLOCK = SQLITE_IOERR or (9 shl 8); + SQLITE_IOERR_DELETE = SQLITE_IOERR or (10 shl 8); + SQLITE_IOERR_BLOCKED = SQLITE_IOERR or (11 shl 8); + SQLITE_IOERR_NOMEM = SQLITE_IOERR or (12 shl 8); + SQLITE_IOERR_ACCESS = SQLITE_IOERR or (13 shl 8); + SQLITE_IOERR_CHECKRESERVEDLOCK = SQLITE_IOERR or (14 shl 8); + SQLITE_IOERR_LOCK = SQLITE_IOERR or (15 shl 8); + SQLITE_IOERR_CLOSE = SQLITE_IOERR or (16 shl 8); + SQLITE_IOERR_DIR_CLOSE = SQLITE_IOERR or (17 shl 8); + SQLITE_LOCKED_SHAREDCACHE = SQLITE_LOCKED or (1 shl 8); + +const + SQLITE_OPEN_READONLY = $00000001; + SQLITE_OPEN_READWRITE = $00000002; + SQLITE_OPEN_CREATE = $00000004; + SQLITE_OPEN_DELETEONCLOSE = $00000008; + SQLITE_OPEN_EXCLUSIVE = $00000010; + SQLITE_OPEN_MAIN_DB = $00000100; + SQLITE_OPEN_TEMP_DB = $00000200; + SQLITE_OPEN_TRANSIENT_DB = $00000400; + SQLITE_OPEN_MAIN_JOURNAL = $00000800; + SQLITE_OPEN_TEMP_JOURNAL = $00001000; + SQLITE_OPEN_SUBJOURNAL = $00002000; + SQLITE_OPEN_MASTER_JOURNAL = $00004000; + SQLITE_OPEN_NOMUTEX = $00008000; + SQLITE_OPEN_FULLMUTEX = $00010000; + SQLITE_OPEN_SHAREDCACHE = $00020000; + SQLITE_OPEN_PRIVATECACHE = $00040000; + +const + SQLITE_IOCAP_ATOMIC = $00000001; + SQLITE_IOCAP_ATOMIC512 = $00000002; + SQLITE_IOCAP_ATOMIC1K = $00000004; + SQLITE_IOCAP_ATOMIC2K = $00000008; + SQLITE_IOCAP_ATOMIC4K = $00000010; + SQLITE_IOCAP_ATOMIC8K = $00000020; + SQLITE_IOCAP_ATOMIC16K = $00000040; + SQLITE_IOCAP_ATOMIC32K = $00000080; + SQLITE_IOCAP_ATOMIC64K = $00000100; + SQLITE_IOCAP_SAFE_APPEND = $00000200; + SQLITE_IOCAP_SEQUENTIAL = $00000400; + +const + SQLITE_LOCK_NONE = 0; + SQLITE_LOCK_SHARED = 1; + SQLITE_LOCK_RESERVED = 2; + SQLITE_LOCK_PENDING = 3; + SQLITE_LOCK_EXCLUSIVE = 4; + +const + SQLITE_SYNC_NORMAL = $00002; + SQLITE_SYNC_FULL = $00003; + SQLITE_SYNC_DATAONLY = $00010; + +type + PSQLite3File = ^TSQLite3File; + PSQLite3IOMethods = ^TSQLite3IOMethods; + + sqlite3_file = record + pMethods: PSQLite3IOMethods; + end; + TSQLite3File = sqlite3_file; + + sqlite3_io_methods = record + iVersion: Integer; + xClose: function(id: PSQLite3File): Integer; cdecl; + xRead: function(id: PSQLite3File; pBuf: Pointer; iAmt: Integer; iOfst: Int64): Integer; cdecl; + xWrite: function(id: PSQLite3File; const pBuf: Pointer; iAmt: Integer; iOfst: Int64): Integer; cdecl; + xTruncate: function(id: PSQLite3File; size: Int64): Integer; cdecl; + xSync: function(id: PSQLite3File; flags: Integer): Integer; cdecl; + xFileSize: function(id: PSQLite3File; var pSize: Int64): Integer; cdecl; + xLock: function(id: PSQLite3File; locktype: Integer): Integer; cdecl; + xUnlock: function(id: PSQLite3File; locktype: Integer): Integer; cdecl; + xCheckReservedLock: function(f: PSQLite3File; var pResOut: Integer): Integer; cdecl; + xFileControl: function(id: PSQLite3File; op: Integer; pArg: Pointer): Integer; cdecl; + xSectorSize: function(id: PSQLite3File): Integer; cdecl; + xDeviceCharacteristics: function(id: PSQLite3File): Integer; cdecl; + end; + TSQLite3IOMethods = sqlite3_io_methods; + +const + SQLITE_FCNTL_LOCKSTATE = 1; + SQLITE_GET_LOCKPROXYFILE = 2; + SQLITE_SET_LOCKPROXYFILE = 3; + SQLITE_LAST_ERRNO = 4; + +type + PSQLite3Mutex = type Pointer; + +type + PSQLite3VFS = ^TSQLite3VFS; + sqlite3_vfs = record + iVersion: Integer; + szOsFile: Integer; + mxPathname: Integer; + pNext: PSQLite3VFS; + zName: PAnsiChar; + pAppData: Pointer; + xOpen: function(pVfs: PSQLite3VFS; const zName: PAnsiChar; id: PSQLite3File; flags: Integer; pOutFlags: PInteger): Integer; cdecl; + xDelete: function(pVfs: PSQLite3VFS; const zName: PAnsiChar; syncDir: Integer): Integer; cdecl; + xAccess: function(pVfs: PSQLite3VFS; const zName: PAnsiChar; flags: Integer; var pResOut: Integer): Integer; cdecl; + xFullPathname: function(pVfs: PSQLite3VFS; const zName: PAnsiChar; nOut: Integer; zOut: PAnsiChar): Integer; cdecl; + xDlOpen: function(pVfs: PSQLite3VFS; const zFilename: PAnsiChar): Pointer; cdecl; + xDlError: procedure(pVfs: PSQLite3VFS; nByte: Integer; zErrMsg: PAnsiChar); cdecl; + xDlSym: function(pVfs: PSQLite3VFS; pHandle: Pointer; const zSymbol: PAnsiChar): Pointer; cdecl; + xDlClose: procedure(pVfs: PSQLite3VFS; pHandle: Pointer); cdecl; + xRandomness: function(pVfs: PSQLite3VFS; nByte: Integer; zOut: PAnsiChar): Integer; cdecl; + xSleep: function(pVfs: PSQLite3VFS; microseconds: Integer): Integer; cdecl; + xCurrentTime: function(pVfs: PSQLite3VFS; var prNow: Double): Integer; cdecl; + xGetLastError: function(pVfs: PSQLite3VFS; nBuf: Integer; zBuf: PAnsiChar): Integer; cdecl; + end; + TSQLite3VFS = sqlite3_vfs; + +const + SQLITE_ACCESS_EXISTS = 0; + SQLITE_ACCESS_READWRITE = 1; + SQLITE_ACCESS_READ = 2; + +function sqlite3_initialize: Integer; cdecl; external sqlite3_lib; +function sqlite3_shutdown: Integer; cdecl; external sqlite3_lib; +function sqlite3_os_init: Integer; cdecl; external sqlite3_lib; +function sqlite3_os_end: Integer; cdecl; external sqlite3_lib; + +{$IFDEF SQLITE_EXPERIMENTAL} +function sqlite3_config(op: Integer{; ...}): Integer; cdecl; external sqlite3_lib; + +function sqlite3_db_config(db: PSQLite3; op: Integer{; ...}): Integer; cdecl; external sqlite3_lib; + +type + sqlite3_mem_methods = record + xMalloc: function(nByte: Integer): Pointer; cdecl; + xFree: procedure(pPrior: Pointer); cdecl; + xRealloc: function(pPrior: Pointer; nByte: Integer): Pointer; cdecl; + xSize: function(pPrior: Pointer): Integer; cdecl; + xRoundup: function(n: Integer): Integer; cdecl; + xInit: function(NotUsed: Pointer): Integer; cdecl; + xShutdown: procedure(NotUsed: Pointer); cdecl; + pAppData: Pointer; + end; + TSQLite3MemMethods = sqlite3_mem_methods; + +const + SQLITE_CONFIG_SINGLETHREAD = 1; + SQLITE_CONFIG_MULTITHREAD = 2; + SQLITE_CONFIG_SERIALIZED = 3; + SQLITE_CONFIG_MALLOC = 4; + SQLITE_CONFIG_GETMALLOC = 5; + SQLITE_CONFIG_SCRATCH = 6; + SQLITE_CONFIG_PAGECACHE = 7; + SQLITE_CONFIG_HEAP = 8; + SQLITE_CONFIG_MEMSTATUS = 9; + SQLITE_CONFIG_MUTEX = 10; + SQLITE_CONFIG_GETMUTEX = 11; + //SQLITE_CONFIG_CHUNKALLOC = 12; + SQLITE_CONFIG_LOOKASIDE = 13; + SQLITE_CONFIG_PCACHE = 14; + SQLITE_CONFIG_GETPCACHE = 15; + +const + SQLITE_DBCONFIG_LOOKASIDE = 1001; +{$ENDIF} + +function sqlite3_extended_result_codes(db: PSQLite3; onoff: Integer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_last_insert_rowid(db: PSQLite3): Int64; cdecl; external sqlite3_lib; + +function sqlite3_changes(db: PSQLite3): Integer; cdecl; external sqlite3_lib; + +function sqlite3_total_changes(db: PSQLite3): Integer; cdecl; external sqlite3_lib; + +procedure sqlite3_interrupt(db: PSQLite3); cdecl; external sqlite3_lib; + +function sqlite3_complete(const sql: PAnsiChar): Integer; cdecl; external sqlite3_lib; +function sqlite3_complete16(const sql: PWideChar): Integer; cdecl; external sqlite3_lib; + +type + TSQLite3BusyCallback = function(ptr: Pointer; count: Integer): Integer; cdecl; + +function sqlite3_busy_handler(db: PSQLite3; xBusy: TSQLite3BusyCallback; pArg: Pointer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_busy_timeout(db: PSQLite3; ms: Integer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_get_table(db: PSQLite3; const zSql: PAnsiChar; var pazResult: PPAnsiCharArray; pnRow: PInteger; pnColumn: PInteger; pzErrmsg: PPAnsiChar): Integer; cdecl; external sqlite3_lib; +procedure sqlite3_free_table(result: PPAnsiCharArray); cdecl; external sqlite3_lib; + +function sqlite3_mprintf(const zFormat: PAnsiChar{; ...}): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_vmprintf(const zFormat: PAnsiChar; ap: Pointer{va_list}): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_snprintf(n: Integer; zBuf: PAnsiChar; const zFormat: PAnsiChar{; ...}): PAnsiChar; cdecl; external sqlite3_lib; + +function sqlite3_malloc(n: Integer): Pointer; cdecl; external sqlite3_lib; +function sqlite3_realloc(pOld: Pointer; n: Integer): Pointer; cdecl; external sqlite3_lib; +procedure sqlite3_free(p: Pointer); cdecl; external sqlite3_lib; + +function sqlite3_memory_used: Int64; cdecl; external sqlite3_lib; +function sqlite3_memory_highwater(resetFlag: Integer): Int64; cdecl; external sqlite3_lib; + +procedure sqlite3_randomness(N: Integer; P: Pointer); cdecl; external sqlite3_lib; + +type + TSQLite3AuthorizerCallback = function(pAuthArg: Pointer; code: Integer; const zTab: PAnsiChar; const zCol: PAnsiChar; const zDb: PAnsiChar; const zAuthContext: PAnsiChar): Integer; cdecl; + +function sqlite3_set_authorizer(db: PSQLite3; xAuth: TSQLite3AuthorizerCallback; pUserData: Pointer): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_DENY = 1; + SQLITE_IGNORE = 2; + +const + SQLITE_CREATE_INDEX = 1; + SQLITE_CREATE_TABLE = 2; + SQLITE_CREATE_TEMP_INDEX = 3; + SQLITE_CREATE_TEMP_TABLE = 4; + SQLITE_CREATE_TEMP_TRIGGER = 5; + SQLITE_CREATE_TEMP_VIEW = 6; + SQLITE_CREATE_TRIGGER = 7; + SQLITE_CREATE_VIEW = 8; + SQLITE_DELETE = 9; + SQLITE_DROP_INDEX = 10; + SQLITE_DROP_TABLE = 11; + SQLITE_DROP_TEMP_INDEX = 12; + SQLITE_DROP_TEMP_TABLE = 13; + SQLITE_DROP_TEMP_TRIGGER = 14; + SQLITE_DROP_TEMP_VIEW = 15; + SQLITE_DROP_TRIGGER = 16; + SQLITE_DROP_VIEW = 17; + SQLITE_INSERT = 18; + SQLITE_PRAGMA = 19; + SQLITE_READ = 20; + SQLITE_SELECT = 21; + SQLITE_TRANSACTION = 22; + SQLITE_UPDATE = 23; + SQLITE_ATTACH = 24; + SQLITE_DETACH = 25; + SQLITE_ALTER_TABLE = 26; + SQLITE_REINDEX = 27; + SQLITE_ANALYZE = 28; + SQLITE_CREATE_VTABLE = 29; + SQLITE_DROP_VTABLE = 30; + SQLITE_FUNCTION = 31; + SQLITE_SAVEPOINT = 32; + SQLITE_COPY = 0; + +{$IFDEF SQLITE_EXPERIMENTAL} +type + TSQLite3TraceCallback = procedure(pTraceArg: Pointer; const zTrace: PAnsiChar); cdecl; + TSQLite3ProfileCallback = procedure(pProfileArg: Pointer; const zSql: PAnsiChar; elapseTime: UInt64); cdecl; + +function sqlite3_trace(db: PSQLite3; xTrace: TSQLite3TraceCallback; pArg: Pointer): Pointer; cdecl; external sqlite3_lib; +function sqlite3_profile(db: PSQLite3; xProfile: TSQLite3ProfileCallback; pArg: Pointer): Pointer; cdecl; external sqlite3_lib; +{$ENDIF} + +type + TSQLite3ProgressCallback = function(pProgressArg: Pointer): Integer; cdecl; + +procedure sqlite3_progress_handler(db: PSQLite3; nOps: Integer; xProgress: TSQLite3ProgressCallback; pArg: Pointer); cdecl; external sqlite3_lib; + +function sqlite3_open(const filename: PAnsiChar; var ppDb: PSQLite3): Integer; cdecl; external sqlite3_lib; +function sqlite3_open16(const filename: PWideChar; var ppDb: PSQLite3): Integer; cdecl; external sqlite3_lib; +function sqlite3_open_v2(const filename: PAnsiChar; var ppDb: PSQLite3; flags: Integer; const zVfs: PAnsiChar): Integer; cdecl; external sqlite3_lib; + +function sqlite3_errcode(db: PSQLite3): Integer; cdecl; external sqlite3_lib; +function sqlite3_extended_errcode(db: PSQLite3): Integer; cdecl; external sqlite3_lib; +function sqlite3_errmsg(db: PSQLite3): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_errmsg16(db: PSQLite3): PWideChar; cdecl; external sqlite3_lib; + +type + PSQLite3Stmt = type Pointer; + +function sqlite3_limit(db: PSQLite3; limitId: Integer; newLimit: Integer): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_LIMIT_LENGTH = 0; + SQLITE_LIMIT_SQL_LENGTH = 1; + SQLITE_LIMIT_COLUMN = 2; + SQLITE_LIMIT_EXPR_DEPTH = 3; + SQLITE_LIMIT_COMPOUND_SELECT = 4; + SQLITE_LIMIT_VDBE_OP = 5; + SQLITE_LIMIT_FUNCTION_ARG = 6; + SQLITE_LIMIT_ATTACHED = 7; + SQLITE_LIMIT_LIKE_PATTERN_LENGTH = 8; + SQLITE_LIMIT_VARIABLE_NUMBER = 9; + SQLITE_LIMIT_TRIGGER_DEPTH = 10; + +function sqlite3_prepare(db: PSQLite3; const zSql: PAnsiChar; nByte: Integer; var ppStmt: PSQLite3Stmt; const pzTail: PPAnsiChar): Integer; cdecl; external sqlite3_lib; +function sqlite3_prepare_v2(db: PSQLite3; const zSql: PAnsiChar; nByte: Integer; var ppStmt: PSQLite3Stmt; const pzTail: PPAnsiChar): Integer; cdecl; external sqlite3_lib; +function sqlite3_prepare16(db: PSQLite3; const zSql: PWideChar; nByte: Integer; var ppStmt: PSQLite3Stmt; const pzTail: PPWideChar): Integer; cdecl; external sqlite3_lib; +function sqlite3_prepare16_v2(db: PSQLite3; const zSql: PWideChar; nByte: Integer; var ppStmt: PSQLite3Stmt; const pzTail: PPWideChar): Integer; cdecl; external sqlite3_lib; + +function sqlite3_sql(pStmt: PSQLite3Stmt): PAnsiChar; cdecl; external sqlite3_lib; + +type + PSQLite3Value = ^TSQLite3Value; + sqlite3_value = type Pointer; + TSQLite3Value = sqlite3_value; + + PPSQLite3ValueArray = ^TPSQLite3ValueArray; + TPSQLite3ValueArray = array[0..MaxInt div SizeOf(PSQLite3Value) - 1] of PSQLite3Value; + +type + PSQLite3Context = type Pointer; + +type + TSQLite3DestructorType = procedure(p: Pointer); cdecl; + +const + SQLITE_STATIC = Pointer(0); + SQLITE_TRANSIENT = Pointer(-1); + +function sqlite3_bind_blob(pStmt: PSQLite3Stmt; i: Integer; const zData: Pointer; n: Integer; xDel: TSQLite3DestructorType): Integer; cdecl; external sqlite3_lib; +function sqlite3_bind_double(pStmt: PSQLite3Stmt; i: Integer; rValue: Double): Integer; cdecl; external sqlite3_lib; +function sqlite3_bind_int(p: PSQLite3Stmt; i: Integer; iValue: Integer): Integer; cdecl; external sqlite3_lib; +function sqlite3_bind_int64(pStmt: PSQLite3Stmt; i: Integer; iValue: Int64): Integer; cdecl; external sqlite3_lib; +function sqlite3_bind_null(pStmt: PSQLite3Stmt; i: Integer): Integer; cdecl; external sqlite3_lib; +function sqlite3_bind_text(pStmt: PSQLite3Stmt; i: Integer; const zData: PAnsiChar; n: Integer; xDel: TSQLite3DestructorType): Integer; cdecl; external sqlite3_lib; +function sqlite3_bind_text16(pStmt: PSQLite3Stmt; i: Integer; const zData: PWideChar; nData: Integer; xDel: TSQLite3DestructorType): Integer; cdecl; external sqlite3_lib; +function sqlite3_bind_value(pStmt: PSQLite3Stmt; i: Integer; const pValue: PSQLite3Value): Integer; cdecl; external sqlite3_lib; +function sqlite3_bind_zeroblob(pStmt: PSQLite3Stmt; i: Integer; n: Integer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_bind_parameter_count(pStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; + +function sqlite3_bind_parameter_name(pStmt: PSQLite3Stmt; i: Integer): PAnsiChar; cdecl; external sqlite3_lib; + +function sqlite3_bind_parameter_index(pStmt: PSQLite3Stmt; const zName: PAnsiChar): Integer; cdecl; external sqlite3_lib; + +function sqlite3_clear_bindings(pStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; + +function sqlite3_column_count(pStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; + +function sqlite3_column_name(pStmt: PSQLite3Stmt; N: Integer): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_column_name16(pStmt: PSQLite3Stmt; N: Integer): PWideChar; cdecl; external sqlite3_lib; + +{$IFDEF SQLITE_ENABLE_COLUMN_METADATA} +function sqlite3_column_database_name(pStmt: PSQLite3Stmt; N: Integer): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_column_database_name16(pStmt: PSQLite3Stmt; N: Integer): PWideChar; cdecl; external sqlite3_lib; +function sqlite3_column_table_name(pStmt: PSQLite3Stmt; N: Integer): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_column_table_name16(pStmt: PSQLite3Stmt; N: Integer): PWideChar; cdecl; external sqlite3_lib; +function sqlite3_column_origin_name(pStmt: PSQLite3Stmt; N: Integer): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_column_origin_name16(pStmt: PSQLite3Stmt; N: Integer): PWideChar; cdecl; external sqlite3_lib; +{$ENDIF} + +function sqlite3_column_decltype(pStmt: PSQLite3Stmt; N: Integer): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_column_decltype16(pStmt: PSQLite3Stmt; N: Integer): PWideChar; cdecl; external sqlite3_lib; + +function sqlite3_step(pStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; + +function sqlite3_data_count(pStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_INTEGER = 1; + SQLITE_FLOAT = 2; + SQLITE_BLOB = 4; + SQLITE_NULL = 5; + SQLITE_TEXT = 3; + SQLITE3_TEXT = 3; + +function sqlite3_column_blob(pStmt: PSQLite3Stmt; iCol: Integer): Pointer; cdecl; external sqlite3_lib; +function sqlite3_column_bytes(pStmt: PSQLite3Stmt; iCol: Integer): Integer; cdecl; external sqlite3_lib; +function sqlite3_column_bytes16(pStmt: PSQLite3Stmt; iCol: Integer): Integer; cdecl; external sqlite3_lib; +function sqlite3_column_double(pStmt: PSQLite3Stmt; iCol: Integer): Double; cdecl; external sqlite3_lib; +function sqlite3_column_int(pStmt: PSQLite3Stmt; iCol: Integer): Integer; cdecl; external sqlite3_lib; +function sqlite3_column_int64(pStmt: PSQLite3Stmt; iCol: Integer): Int64; cdecl; external sqlite3_lib; +function sqlite3_column_text(pStmt: PSQLite3Stmt; iCol: Integer): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_column_text16(pStmt: PSQLite3Stmt; iCol: Integer): PWideChar; cdecl; external sqlite3_lib; +function sqlite3_column_type(pStmt: PSQLite3Stmt; iCol: Integer): Integer; cdecl; external sqlite3_lib; +function sqlite3_column_value(pStmt: PSQLite3Stmt; iCol: Integer): PSQLite3Value; cdecl; external sqlite3_lib; + +function sqlite3_finalize(pStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; + +function sqlite3_reset(pStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; + +type + TSQLite3RegularFunction = procedure(ctx: PSQLite3Context; n: Integer; apVal: PPSQLite3ValueArray); cdecl; + TSQLite3AggregateStep = procedure(ctx: PSQLite3Context; n: Integer; apVal: PPSQLite3ValueArray); cdecl; + TSQLite3AggregateFinalize = procedure(ctx: PSQLite3Context); cdecl; + +function sqlite3_create_function(db: PSQLite3; const zFunctionName: PAnsiChar; nArg: Integer; eTextRep: Integer; pApp: Pointer; xFunc: TSQLite3RegularFunction; xStep: TSQLite3AggregateStep; xFinal: TSQLite3AggregateFinalize): Integer; cdecl; external sqlite3_lib; +function sqlite3_create_function16(db: PSQLite3; const zFunctionName: PWideChar; nArg: Integer; eTextRep: Integer; pApp: Pointer; xFunc: TSQLite3RegularFunction; xStep: TSQLite3AggregateStep; xFinal: TSQLite3AggregateFinalize): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_UTF8 = 1; + SQLITE_UTF16LE = 2; + SQLITE_UTF16BE = 3; + SQLITE_UTF16 = 4; + SQLITE_ANY = 5; + SQLITE_UTF16_ALIGNED = 8; + +{$IFDEF SQLITE_DEPRECATED} +type + TSQLite3MemoryAlarmCallback = procedure(pArg: Pointer; used: Int64; N: Integer); cdecl; + +function sqlite3_aggregate_count(p: PSQLite3Context): Integer; cdecl; external sqlite3_lib; +function sqlite3_expired(pStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; +function sqlite3_transfer_bindings(pFromStmt: PSQLite3Stmt; pToStmt: PSQLite3Stmt): Integer; cdecl; external sqlite3_lib; +function sqlite3_global_recover: Integer; cdecl; external sqlite3_lib; +procedure sqlite3_thread_cleanup; cdecl; external sqlite3_lib; +function sqlite3_memory_alarm(xCallback: TSQLite3MemoryAlarmCallback; pArg: Pointer; iThreshold: Int64): Integer; cdecl; external sqlite3_lib; +{$ENDIF} + +function sqlite3_value_blob(pVal: PSQLite3Value): Pointer; cdecl; external sqlite3_lib; +function sqlite3_value_bytes(pVal: PSQLite3Value): Integer; cdecl; external sqlite3_lib; +function sqlite3_value_bytes16(pVal: PSQLite3Value): Integer; cdecl; external sqlite3_lib; +function sqlite3_value_double(pVal: PSQLite3Value): Double; cdecl; external sqlite3_lib; +function sqlite3_value_int(pVal: PSQLite3Value): Integer; cdecl; external sqlite3_lib; +function sqlite3_value_int64(pVal: PSQLite3Value): Int64; cdecl; external sqlite3_lib; +function sqlite3_value_text(pVal: PSQLite3Value): PAnsiChar; cdecl; external sqlite3_lib; +function sqlite3_value_text16(pVal: PSQLite3Value): PWideChar; cdecl; external sqlite3_lib; +function sqlite3_value_text16le(pVal: PSQLite3Value): Pointer; cdecl; external sqlite3_lib; +function sqlite3_value_text16be(pVal: PSQLite3Value): Pointer; cdecl; external sqlite3_lib; +function sqlite3_value_type(pVal: PSQLite3Value): Integer; cdecl; external sqlite3_lib; +function sqlite3_value_numeric_type(pVal: PSQLite3Value): Integer; cdecl; external sqlite3_lib; + +function sqlite3_aggregate_context(p: PSQLite3Context; nBytes: Integer): Pointer; cdecl; external sqlite3_lib; + +function sqlite3_user_data(p: PSQLite3Context): Pointer; cdecl; external sqlite3_lib; + +function sqlite3_context_db_handle(p: PSQLite3Context): PSQLite3; cdecl; external sqlite3_lib; + +type + TSQLite3AuxDataDestructor = procedure(pAux: Pointer); cdecl; + +function sqlite3_get_auxdata(pCtx: PSQLite3Context; N: Integer): Pointer; cdecl; external sqlite3_lib; +procedure sqlite3_set_auxdata(pCtx: PSQLite3Context; N: Integer; pAux: Pointer; xDelete: TSQLite3AuxDataDestructor); cdecl; external sqlite3_lib; + +procedure sqlite3_result_blob(pCtx: PSQLite3Context; const z: Pointer; n: Integer; xDel: TSQLite3DestructorType); cdecl; external sqlite3_lib; +procedure sqlite3_result_double(pCtx: PSQLite3Context; rVal: Double); cdecl; external sqlite3_lib; +procedure sqlite3_result_error(pCtx: PSQLite3Context; const z: PAnsiChar; n: Integer); cdecl; external sqlite3_lib; +procedure sqlite3_result_error16(pCtx: PSQLite3Context; const z: PWideChar; n: Integer); cdecl; external sqlite3_lib; +procedure sqlite3_result_error_toobig(pCtx: PSQLite3Context); cdecl; external sqlite3_lib; +procedure sqlite3_result_error_nomem(pCtx: PSQLite3Context); cdecl; external sqlite3_lib; +procedure sqlite3_result_error_code(pCtx: PSQLite3Context; errCode: Integer); cdecl; external sqlite3_lib; +procedure sqlite3_result_int(pCtx: PSQLite3Context; iVal: Integer); cdecl; external sqlite3_lib; +procedure sqlite3_result_int64(pCtx: PSQLite3Context; iVal: Int64); cdecl; external sqlite3_lib; +procedure sqlite3_result_null(pCtx: PSQLite3Context); cdecl; external sqlite3_lib; +procedure sqlite3_result_text(pCtx: PSQLite3Context; const z: PAnsiChar; n: Integer; xDel: TSQLite3DestructorType); cdecl; external sqlite3_lib; +procedure sqlite3_result_text16(pCtx: PSQLite3Context; const z: PWideChar; n: Integer; xDel: TSQLite3DestructorType); cdecl; external sqlite3_lib; +procedure sqlite3_result_text16le(pCtx: PSQLite3Context; const z: Pointer; n: Integer; xDel: TSQLite3DestructorType); cdecl; external sqlite3_lib; +procedure sqlite3_result_text16be(pCtx: PSQLite3Context; const z: Pointer; n: Integer; xDel: TSQLite3DestructorType); cdecl; external sqlite3_lib; +procedure sqlite3_result_value(pCtx: PSQLite3Context; pValue: PSQLite3Value); cdecl; external sqlite3_lib; +procedure sqlite3_result_zeroblob(pCtx: PSQLite3Context; n: Integer); cdecl; external sqlite3_lib; + +type + TSQLite3CollationCompare = function(pUser: Pointer; n1: Integer; const z1: Pointer; n2: Integer; const z2: Pointer): Integer; cdecl; + TSQLite3CollationDestructor = procedure(pUser: Pointer); cdecl; + +function sqlite3_create_collation(db: PSQLite3; const zName: PAnsiChar; eTextRep: Integer; pUser: Pointer; xCompare: TSQLite3CollationCompare): Integer; cdecl; external sqlite3_lib; +function sqlite3_create_collation_v2(db: PSQLite3; const zName: PAnsiChar; eTextRep: Integer; pUser: Pointer; xCompare: TSQLite3CollationCompare; xDestroy: TSQLite3CollationDestructor): Integer; cdecl; external sqlite3_lib; +function sqlite3_create_collation16(db: PSQLite3; const zName: PWideChar; eTextRep: Integer; pUser: Pointer; xCompare: TSQLite3CollationCompare): Integer; cdecl; external sqlite3_lib; + +type + TSQLite3CollationNeededCallback = procedure(pCollNeededArg: Pointer; db: PSQLite3; eTextRep: Integer; const zExternal: PAnsiChar); cdecl; + TSQLite3CollationNeededCallback16 = procedure(pCollNeededArg: Pointer; db: PSQLite3; eTextRep: Integer; const zExternal: PWideChar); cdecl; + +function sqlite3_collation_needed(db: PSQLite3; pCollNeededArg: Pointer; xCollNeeded: TSQLite3CollationNeededCallback): Integer; cdecl; external sqlite3_lib; +function sqlite3_collation_needed16(db: PSQLite3; pCollNeededArg: Pointer; xCollNeeded16: TSQLite3CollationNeededCallback16): Integer; cdecl; external sqlite3_lib; + +//function sqlite3_key(db: PSQLite3; const pKey: Pointer; nKey: Integer): Integer; cdecl; external sqlite3_lib; + +//function sqlite3_rekey(db: PSQLite3; const pKey: Pointer; nKey: Integer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_sleep(ms: Integer): Integer; cdecl; external sqlite3_lib; + +//var sqlite3_temp_directory: PAnsiChar; + +function sqlite3_get_autocommit(db: PSQLite3): Integer; cdecl; external sqlite3_lib; + +function sqlite3_db_handle(pStmt: PSQLite3Stmt): PSQLite3; cdecl; external sqlite3_lib; + +function sqlite3_next_stmt(pDb: PSQLite3; pStmt: PSQLite3Stmt): PSQLite3Stmt; cdecl; external sqlite3_lib; + +type + TSQLite3CommitCallback = function(pCommitArg: Pointer): Integer; cdecl; + TSQLite3RollbackCallback = procedure(pRollbackArg: Pointer); cdecl; + +function sqlite3_commit_hook(db: PSQLite3; xCallback: TSQLite3CommitCallback; pArg: Pointer): Pointer; cdecl; external sqlite3_lib; +function sqlite3_rollback_hook(db: PSQLite3; xCallback: TSQLite3RollbackCallback; pArg: Pointer): Pointer; cdecl; external sqlite3_lib; + +type + TSQLite3UpdateCallback = procedure(pUpdateArg: Pointer; op: Integer; const zDb: PAnsiChar; const zTbl: PAnsiChar; iKey: Int64); cdecl; + +function sqlite3_update_hook(db: PSQLite3; xCallback: TSQLite3UpdateCallback; pArg: Pointer): Pointer; cdecl; external sqlite3_lib; + +function sqlite3_enable_shared_cache(enable: Integer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_release_memory(n: Integer): Integer; cdecl; external sqlite3_lib; + +procedure sqlite3_soft_heap_limit(n: Integer); cdecl; external sqlite3_lib; + +{$IFDEF SQLITE_ENABLE_COLUMN_METADATA} +function sqlite3_table_column_metadata(db: PSQLite3; const zDbName: PAnsiChar; const zTableName: PAnsiChar; const zColumnName: PAnsiChar; const pzDataType: PPAnsiChar; const pzCollSeq: PPAnsiChar; pNotNull: PInteger; pPrimaryKey: PInteger; pAutoinc: PInteger): Integer; cdecl; external sqlite3_lib; +{$ENDIF} + +function sqlite3_load_extension(db: PSQLite3; const zFile: PAnsiChar; const zProc: PAnsiChar; pzErrMsg: PPAnsiChar): Integer; cdecl; external sqlite3_lib; + +function sqlite3_enable_load_extension(db: PSQLite3; onoff: Integer): Integer; cdecl; external sqlite3_lib; + +type + TSQLiteAutoExtensionEntryPoint = procedure; cdecl; + +function sqlite3_auto_extension(xEntryPoint: TSQLiteAutoExtensionEntryPoint): Integer; cdecl; external sqlite3_lib; + +procedure sqlite3_reset_auto_extension; cdecl; external sqlite3_lib; + +{$IFDEF SQLITE_EXPERIMENTAL} +type + TSQLite3FTS3Func = procedure(pContext: PSQLite3Context; argc: Integer; argv: PPSQLite3ValueArray); cdecl; + +type + PSQLite3VTab = ^TSQLite3VTab; + PSQLite3IndexInfo = ^TSQLite3IndexInfo; + PSQLite3VTabCursor = ^TSQLite3VTabCursor; + PSQLite3Module = ^TSQLite3Module; + + sqlite3_module = record + iVersion: Integer; + xCreate: function(db: PSQLite3; pAux: Pointer; argc: Integer; const argv: PPAnsiCharArray; var ppVTab: PSQLite3VTab; var pzErr: PAnsiChar): Integer; cdecl; + xConnect: function(db: PSQLite3; pAux: Pointer; argc: Integer; const argv: PPAnsiCharArray; var ppVTab: PSQLite3VTab; var pzErr: PAnsiChar): Integer; cdecl; + xBestIndex: function(pVTab: PSQLite3VTab; pInfo: PSQLite3IndexInfo): Integer; cdecl; + xDisconnect: function(pVTab: PSQLite3VTab): Integer; cdecl; + xDestroy: function(pVTab: PSQLite3VTab): Integer; cdecl; + xOpen: function(pVTab: PSQLite3VTab; var ppCursor: PSQLite3VTabCursor): Integer; cdecl; + xClose: function(pVtabCursor: PSQLite3VTabCursor): Integer; cdecl; + xFilter: function(pVtabCursor: PSQLite3VTabCursor; idxNum: Integer; const idxStr: PAnsiChar; argc: Integer; argv: PPSQLite3ValueArray): Integer; cdecl; + xNext: function(pVtabCursor: PSQLite3VTabCursor): Integer; cdecl; + xEof: function(pVtabCursor: PSQLite3VTabCursor): Integer; cdecl; + xColumn: function(pVtabCursor: PSQLite3VTabCursor; sContext: PSQLite3Context; p2: Integer): Integer; cdecl; + xRowid: function(pVtabCursor: PSQLite3VTabCursor; var pRowid: Int64): Integer; cdecl; + xUpdate: function(pVtab: PSQLite3VTab; nArg: Integer; ppArg: PPSQLite3ValueArray; var pRowid: Int64): Integer; cdecl; + xBegin: function(pVTab: PSQLite3VTab): Integer; cdecl; + xSync: function(pVTab: PSQLite3VTab): Integer; cdecl; + xCommit: function(pVTab: PSQLite3VTab): Integer; cdecl; + xRollback: function(pVTab: PSQLite3VTab): Integer; cdecl; + xFindFunction: function(pVtab: PSQLite3VTab; nArg: Integer; const zName: PAnsiChar; var pxFunc: TSQLite3FTS3Func; var ppArg: Pointer): Integer; cdecl; + xRename: function(pVtab: PSQLite3VTab; const zNew: PAnsiChar): Integer; cdecl; + end; + TSQLite3Module = sqlite3_module; + + sqlite3_index_constraint = record + iColumn: Integer; + op: Byte; + usable: Byte; + iTermOffset: Integer; + end; + TSQLite3IndexConstraint = sqlite3_index_constraint; + + PSQLite3IndexConstraintArray = ^TSQLite3IndexConstraintArray; + TSQLite3IndexConstraintArray = array[0..MaxInt div SizeOf(TSQLite3IndexConstraint) - 1] of TSQLite3IndexConstraint; + + sqlite3_index_orderby = record + iColumn: Integer; + desc: Byte; + end; + TSQLite3IndexOrderBy = sqlite3_index_orderby; + + PSQLite3IndexOrderByArray = ^TSQLite3IndexOrderByArray; + TSQLite3IndexOrderByArray = array[0..MaxInt div SizeOf(TSQLite3IndexOrderBy) - 1] of TSQLite3IndexOrderBy; + + sqlite3_index_constraint_usage = record + argvIndex: Integer; + omit: Byte; + end; + TSQLite3IndexConstraintUsage = sqlite3_index_constraint_usage; + + PSQLite3IndexConstraintUsageArray = ^TSQLite3IndexConstraintUsageArray; + TSQLite3IndexConstraintUsageArray = array[0..MaxInt div SizeOf(TSQLite3IndexConstraintUsage) - 1] of TSQLite3IndexConstraintUsage; + + sqlite3_index_info = record + nConstraint: Integer; + aConstraint: PSQLite3IndexConstraintArray; + nOrderBy: Integer; + aOrderBy: PSQLite3IndexOrderByArray; + aConstraintUsage: PSQLite3IndexConstraintUsageArray; + idxNum: Integer; + idxStr: PAnsiChar; + needToFreeIdxStr: Integer; + orderByConsumed: Integer; + estimatedCost: Double; + end; + TSQLite3IndexInfo = sqlite3_index_info; + + sqlite3_vtab = record + pModule: PSQLite3Module; + nRef: Integer; + zErrMsg: PAnsiChar; + end; + TSQLite3VTab = sqlite3_vtab; + + sqlite3_vtab_cursor = record + pVtab: PSQLite3VTab; + end; + TSQLite3VTabCursor = sqlite3_vtab_cursor; + +const + SQLITE_INDEX_CONSTRAINT_EQ = 2; + SQLITE_INDEX_CONSTRAINT_GT = 4; + SQLITE_INDEX_CONSTRAINT_LE = 8; + SQLITE_INDEX_CONSTRAINT_LT = 16; + SQLITE_INDEX_CONSTRAINT_GE = 32; + SQLITE_INDEX_CONSTRAINT_MATCH = 64; + +function sqlite3_create_module(db: PSQLite3; const zName: PAnsiChar; const p: PSQLite3Module; pClientData: Pointer): Integer; cdecl; external sqlite3_lib; + +type + TSQLite3ModuleDestructor = procedure(pAux: Pointer); cdecl; + +function sqlite3_create_module_v2(db: PSQLite3; const zName: PAnsiChar; const p: PSQLite3Module; pClientData: Pointer; xDestroy: TSQLite3ModuleDestructor): Integer; cdecl; external sqlite3_lib; + +function sqlite3_declare_vtab(db: PSQLite3; const zSQL: PAnsiChar): Integer; cdecl; external sqlite3_lib; + +function sqlite3_overload_function(db: PSQLite3; const zFuncName: PAnsiChar; nArg: Integer): Integer; cdecl; external sqlite3_lib; +{$ENDIF} + +type + PSQLite3Blob = type Pointer; + +function sqlite3_blob_open(db: PSQLite3; const zDb: PAnsiChar; const zTable: PAnsiChar; const zColumn: PAnsiChar; iRow: Int64; flags: Integer; var ppBlob: PSQLite3Blob): Integer; cdecl; external sqlite3_lib; + +function sqlite3_blob_close(pBlob: PSQLite3Blob): Integer; cdecl; external sqlite3_lib; + +function sqlite3_blob_bytes(pBlob: PSQLite3Blob): Integer; cdecl; external sqlite3_lib; + +function sqlite3_blob_read(pBlob: PSQLite3Blob; Z: Pointer; N: Integer; iOffset: Integer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_blob_write(pBlob: PSQLite3Blob; const z: Pointer; n: Integer; iOffset: Integer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_vfs_find(const zVfsName: PAnsiChar): PSQLite3VFS; cdecl; external sqlite3_lib; +function sqlite3_vfs_register(pVfs: PSQLite3VFS; makeDflt: Integer): Integer; cdecl; external sqlite3_lib; +function sqlite3_vfs_unregister(pVfs: PSQLite3VFS): Integer; cdecl; external sqlite3_lib; + +function sqlite3_mutex_alloc(id: Integer): PSQLite3Mutex; cdecl; external sqlite3_lib; +procedure sqlite3_mutex_free(p: PSQLite3Mutex); cdecl; external sqlite3_lib; +procedure sqlite3_mutex_enter(p: PSQLite3Mutex); cdecl; external sqlite3_lib; +function sqlite3_mutex_try(p: PSQLite3Mutex): Integer; cdecl; external sqlite3_lib; +procedure sqlite3_mutex_leave(p: PSQLite3Mutex); cdecl; external sqlite3_lib; + +{$IFDEF SQLITE_EXPERIMENTAL} +type + sqlite3_mutex_methods = record + xMutexInit: function: Integer; cdecl; + xMutexEnd: function: Integer; cdecl; + xMutexAlloc: function(id: Integer): PSQLite3Mutex; cdecl; + xMutexFree: procedure(p: PSQLite3Mutex); cdecl; + xMutexEnter: procedure(p: PSQLite3Mutex); cdecl; + xMutexTry: function(p: PSQLite3Mutex): Integer; cdecl; + xMutexLeave: procedure(p: PSQLite3Mutex); cdecl; + xMutexHeld: function(p: PSQLite3Mutex): Integer; cdecl; + xMutexNotheld: function(p: PSQLite3Mutex): Integer; cdecl; + end; + TSQLite3MutexMethods = sqlite3_mutex_methods; +{$ENDIF} + +{$IFDEF SQLITE_DEBUG} +function sqlite3_mutex_held(p: PSQLite3Mutex): Integer; cdecl; external sqlite3_lib; +function sqlite3_mutex_notheld(p: PSQLite3Mutex): Integer; cdecl; external sqlite3_lib; +{$ENDIF} + +const + SQLITE_MUTEX_FAST = 0; + SQLITE_MUTEX_RECURSIVE = 1; + SQLITE_MUTEX_STATIC_MASTER = 2; + SQLITE_MUTEX_STATIC_MEM = 3; + SQLITE_MUTEX_STATIC_MEM2 = 4; + SQLITE_MUTEX_STATIC_OPEN = 4; + SQLITE_MUTEX_STATIC_PRNG = 5; + SQLITE_MUTEX_STATIC_LRU = 6; + SQLITE_MUTEX_STATIC_LRU2 = 7; + +function sqlite3_db_mutex(db: PSQLite3): PSQLite3Mutex; cdecl; external sqlite3_lib; + +function sqlite3_file_control(db: PSQLite3; const zDbName: PAnsiChar; op: Integer; pArg: Pointer): Integer; cdecl; external sqlite3_lib; + +function sqlite3_test_control(op: Integer{; ...}): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_TESTCTRL_FIRST = 5; + SQLITE_TESTCTRL_PRNG_SAVE = 5; + SQLITE_TESTCTRL_PRNG_RESTORE = 6; + SQLITE_TESTCTRL_PRNG_RESET = 7; + SQLITE_TESTCTRL_BITVEC_TEST = 8; + SQLITE_TESTCTRL_FAULT_INSTALL = 9; + SQLITE_TESTCTRL_BENIGN_MALLOC_HOOKS = 10; + SQLITE_TESTCTRL_PENDING_BYTE = 11; + SQLITE_TESTCTRL_ASSERT = 12; + SQLITE_TESTCTRL_ALWAYS = 13; + SQLITE_TESTCTRL_RESERVE = 14; + SQLITE_TESTCTRL_OPTIMIZATIONS = 15; + SQLITE_TESTCTRL_ISKEYWORD = 16; + SQLITE_TESTCTRL_LAST = 16; + +{$IFDEF SQLITE_EXPERIMENTAL} +function sqlite3_status(op: Integer; var pCurrent: Integer; var pHighwater: Integer; resetFlag: Integer): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_STATUS_MEMORY_USED = 0; + SQLITE_STATUS_PAGECACHE_USED = 1; + SQLITE_STATUS_PAGECACHE_OVERFLOW = 2; + SQLITE_STATUS_SCRATCH_USED = 3; + SQLITE_STATUS_SCRATCH_OVERFLOW = 4; + SQLITE_STATUS_MALLOC_SIZE = 5; + SQLITE_STATUS_PARSER_STACK = 6; + SQLITE_STATUS_PAGECACHE_SIZE = 7; + SQLITE_STATUS_SCRATCH_SIZE = 8; + +function sqlite3_db_status(db: PSQLite3; op: Integer; var pCur: Integer; var pHiwtr: Integer; resetFlg: Integer): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_DBSTATUS_LOOKASIDE_USED = 0; + +function sqlite3_stmt_status(pStmt: PSQLite3Stmt; op: Integer; resetFlg: Integer): Integer; cdecl; external sqlite3_lib; + +const + SQLITE_STMTSTATUS_FULLSCAN_STEP = 1; + SQLITE_STMTSTATUS_SORT = 2; + +type + PSQLite3PCache = type Pointer; + +type + sqlite3_pcache_methods = record + pArg: Pointer; + xInit: function(pArg: Pointer): Integer; cdecl; + xShutdown: procedure(pArg: Pointer); cdecl; + xCreate: function(szPage: Integer; bPurgeable: Integer): PSQLite3PCache; cdecl; + xCachesize: procedure(pCache: PSQLite3PCache; nCachesize: Integer); cdecl; + xPagecount: function(pCache: PSQLite3PCache): Integer; cdecl; + xFetch: function(pCache: PSQLite3PCache; key: Cardinal; createFlag: Integer): Pointer; cdecl; + xUnpin: procedure(pCache: PSQLite3PCache; pPg: Pointer; discard: Integer); cdecl; + xRekey: procedure(pCache: PSQLite3PCache; pPg: Pointer; oldKey: Cardinal; newKey: Cardinal); cdecl; + xTruncate: procedure(pCache: PSQLite3PCache; iLimit: Cardinal); cdecl; + xDestroy: procedure(pCache: PSQLite3PCache); cdecl; + end; + TSQLite3PCacheMethods = sqlite3_pcache_methods; + +type + PSQLite3Backup = type Pointer; + +function sqlite3_backup_init(pDest: PSQLite3; const zDestName: PAnsiChar; pSource: PSQLite3; const zSourceName: PAnsiChar): PSQLite3Backup; cdecl; external sqlite3_lib; +function sqlite3_backup_step(p: PSQLite3Backup; nPage: Integer): Integer; cdecl; external sqlite3_lib; +function sqlite3_backup_finish(p: PSQLite3Backup): Integer; cdecl; external sqlite3_lib; +function sqlite3_backup_remaining(p: PSQLite3Backup): Integer; cdecl; external sqlite3_lib; +function sqlite3_backup_pagecount(p: PSQLite3Backup): Integer; cdecl; external sqlite3_lib; + +{$IFDEF SQLITE_ENABLE_UNLOCK_NOTIFY} +type + TSQLite3UnlockNotifyCallback = procedure(apArg: PPointerArray; nArg: Integer); cdecl; + +function sqlite3_unlock_notify(pBlocked: PSQLite3; xNotify: TSQLite3UnlockNotifyCallback; pNotifyArg: Pointer): Integer; cdecl; external sqlite3_lib; +{$ENDIF} + +function sqlite3_strnicmp(const zLeft: PAnsiChar; const zRight: PAnsiChar; N: Integer): Integer; cdecl; external sqlite3_lib; +{$ENDIF} + +//function sqlite3_win32_mbcs_to_utf8(const S: PAnsiChar): PAnsiChar; cdecl; external sqlite3_lib; + +implementation + +end. diff --git a/Tocsg.Lib/VCL/SQLite3/EM.SQLite3Utils.pas b/Tocsg.Lib/VCL/SQLite3/EM.SQLite3Utils.pas new file mode 100644 index 00000000..4867164a --- /dev/null +++ b/Tocsg.Lib/VCL/SQLite3/EM.SQLite3Utils.pas @@ -0,0 +1,95 @@ +{* + * SQLite for Delphi and FreePascal/Lazarus + * + * This unit contains miscellaneous utility functions + * + * Copyright 2010-2013 Yury Plashenkov + * http://plashenkov.github.io/sqlite/ + * + * The MIT License (MIT) + * + * 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 EM.SQLite3Utils; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +function StrToUTF8(const S: WideString): AnsiString; +function UTF8ToStr(const S: PAnsiChar; const Len: Integer = -1): WideString; +function QuotedStr(const S: WideString): WideString; +function FloatToSQLStr(Value: Extended): WideString; + +implementation + +uses + {$IFNDEF FPC}Windows,{$ENDIF} SysUtils; + +function StrToUTF8(const S: WideString): AnsiString; +begin + Result := UTF8Encode(S); +end; + +function UTF8ToStr(const S: PAnsiChar; const Len: Integer): WideString; +var + UTF8Str: AnsiString; +begin + if Len < 0 then + begin + Result := UTF8Decode(S); + end + else if Len > 0 then + begin + SetLength(UTF8Str, Len); + Move(S^, UTF8Str[1], Len); + Result := UTF8Decode(UTF8Str); + end + else Result := ''; +end; + +function QuotedStr(const S: WideString): WideString; +const + Quote = #39; +var + I: Integer; +begin + Result := S; + for I := Length(Result) downto 1 do + if Result[I] = Quote then Insert(Quote, Result, I); + Result := Quote + Result + Quote; +end; + +function FloatToSQLStr(Value: Extended): WideString; +var + FS: TFormatSettings; +begin +{$IFDEF FPC} + FS := DefaultFormatSettings; +{$ELSE} + GetLocaleFormatSettings(GetThreadLocale, FS); +{$ENDIF} + FS.DecimalSeparator := '.'; + Result := FloatToStr(Value, FS); +end; + +end. \ No newline at end of file diff --git a/Tocsg.Lib/VCL/SQLite3/EM.SQLite3Wrap.pas b/Tocsg.Lib/VCL/SQLite3/EM.SQLite3Wrap.pas new file mode 100644 index 00000000..fe3bf404 --- /dev/null +++ b/Tocsg.Lib/VCL/SQLite3/EM.SQLite3Wrap.pas @@ -0,0 +1,480 @@ +{* + * SQLite for Delphi and FreePascal/Lazarus + * + * This unit contains easy-to-use object wrapper over SQLite3 API functions + * + * Copyright 2010-2013 Yury Plashenkov + * http://plashenkov.github.io/sqlite/ + * + * The MIT License (MIT) + * + * 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 EM.SQLite3Wrap; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + SysUtils, Classes, SQLite3; + +type + ESQLite3Error = class(Exception); + + TSQLite3Statement = class; + TSQLite3BlobHandler = class; + + { TSQLite3Database class } + + TSQLite3Database = class(TObject) + private + FHandle: PSQLite3; + FStatementList: TList; + FBlobHandlerList: TList; + FTransactionOpen: Boolean; + procedure Check(const ErrCode: Integer); + procedure CheckHandle; + public + constructor Create; + destructor Destroy; override; + + procedure Open(const FileName: WideString; Flags: Integer = 0); + procedure Close; + + procedure Execute(const SQL: WideString); + function LastInsertRowID: Int64; + function Prepare(const SQL: WideString): TSQLite3Statement; + function BlobOpen(const Table, Column: WideString; const RowID: Int64; const WriteAccess: Boolean = True): TSQLite3BlobHandler; + + procedure BeginTransaction; + procedure Commit; + procedure Rollback; + + property Handle: PSQLite3 read FHandle; + property TransactionOpen: Boolean read FTransactionOpen; + end; + + { TSQLite3Statement class } + + TSQLite3Statement = class(TObject) + private + FHandle: PSQLite3Stmt; + FOwnerDatabase: TSQLite3Database; + function ParamIndexByName(const ParamName: WideString): Integer; + public + constructor Create(OwnerDatabase: TSQLite3Database; const SQL: WideString); + destructor Destroy; override; + + procedure BindInt(const ParamIndex: Integer; const Value: Integer); overload; + procedure BindInt64(const ParamIndex: Integer; const Value: Int64); overload; + procedure BindDouble(const ParamIndex: Integer; const Value: Double); overload; + procedure BindText(const ParamIndex: Integer; const Value: WideString); overload; + procedure BindNull(const ParamIndex: Integer); overload; + procedure BindBlob(const ParamIndex: Integer; Data: Pointer; const Size: Integer); overload; + procedure BindZeroBlob(const ParamIndex: Integer; const Size: Integer); overload; + procedure BindInt(const ParamName: WideString; const Value: Integer); overload; + procedure BindInt64(const ParamName: WideString; const Value: Int64); overload; + procedure BindDouble(const ParamName: WideString; const Value: Double); overload; + procedure BindText(const ParamName: WideString; const Value: WideString); overload; + procedure BindNull(const ParamName: WideString); overload; + procedure BindBlob(const ParamName: WideString; Data: Pointer; const Size: Integer); overload; + procedure BindZeroBlob(const ParamName: WideString; const Size: Integer); overload; + procedure ClearBindings; + + function Step: Integer; + procedure Reset; + function StepAndReset: Integer; + + function ColumnCount: Integer; + function ColumnName(const ColumnIndex: Integer): WideString; + function ColumnType(const ColumnIndex: Integer): Integer; + function ColumnInt(const ColumnIndex: Integer): Integer; + function ColumnInt64(const ColumnIndex: Integer): Int64; + function ColumnDouble(const ColumnIndex: Integer): Double; + function ColumnText(const ColumnIndex: Integer): WideString; + function ColumnBlob(const ColumnIndex: Integer): Pointer; + function ColumnBytes(const ColumnIndex: Integer): Integer; + + property Handle: PSQLite3Stmt read FHandle; + property OwnerDatabase: TSQLite3Database read FOwnerDatabase; + end; + + { TSQLite3BlobHandler class } + + TSQLite3BlobHandler = class(TObject) + private + FHandle: PSQLite3Blob; + FOwnerDatabase: TSQLite3Database; + public + constructor Create(OwnerDatabase: TSQLite3Database; const Table, Column: WideString; const RowID: Int64; const WriteAccess: Boolean = True); + destructor Destroy; override; + + function Bytes: Integer; + procedure Read(Buffer: Pointer; const Size, Offset: Integer); + procedure Write(Buffer: Pointer; const Size, Offset: Integer); + + property Handle: PSQLite3Blob read FHandle; + property OwnerDatabase: TSQLite3Database read FOwnerDatabase; + end; + +implementation + +uses + SQLite3Utils; + +resourcestring + SErrorMessage = 'SQLite3 error: %s'; + SDatabaseNotConnected = 'SQLite3 error: database is not connected.'; + STransactionAlreadyOpen = 'Transaction is already opened.'; + SNoTransactionOpen = 'No transaction is open'; + +{ TSQLite3Database } + +procedure TSQLite3Database.BeginTransaction; +begin + if not FTransactionOpen then + begin + Execute('BEGIN TRANSACTION;'); + FTransactionOpen := True; + end + else + raise ESQLite3Error.Create(STransactionAlreadyOpen); +end; + +function TSQLite3Database.BlobOpen(const Table, Column: WideString; + const RowID: Int64; const WriteAccess: Boolean): TSQLite3BlobHandler; +begin + Result := TSQLite3BlobHandler.Create(Self, Table, Column, RowID, WriteAccess); +end; + +procedure TSQLite3Database.Check(const ErrCode: Integer); +begin + if ErrCode <> SQLITE_OK then + raise ESQLite3Error.CreateFmt(SErrorMessage, [UTF8ToStr(sqlite3_errmsg(FHandle))]); +end; + +procedure TSQLite3Database.CheckHandle; +begin + if FHandle = nil then + raise ESQLite3Error.Create(SDatabaseNotConnected); +end; + +procedure TSQLite3Database.Close; +var + I: Integer; +begin + if FHandle <> nil then + begin + if FTransactionOpen then + Rollback; + // Delete all statements + for I := FStatementList.Count - 1 downto 0 do + TSQLite3Statement(FStatementList[I]).Free; + // Delete all blob handlers + for I := FBlobHandlerList.Count - 1 downto 0 do + TSQLite3BlobHandler(FBlobHandlerList[I]).Free; + sqlite3_close(FHandle); + FHandle := nil; + end; +end; + +procedure TSQLite3Database.Commit; +begin + if FTransactionOpen then + begin + Execute('COMMIT;'); + FTransactionOpen := False; + end + else + raise ESQLite3Error.Create(SNoTransactionOpen); +end; + +constructor TSQLite3Database.Create; +begin + FHandle := nil; + FStatementList := TList.Create; + FBlobHandlerList := TList.Create; +end; + +destructor TSQLite3Database.Destroy; +begin + Close; + FBlobHandlerList.Free; + FStatementList.Free; + inherited; +end; + +procedure TSQLite3Database.Execute(const SQL: WideString); +begin + CheckHandle; + Check(sqlite3_exec(FHandle, PAnsiChar(StrToUTF8(SQL)), nil, nil, nil)); +end; + +function TSQLite3Database.LastInsertRowID: Int64; +begin + CheckHandle; + Result := sqlite3_last_insert_rowid(FHandle); +end; + +procedure TSQLite3Database.Open(const FileName: WideString; Flags: Integer); +begin + Close; + if Flags = 0 then + Check(sqlite3_open(PAnsiChar(StrToUTF8(FileName)), FHandle)) + else + Check(sqlite3_open_v2(PAnsiChar(StrToUTF8(FileName)), FHandle, Flags, nil)); +end; + +function TSQLite3Database.Prepare(const SQL: WideString): TSQLite3Statement; +begin + Result := TSQLite3Statement.Create(Self, SQL); +end; + +procedure TSQLite3Database.Rollback; +begin + if FTransactionOpen then + begin + Execute('ROLLBACK;'); + FTransactionOpen := False; + end + else + raise ESQLite3Error.Create(SNoTransactionOpen); +end; + +{ TSQLite3Statement } + +procedure TSQLite3Statement.BindBlob(const ParamIndex: Integer; Data: Pointer; + const Size: Integer); +begin + FOwnerDatabase.Check(sqlite3_bind_blob(FHandle, ParamIndex, Data, Size, SQLITE_TRANSIENT)); +end; + +procedure TSQLite3Statement.BindDouble(const ParamIndex: Integer; + const Value: Double); +begin + FOwnerDatabase.Check(sqlite3_bind_double(FHandle, ParamIndex, Value)); +end; + +procedure TSQLite3Statement.BindInt(const ParamIndex, Value: Integer); +begin + FOwnerDatabase.Check(sqlite3_bind_int(FHandle, ParamIndex, Value)); +end; + +procedure TSQLite3Statement.BindInt64(const ParamIndex: Integer; + const Value: Int64); +begin + FOwnerDatabase.Check(sqlite3_bind_int64(FHandle, ParamIndex, Value)); +end; + +procedure TSQLite3Statement.BindNull(const ParamIndex: Integer); +begin + FOwnerDatabase.Check(sqlite3_bind_null(FHandle, ParamIndex)); +end; + +procedure TSQLite3Statement.BindText(const ParamIndex: Integer; + const Value: WideString); +var + S: AnsiString; { UTF-8 string } +begin + S := StrToUTF8(Value); + FOwnerDatabase.Check( + sqlite3_bind_text(FHandle, ParamIndex, PAnsiChar(S), Length(S), SQLITE_TRANSIENT) + ); +end; + +procedure TSQLite3Statement.BindZeroBlob(const ParamIndex, Size: Integer); +begin + FOwnerDatabase.Check(sqlite3_bind_zeroblob(FHandle, ParamIndex, Size)); +end; + +procedure TSQLite3Statement.ClearBindings; +begin + FOwnerDatabase.Check(sqlite3_clear_bindings(FHandle)); +end; + +function TSQLite3Statement.ColumnBlob(const ColumnIndex: Integer): Pointer; +begin + Result := sqlite3_column_blob(FHandle, ColumnIndex); +end; + +function TSQLite3Statement.ColumnBytes(const ColumnIndex: Integer): Integer; +begin + Result := sqlite3_column_bytes(FHandle, ColumnIndex); +end; + +function TSQLite3Statement.ColumnCount: Integer; +begin + Result := sqlite3_column_count(FHandle); +end; + +function TSQLite3Statement.ColumnDouble(const ColumnIndex: Integer): Double; +begin + Result := sqlite3_column_double(FHandle, ColumnIndex); +end; + +function TSQLite3Statement.ColumnInt(const ColumnIndex: Integer): Integer; +begin + Result := sqlite3_column_int(FHandle, ColumnIndex); +end; + +function TSQLite3Statement.ColumnInt64(const ColumnIndex: Integer): Int64; +begin + Result := sqlite3_column_int64(FHandle, ColumnIndex); +end; + +function TSQLite3Statement.ColumnName(const ColumnIndex: Integer): WideString; +begin + Result := UTF8ToStr(sqlite3_column_name(FHandle, ColumnIndex)); +end; + +function TSQLite3Statement.ColumnText(const ColumnIndex: Integer): WideString; +var + Len: Integer; +begin + Len := ColumnBytes(ColumnIndex); + Result := UTF8ToStr(sqlite3_column_text(FHandle, ColumnIndex), Len); +end; + +function TSQLite3Statement.ColumnType(const ColumnIndex: Integer): Integer; +begin + Result := sqlite3_column_type(FHandle, ColumnIndex); +end; + +constructor TSQLite3Statement.Create(OwnerDatabase: TSQLite3Database; + const SQL: WideString); +begin + FOwnerDatabase := OwnerDatabase; + FOwnerDatabase.CheckHandle; + FOwnerDatabase.Check( + sqlite3_prepare_v2(FOwnerDatabase.Handle, PAnsiChar(StrToUTF8(SQL)), -1, FHandle, nil) + ); + FOwnerDatabase.FStatementList.Add(Self); +end; + +destructor TSQLite3Statement.Destroy; +begin + FOwnerDatabase.FStatementList.Remove(Self); + sqlite3_finalize(FHandle); + inherited; +end; + +function TSQLite3Statement.ParamIndexByName(const ParamName: WideString): Integer; +begin + Result := sqlite3_bind_parameter_index(FHandle, PAnsiChar(StrToUTF8(ParamName))); +end; + +procedure TSQLite3Statement.Reset; +begin + sqlite3_reset(FHandle); +end; + +function TSQLite3Statement.Step: Integer; +begin + Result := sqlite3_step(FHandle); +end; + +function TSQLite3Statement.StepAndReset: Integer; +begin + Result := Step; + Reset; +end; + +procedure TSQLite3Statement.BindBlob(const ParamName: WideString; Data: Pointer; + const Size: Integer); +begin + BindBlob(ParamIndexByName(ParamName), Data, Size); +end; + +procedure TSQLite3Statement.BindDouble(const ParamName: WideString; + const Value: Double); +begin + BindDouble(ParamIndexByName(ParamName), Value); +end; + +procedure TSQLite3Statement.BindInt(const ParamName: WideString; + const Value: Integer); +begin + BindInt(ParamIndexByName(ParamName), Value); +end; + +procedure TSQLite3Statement.BindInt64(const ParamName: WideString; + const Value: Int64); +begin + BindInt64(ParamIndexByName(ParamName), Value); +end; + +procedure TSQLite3Statement.BindNull(const ParamName: WideString); +begin + BindNull(ParamIndexByName(ParamName)); +end; + +procedure TSQLite3Statement.BindText(const ParamName, Value: WideString); +begin + BindText(ParamIndexByName(ParamName), Value); +end; + +procedure TSQLite3Statement.BindZeroBlob(const ParamName: WideString; + const Size: Integer); +begin + BindZeroBlob(ParamIndexByName(ParamName), Size); +end; + +{ TSQLite3BlobHandler } + +function TSQLite3BlobHandler.Bytes: Integer; +begin + Result := sqlite3_blob_bytes(FHandle); +end; + +constructor TSQLite3BlobHandler.Create(OwnerDatabase: TSQLite3Database; const Table, + Column: WideString; const RowID: Int64; const WriteAccess: Boolean); +begin + FOwnerDatabase := OwnerDatabase; + FOwnerDatabase.CheckHandle; + FOwnerDatabase.Check( + sqlite3_blob_open(FOwnerDatabase.FHandle, 'main', PAnsiChar(StrToUTF8(Table)), + PAnsiChar(StrToUTF8(Column)), RowID, Ord(WriteAccess), FHandle) + ); + FOwnerDatabase.FBlobHandlerList.Add(Self); +end; + +destructor TSQLite3BlobHandler.Destroy; +begin + FOwnerDatabase.FBlobHandlerList.Remove(Self); + sqlite3_blob_close(FHandle); + inherited; +end; + +procedure TSQLite3BlobHandler.Read(Buffer: Pointer; const Size, + Offset: Integer); +begin + FOwnerDatabase.Check(sqlite3_blob_read(FHandle, Buffer, Size, Offset)); +end; + +procedure TSQLite3BlobHandler.Write(Buffer: Pointer; const Size, + Offset: Integer); +begin + FOwnerDatabase.Check(sqlite3_blob_write(FHandle, Buffer, Size, Offset)); +end; + +end. \ No newline at end of file diff --git a/Tocsg.Lib/VCL/SQLite3/EM.SQLite3udf.pas b/Tocsg.Lib/VCL/SQLite3/EM.SQLite3udf.pas new file mode 100644 index 00000000..6f5d590f --- /dev/null +++ b/Tocsg.Lib/VCL/SQLite3/EM.SQLite3udf.pas @@ -0,0 +1,131 @@ +{ +UDF Sqlite3 support v1.0.0 + translation to Pascal by Lukas Gebauer + +This is experimental translation. Be patient! +} +unit EM.sqlite3udf; + +interface + +uses + sqlite3; + +type + Psqlite3_context = pointer; + Psqlite3_value = ppchar; + + TxFunc = procedure(sqlite3_context: Psqlite3_context; cArg: integer; ArgV: Psqlite3_value); + TxStep = procedure(sqlite3_context: Psqlite3_context; cArg: integer; ArgV: Psqlite3_value); + TxFinal = procedure(sqlite3_context: Psqlite3_context); +{ + void (*xFunc)(sqlite3_context*,int,sqlite3_value**), + void (*xStep)(sqlite3_context*,int,sqlite3_value**), + void (*xFinal)(sqlite3_context*) +} + +//UDF SQLITE3 support +function sqlite3_create_function(db: TSQLiteDB; functionName: PChar; nArg: integer; + eTextRep: integer; pUserdata: pointer; xFunc: TxFunc; xStep: TxStep; xFinal: TxFinal + ): integer; cdecl; external SQLiteDLL name 'sqlite3_create_function'; + +procedure sqlite3_result_blob(sqlite3_context: Psqlite3_context; value: Pointer; + n: integer; destroy: pointer); cdecl; external SQLiteDLL name 'sqlite3_result_blob'; +procedure sqlite3_result_double(sqlite3_context: Psqlite3_context; value: Double); + cdecl; external SQLiteDLL name 'sqlite3_result_double'; +procedure sqlite3_result_error(sqlite3_context: Psqlite3_context; value: Pchar; + n: integer); cdecl; external SQLiteDLL name 'sqlite3_result_error'; +procedure sqlite3_result_error16(sqlite3_context: Psqlite3_context; value: PWidechar; + n: integer); cdecl; external SQLiteDLL name 'sqlite3_result_error16'; +procedure sqlite3_result_int(sqlite3_context: Psqlite3_context; value: integer); + cdecl; external SQLiteDLL name 'sqlite3_result_int'; +procedure sqlite3_result_int64(sqlite3_context: Psqlite3_context; value: int64); + cdecl; external SQLiteDLL name 'sqlite3_result_int64'; +procedure sqlite3_result_null(sqlite3_context: Psqlite3_context); + cdecl; external SQLiteDLL name 'sqlite3_result_null'; +procedure sqlite3_result_text(sqlite3_context: Psqlite3_context; value: PChar; + n: integer; destroy: pointer); cdecl; external SQLiteDLL name 'sqlite3_result_text'; +procedure sqlite3_result_text16(sqlite3_context: Psqlite3_context; value: PWideChar; + n: integer; destroy: pointer); cdecl; external SQLiteDLL name 'sqlite3_result_text16'; +procedure sqlite3_result_text16be(sqlite3_context: Psqlite3_context; value: PWideChar; + n: integer; destroy: pointer); cdecl; external SQLiteDLL name 'sqlite3_result_text16be'; +procedure sqlite3_result_text16le(sqlite3_context: Psqlite3_context; value: PWideChar; + n: integer; destroy: pointer); cdecl; external SQLiteDLL name 'sqlite3_result_text16le'; +procedure sqlite3_result_value(sqlite3_context: Psqlite3_context; value: Psqlite3_value); + cdecl; external SQLiteDLL name 'sqlite3_result_value'; + +{ + void sqlite3_result_blob(sqlite3_context*, const void*, int n, void(*)(void*)); + void sqlite3_result_double(sqlite3_context*, double); + void sqlite3_result_error(sqlite3_context*, const char*, int); + void sqlite3_result_error16(sqlite3_context*, const void*, int); + void sqlite3_result_int(sqlite3_context*, int); + void sqlite3_result_int64(sqlite3_context*, long long int); + void sqlite3_result_null(sqlite3_context*); + void sqlite3_result_text(sqlite3_context*, const char*, int n, void(*)(void*)); + void sqlite3_result_text16(sqlite3_context*, const void*, int n, void(*)(void*)); + void sqlite3_result_text16be(sqlite3_context*, const void*, int n, void(*)(void*)); + void sqlite3_result_text16le(sqlite3_context*, const void*, int n, void(*)(void*)); + void sqlite3_result_value(sqlite3_context*, sqlite3_value*); +} + +function sqlite3_value_blob(value: pointer): Pointer; + cdecl; external SQLiteDLL name 'sqlite3_value_blob'; +function sqlite3_value_bytes(value: pointer): integer; + cdecl; external SQLiteDLL name 'sqlite3_value_bytes'; +function sqlite3_value_bytes16(value: pointer): integer; + cdecl; external SQLiteDLL name 'sqlite3_value_bytes16'; +function sqlite3_value_double(value: pointer): double; + cdecl; external SQLiteDLL name 'sqlite3_value_double'; +function sqlite3_value_int(value: pointer): integer; + cdecl; external SQLiteDLL name 'sqlite3_value_int'; +function sqlite3_value_int64(value: pointer): int64; + cdecl; external SQLiteDLL name 'sqlite3_value_int64'; +function sqlite3_value_text(value: pointer): PChar; + cdecl; external SQLiteDLL name 'sqlite3_value_text'; +function sqlite3_value_text16(value: pointer): PWideChar; + cdecl; external SQLiteDLL name 'sqlite3_value_text16'; +function sqlite3_value_text16be(value: pointer): PWideChar; + cdecl; external SQLiteDLL name 'sqlite3_value_text16be'; +function sqlite3_value_text16le(value: pointer): PWideChar; + cdecl; external SQLiteDLL name 'sqlite3_value_text16le'; +function sqlite3_value_type(value: pointer): integer; + cdecl; external SQLiteDLL name 'sqlite3_value_type'; + +{ const void *sqlite3_value_blob(sqlite3_value*); + int sqlite3_value_bytes(sqlite3_value*); + int sqlite3_value_bytes16(sqlite3_value*); + double sqlite3_value_double(sqlite3_value*); + int sqlite3_value_int(sqlite3_value*); + long long int sqlite3_value_int64(sqlite3_value*); + const unsigned char *sqlite3_value_text(sqlite3_value*); + const void *sqlite3_value_text16(sqlite3_value*); + const void *sqlite3_value_text16be(sqlite3_value*); + const void *sqlite3_value_text16le(sqlite3_value*); + int sqlite3_value_type(sqlite3_value*); +} + +{ +//Sample of usage: +PROCEDURE fn(ctx:pointer;n:integer;args:ppchar);cdecl; +VAR p : ppchar; theString : string; res:integer; +BEGIN +p := args; +theString := trim(sqlite3_value_text(p^)); + +...do something with theString... + +sqlite3_result_int(ctx,res); // < return a number based on string +END; +... +var i:integer; +begin +i := sqlite3_create_function(db3,'myfn',1,SQLITE_UTF8,nil,@fn,nil,nil); +s := 'select myfn(thestring) from theTable;' +...execute statement... +end; +} + +implementation + +end. diff --git a/Tocsg.Lib/VCL/SQLite3/EM.SQLiteTable3.pas b/Tocsg.Lib/VCL/SQLite3/EM.SQLiteTable3.pas new file mode 100644 index 00000000..4b8c3a3f --- /dev/null +++ b/Tocsg.Lib/VCL/SQLite3/EM.SQLiteTable3.pas @@ -0,0 +1,1326 @@ +unit EM.SQLiteTable3; +{ + Simple classes for using SQLite's exec and get_table. + TSQLiteDatabase wraps the calls to open and close an SQLite database. + It also wraps SQLite_exec for queries that do not return a result set + TSQLiteTable wraps execution of SQL query. + It run query and read all returned rows to internal buffer. + It allows accessing fields by name as well as index and can move through a + result set forward and backwards, or randomly to any row. + TSQLiteUniTable wraps execution of SQL query. + It run query as TSQLiteTable, but reading just first row only! + You can step to next row (until not EOF) by 'Next' method. + You cannot step backwards! (So, it is called as UniDirectional result set.) + It not using any internal buffering, this class is very close to Sqlite API. + It allows accessing fields by name as well as index on actual row only. + Very good and fast for sequentional scanning of large result sets with minimal + memory footprint. + Warning! Do not close TSQLiteDatabase before any TSQLiteUniTable, + because query is closed on TSQLiteUniTable destructor and database connection + is used during TSQLiteUniTable live! + SQL parameter usage: + You can add named parameter values by call set of AddParam* methods. + Parameters will be used for first next SQL statement only. + Parameter name must be prefixed by ':', '$' or '@' and same prefix must be + used in SQL statement! + Sample: + table.AddParamText(':str', 'some value'); + s := table.GetTableString('SELECT value FROM sometable WHERE id=:str'); + Notes from Andrew Retmanski on prepared queries + The changes are as follows: + SQLiteTable3.pas + - Added new boolean property Synchronised (this controls the SYNCHRONOUS pragma as I found that turning this OFF increased the write performance in my application) + - Added new type TSQLiteQuery (this is just a simple record wrapper around the SQL string and a TSQLiteStmt pointer) + - Added PrepareSQL method to prepare SQL query - returns TSQLiteQuery + - Added ReleaseSQL method to release previously prepared query + - Added overloaded BindSQL methods for Integer and String types - these set new values for the prepared query parameters + - Added overloaded ExecSQL method to execute a prepared TSQLiteQuery + Usage of the new methods should be self explanatory but the process is in essence: + 1. Call PrepareSQL to return TSQLiteQuery 2. Call BindSQL for each parameter in the prepared query 3. Call ExecSQL to run the prepared query 4. Repeat steps 2 & 3 as required 5. Call ReleaseSQL to free SQLite resources + One other point - the Synchronised property throws an error if used inside a transaction. + Acknowledments + Adapted by Tim Anderson (tim@itwriting.com) + Originally created by Pablo Pissanetzky (pablo@myhtpc.net) + Modified and enhanced by Lukas Gebauer + Modified and enhanced by Tobias Gunkel +} +interface +{$IFDEF FPC} + {$MODE Delphi}{$H+} +{$ENDIF} +uses + {$IFDEF WIN32} + WinApi.Windows, + {$ENDIF} + EM.Old.SQLite3, Classes, SysUtils; +const + dtInt = 1; + dtNumeric = 2; + dtStr = 3; + dtBlob = 4; + dtNull = 5; +type + ESQLiteException = class(Exception) + end; + TSQliteParam = class + public + name: string; + valuetype: integer; + valueinteger: int64; + valuefloat: double; + valuedata: string; + end; + THookQuery = procedure(Sender: TObject; SQL: String) of object; + TSQLiteQuery = record + SQL: String; + Statement: TSQLiteStmt; + end; + TSQLiteTable = class; + TSQLiteUniTable = class; + TSQLiteDatabase = class + private + fDB: TSQLiteDB; + fInTrans: boolean; + fSync: boolean; + fParams: TList; + FOnQuery: THookQuery; + procedure RaiseError(s: string; SQL: string); + procedure SetParams(Stmt: TSQLiteStmt); + procedure BindData(Stmt: TSQLiteStmt; const Bindings: array of const); + function GetRowsChanged: integer; + protected + procedure SetSynchronised(Value: boolean); + procedure DoQuery(value: string); + public + constructor Create(const FileName: string); + destructor Destroy; override; + function GetTable(const SQL: Ansistring): TSQLiteTable; overload; + function GetTable(const SQL: Ansistring; const Bindings: array of const): TSQLiteTable; overload; + procedure ExecSQL(const SQL: Ansistring); overload; + procedure ExecSQL(const SQL: Ansistring; const Bindings: array of const); overload; + procedure ExecSQL(Query: TSQLiteQuery); overload; + function PrepareSQL(const SQL: Ansistring): TSQLiteQuery; + procedure BindSQL(Query: TSQLiteQuery; const Index: Integer; const Value: Integer); overload; + procedure BindSQL(Query: TSQLiteQuery; const Index: Integer; const Value: String); overload; + procedure ReleaseSQL(Query: TSQLiteQuery); + function GetUniTable(const SQL: Ansistring): TSQLiteUniTable; overload; + function GetUniTable(const SQL: Ansistring; const Bindings: array of const): TSQLiteUniTable; overload; + function GetTableValue(const SQL: Ansistring): int64; overload; + function GetTableValue(const SQL: Ansistring; const Bindings: array of const): int64; overload; + function GetTableString(const SQL: Ansistring): string; overload; + function GetTableString(const SQL: Ansistring; const Bindings: array of const): string; overload; + procedure GetTableStrings(const SQL: Ansistring; const Value: TStrings); + procedure UpdateBlob(const SQL: Ansistring; BlobData: TStream); + procedure BeginTransaction; + procedure Commit; + procedure Rollback; + function TableExists(TableName: string): boolean; + function GetLastInsertRowID: int64; + function GetLastChangedRows: int64; + procedure SetTimeout(Value: integer); + function Version: string; + procedure AddCustomCollate(name: string; xCompare: TCollateXCompare); + //adds collate named SYSTEM for correct data sorting by user's locale + Procedure AddSystemCollate; + procedure ParamsClear; + procedure AddParamInt(name: string; value: int64); + procedure AddParamFloat(name: string; value: double); + procedure AddParamText(name: string; value: string); + procedure AddParamNull(name: string); + property DB: TSQLiteDB read fDB; + //published + property IsTransactionOpen: boolean read fInTrans; + //database rows that were changed (or inserted or deleted) by the most recent SQL statement + property RowsChanged : integer read getRowsChanged; + property Synchronised: boolean read FSync write SetSynchronised; + property OnQuery: THookQuery read FOnQuery write FOnQuery; + end; + TSQLiteTable = class + private + fResults: TList; + fRowCount: cardinal; + fColCount: cardinal; + fCols: TStringList; + fColTypes: TList; + fRow: cardinal; + function GetFields(I: cardinal): string; + function GetEOF: boolean; + function GetBOF: boolean; + function GetColumns(I: integer): string; + function GetFieldByName(FieldName: string): string; + function GetFieldIndex(FieldName: string): integer; + function GetCount: integer; + function GetCountResult: integer; + public + constructor Create(DB: TSQLiteDatabase; const SQL: Ansistring); overload; + constructor Create(DB: TSQLiteDatabase; const SQL: Ansistring; const Bindings: array of const); overload; + destructor Destroy; override; + function FieldAsInteger(I: cardinal): int64; + function FieldAsBlob(I: cardinal): TMemoryStream; + function FieldAsBlobText(I: cardinal): string; + function FieldIsNull(I: cardinal): boolean; + function FieldAsString(I: cardinal): string; + function FieldAsDouble(I: cardinal): double; + function Next: boolean; + function Previous: boolean; + property EOF: boolean read GetEOF; + property BOF: boolean read GetBOF; + property Fields[I: cardinal]: string read GetFields; + property FieldByName[FieldName: string]: string read GetFieldByName; + property FieldIndex[FieldName: string]: integer read GetFieldIndex; + property Columns[I: integer]: string read GetColumns; + property ColCount: cardinal read fColCount; + property RowCount: cardinal read fRowCount; + property Row: cardinal read fRow; + function MoveFirst: boolean; + function MoveLast: boolean; + function MoveTo(position: cardinal): boolean; + property Count: integer read GetCount; + // The property CountResult is used when you execute count(*) queries. + // It returns 0 if the result set is empty or the value of the + // first field as an integer. + property CountResult: integer read GetCountResult; + end; + TSQLiteUniTable = class + private + fColCount: cardinal; + fCols: TStringList; + fRow: cardinal; + fEOF: boolean; + fStmt: TSQLiteStmt; + fDB: TSQLiteDatabase; + fSQL: string; + function GetFields(I: cardinal): string; + function GetColumns(I: integer): string; + function GetFieldByName(FieldName: string): string; + function GetFieldIndex(FieldName: string): integer; + public + constructor Create(DB: TSQLiteDatabase; const SQL: Ansistring); overload; + constructor Create(DB: TSQLiteDatabase; const SQL: Ansistring; const Bindings: array of const); overload; + destructor Destroy; override; + function FieldAsInteger(I: cardinal): int64; + function FieldAsBlob(I: cardinal): TMemoryStream; + function FieldAsBlobPtr(I: cardinal; out iNumBytes: integer): Pointer; + function FieldAsBlobText(I: cardinal): string; + function FieldIsNull(I: cardinal): boolean; + function FieldAsString(I: cardinal): string; + function FieldAsDouble(I: cardinal): double; + function Next: boolean; + property EOF: boolean read FEOF; + property Fields[I: cardinal]: string read GetFields; + property FieldByName[FieldName: string]: string read GetFieldByName; + property FieldIndex[FieldName: string]: integer read GetFieldIndex; + property Columns[I: integer]: string read GetColumns; + property ColCount: cardinal read fColCount; + property Row: cardinal read fRow; + end; +procedure DisposePointer(ptr: pointer); cdecl; +{$IFDEF WIN32} +function SystemCollate(Userdta: pointer; Buf1Len: integer; Buf1: pointer; + Buf2Len: integer; Buf2: pointer): integer; cdecl; +{$ENDIF} +implementation +procedure DisposePointer(ptr: pointer); cdecl; +begin + if assigned(ptr) then + freemem(ptr); +end; +{$IFDEF WIN32} +function SystemCollate(Userdta: pointer; Buf1Len: integer; Buf1: pointer; + Buf2Len: integer; Buf2: pointer): integer; cdecl; +begin + Result := CompareStringW(LOCALE_USER_DEFAULT, 0, PWideChar(Buf1), Buf1Len, + PWideChar(Buf2), Buf2Len) - 2; +end; +{$ENDIF} +//------------------------------------------------------------------------------ +// TSQLiteDatabase +//------------------------------------------------------------------------------ +constructor TSQLiteDatabase.Create(const FileName: string); +var + Msg: PAnsiChar; + iResult: integer; + utf8FileName: UTF8string; +begin + inherited Create; + fParams := TList.Create; + self.fInTrans := False; + Msg := nil; + try + utf8FileName := UTF8String(FileName); + iResult := SQLite3_Open(PAnsiChar(utf8FileName), Fdb); + if iResult <> SQLITE_OK then + if Assigned(Fdb) then + begin + Msg := Sqlite3_ErrMsg(Fdb); + raise ESqliteException.CreateFmt('Failed to open database "%s" : %s', + [FileName, Msg]); + end + else + raise ESqliteException.CreateFmt('Failed to open database "%s" : unknown error', + [FileName]); +//set a few configs +//L.G. Do not call it here. Because busy handler is not setted here, +// any share violation causing exception! +// self.ExecSQL('PRAGMA SYNCHRONOUS=NORMAL;'); +// self.ExecSQL('PRAGMA temp_store = MEMORY;'); + finally + if Assigned(Msg) then + SQLite3_Free(Msg); + end; +end; +//.............................................................................. +destructor TSQLiteDatabase.Destroy; +begin + if self.fInTrans then + self.Rollback; //assume rollback + if Assigned(fDB) then + SQLite3_Close(fDB); + ParamsClear; + fParams.Free; + inherited; +end; +function TSQLiteDatabase.GetLastInsertRowID: int64; +begin + Result := Sqlite3_LastInsertRowID(self.fDB); +end; +function TSQLiteDatabase.GetLastChangedRows: int64; +begin + Result := SQLite3_TotalChanges(self.fDB); +end; +//.............................................................................. +procedure TSQLiteDatabase.RaiseError(s: string; SQL: string); +//look up last error and raise an exception with an appropriate message +var + Msg: PAnsiChar; + ret : integer; +begin + Msg := nil; + ret := sqlite3_errcode(self.fDB); + if ret <> SQLITE_OK then + Msg := sqlite3_errmsg(self.fDB); + if Msg <> nil then + raise ESqliteException.CreateFmt(s +'.'#13'Error [%d]: %s.'#13'"%s": %s', [ret, SQLiteErrorStr(ret),SQL, Msg]) + else + raise ESqliteException.CreateFmt(s, [SQL, 'No message']); +end; +procedure TSQLiteDatabase.SetSynchronised(Value: boolean); +begin + if Value <> fSync then + begin + if Value then + ExecSQL('PRAGMA synchronous = ON;') + else + ExecSQL('PRAGMA synchronous = OFF;'); + fSync := Value; + end; +end; +procedure TSQLiteDatabase.BindData(Stmt: TSQLiteStmt; const Bindings: array of const); +var + BlobMemStream: TCustomMemoryStream; + BlobStdStream: TStream; + DataPtr: Pointer; + DataSize: integer; + AnsiStr: AnsiString; + AnsiStrPtr: PAnsiString; + I: integer; +begin + for I := 0 to High(Bindings) do + begin + case Bindings[I].VType of + vtString, + vtAnsiString, vtPChar, + vtWideString, vtPWideChar, + vtChar, vtWideChar: + begin + case Bindings[I].VType of + vtString: begin // ShortString + AnsiStr := Bindings[I].VString^; + DataPtr := PAnsiChar(AnsiStr); + DataSize := Length(AnsiStr)+1; + end; + vtPChar: begin + DataPtr := Bindings[I].VPChar; + DataSize := -1; + end; + vtAnsiString: begin + AnsiStrPtr := PAnsiString(@Bindings[I].VAnsiString); + DataPtr := PAnsiChar(AnsiStrPtr^); + DataSize := Length(AnsiStrPtr^)+1; + end; + vtPWideChar: begin + DataPtr := PAnsiChar(UTF8Encode(WideString(Bindings[I].VPWideChar))); + DataSize := -1; + end; + vtWideString: begin + DataPtr := PAnsiChar(UTF8Encode(PWideString(@Bindings[I].VWideString)^)); + DataSize := -1; + end; + vtChar: begin + //DataPtr := PAnsiChar(String(Bindings[I].VChar)); + //TODO : modify + DataPtr := PChar(String(Bindings[I].VChar)); + DataSize := 2; + end; + vtWideChar: begin + DataPtr := PAnsiChar(UTF8Encode(WideString(Bindings[I].VWideChar))); + DataSize := -1; + end; + else + raise ESqliteException.Create('Unknown string-type'); + end; + if (sqlite3_bind_text(Stmt, I+1, DataPtr, DataSize, SQLITE_STATIC) <> SQLITE_OK) then + RaiseError('Could not bind text', 'BindData'); + end; + vtInteger: + if (sqlite3_bind_int(Stmt, I+1, Bindings[I].VInteger) <> SQLITE_OK) then + RaiseError('Could not bind integer', 'BindData'); + vtInt64: + if (sqlite3_bind_int64(Stmt, I+1, Bindings[I].VInt64^) <> SQLITE_OK) then + RaiseError('Could not bind int64', 'BindData'); + vtExtended: + if (sqlite3_bind_double(Stmt, I+1, Bindings[I].VExtended^) <> SQLITE_OK) then + RaiseError('Could not bind extended', 'BindData'); + vtBoolean: + if (sqlite3_bind_int(Stmt, I+1, Integer(Bindings[I].VBoolean)) <> SQLITE_OK) then + RaiseError('Could not bind boolean', 'BindData'); + vtPointer: + begin + if (Bindings[I].VPointer = nil) then + begin + if (sqlite3_bind_null(Stmt, I+1) <> SQLITE_OK) then + RaiseError('Could not bind null', 'BindData'); + end + else + raise ESqliteException.Create('Unhandled pointer (<> nil)'); + end; + vtObject: + begin + if (Bindings[I].VObject is TCustomMemoryStream) then + begin + BlobMemStream := TCustomMemoryStream(Bindings[I].VObject); + if (sqlite3_bind_blob(Stmt, I+1, @PAnsiChar(BlobMemStream.Memory)[BlobMemStream.Position], + BlobMemStream.Size-BlobMemStream.Position, SQLITE_STATIC) <> SQLITE_OK) then + begin + RaiseError('Could not bind BLOB', 'BindData'); + end; + end + else if (Bindings[I].VObject is TStream) then + begin + BlobStdStream := TStream(Bindings[I].VObject); + DataSize := BlobStdStream.Size; + GetMem(DataPtr, DataSize); + if (DataPtr = nil) then + raise ESqliteException.Create('Error getting memory to save blob'); + BlobStdStream.Position := 0; + BlobStdStream.Read(DataPtr^, DataSize); + if (sqlite3_bind_blob(stmt, I+1, DataPtr, DataSize, @DisposePointer) <> SQLITE_OK) then + RaiseError('Could not bind BLOB', 'BindData'); + end + else + raise ESqliteException.Create('Unhandled object-type in binding'); + end + else + begin + raise ESqliteException.Create('Unhandled binding'); + end; + end; + end; +end; +procedure TSQLiteDatabase.ExecSQL(const SQL: Ansistring); +begin + ExecSQL(SQL, []); +end; +procedure TSQLiteDatabase.ExecSQL(const SQL: Ansistring; const Bindings: array of const); +var + Stmt: TSQLiteStmt; + NextSQLStatement: PAnsiChar; + iStepResult: integer; +begin + try + if Sqlite3_Prepare_v2(self.fDB, PAnsiChar(SQL), -1, Stmt, NextSQLStatement) <> + SQLITE_OK then + RaiseError('Error executing SQL', string(SQL)); + if (Stmt = nil) then + RaiseError('Could not prepare SQL statement', string(SQL)); + DoQuery( string(SQL)); + SetParams(Stmt); + BindData(Stmt, Bindings); + iStepResult := Sqlite3_step(Stmt); + if (iStepResult <> SQLITE_DONE) then + begin + SQLite3_reset(stmt); + RaiseError('Error executing SQL statement', string(SQL)); + end; + finally + if Assigned(Stmt) then + Sqlite3_Finalize(stmt); + end; +end; +{$WARNINGS OFF} +procedure TSQLiteDatabase.ExecSQL(Query: TSQLiteQuery); +var + iStepResult: integer; +begin + if Assigned(Query.Statement) then + begin + iStepResult := Sqlite3_step(Query.Statement); + if (iStepResult <> SQLITE_DONE) then + begin + SQLite3_reset(Query.Statement); + RaiseError('Error executing prepared SQL statement', Query.SQL); + end; + Sqlite3_Reset(Query.Statement); + end; +end; +{$WARNINGS ON} +{$WARNINGS OFF} +function TSQLiteDatabase.PrepareSQL(const SQL: Ansistring): TSQLiteQuery; +var + Stmt: TSQLiteStmt; + NextSQLStatement: PAnsiChar; +begin + Result.SQL := SQL; + Result.Statement := nil; + if Sqlite3_Prepare(self.fDB, PAnsiChar(SQL), -1, Stmt, NextSQLStatement) <> + SQLITE_OK then + RaiseError('Error executing SQL', SQL) + else + Result.Statement := Stmt; + if (Result.Statement = nil) then + RaiseError('Could not prepare SQL statement', SQL); + DoQuery(SQL); +end; +{$WARNINGS ON} +{$WARNINGS OFF} +procedure TSQLiteDatabase.BindSQL(Query: TSQLiteQuery; const Index: Integer; const Value: Integer); +begin + if Assigned(Query.Statement) then + sqlite3_Bind_Int(Query.Statement, Index, Value) + else + RaiseError('Could not bind integer to prepared SQL statement', Query.SQL); +end; +{$WARNINGS ON} +{$WARNINGS OFF} +procedure TSQLiteDatabase.BindSQL(Query: TSQLiteQuery; const Index: Integer; const Value: String); +begin + if Assigned(Query.Statement) then + Sqlite3_Bind_Text(Query.Statement, Index, PAnsiChar(Value), Length(Value), Pointer(SQLITE_STATIC)) + else + RaiseError('Could not bind string to prepared SQL statement', Query.SQL); +end; +{$WARNINGS ON} +{$WARNINGS OFF} +procedure TSQLiteDatabase.ReleaseSQL(Query: TSQLiteQuery); +begin + if Assigned(Query.Statement) then + begin + Sqlite3_Finalize(Query.Statement); + Query.Statement := nil; + end + else + RaiseError('Could not release prepared SQL statement', Query.SQL); +end; +{$WARNINGS ON} +procedure TSQLiteDatabase.UpdateBlob(const SQL: Ansistring; BlobData: TStream); +var + iSize: integer; + ptr: pointer; + Stmt: TSQLiteStmt; + Msg: PAnsiChar; + NextSQLStatement: PAnsiChar; + iStepResult: integer; + iBindResult: integer; +begin + //expects SQL of the form 'UPDATE MYTABLE SET MYFIELD = ? WHERE MYKEY = 1' + if pos('?', string(SQL)) = 0 then + RaiseError('SQL must include a ? parameter', string(SQL)); + Msg := nil; + try + if Sqlite3_Prepare_v2(self.fDB, PAnsiChar(SQL), -1, Stmt, NextSQLStatement) <> + SQLITE_OK then + RaiseError('Could not prepare SQL statement', string(SQL)); + if (Stmt = nil) then + RaiseError('Could not prepare SQL statement', string(SQL)); + DoQuery( string(SQL) ); + //now bind the blob data + iSize := BlobData.size; + GetMem(ptr, iSize); + if (ptr = nil) then + raise ESqliteException.CreateFmt('Error getting memory to save blob', + [SQL, 'Error']); + BlobData.position := 0; + BlobData.Read(ptr^, iSize); + iBindResult := SQLite3_Bind_Blob(stmt, 1, ptr, iSize, @DisposePointer); + if iBindResult <> SQLITE_OK then + RaiseError('Error binding blob to database', string(SQL)); + iStepResult := Sqlite3_step(Stmt); + if (iStepResult <> SQLITE_DONE) then + begin + SQLite3_reset(stmt); + RaiseError('Error executing SQL statement', string(SQL)); + end; + finally + if Assigned(Stmt) then + Sqlite3_Finalize(stmt); + if Assigned(Msg) then + SQLite3_Free(Msg); + end; +end; +//.............................................................................. +function TSQLiteDatabase.GetTable(const SQL: Ansistring): TSQLiteTable; +begin + Result := TSQLiteTable.Create(Self, SQL); +end; +function TSQLiteDatabase.GetTable(const SQL: Ansistring; const Bindings: array of const): TSQLiteTable; +begin + Result := TSQLiteTable.Create(Self, SQL, Bindings); +end; +function TSQLiteDatabase.GetUniTable(const SQL: Ansistring): TSQLiteUniTable; +begin + Result := TSQLiteUniTable.Create(Self, SQL); +end; +function TSQLiteDatabase.GetUniTable(const SQL: Ansistring; const Bindings: array of const): TSQLiteUniTable; +begin + Result := TSQLiteUniTable.Create(Self, SQL, Bindings); +end; +function TSQLiteDatabase.GetTableValue(const SQL: Ansistring): int64; +begin + Result := GetTableValue(SQL, []); +end; +function TSQLiteDatabase.GetTableValue(const SQL: Ansistring; const Bindings: array of const): int64; +var + Table: TSQLiteUniTable; +begin + Result := 0; + Table := self.GetUniTable(SQL, Bindings); + try + if not Table.EOF then + Result := Table.FieldAsInteger(0); + finally + Table.Free; + end; +end; +function TSQLiteDatabase.GetTableString(const SQL: Ansistring): String; +begin + Result := GetTableString(SQL, []); +end; +function TSQLiteDatabase.GetTableString(const SQL: Ansistring; const Bindings: array of const): String; +var + Table: TSQLiteUniTable; +begin + Result := ''; + Table := self.GetUniTable(SQL, Bindings); + try + if not Table.EOF then + Result := Table.FieldAsString(0); + finally + Table.Free; + end; +end; +procedure TSQLiteDatabase.GetTableStrings(const SQL: Ansistring; + const Value: TStrings); +var + Table: TSQLiteUniTable; +begin + Value.Clear; + Table := self.GetUniTable(SQL); + try + while not table.EOF do + begin + Value.Add(Table.FieldAsString(0)); + table.Next; + end; + finally + Table.Free; + end; +end; +procedure TSQLiteDatabase.BeginTransaction; +begin + if not self.fInTrans then + begin + self.ExecSQL('BEGIN TRANSACTION'); + self.fInTrans := True; + end + else + raise ESqliteException.Create('Transaction already open'); +end; +procedure TSQLiteDatabase.Commit; +begin + self.ExecSQL('COMMIT'); + self.fInTrans := False; +end; +procedure TSQLiteDatabase.Rollback; +begin + self.ExecSQL('ROLLBACK'); + self.fInTrans := False; +end; +function TSQLiteDatabase.TableExists(TableName: string): boolean; +var + sql: string; + ds: TSqliteTable; +begin + //returns true if table exists in the database + sql := 'select [sql] from sqlite_master where [type] = ''table'' and lower(name) = ''' + + lowercase(TableName) + ''' '; + ds := self.GetTable(Ansistring(sql)); + try + Result := (ds.Count > 0); + finally + ds.Free; + end; +end; +procedure TSQLiteDatabase.SetTimeout(Value: integer); +begin + SQLite3_BusyTimeout(self.fDB, Value); +end; +function TSQLiteDatabase.Version: string; +begin + Result := string(SQLite3_Version); +end; +procedure TSQLiteDatabase.AddCustomCollate(name: string; + xCompare: TCollateXCompare); +begin + sqlite3_create_collation(fdb, PAnsiChar(AnsiString(name)), SQLITE_UTF8, nil, xCompare); +end; +procedure TSQLiteDatabase.AddSystemCollate; +begin + {$IFDEF WIN32} + sqlite3_create_collation(fdb, 'SYSTEM', SQLITE_UTF16LE, nil, @SystemCollate); + {$ENDIF} +end; +procedure TSQLiteDatabase.ParamsClear; +var + n: integer; +begin + for n := fParams.Count - 1 downto 0 do + TSQliteParam(fparams[n]).free; + fParams.Clear; +end; +procedure TSQLiteDatabase.AddParamInt(name: string; value: int64); +var + par: TSQliteParam; +begin + par := TSQliteParam.Create; + par.name := name; + par.valuetype := SQLITE_INTEGER; + par.valueinteger := value; + fParams.Add(par); +end; +procedure TSQLiteDatabase.AddParamFloat(name: string; value: double); +var + par: TSQliteParam; +begin + par := TSQliteParam.Create; + par.name := name; + par.valuetype := SQLITE_FLOAT; + par.valuefloat := value; + fParams.Add(par); +end; +procedure TSQLiteDatabase.AddParamText(name: string; value: string); +var + par: TSQliteParam; +begin + par := TSQliteParam.Create; + par.name := name; + par.valuetype := SQLITE_TEXT; + par.valuedata := value; + fParams.Add(par); +end; +procedure TSQLiteDatabase.AddParamNull(name: string); +var + par: TSQliteParam; +begin + par := TSQliteParam.Create; + par.name := name; + par.valuetype := SQLITE_NULL; + fParams.Add(par); +end; +procedure TSQLiteDatabase.SetParams(Stmt: TSQLiteStmt); +var + n: integer; + i: integer; + par: TSQliteParam; +begin + try + for n := 0 to fParams.Count - 1 do + begin + par := TSQliteParam(fParams[n]); + i := sqlite3_bind_parameter_index(Stmt, PAnsiChar(AnsiString(par.name))); + if i > 0 then + begin + case par.valuetype of + SQLITE_INTEGER: + sqlite3_bind_int64(Stmt, i, par.valueinteger); + SQLITE_FLOAT: + sqlite3_bind_double(Stmt, i, par.valuefloat); + SQLITE_TEXT: + sqlite3_bind_text(Stmt, i, PAnsiChar(AnsiString(par.valuedata)), + length(par.valuedata), SQLITE_TRANSIENT); + SQLITE_NULL: + sqlite3_bind_null(Stmt, i); + end; + end; + end; + finally + ParamsClear; + end; +end; +//database rows that were changed (or inserted or deleted) by the most recent SQL statement +function TSQLiteDatabase.GetRowsChanged: integer; +begin + Result := SQLite3_Changes(self.fDB); +end; +procedure TSQLiteDatabase.DoQuery(value: string); +begin + if assigned(OnQuery) then + OnQuery(Self, Value); +end; +//------------------------------------------------------------------------------ +// TSQLiteTable +//------------------------------------------------------------------------------ +constructor TSQLiteTable.Create(DB: TSQLiteDatabase; const SQL: Ansistring); +begin + Create(DB, SQL, []); +end; +constructor TSQLiteTable.Create(DB: TSQLiteDatabase; const SQL: Ansistring; const Bindings: array of const); +var + Stmt: TSQLiteStmt; + NextSQLStatement: PAnsiChar; + iStepResult: integer; + ptr: pointer; + iNumBytes: integer; + thisBlobValue: TMemoryStream; + thisStringValue: pstring; + thisDoubleValue: pDouble; + thisIntValue: pInt64; + thisColType: pInteger; + i: integer; + DeclaredColType: PAnsiChar; + ActualColType: integer; + ptrValue2: PWideChar; + sTemp : UnicodeString; +begin + inherited create; + try + self.fRowCount := 0; + self.fColCount := 0; + //if there are several SQL statements in SQL, NextSQLStatment points to the + //beginning of the next one. Prepare only prepares the first SQL statement. + if Sqlite3_Prepare_v2(DB.fDB, PAnsiChar(SQL), -1, Stmt, NextSQLStatement) <> SQLITE_OK then + DB.RaiseError('Error executing SQL', string(SQL)); + if (Stmt = nil) then + DB.RaiseError('Could not prepare SQL statement', string(SQL)); + DB.DoQuery(string(SQL)); + DB.SetParams(Stmt); + DB.BindData(Stmt, Bindings); + iStepResult := Sqlite3_step(Stmt); + while (iStepResult <> SQLITE_DONE) do + begin + case iStepResult of + SQLITE_ROW: + begin + Inc(fRowCount); + if (fRowCount = 1) then + begin + //get data types + fCols := TStringList.Create; + fColTypes := TList.Create; + fColCount := SQLite3_ColumnCount(stmt); + for i := 0 to Pred(fColCount) do + fCols.Add(AnsiUpperCase(string(Sqlite3_ColumnName(stmt, i)))); + for i := 0 to Pred(fColCount) do + begin + new(thisColType); + DeclaredColType := Sqlite3_ColumnDeclType(stmt, i); + if DeclaredColType = nil then + thisColType^ := Sqlite3_ColumnType(stmt, i) //use the actual column type instead + //seems to be needed for last_insert_rowid + else + if (DeclaredColType = 'INTEGER') or (DeclaredColType = 'BOOLEAN') then + thisColType^ := dtInt + else + if (DeclaredColType = 'NUMERIC') or + (DeclaredColType = 'FLOAT') or + (DeclaredColType = 'DOUBLE') or + (DeclaredColType = 'REAL') then + thisColType^ := dtNumeric + else + if DeclaredColType = 'BLOB' then + thisColType^ := dtBlob + else + thisColType^ := dtStr; + fColTypes.Add(thiscoltype); + end; + fResults := TList.Create; + end; + //get column values + for i := 0 to Pred(ColCount) do + begin + ActualColType := Sqlite3_ColumnType(stmt, i); + if (ActualColType = SQLITE_NULL) then + fResults.Add(nil) + else + if pInteger(fColTypes[i])^ = dtInt then + begin + new(thisintvalue); + thisintvalue^ := Sqlite3_ColumnInt64(stmt, i); + fResults.Add(thisintvalue); + end + else + if pInteger(fColTypes[i])^ = dtNumeric then + begin + new(thisdoublevalue); + thisdoublevalue^ := Sqlite3_ColumnDouble(stmt, i); + fResults.Add(thisdoublevalue); + end + else + if pInteger(fColTypes[i])^ = dtBlob then + begin + iNumBytes := Sqlite3_ColumnBytes(stmt, i); + if iNumBytes = 0 then + thisblobvalue := nil + else + begin + thisblobvalue := TMemoryStream.Create; + thisblobvalue.position := 0; + ptr := Sqlite3_ColumnBlob(stmt, i); + thisblobvalue.writebuffer(ptr^, iNumBytes); + end; + fResults.Add(thisblobvalue); + end + else + begin + new(thisstringvalue); + stemp := UnicodeString(UTF8String(Sqlite3_ColumnText(stmt, i))); + ptrValue2 := PWideChar(stemp); + setstring(thisstringvalue^, ptrvalue2, length(ptrvalue2)); + fResults.Add(thisstringvalue); +// new(thisstringvalue); +// ptrValue := Sqlite3_ColumnText(stmt, i); +// setstring(thisstringvalue^, ptrvalue, strlen(ptrvalue)); +// fResults.Add(thisstringvalue); + end; + end; + end; + SQLITE_BUSY: + raise ESqliteException.CreateFmt('Could not prepare SQL statement', + [SQL, 'SQLite is Busy']); + else + begin + SQLite3_reset(stmt); + DB.RaiseError('Could not retrieve data', string(SQL)); + end; + end; + iStepResult := Sqlite3_step(Stmt); + end; + fRow := 0; + finally + if Assigned(Stmt) then + Sqlite3_Finalize(stmt); + end; +end; +//.............................................................................. +destructor TSQLiteTable.Destroy; +var + i: cardinal; + iColNo: integer; +begin + if Assigned(fResults) then + begin + for i := 0 to fResults.Count - 1 do + begin + //check for blob type + iColNo := (i mod fColCount); + case pInteger(self.fColTypes[iColNo])^ of + dtBlob: + TMemoryStream(fResults[i]).Free; + dtStr: + if fResults[i] <> nil then + begin + setstring(string(fResults[i]^), nil, 0); + dispose(fResults[i]); + end; + else + dispose(fResults[i]); + end; + end; + fResults.Free; + end; + if Assigned(fCols) then + fCols.Free; + if Assigned(fColTypes) then + for i := 0 to fColTypes.Count - 1 do + dispose(fColTypes[i]); + fColTypes.Free; + inherited; +end; +//.............................................................................. +function TSQLiteTable.GetColumns(I: integer): string; +begin + Result := fCols[I]; +end; +//.............................................................................. +function TSQLiteTable.GetCountResult: integer; +begin + if not EOF then + Result := StrToInt(Fields[0]) + else + Result := 0; +end; +function TSQLiteTable.GetCount: integer; +begin + Result := FRowCount; +end; +//.............................................................................. +function TSQLiteTable.GetEOF: boolean; +begin + Result := fRow >= fRowCount; +end; +function TSQLiteTable.GetBOF: boolean; +begin + Result := fRow <= 0; +end; +//.............................................................................. +function TSQLiteTable.GetFieldByName(FieldName: string): string; +begin + Result := GetFields(self.GetFieldIndex(FieldName)); +end; +function TSQLiteTable.GetFieldIndex(FieldName: string): integer; +begin + if (fCols = nil) then + begin + raise ESqliteException.Create('Field ' + fieldname + ' Not found. Empty dataset'); + exit; + end; + if (fCols.count = 0) then + begin + raise ESqliteException.Create('Field ' + fieldname + ' Not found. Empty dataset'); + exit; + end; + Result := fCols.IndexOf(AnsiUpperCase(FieldName)); + if (result < 0) then + begin + raise ESqliteException.Create('Field not found in dataset: ' + fieldname) + end; +end; +//.............................................................................. +function TSQLiteTable.GetFields(I: cardinal): string; +var + thisvalue: pstring; + thistype: integer; +begin + Result := ''; + if EOF then + raise ESqliteException.Create('Table is at End of File'); + //integer types are not stored in the resultset + //as strings, so they should be retrieved using the type-specific + //methods + thistype := pInteger(self.fColTypes[I])^; + case thistype of + dtStr: + begin + thisvalue := self.fResults[(self.frow * self.fColCount) + I]; + if (thisvalue <> nil) then + Result := thisvalue^ + else + Result := ''; + end; + dtInt: + Result := IntToStr(self.FieldAsInteger(I)); + dtNumeric: + Result := FloatToStr(self.FieldAsDouble(I)); + dtBlob: + Result := self.FieldAsBlobText(I); + else + Result := ''; + end; +end; +function TSqliteTable.FieldAsBlob(I: cardinal): TMemoryStream; +begin + if EOF then + raise ESqliteException.Create('Table is at End of File'); + if (self.fResults[(self.frow * self.fColCount) + I] = nil) then + Result := nil + else + if pInteger(self.fColTypes[I])^ = dtBlob then + Result := TMemoryStream(self.fResults[(self.frow * self.fColCount) + I]) + else + raise ESqliteException.Create('Not a Blob field'); +end; +function TSqliteTable.FieldAsBlobText(I: cardinal): string; +var + MemStream: TMemoryStream; + Buffer: PAnsiChar; +begin + Result := ''; + MemStream := self.FieldAsBlob(I); + if MemStream <> nil then + if MemStream.Size > 0 then + begin + MemStream.position := 0; + {$IFDEF UNICODE} + Buffer := AnsiStralloc(MemStream.Size + 1); + {$ELSE} + Buffer := Stralloc(MemStream.Size + 1); + {$ENDIF} + MemStream.readbuffer(Buffer[0], MemStream.Size); + (Buffer + MemStream.Size)^ := chr(0); + SetString(Result, Buffer, MemStream.size); + strdispose(Buffer); + end; + //do not free the TMemoryStream here; it is freed when + //TSqliteTable is destroyed +end; + +function TSqliteTable.FieldAsInteger(I: cardinal): int64; +begin + if EOF then + raise ESqliteException.Create('Table is at End of File'); + if (self.fResults[(self.frow * self.fColCount) + I] = nil) then + Result := 0 + else + if pInteger(self.fColTypes[I])^ = dtInt then + Result := pInt64(self.fResults[(self.frow * self.fColCount) + I])^ + else + if pInteger(self.fColTypes[I])^ = dtNumeric then + Result := trunc(strtofloat(pString(self.fResults[(self.frow * self.fColCount) + I])^)) + else + raise ESqliteException.Create('Not an integer or numeric field'); +end; +function TSqliteTable.FieldAsDouble(I: cardinal): double; +begin + if EOF then + raise ESqliteException.Create('Table is at End of File'); + if (self.fResults[(self.frow * self.fColCount) + I] = nil) then + Result := 0 + else + if pInteger(self.fColTypes[I])^ = dtInt then + Result := pInt64(self.fResults[(self.frow * self.fColCount) + I])^ + else + if pInteger(self.fColTypes[I])^ = dtNumeric then + Result := pDouble(self.fResults[(self.frow * self.fColCount) + I])^ + else + raise ESqliteException.Create('Not an integer or numeric field'); +end; +function TSqliteTable.FieldAsString(I: cardinal): string; +begin + if EOF then + raise ESqliteException.Create('Table is at End of File'); + if (self.fResults[(self.frow * self.fColCount) + I] = nil) then + Result := '' + else + Result := self.GetFields(I); +end; +function TSqliteTable.FieldIsNull(I: cardinal): boolean; +var + thisvalue: pointer; +begin + if EOF then + raise ESqliteException.Create('Table is at End of File'); + thisvalue := self.fResults[(self.frow * self.fColCount) + I]; + Result := (thisvalue = nil); +end; +//.............................................................................. +function TSQLiteTable.Next: boolean; +begin + Result := False; + if not EOF then + begin + Inc(fRow); + Result := True; + end; +end; +function TSQLiteTable.Previous: boolean; +begin + Result := False; + if not BOF then + begin + Dec(fRow); + Result := True; + end; +end; +function TSQLiteTable.MoveFirst: boolean; +begin + Result := False; + if self.fRowCount > 0 then + begin + fRow := 0; + Result := True; + end; +end; +function TSQLiteTable.MoveLast: boolean; +begin + Result := False; + if self.fRowCount > 0 then + begin + fRow := fRowCount - 1; + Result := True; + end; +end; +{$WARNINGS OFF} +function TSQLiteTable.MoveTo(position: cardinal): boolean; +begin + Result := False; + if (self.fRowCount > 0) and (self.fRowCount > position) then + begin + fRow := position; + Result := True; + end; +end; +{$WARNINGS ON} + +{ TSQLiteUniTable } +constructor TSQLiteUniTable.Create(DB: TSQLiteDatabase; const SQL: Ansistring); +begin + Create(DB, SQL, []); +end; +constructor TSQLiteUniTable.Create(DB: TSQLiteDatabase; const SQL: Ansistring; const Bindings: array of const); +var + NextSQLStatement: PAnsiChar; + i: integer; +begin + inherited create; + self.fDB := db; + self.fEOF := false; + self.fRow := 0; + self.fColCount := 0; + self.fSQL := string(SQL); + if Sqlite3_Prepare_v2(DB.fDB, PAnsiChar(SQL), -1, fStmt, NextSQLStatement) <> SQLITE_OK then + DB.RaiseError('Error executing SQL', string(SQL)); + if (fStmt = nil) then + DB.RaiseError('Could not prepare SQL statement', string(SQL)); + DB.DoQuery(string(SQL)); + DB.SetParams(fStmt); + DB.BindData(fStmt, Bindings); + //get data types + fCols := TStringList.Create; + fColCount := SQLite3_ColumnCount(fstmt); + for i := 0 to Pred(fColCount) do + fCols.Add(AnsiUpperCase(string(Sqlite3_ColumnName(fstmt, i)))); + Next; +end; +destructor TSQLiteUniTable.Destroy; +begin + if Assigned(fStmt) then + Sqlite3_Finalize(fstmt); + if Assigned(fCols) then + fCols.Free; + inherited; +end; +function TSQLiteUniTable.FieldAsBlob(I: cardinal): TMemoryStream; +var + iNumBytes: integer; + ptr: pointer; +begin + Result := TMemoryStream.Create; + iNumBytes := Sqlite3_ColumnBytes(fstmt, i); + if iNumBytes > 0 then + begin + ptr := Sqlite3_ColumnBlob(fstmt, i); + Result.writebuffer(ptr^, iNumBytes); + Result.Position := 0; + end; +end; +function TSQLiteUniTable.FieldAsBlobPtr(I: cardinal; out iNumBytes: integer): Pointer; +begin + iNumBytes := Sqlite3_ColumnBytes(fstmt, i); + Result := Sqlite3_ColumnBlob(fstmt, i); +end; +function TSQLiteUniTable.FieldAsBlobText(I: cardinal): string; +var + MemStream: TMemoryStream; + Buffer: PAnsiChar; +begin + Result := ''; + MemStream := self.FieldAsBlob(I); + if MemStream <> nil then + try + if MemStream.Size > 0 then + begin + MemStream.position := 0; + {$IFDEF UNICODE} + Buffer := AnsiStralloc(MemStream.Size + 1); + {$ELSE} + Buffer := Stralloc(MemStream.Size + 1); + {$ENDIF} + MemStream.readbuffer(Buffer[0], MemStream.Size); + (Buffer + MemStream.Size)^ := chr(0); + SetString(Result, Buffer, MemStream.size); + strdispose(Buffer); + end; + finally + MemStream.Free; + end +end; +function TSQLiteUniTable.FieldAsDouble(I: cardinal): double; +begin + Result := Sqlite3_ColumnDouble(fstmt, i); +end; +function TSQLiteUniTable.FieldAsInteger(I: cardinal): int64; +begin + Result := Sqlite3_ColumnInt64(fstmt, i); +end; +function TSQLiteUniTable.FieldAsString(I: cardinal): string; +begin + Result := self.GetFields(I); +end; +function TSQLiteUniTable.FieldIsNull(I: cardinal): boolean; +begin + Result := Sqlite3_ColumnText(fstmt, i) = nil; +end; +function TSQLiteUniTable.GetColumns(I: integer): string; +begin + Result := fCols[I]; +end; +function TSQLiteUniTable.GetFieldByName(FieldName: string): string; +begin + Result := GetFields(self.GetFieldIndex(FieldName)); +end; +function TSQLiteUniTable.GetFieldIndex(FieldName: string): integer; +begin + if (fCols = nil) then + begin + raise ESqliteException.Create('Field ' + fieldname + ' Not found. Empty dataset'); + exit; + end; + if (fCols.count = 0) then + begin + raise ESqliteException.Create('Field ' + fieldname + ' Not found. Empty dataset'); + exit; + end; + Result := fCols.IndexOf(AnsiUpperCase(FieldName)); + if (result < 0) then + begin + raise ESqliteException.Create('Field not found in dataset: ' + fieldname) + end; +end; +function TSQLiteUniTable.GetFields(I: cardinal): string; +begin + Result := string(Sqlite3_ColumnText(fstmt, i)); +end; +function TSQLiteUniTable.Next: boolean; +var + iStepResult: integer; +begin + fEOF := true; + iStepResult := Sqlite3_step(fStmt); + case iStepResult of + SQLITE_ROW: + begin + fEOF := false; + inc(fRow); + end; + SQLITE_DONE: + // we are on the end of dataset + // return EOF=true only + ; + else + begin + SQLite3_reset(fStmt); + fDB.RaiseError('Could not retrieve data', fSQL); + end; + end; + Result := not fEOF; +end; +end. diff --git a/Tocsg.Lib/VCL/SuperObject/superobject.pas b/Tocsg.Lib/VCL/SuperObject/superobject.pas new file mode 100644 index 00000000..062a212d --- /dev/null +++ b/Tocsg.Lib/VCL/SuperObject/superobject.pas @@ -0,0 +1,7808 @@ +(* + * Super Object Toolkit + * + * Usage allowed under the restrictions of the Lesser GNU General Public License + * or alternatively the restrictions of the Mozilla Public License 1.1 + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for + * the specific language governing rights and limitations under the License. + * + * Embarcadero Technologies Inc is not permitted to use or redistribute + * this source code without explicit permission. + * + * Unit owner : Henri Gourvest <hgourvest@gmail.com> + * Web site : http://www.progdigy.com + * + * This unit is inspired from the json c lib: + * Michael Clark <michael@metaparadigm.com> + * http://oss.metaparadigm.com/json-c/ + * + * CHANGES: + * v1.2 + * + support of currency data type + * + right trim unquoted string + * + read Unicode Files and streams (Litle Endian with BOM) + * + Fix bug on javadate functions + windows nt compatibility + * + Now you can force to parse only the canonical syntax of JSON using the stric parameter + * + Delphi 2010 RTTI marshalling + * v1.1 + * + Double licence MPL or LGPL. + * + Delphi 2009 compatibility & Unicode support. + * + AsString return a string instead of PChar. + * + Escaped and Unascaped JSON serialiser. + * + Missed FormFeed added \f + * - Removed @ trick, uses forcepath() method instead. + * + Fixed parse error with uppercase E symbol in numbers. + * + Fixed possible buffer overflow when enlarging array. + * + Added "delete", "pack", "insert" methods for arrays and/or objects + * + Multi parametters when calling methods + * + Delphi Enumerator (for obj1 in obj2 do ...) + * + Format method ex: obj.format('<%name%>%tab[1]%</%name%>') + * + ParseFile and ParseStream methods + * + Parser now understand hexdecimal c syntax ex: \xFF + * + Null Object Design Patern (ex: for obj in values.N['path'] do ...) + * v1.0 + * + renamed class + * + interfaced object + * + added a new data type: the method + * + parser can now evaluate properties and call methods + * - removed obselet rpc class + * - removed "find" method, now you can use "parse" method instead + * v0.6 + * + refactoring + * v0.5 + * + new find method to get or set value using a path syntax + * ex: obj.s['obj.prop[1]'] := 'string value'; + * obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary + * v0.4 + * + bug corrected: AVL tree badly balanced. + * v0.3 + * + New validator partially based on the Kwalify syntax. + * + extended syntax to parse unquoted fields. + * + Freepascal compatibility win32/64 Linux32/64. + * + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC. + * + new TJsonObject.Compare function. + * v0.2 + * + Hashed string list replaced with a faster AVL tree + * + JsonInt data type can be changed to int64 + * + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions + * + from json-c v0.7 + * + Add escaping of backslash to json output + * + Add escaping of foward slash on tokenizing and output + * + Changes to internal tokenizer from using recursion to + * using a depth state structure to allow incremental parsing + * v0.1 + * + first release + *) + +{$IFDEF FPC} + {$MODE OBJFPC}{$H+} +{$ENDIF} + +{$DEFINE SUPER_METHOD} +{$DEFINE WINDOWSNT_COMPATIBILITY} +{.$DEFINE DEBUG} // track memory leack + + +{$if defined(FPC) or defined(VER170) or defined(VER180) or defined(VER190) or defined(VER200) or defined(VER210)} + {$DEFINE HAVE_INLINE} +{$ifend} + +//{$if defined(VER210) or defined(VER220) or defined(VER230)} +//{$if defined(VER210) or defined(VER220) or defined(VER230) or defined(VER240)} // XE3 (VER240) 추가 2017-08-03 + {$define HAVE_RTTI} +//{$ifend} + +//{$if defined(VER230)} +//{$if defined(VER230) or defined(VER240)} // XE3 (VER240) 추가 2017-08-03 + {$define NEED_FORMATSETTINGS} +//{$ifend} + +{$if defined(FPC) and defined(VER2_6)} + {$define NEED_FORMATSETTINGS} +{$ifend} + +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} + +unit superobject; + +interface +uses + Classes +{$IFDEF HAVE_RTTI} + ,Generics.Collections, RTTI, TypInfo, System.SysUtils +{$ENDIF} + ; + +type +{$IFNDEF FPC} +{$IFDEF CPUX64} + PtrInt = Int64; + PtrUInt = UInt64; +{$ELSE} + PtrInt = longint; + PtrUInt = Longword; +{$ENDIF} +{$ENDIF} + SuperInt = Int64; + +{$if (sizeof(Char) = 1)} + SOChar = WideChar; + SOIChar = Word; + PSOChar = PWideChar; +{$IFDEF FPC} + SOString = UnicodeString; +{$ELSE} + SOString = WideString; +{$ENDIF} +{$else} + SOChar = Char; + SOIChar = Word; + PSOChar = PChar; + SOString = string; +{$ifend} + +const + SUPER_ARRAY_LIST_DEFAULT_SIZE = 32; + SUPER_TOKENER_MAX_DEPTH = 32; + + SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8; + SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1); + +type + // forward declarations + TSuperObject = class; + ISuperObject = interface; + TSuperArray = class; + +(* AVL Tree + * This is a "special" autobalanced AVL tree + * It use a hash value for fast compare + *) + +{$IFDEF SUPER_METHOD} + TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject); +{$ENDIF} + + + TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1; + + TSuperAvlSearchType = (stEQual, stLess, stGreater); + TSuperAvlSearchTypes = set of TSuperAvlSearchType; + TSuperAvlIterator = class; + + TSuperAvlEntry = class + private + FGt, FLt: TSuperAvlEntry; + FBf: integer; + FHash: Cardinal; + FName: SOString; + FPtr: Pointer; + function GetValue: ISuperObject; + procedure SetValue(const val: ISuperObject); + public + class function Hash(const k: SOString): Cardinal; virtual; + constructor Create(const AName: SOString; Obj: Pointer); virtual; + property Name: SOString read FName; + property Ptr: Pointer read FPtr; + property Value: ISuperObject read GetValue write SetValue; + end; + + TSuperAvlTree = class + private + FRoot: TSuperAvlEntry; + FCount: Integer; + function balance(bal: TSuperAvlEntry): TSuperAvlEntry; + protected + procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual; + function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual; + function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual; + function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual; + function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual; + public + constructor Create; virtual; + destructor Destroy; override; + function IsEmpty: boolean; + procedure Clear(all: boolean = false); virtual; + procedure Pack(all: boolean); + function Delete(const k: SOString): ISuperObject; + function GetEnumerator: TSuperAvlIterator; + property count: Integer read FCount; + end; + + TSuperTableString = class(TSuperAvlTree) + protected + procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override; + procedure PutO(const k: SOString; const value: ISuperObject); + function GetO(const k: SOString): ISuperObject; + procedure PutS(const k: SOString; const value: SOString); + function GetS(const k: SOString): SOString; + procedure PutI(const k: SOString; value: SuperInt); + function GetI(const k: SOString): SuperInt; + procedure PutD(const k: SOString; value: Double); + function GetD(const k: SOString): Double; + procedure PutB(const k: SOString; value: Boolean); + function GetB(const k: SOString): Boolean; +{$IFDEF SUPER_METHOD} + procedure PutM(const k: SOString; value: TSuperMethod); + function GetM(const k: SOString): TSuperMethod; +{$ENDIF} + procedure PutN(const k: SOString; const value: ISuperObject); + function GetN(const k: SOString): ISuperObject; + procedure PutC(const k: SOString; value: Currency); + function GetC(const k: SOString): Currency; + public + property O[const k: SOString]: ISuperObject read GetO write PutO; default; + property S[const k: SOString]: SOString read GetS write PutS; + property I[const k: SOString]: SuperInt read GetI write PutI; + property D[const k: SOString]: Double read GetD write PutD; + property B[const k: SOString]: Boolean read GetB write PutB; +{$IFDEF SUPER_METHOD} + property M[const k: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property N[const k: SOString]: ISuperObject read GetN write PutN; + property C[const k: SOString]: Currency read GetC write PutC; + + function GetValues: ISuperObject; + function GetNames: ISuperObject; + function Find(const k: SOString; var value: ISuperObject): Boolean; + function Exists(const k: SOString): Boolean; + end; + + TSuperAvlIterator = class + private + FTree: TSuperAvlTree; + FBranch: TSuperAvlBitArray; + FDepth: LongInt; + FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry; + public + constructor Create(tree: TSuperAvlTree); virtual; + procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]); + procedure First; + procedure Last; + function GetIter: TSuperAvlEntry; + procedure Next; + procedure Prior; + // delphi enumerator + function MoveNext: Boolean; + property Current: TSuperAvlEntry read GetIter; + end; + + TSuperObjectArray = array[0..(high(Integer) div sizeof(TSuperObject))-1] of ISuperObject; + PSuperObjectArray = ^TSuperObjectArray; + + TSuperArray = class + private + FArray: PSuperObjectArray; + FLength: Integer; + FSize: Integer; + procedure Expand(max: Integer); + protected + function GetO(const index: integer): ISuperObject; + procedure PutO(const index: integer; const Value: ISuperObject); + function GetB(const index: integer): Boolean; + procedure PutB(const index: integer; Value: Boolean); + function GetI(const index: integer): SuperInt; + procedure PutI(const index: integer; Value: SuperInt); + function GetD(const index: integer): Double; + procedure PutD(const index: integer; Value: Double); + function GetC(const index: integer): Currency; + procedure PutC(const index: integer; Value: Currency); + function GetS(const index: integer): SOString; + procedure PutS(const index: integer; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const index: integer): TSuperMethod; + procedure PutM(const index: integer; Value: TSuperMethod); +{$ENDIF} + function GetN(const index: integer): ISuperObject; + procedure PutN(const index: integer; const Value: ISuperObject); + public + constructor Create; virtual; + destructor Destroy; override; + function Add(const Data: ISuperObject): Integer; overload; + function Add(Data: SuperInt): Integer; overload; + function Add(const Data: SOString): Integer; overload; + function Add(Data: Boolean): Integer; overload; + function Add(Data: Double): Integer; overload; + function AddC(const Data: Currency): Integer; + function Delete(index: Integer): ISuperObject; + procedure Insert(index: Integer; const value: ISuperObject); + procedure Clear(all: boolean = false); + procedure Pack(all: boolean); + property Length: Integer read FLength; + + property N[const index: integer]: ISuperObject read GetN write PutN; + property O[const index: integer]: ISuperObject read GetO write PutO; default; + property B[const index: integer]: boolean read GetB write PutB; + property I[const index: integer]: SuperInt read GetI write PutI; + property D[const index: integer]: Double read GetD write PutD; + property C[const index: integer]: Currency read GetC write PutC; + property S[const index: integer]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const index: integer]: TSuperMethod read GetM write PutM; +{$ENDIF} + end; + + TSuperWriter = class + public + // abstact methods to overide + function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract; + function Append(buf: PSOChar): Integer; overload; virtual; abstract; + procedure Reset; virtual; abstract; + end; + + TSuperWriterString = class(TSuperWriter) + private + FBuf: PSOChar; + FBPos: integer; + FSize: integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; overload; override; + function Append(buf: PSOChar): Integer; overload; override; + procedure Reset; override; + procedure TrimRight; + constructor Create; virtual; + destructor Destroy; override; + function GetString: SOString; + property Data: PSOChar read FBuf; + property Size: Integer read FSize; + property Position: integer read FBPos; + end; + + TSuperWriterStream = class(TSuperWriter) + private + FStream: TStream; + public + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create(AStream: TStream); reintroduce; virtual; + end; + + TSuperAnsiWriterStream = class(TSuperWriterStream) + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + end; + + TSuperUnicodeWriterStream = class(TSuperWriterStream) + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + end; + + TSuperWriterFake = class(TSuperWriter) + private + FSize: Integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create; reintroduce; virtual; + property size: integer read FSize; + end; + + TSuperWriterSock = class(TSuperWriter) + private + FSocket: longint; + FSize: Integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create(ASocket: longint); reintroduce; virtual; + property Socket: longint read FSocket; + property Size: Integer read FSize; + end; + + TSuperTokenizerError = ( + teSuccess, + teContinue, + teDepth, + teParseEof, + teParseUnexpected, + teParseNull, + teParseBoolean, + teParseNumber, + teParseArray, + teParseObjectKeyName, + teParseObjectKeySep, + teParseObjectValueSep, + teParseString, + teParseComment, + teEvalObject, + teEvalArray, + teEvalMethod, + teEvalInt + ); + + TSuperTokenerState = ( + tsEatws, + tsStart, + tsFinish, + tsNull, + tsCommentStart, + tsComment, + tsCommentEol, + tsCommentEnd, + tsString, + tsStringEscape, + tsIdentifier, + tsEscapeUnicode, + tsEscapeHexadecimal, + tsBoolean, + tsNumber, + tsArray, + tsArrayAdd, + tsArraySep, + tsObjectFieldStart, + tsObjectField, + tsObjectUnquotedField, + tsObjectFieldEnd, + tsObjectValue, + tsObjectValueAdd, + tsObjectSep, + tsEvalProperty, + tsEvalArray, + tsEvalMethod, + tsParamValue, + tsParamPut, + tsMethodValue, + tsMethodPut + ); + + PSuperTokenerSrec = ^TSuperTokenerSrec; + TSuperTokenerSrec = record + state, saved_state: TSuperTokenerState; + obj: ISuperObject; + current: ISuperObject; + field_name: SOString; + parent: ISuperObject; + gparent: ISuperObject; + end; + + TSuperTokenizer = class + public + str: PSOChar; + pb: TSuperWriterString; + depth, is_double, floatcount, st_pos, char_offset: Integer; + err: TSuperTokenizerError; + ucs_char: Word; + quote_char: SOChar; + stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec; + line, col: Integer; + public + constructor Create; virtual; + destructor Destroy; override; + procedure ResetLevel(adepth: integer); + procedure Reset; + end; + + // supported object types + TSuperType = ( + stNull, + stBoolean, + stDouble, + stCurrency, + stInt, + stObject, + stArray, + stString +{$IFDEF SUPER_METHOD} + ,stMethod +{$ENDIF} + ); + + TSuperValidateError = ( + veRuleMalformated, + veFieldIsRequired, + veInvalidDataType, + veFieldNotFound, + veUnexpectedField, + veDuplicateEntry, + veValueNotInEnum, + veInvalidLength, + veInvalidRange + ); + + TSuperFindOption = ( + foCreatePath, + foPutValue, + foDelete +{$IFDEF SUPER_METHOD} + ,foCallMethod +{$ENDIF} + ); + + TSuperFindOptions = set of TSuperFindOption; + TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError); + TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString); + + TSuperEnumerator = class + private + FObj: ISuperObject; + FObjEnum: TSuperAvlIterator; + FCount: Integer; + public + constructor Create(const obj: ISuperObject); virtual; + destructor Destroy; override; + function MoveNext: Boolean; + function GetCurrent: ISuperObject; + property Current: ISuperObject read GetCurrent; + end; + + ISuperObject = interface + ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}'] + function GetEnumerator: TSuperEnumerator; + function GetDataType: TSuperType; + function GetProcessing: boolean; + procedure SetProcessing(value: boolean); + function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; + function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; + + function GetO(const path: SOString): ISuperObject; + procedure PutO(const path: SOString; const Value: ISuperObject); + function GetB(const path: SOString): Boolean; + procedure PutB(const path: SOString; Value: Boolean); + function GetI(const path: SOString): SuperInt; + procedure PutI(const path: SOString; Value: SuperInt); + function GetD(const path: SOString): Double; + procedure PutC(const path: SOString; Value: Currency); + function GetC(const path: SOString): Currency; + procedure PutD(const path: SOString; Value: Double); + function GetS(const path: SOString): SOString; + procedure PutS(const path: SOString; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const path: SOString): TSuperMethod; + procedure PutM(const path: SOString; Value: TSuperMethod); +{$ENDIF} + function GetA(const path: SOString): TSuperArray; + + // Null Object Design patern + function GetN(const path: SOString): ISuperObject; + procedure PutN(const path: SOString; const Value: ISuperObject); + + // Writers + function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; + function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; + function CalcSize(indent: boolean = false; escape: boolean = true): integer; + + // convert + function AsBoolean: Boolean; + function AsInteger: SuperInt; + function AsDouble: Double; + function AsCurrency: Currency; + function AsString: SOString; + function AsArray: TSuperArray; + function AsObject: TSuperTableString; +{$IFDEF SUPER_METHOD} + function AsMethod: TSuperMethod; +{$ENDIF} + function AsJSon(indent: boolean = false; escape: boolean = true): SOString; + + procedure Clear(all: boolean = false); + procedure Pack(all: boolean = false); + + property N[const path: SOString]: ISuperObject read GetN write PutN; + property O[const path: SOString]: ISuperObject read GetO write PutO; default; + property B[const path: SOString]: boolean read GetB write PutB; + property I[const path: SOString]: SuperInt read GetI write PutI; + property D[const path: SOString]: Double read GetD write PutD; + property C[const path: SOString]: Currency read GetC write PutC; + property S[const path: SOString]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const path: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property A[const path: SOString]: TSuperArray read GetA; + +{$IFDEF SUPER_METHOD} + function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; + function call(const path, param: SOString): ISuperObject; overload; +{$ENDIF} + + // clone a node + function Clone: ISuperObject; + function Delete(const path: SOString): ISuperObject; + // merges tow objects of same type, if reference is true then nodes are not cloned + procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; + procedure Merge(const str: SOString); overload; + + // validate methods + function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + + // compare + function Compare(const obj: ISuperObject): TSuperCompareResult; overload; + function Compare(const str: SOString): TSuperCompareResult; overload; + + // the data type + function IsType(AType: TSuperType): boolean; + property DataType: TSuperType read GetDataType; + property Processing: boolean read GetProcessing write SetProcessing; + + function GetDataPtr: Pointer; + procedure SetDataPtr(const Value: Pointer); + property DataPtr: Pointer read GetDataPtr write SetDataPtr; + end; + + TSuperObject = class(TObject, ISuperObject) + private + FRefCount: Integer; + FProcessing: boolean; + FDataType: TSuperType; + FDataPtr: Pointer; +{.$if true} + FO: record + case TSuperType of + stBoolean: (c_boolean: boolean); + stDouble: (c_double: double); + stCurrency: (c_currency: Currency); + stInt: (c_int: SuperInt); + stObject: (c_object: TSuperTableString); + stArray: (c_array: TSuperArray); +{$IFDEF SUPER_METHOD} + stMethod: (c_method: TSuperMethod); +{$ENDIF} + end; +{.$ifend} + FOString: SOString; + function GetDataType: TSuperType; + function GetDataPtr: Pointer; + procedure SetDataPtr(const Value: Pointer); + protected +{$IFDEF FPC} + function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; +{$ELSE} + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; +{$ENDIF} + function _AddRef: Integer; virtual; stdcall; + function _Release: Integer; virtual; stdcall; + + function GetO(const path: SOString): ISuperObject; + procedure PutO(const path: SOString; const Value: ISuperObject); + function GetB(const path: SOString): Boolean; + procedure PutB(const path: SOString; Value: Boolean); + function GetI(const path: SOString): SuperInt; + procedure PutI(const path: SOString; Value: SuperInt); + function GetD(const path: SOString): Double; + procedure PutD(const path: SOString; Value: Double); + procedure PutC(const path: SOString; Value: Currency); + function GetC(const path: SOString): Currency; + function GetS(const path: SOString): SOString; + procedure PutS(const path: SOString; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const path: SOString): TSuperMethod; + procedure PutM(const path: SOString; Value: TSuperMethod); +{$ENDIF} + function GetA(const path: SOString): TSuperArray; + function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual; + public + function GetEnumerator: TSuperEnumerator; + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + + function GetProcessing: boolean; + procedure SetProcessing(value: boolean); + + // Writers + function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; + function CalcSize(indent: boolean = false; escape: boolean = true): integer; + function AsJSon(indent: boolean = false; escape: boolean = true): SOString; + + // parser ... owned! + class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil; + options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + + // constructors / destructor + constructor Create(jt: TSuperType = stObject); overload; virtual; + constructor Create(b: boolean); overload; virtual; + constructor Create(i: SuperInt); overload; virtual; + constructor Create(d: double); overload; virtual; + constructor CreateCurrency(c: Currency); overload; virtual; + constructor Create(const s: SOString); overload; virtual; +{$IFDEF SUPER_METHOD} + constructor Create(m: TSuperMethod); overload; virtual; +{$ENDIF} + destructor Destroy; override; + + // convert + function AsBoolean: Boolean; virtual; + function AsInteger: SuperInt; virtual; + function AsDouble: Double; virtual; + function AsCurrency: Currency; virtual; + function AsString: SOString; virtual; + function AsArray: TSuperArray; virtual; + function AsObject: TSuperTableString; virtual; +{$IFDEF SUPER_METHOD} + function AsMethod: TSuperMethod; virtual; +{$ENDIF} + procedure Clear(all: boolean = false); virtual; + procedure Pack(all: boolean = false); virtual; + function GetN(const path: SOString): ISuperObject; + procedure PutN(const path: SOString; const Value: ISuperObject); + function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; + function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; + + property N[const path: SOString]: ISuperObject read GetN write PutN; + property O[const path: SOString]: ISuperObject read GetO write PutO; default; + property B[const path: SOString]: boolean read GetB write PutB; + property I[const path: SOString]: SuperInt read GetI write PutI; + property D[const path: SOString]: Double read GetD write PutD; + property C[const path: SOString]: Currency read GetC write PutC; + property S[const path: SOString]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const path: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property A[const path: SOString]: TSuperArray read GetA; + + {$IFDEF SUPER_METHOD} + function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual; + function call(const path, param: SOString): ISuperObject; overload; virtual; +{$ENDIF} + // clone a node + function Clone: ISuperObject; virtual; + function Delete(const path: SOString): ISuperObject; + // merges tow objects of same type, if reference is true then nodes are not cloned + procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; + procedure Merge(const str: SOString); overload; + + // validate methods + function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + + // compare + function Compare(const obj: ISuperObject): TSuperCompareResult; overload; + function Compare(const str: SOString): TSuperCompareResult; overload; + + // the data type + function IsType(AType: TSuperType): boolean; + property DataType: TSuperType read GetDataType; + // a data pointer to link to something ele, a treeview for example + property DataPtr: Pointer read GetDataPtr write SetDataPtr; + property Processing: boolean read GetProcessing; + end; + +{$IFDEF HAVE_RTTI} + TSuperRttiContext = class; + + TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; + TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; + + TSuperAttribute = class(TCustomAttribute) + private + FName: string; + public + constructor Create(const AName: string); + property Name: string read FName; + end; + + SOName = class(TSuperAttribute); + SODefault = class(TSuperAttribute); + + + TSuperRttiContext = class + private + class function GetFieldName(r: TRttiField): string; + class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; + public + Context: TRttiContext; + SerialFromJson: TDictionary<PTypeInfo, TSerialFromJson>; + SerialToJson: TDictionary<PTypeInfo, TSerialToJson>; + constructor Create; virtual; + destructor Destroy; override; + function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual; + function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual; + function AsType<T>(const obj: ISuperObject): T; + function AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject; + end; + + TSuperObjectHelper = class helper for TObject + public + function ToJson(ctx: TSuperRttiContext = nil): ISuperObject; + constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload; + constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload; + end; +{$ENDIF} + + TSuperObjectIter = record + key: SOString; + val: ISuperObject; + Ite: TSuperAvlIterator; + end; + +function ObjectIsError(obj: TSuperObject): boolean; +function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; +function ObjectGetType(const obj: ISuperObject): TSuperType; +function ObjectIsNull(const obj: ISuperObject): Boolean; + +function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; +function ObjectFindNext(var F: TSuperObjectIter): boolean; +procedure ObjectFindClose(var F: TSuperObjectIter); + +function SO(const s: SOString = '{}'): ISuperObject; overload; +function SO(const value: Variant): ISuperObject; overload; +function SO(const Args: array of const): ISuperObject; overload; + +function SA(const Args: array of const): ISuperObject; overload; + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +function DelphiToJavaDateTime(const dt: TDateTime): int64; +function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean; +function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean; +function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean; +function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString; +function UUIDToString(const g: TGUID): SOString; +function StringToUUID(const str: SOString; var g: TGUID): Boolean; + +function StringsToJsonObj(aList: TStrings): ISuperObject; +procedure LoadStringsFromJsonObj(aObj: ISuperObject; aList: TStrings); + +function SaveJsonObjToStream(aO: ISuperObject; aStream: TStream; aEncoding: TEncoding = nil): Boolean; +function SaveJsonObjToFile(aO: ISuperObject; sPath: String; aEncoding: TEncoding = nil; bIncIndent: Boolean = false): Boolean; +function LoadJsonObjFromFile(var aO: ISuperObject; sPath: String; aEncoding: TEncoding = nil): Boolean; + +function SaveJsonObjToEncStream(aO: ISuperObject; aStream: TStream; sPass: String; aEncoding: TEncoding = nil): Boolean; +function SaveJsonObjToEncFile(aO: ISuperObject; sPath: String; sPass: String; aEncoding: TEncoding = nil): Boolean; +function LoadJsonObjFromEncFile(var aO: ISuperObject; sPath: String; sPass: String; aEncoding: TEncoding = nil): Boolean; + +{$IFDEF HAVE_RTTI} + +type + TSuperInvokeResult = ( + irSuccess, + irMethothodError, // method don't exist + irParamError, // invalid parametters + irError // other error + ); + +function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload; +function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload; +function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload; +{$ENDIF} + +implementation +uses +{$IFDEF UNIX} + baseunix, unix, DateUtils +{$ELSE} + WinApi.Windows +{$ENDIF} +{$IFDEF FPC} + ,sockets +{$ELSE} + ,WinApi.WinSock, Tocsg.Encrypt; +{$ENDIF} + +{$IFDEF DEBUG} +var + debugcount: integer = 0; +{$ENDIF} + +const + super_number_chars_set = ['0'..'9','.','+','-','e','E']; + super_hex_chars: PSOChar = '0123456789abcdef'; + super_hex_chars_set = ['0'..'9','a'..'f','A'..'F']; + + ESC_BS: PSOChar = '\b'; + ESC_LF: PSOChar = '\n'; + ESC_CR: PSOChar = '\r'; + ESC_TAB: PSOChar = '\t'; + ESC_FF: PSOChar = '\f'; + ESC_QUOT: PSOChar = '\"'; + ESC_SL: PSOChar = '\\'; + ESC_SR: PSOChar = '\/'; + ESC_ZERO: PSOChar = '\u0000'; + + TOK_CRLF: PSOChar = #13#10; + TOK_SP: PSOChar = #32; + TOK_BS: PSOChar = #8; + TOK_TAB: PSOChar = #9; + TOK_LF: PSOChar = #10; + TOK_FF: PSOChar = #12; + TOK_CR: PSOChar = #13; +// TOK_SL: PSOChar = '\'; +// TOK_SR: PSOChar = '/'; + TOK_NULL: PSOChar = 'null'; + TOK_CBL: PSOChar = '{'; // curly bracket left + TOK_CBR: PSOChar = '}'; // curly bracket right + TOK_ARL: PSOChar = '['; + TOK_ARR: PSOChar = ']'; + TOK_ARRAY: PSOChar = '[]'; + TOK_OBJ: PSOChar = '{}'; // empty object + TOK_COM: PSOChar = ','; // Comma + TOK_DQT: PSOChar = '"'; // Double Quote + TOK_TRUE: PSOChar = 'true'; + TOK_FALSE: PSOChar = 'false'; + +{$if (sizeof(Char) = 1)} +function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer; +var + P1, P2: PWideChar; + I: Cardinal; + C1, C2: WideChar; +begin + P1 := Str1; + P2 := Str2; + I := 0; + while I < MaxLen do + begin + C1 := P1^; + C2 := P2^; + + if (C1 <> C2) or (C1 = #0) then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + + Inc(P1); + Inc(P2); + Inc(I); + end; + Result := 0; +end; + +function StrComp(const Str1, Str2: PSOChar): Integer; +var + P1, P2: PWideChar; + C1, C2: WideChar; +begin + P1 := Str1; + P2 := Str2; + while True do + begin + C1 := P1^; + C2 := P2^; + + if (C1 <> C2) or (C1 = #0) then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + + Inc(P1); + Inc(P2); + end; +end; + +function StrLen(const Str: PSOChar): Cardinal; +var + p: PSOChar; +begin + Result := 0; + if Str <> nil then + begin + p := Str; + while p^ <> #0 do inc(p); + Result := (p - Str); + end; +end; +{$ifend} + +function FloatToJson(const value: Double): SOString; +var + p: PSOChar; +begin + Result := FloatToStr(value); + if {$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator <> '.' then + begin + p := PSOChar(Result); + while p^ <> #0 do + if p^ <> SOChar({$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator) then + inc(p) else + begin + p^ := '.'; + Exit; + end; + end; +end; + +function CurrToJson(const value: Currency): SOString; +var + p: PSOChar; +begin + Result := CurrToStr(value); + if {$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator <> '.' then + begin + p := PSOChar(Result); + while p^ <> #0 do + if p^ <> SOChar({$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator) then + inc(p) else + begin + p^ := '.'; + Exit; + end; + end; +end; + +{$IFDEF UNIX} +function GetTimeBias: integer; +var + TimeVal: TTimeVal; + TimeZone: TTimeZone; +begin + fpGetTimeOfDay(@TimeVal, @TimeZone); + Result := TimeZone.tz_minuteswest; +end; +{$ELSE} +function GetTimeBias: integer; +var + tzi : TTimeZoneInformation; +begin + case GetTimeZoneInformation(tzi) of + TIME_ZONE_ID_UNKNOWN : Result := tzi.Bias; + TIME_ZONE_ID_STANDARD: Result := tzi.Bias + tzi.StandardBias; + TIME_ZONE_ID_DAYLIGHT: Result := tzi.Bias + tzi.DaylightBias; + else + Result := 0; + end; +end; +{$ENDIF} + +{$IFDEF UNIX} +type + ptm = ^tm; + tm = record + tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *) + tm_min: Integer; (* Minutes: 0-59 *) + tm_hour: Integer; (* Hours since midnight: 0-23 *) + tm_mday: Integer; (* Day of the month: 1-31 *) + tm_mon: Integer; (* Months *since* january: 0-11 *) + tm_year: Integer; (* Years since 1900 *) + tm_wday: Integer; (* Days since Sunday (0-6) *) + tm_yday: Integer; (* Days since Jan. 1: 0-365 *) + tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *) + end; + +function mktime(p: ptm): LongInt; cdecl; external; +function gmtime(const t: PLongint): ptm; cdecl; external; +function localtime (const t: PLongint): ptm; cdecl; external; + +function DelphiToJavaDateTime(const dt: TDateTime): Int64; +var + p: ptm; + l, ms: Integer; + v: Int64; +begin + v := Round((dt - 25569) * 86400000); + ms := v mod 1000; + l := v div 1000; + p := localtime(@l); + Result := Int64(mktime(p)) * 1000 + ms; +end; + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +var + p: ptm; + l, ms: Integer; +begin + l := dt div 1000; + ms := dt mod 1000; + p := gmtime(@l); + Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms); +end; +{$ELSE} + +{$IFDEF WINDOWSNT_COMPATIBILITY} +function DayLightCompareDate(const date: PSystemTime; + const compareDate: PSystemTime): Integer; +var + limit_day, dayinsecs, weekofmonth: Integer; + First: Word; +begin + if (date^.wMonth < compareDate^.wMonth) then + begin + Result := -1; (* We are in a month before the date limit. *) + Exit; + end; + + if (date^.wMonth > compareDate^.wMonth) then + begin + Result := 1; (* We are in a month after the date limit. *) + Exit; + end; + + (* if year is 0 then date is in day-of-week format, otherwise + * it's absolute date. + *) + if (compareDate^.wYear = 0) then + begin + (* compareDate.wDay is interpreted as number of the week in the month + * 5 means: the last week in the month *) + weekofmonth := compareDate^.wDay; + (* calculate the day of the first DayOfWeek in the month *) + First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1; + limit_day := First + 7 * (weekofmonth - 1); + (* check needed for the 5th weekday of the month *) + if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth]) then + dec(limit_day, 7); + end + else + limit_day := compareDate^.wDay; + + (* convert to seconds *) + limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60; + dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond; + (* and compare *) + + if dayinsecs < limit_day then + Result := -1 else + if dayinsecs > limit_day then + Result := 1 else + Result := 0; (* date is equal to the date limit. *) +end; + +function CompTimeZoneID(const pTZinfo: PTimeZoneInformation; + lpFileTime: PFileTime; islocal: Boolean): LongWord; +var + ret: Integer; + beforeStandardDate, afterDaylightDate: Boolean; + llTime: Int64; + SysTime: TSystemTime; + ftTemp: TFileTime; +begin + llTime := 0; + + if (pTZinfo^.DaylightDate.wMonth <> 0) then + begin + (* if year is 0 then date is in day-of-week format, otherwise + * it's absolute date. + *) + if ((pTZinfo^.StandardDate.wMonth = 0) or + ((pTZinfo^.StandardDate.wYear = 0) and + ((pTZinfo^.StandardDate.wDay < 1) or + (pTZinfo^.StandardDate.wDay > 5) or + (pTZinfo^.DaylightDate.wDay < 1) or + (pTZinfo^.DaylightDate.wDay > 5)))) then + begin + SetLastError(ERROR_INVALID_PARAMETER); + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + if (not islocal) then + begin + llTime := PInt64(lpFileTime)^; + dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000); + PInt64(@ftTemp)^ := llTime; + lpFileTime := @ftTemp; + end; + + FileTimeToSystemTime(lpFileTime^, SysTime); + + (* check for daylight savings *) + ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate); + if (ret = -2) then + begin + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + beforeStandardDate := ret < 0; + + if (not islocal) then + begin + dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000); + PInt64(@ftTemp)^ := llTime; + FileTimeToSystemTime(lpFileTime^, SysTime); + end; + + ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate); + if (ret = -2) then + begin + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + afterDaylightDate := ret >= 0; + + Result := TIME_ZONE_ID_STANDARD; + if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then + begin + (* Northern hemisphere *) + if( beforeStandardDate and afterDaylightDate) then + Result := TIME_ZONE_ID_DAYLIGHT; + end else (* Down south *) + if( beforeStandardDate or afterDaylightDate) then + Result := TIME_ZONE_ID_DAYLIGHT; + end else + (* No transition date *) + Result := TIME_ZONE_ID_UNKNOWN; +end; + +function GetTimezoneBias(const pTZinfo: PTimeZoneInformation; + lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean; +var + bias: LongInt; + tzid: LongWord; +begin + bias := pTZinfo^.Bias; + tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal); + + if( tzid = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + if (tzid = TIME_ZONE_ID_DAYLIGHT) then + inc(bias, pTZinfo^.DaylightBias) + else if (tzid = TIME_ZONE_ID_STANDARD) then + inc(bias, pTZinfo^.StandardBias); + pBias^ := bias; + Result := True; +end; + +function SystemTimeToTzSpecificLocalTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpUniversalTime, lpLocalTime: PSystemTime): BOOL; +var + ft: TFileTime; + lBias: LongInt; + llTime: Int64; + tzinfo: TTimeZoneInformation; +begin + if (lpTimeZoneInformation <> nil) then + tzinfo := lpTimeZoneInformation^ else + if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + + if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then + begin + Result := False; + Exit; + end; + llTime := PInt64(@ft)^; + if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then + begin + Result := False; + Exit; + end; + (* convert minutes to 100-nanoseconds-ticks *) + dec(llTime, Int64(lBias) * 600000000); + PInt64(@ft)^ := llTime; + Result := FileTimeToSystemTime(ft, lpLocalTime^); +end; + +function TzSpecificLocalTimeToSystemTime( + const lpTimeZoneInformation: PTimeZoneInformation; + const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL; +var + ft: TFileTime; + lBias: LongInt; + t: Int64; + tzinfo: TTimeZoneInformation; +begin + if (lpTimeZoneInformation <> nil) then + tzinfo := lpTimeZoneInformation^ + else + if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + + if (not SystemTimeToFileTime(lpLocalTime^, ft)) then + begin + Result := False; + Exit; + end; + t := PInt64(@ft)^; + if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then + begin + Result := False; + Exit; + end; + (* convert minutes to 100-nanoseconds-ticks *) + inc(t, Int64(lBias) * 600000000); + PInt64(@ft)^ := t; + Result := FileTimeToSystemTime(ft, lpUniversalTime^); +end; +{$ELSE} +function TzSpecificLocalTimeToSystemTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; + +function SystemTimeToTzSpecificLocalTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; +{$ENDIF} + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +var + t: TSystemTime; +begin + DateTimeToSystemTime(25569 + (dt / 86400000), t); + SystemTimeToTzSpecificLocalTime(nil, @t, @t); + Result := SystemTimeToDateTime(t); +end; + +function DelphiToJavaDateTime(const dt: TDateTime): int64; +var + t: TSystemTime; +begin + DateTimeToSystemTime(dt, t); + TzSpecificLocalTimeToSystemTime(nil, @t, @t); + Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000) +end; +{$ENDIF} + +function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean; +type + TState = ( + stStart, stYear, stMonth, stWeek, stWeekDay, stDay, stDayOfYear, + stHour, stMin, stSec, stMs, stUTC, stGMTH, stGMTM, + stGMTend, stEnd); + + TPerhaps = (yes, no, perhaps); + TDateTimeInfo = record + year: Word; + month: Word; + week: Word; + weekday: Word; + day: Word; + dayofyear: Integer; + hour: Word; + minute: Word; + second: Word; + ms: Word; + bias: Integer; + end; + +var + p: PSOChar; + state: TState; + pos, v: Word; + sep: TPerhaps; + inctz, havetz, havedate: Boolean; + st: TDateTimeInfo; + DayTable: PDayTable; + + function get(var v: Word; c: SOChar): Boolean; {$IFDEF HAVE_INLINE} inline;{$ENDIF} + begin + if (c < #256) and (AnsiChar(c) in ['0'..'9']) then + begin + Result := True; + v := v * 10 + Ord(c) - Ord('0'); + end else + Result := False; + end; + +label + error; +begin + p := PSOChar(str); + sep := perhaps; + state := stStart; + pos := 0; + FillChar(st, SizeOf(st), 0); + havedate := True; + inctz := False; + havetz := False; + + while true do + case state of + stStart: + case p^ of + '0'..'9': state := stYear; + 'T', 't': + begin + state := stHour; + pos := 0; + inc(p); + havedate := False; + end; + else + goto error; + end; + stYear: + case pos of + 0..1,3: + if get(st.year, p^) then + begin + Inc(pos); + Inc(p); + end else + goto error; + 2: case p^ of + '0'..'9': + begin + st.year := st.year * 10 + ord(p^) - ord('0'); + Inc(pos); + Inc(p); + end; + ':': + begin + havedate := false; + st.hour := st.year; + st.year := 0; + inc(p); + pos := 0; + state := stMin; + sep := yes; + end; + else + goto error; + end; + 4: case p^ of + '-': begin + pos := 0; + Inc(p); + sep := yes; + state := stMonth; + end; + '0'..'9': + begin + sep := no; + pos := 0; + state := stMonth; + end; + 'W', 'w' : + begin + pos := 0; + Inc(p); + state := stWeek; + end; + 'T', 't', ' ': + begin + state := stHour; + pos := 0; + inc(p); + st.month := 1; + st.day := 1; + end; + #0: + begin + st.month := 1; + st.day := 1; + state := stEnd; + end; + else + goto error; + end; + end; + stMonth: + case pos of + 0: case p^ of + '0'..'9': + begin + st.month := ord(p^) - ord('0'); + Inc(pos); + Inc(p); + end; + 'W', 'w': + begin + pos := 0; + Inc(p); + state := stWeek; + end; + else + goto error; + end; + 1: if get(st.month, p^) then + begin + Inc(pos); + Inc(p); + end else + goto error; + 2: case p^ of + '-': + if (sep in [yes, perhaps]) then + begin + pos := 0; + Inc(p); + state := stDay; + sep := yes; + end else + goto error; + '0'..'9': + if sep in [no, perhaps] then + begin + pos := 0; + state := stDay; + sep := no; + end else + begin + st.dayofyear := st.month * 10 + Ord(p^) - Ord('0'); + st.month := 0; + inc(p); + pos := 3; + state := stDayOfYear; + end; + 'T', 't', ' ': + begin + state := stHour; + pos := 0; + inc(p); + st.day := 1; + end; + #0: + begin + st.day := 1; + state := stEnd; + end; + else + goto error; + end; + end; + stDay: + case pos of + 0: if get(st.day, p^) then + begin + Inc(pos); + Inc(p); + end else + goto error; + 1: if get(st.day, p^) then + begin + Inc(pos); + Inc(p); + end else + if sep in [no, perhaps] then + begin + st.dayofyear := st.month * 10 + st.day; + st.day := 0; + st.month := 0; + state := stDayOfYear; + end else + goto error; + + 2: case p^ of + 'T', 't', ' ': + begin + pos := 0; + Inc(p); + state := stHour; + end; + #0: state := stEnd; + else + goto error; + end; + end; + stDayOfYear: + begin + if (st.dayofyear <= 0) then goto error; + case p^ of + 'T', 't', ' ': + begin + pos := 0; + Inc(p); + state := stHour; + end; + #0: state := stEnd; + else + goto error; + end; + end; + stWeek: + begin + case pos of + 0..1: if get(st.week, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + 2: case p^ of + '-': if (sep in [yes, perhaps]) then + begin + Inc(p); + state := stWeekDay; + sep := yes; + end else + goto error; + '1'..'7': + if sep in [no, perhaps] then + begin + state := stWeekDay; + sep := no; + end else + goto error; + else + goto error; + end; + end; + end; + stWeekDay: + begin + if (st.week > 0) and get(st.weekday, p^) then + begin + inc(p); + v := st.year - 1; + v := ((v * 365) + (v div 4) - (v div 100) + (v div 400)) mod 7 + 1; + st.dayofyear := (st.weekday - v) + ((st.week) * 7) + 1; + if v <= 4 then dec(st.dayofyear, 7); + case p^ of + 'T', 't', ' ': + begin + pos := 0; + Inc(p); + state := stHour; + end; + #0: state := stEnd; + else + goto error; + end; + end else + goto error; + end; + stHour: + case pos of + 0: case p^ of + '0'..'9': + if get(st.hour, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + '-': + begin + inc(p); + state := stMin; + end; + else + goto error; + end; + 1: if get(st.hour, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + 2: case p^ of + ':': if sep in [yes, perhaps] then + begin + sep := yes; + pos := 0; + Inc(p); + state := stMin; + end else + goto error; + ',', '.': + begin + Inc(p); + state := stMs; + end; + '+': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + end else + goto error; + '-': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + inctz := True; + end else + goto error; + 'Z', 'z': + if havedate then + state := stUTC else + goto error; + '0'..'9': + if sep in [no, perhaps] then + begin + pos := 0; + state := stMin; + sep := no; + end else + goto error; + #0: state := stEnd; + else + goto error; + end; + end; + stMin: + case pos of + 0: case p^ of + '0'..'9': + if get(st.minute, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + '-': + begin + inc(p); + state := stSec; + end; + else + goto error; + end; + 1: if get(st.minute, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + 2: case p^ of + ':': if sep in [yes, perhaps] then + begin + pos := 0; + Inc(p); + state := stSec; + sep := yes; + end else + goto error; + ',', '.': + begin + Inc(p); + state := stMs; + end; + '+': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + end else + goto error; + '-': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + inctz := True; + end else + goto error; + 'Z', 'z': + if havedate then + state := stUTC else + goto error; + '0'..'9': + if sep in [no, perhaps] then + begin + pos := 0; + state := stSec; + end else + goto error; + #0: state := stEnd; + else + goto error; + end; + end; + stSec: + case pos of + 0..1: if get(st.second, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + 2: case p^ of + ',', '.': + begin + Inc(p); + state := stMs; + end; + '+': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + end else + goto error; + '-': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + inctz := True; + end else + goto error; + 'Z', 'z': + if havedate then + state := stUTC else + goto error; + #0: state := stEnd; + else + goto error; + end; + end; + stMs: + case p^ of + '0'..'9': + begin + st.ms := st.ms * 10 + ord(p^) - ord('0'); + inc(p); + end; + '+': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + end else + goto error; + '-': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + inctz := True; + end else + goto error; + 'Z', 'z': + if havedate then + state := stUTC else + goto error; + #0: state := stEnd; + else + goto error; + end; + stUTC: // = GMT 0 + begin + havetz := True; + inc(p); + if p^ = #0 then + Break else + goto error; + end; + stGMTH: + begin + havetz := True; + case pos of + 0..1: if get(v, p^) then + begin + inc(p); + inc(pos); + end else + goto error; + 2: + begin + st.bias := v * 60; + case p^ of + ':': if sep in [yes, perhaps] then + begin + state := stGMTM; + inc(p); + pos := 0; + v := 0; + sep := yes; + end else + goto error; + '0'..'9': + if sep in [no, perhaps] then + begin + state := stGMTM; + pos := 1; + sep := no; + inc(p); + v := ord(p^) - ord('0'); + end else + goto error; + #0: state := stGMTend; + else + goto error; + end; + + end; + end; + end; + stGMTM: + case pos of + 0..1: if get(v, p^) then + begin + inc(p); + inc(pos); + end else + goto error; + 2: case p^ of + #0: + begin + state := stGMTend; + inc(st.Bias, v); + end; + else + goto error; + end; + end; + stGMTend: + begin + if not inctz then + st.Bias := -st.bias; + Break; + end; + stEnd: + begin + + Break; + end; + end; + + if (st.hour >= 24) or (st.minute >= 60) or (st.second >= 60) or (st.ms >= 1000) or (st.week > 53) + then goto error; + + if not havetz then + st.bias := GetTimeBias; + + ms := st.ms + st.second * 1000 + (st.minute + st.bias) * 60000 + st.hour * 3600000; + if havedate then + begin + DayTable := @MonthDays[IsLeapYear(st.year)]; + if st.month <> 0 then + begin + if not (st.month in [1..12]) or (DayTable^[st.month] < st.day) then + goto error; + + for v := 1 to st.month - 1 do + Inc(ms, DayTable^[v] * 86400000); + end; + dec(st.year); + ms := ms + (int64((st.year * 365) + (st.year div 4) - (st.year div 100) + + (st.year div 400) + st.day + st.dayofyear - 719163) * 86400000); + end; + + Result := True; + Exit; +error: + Result := False; +end; + +function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean; +var + ms: Int64; +begin + Result := ISO8601DateToJavaDateTime(str, ms); + if Result then + dt := JavaToDelphiDateTime(ms) +end; + +function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString; +var + year, month, day, hour, min, sec, msec: Word; + tzh: SmallInt; + tzm: Word; + sign: SOChar; + bias: Integer; +begin + DecodeDate(dt, year, month, day); + DecodeTime(dt, hour, min, sec, msec); + bias := GetTimeBias; + tzh := Abs(bias) div 60; + tzm := Abs(bias) - tzh * 60; + if Bias > 0 then + sign := '-' else + sign := '+'; + Result := Format('%.4d-%.2d-%.2dT%.2d:%.2d:%.2d,%d%s%.2d:%.2d', + [year, month, day, hour, min, sec, msec, sign, tzh, tzm]); +end; + +function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean; +var + i: Int64; +begin + case ObjectGetType(obj) of + stInt: + begin + dt := JavaToDelphiDateTime(obj.AsInteger); + Result := True; + end; + stString: + begin + if ISO8601DateToJavaDateTime(obj.AsString, i) then + begin + dt := JavaToDelphiDateTime(i); + Result := True; + end else + Result := TryStrToDateTime(obj.AsString, dt); + end; + else + Result := False; + end; +end; + +function SO(const s: SOString): ISuperObject; overload; +begin + Result := TSuperObject.ParseString(PSOChar(s), False); +end; + +function SA(const Args: array of const): ISuperObject; overload; +type + TByteArray = array[0..sizeof(integer) - 1] of byte; + PByteArray = ^TByteArray; +var + j: Integer; + intf: IInterface; +begin + Result := TSuperObject.Create(stArray); + for j := 0 to length(Args) - 1 do + with Result.AsArray do + case TVarRec(Args[j]).VType of + vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger)); + vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^)); + vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean)); + vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar))); + vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar))); + vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^)); + vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^)); + vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^))); + vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^))); + vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString)))); + vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString)))); + vtInterface: + if TVarRec(Args[j]).VInterface = nil then + Add(nil) else + if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then + Add(ISuperObject(intf)) else + Add(nil); + vtPointer : + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); + vtVariant: + Add(SO(TVarRec(Args[j]).VVariant^)); + vtObject: + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); + vtClass: + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); +{$if declared(vtUnicodeString)} + vtUnicodeString: + Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString)))); +{$ifend} + else + assert(false); + end; +end; + +function SO(const Args: array of const): ISuperObject; overload; +var + j: Integer; + arr: ISuperObject; +begin + Result := TSuperObject.Create(stObject); + arr := SA(Args); + with arr.AsArray do + for j := 0 to (Length div 2) - 1 do + Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]); +end; + +function SO(const value: Variant): ISuperObject; overload; +begin + with TVarData(value) do + case VType of + varNull: Result := nil; + varEmpty: Result := nil; + varSmallInt: Result := TSuperObject.Create(VSmallInt); + varInteger: Result := TSuperObject.Create(VInteger); + varSingle: Result := TSuperObject.Create(VSingle); + varDouble: Result := TSuperObject.Create(VDouble); + varCurrency: Result := TSuperObject.CreateCurrency(VCurrency); + varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate)); + varOleStr: Result := TSuperObject.Create(SOString(VOleStr)); + varBoolean: Result := TSuperObject.Create(VBoolean); + varShortInt: Result := TSuperObject.Create(VShortInt); + varByte: Result := TSuperObject.Create(VByte); + varWord: Result := TSuperObject.Create(VWord); + varLongWord: Result := TSuperObject.Create(VLongWord); + varInt64: Result := TSuperObject.Create(VInt64); + varString: Result := TSuperObject.Create(SOString(AnsiString(VString))); +{$if declared(varUString)} + {$IFDEF FPC} + varUString: Result := TSuperObject.Create(SOString(UnicodeString(VString))); + {$ELSE} + varUString: Result := TSuperObject.Create(SOString(string(VUString))); + {$ENDIF} +{$ifend} + else + raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]); + end; +end; + +function ObjectIsError(obj: TSuperObject): boolean; +begin + Result := PtrUInt(obj) > PtrUInt(-4000); +end; + +function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; +begin + if obj <> nil then + Result := typ = obj.DataType else + Result := typ = stNull; +end; + +function ObjectGetType(const obj: ISuperObject): TSuperType; +begin + if obj <> nil then + Result := obj.DataType else + Result := stNull; +end; + +function ObjectIsNull(const obj: ISuperObject): Boolean; +begin + Result := ObjectIsType(obj, stNull); +end; + +function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; +var + i: TSuperAvlEntry; +begin + if ObjectIsType(obj, stObject) then + begin + F.Ite := TSuperAvlIterator.Create(obj.AsObject); + F.Ite.First; + i := F.Ite.GetIter; + if i <> nil then + begin + f.key := i.Name; + f.val := i.Value; + Result := true; + end else + Result := False; + end else + Result := False; +end; + +function ObjectFindNext(var F: TSuperObjectIter): boolean; +var + i: TSuperAvlEntry; +begin + F.Ite.Next; + i := F.Ite.GetIter; + if i <> nil then + begin + f.key := i.FName; + f.val := i.Value; + Result := true; + end else + Result := False; +end; + +procedure ObjectFindClose(var F: TSuperObjectIter); +begin + F.Ite.Free; + F.val := nil; +end; + +function UuidFromString(p: PSOChar; Uuid: PGUID): Boolean; +const + hex2bin: array[48..102] of Byte = ( + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, + 0,10,11,12,13,14,15, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0,10,11,12,13,14,15); +type + TState = (stEatSpaces, stStart, stHEX, stBracket, stEnd); + TUUID = record + case byte of + 0: (guid: TGUID); + 1: (bytes: array[0..15] of Byte); + 2: (words: array[0..7] of Word); + 3: (ints: array[0..3] of Cardinal); + 4: (i64s: array[0..1] of UInt64); + end; + + function ishex(const c: SOChar): Boolean; {$IFDEF HAVE_INLINE} inline;{$ENDIF} + begin + result := (c < #256) and (AnsiChar(c) in ['0'..'9', 'a'..'z', 'A'..'Z']) + end; +var + pos: Byte; + state, saved: TState; + bracket, separator: Boolean; +label + redo; +begin + FillChar(Uuid^, SizeOf(TGUID), 0); + saved := stStart; + state := stEatSpaces; + bracket := false; + separator := false; + pos := 0; + while true do +redo: + case state of + stEatSpaces: + begin + while true do + case p^ of + ' ', #13, #10, #9: inc(p); + else + state := saved; + goto redo; + end; + end; + stStart: + case p^ of + '{': + begin + bracket := true; + inc(p); + state := stEatSpaces; + saved := stHEX; + pos := 0; + end; + else + state := stHEX; + end; + stHEX: + case pos of + 0..7: + if ishex(p^) then + begin + Uuid^.D1 := (Uuid^.D1 * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 8: + if (p^ = '-') then + begin + separator := true; + inc(p); + inc(pos) + end else + inc(pos); + 13,18,23: + if separator then + begin + if p^ <> '-' then + begin + Result := False; + Exit; + end; + inc(p); + inc(pos); + end else + inc(pos); + 9..12: + if ishex(p^) then + begin + TUUID(Uuid^).words[2] := (TUUID(Uuid^).words[2] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 14..17: + if ishex(p^) then + begin + TUUID(Uuid^).words[3] := (TUUID(Uuid^).words[3] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 19..20: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[8] := (TUUID(Uuid^).bytes[8] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 21..22: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[9] := (TUUID(Uuid^).bytes[9] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 24..25: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[10] := (TUUID(Uuid^).bytes[10] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 26..27: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[11] := (TUUID(Uuid^).bytes[11] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 28..29: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[12] := (TUUID(Uuid^).bytes[12] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 30..31: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[13] := (TUUID(Uuid^).bytes[13] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 32..33: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[14] := (TUUID(Uuid^).bytes[14] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 34..35: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[15] := (TUUID(Uuid^).bytes[15] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 36: if bracket then + begin + state := stEatSpaces; + saved := stBracket; + end else + begin + state := stEatSpaces; + saved := stEnd; + end; + end; + stBracket: + begin + if p^ <> '}' then + begin + Result := False; + Exit; + end; + inc(p); + state := stEatSpaces; + saved := stEnd; + end; + stEnd: + begin + if p^ <> #0 then + begin + Result := False; + Exit; + end; + Break; + end; + end; + Result := True; +end; + +function UUIDToString(const g: TGUID): SOString; +begin + Result := format('%.8x%.4x%.4x%.2x%.2x%.2x%.2x%.2x%.2x%.2x%.2x', + [g.D1, g.D2, g.D3, + g.D4[0], g.D4[1], g.D4[2], + g.D4[3], g.D4[4], g.D4[5], + g.D4[6], g.D4[7]]); +end; + +function StringToUUID(const str: SOString; var g: TGUID): Boolean; +begin + Result := UuidFromString(PSOChar(str), @g); +end; + +{$IFDEF HAVE_RTTI} + +function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +begin + Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0); +end; + +function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +begin + Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble)); +end; + +function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +var + g: TGUID; +begin + value.ExtractRawData(@g); + Result := TSuperObject.Create( + format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x', + [g.D1, g.D2, g.D3, + g.D4[0], g.D4[1], g.D4[2], + g.D4[3], g.D4[4], g.D4[5], + g.D4[6], g.D4[7]]) + ); +end; + +function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +var + o: ISuperObject; +begin + case ObjectGetType(obj) of + stBoolean: + begin + TValueData(Value).FAsSLong := obj.AsInteger; + Result := True; + end; + stInt: + begin + TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0); + Result := True; + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + Result := serialfromboolean(ctx, SO(obj.AsString), Value) else + Result := False; + end; + else + Result := False; + end; +end; + +function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +var + dt: TDateTime; + i: Int64; +begin + case ObjectGetType(obj) of + stInt: + begin + TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger); + Result := True; + end; + stString: + begin + if ISO8601DateToJavaDateTime(obj.AsString, i) then + begin + TValueData(Value).FAsDouble := JavaToDelphiDateTime(i); + Result := True; + end else + if TryStrToDateTime(obj.AsString, dt) then + begin + TValueData(Value).FAsDouble := dt; + Result := True; + end else + Result := False; + end; + else + Result := False; + end; +end; + +function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +begin + case ObjectGetType(obj) of + stNull: + begin + FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0); + Result := True; + end; + stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData); + else + Result := False; + end; +end; + +function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload; +var + owned: Boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + owned := True; + end else + owned := False; + try + if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then + raise Exception.Create('Invalid method call'); + finally + if owned then + ctx.Free; + end; +end; + +function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload; +begin + Result := SOInvoke(obj, method, so(params), ctx) +end; + +function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; + const method: string; const params: ISuperObject; + var Return: ISuperObject): TSuperInvokeResult; +var + t: TRttiInstanceType; + m: TRttiMethod; + a: TArray<TValue>; + ps: TArray<TRttiParameter>; + v: TValue; + index: ISuperObject; + + function GetParams: Boolean; + var + i: Integer; + begin + case ObjectGetType(params) of + stArray: + for i := 0 to Length(ps) - 1 do + if (pfOut in ps[i].Flags) then + TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else + if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then + Exit(False); + stObject: + for i := 0 to Length(ps) - 1 do + if (pfOut in ps[i].Flags) then + TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else + if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then + Exit(False); + stNull: ; + else + Exit(False); + end; + Result := True; + end; + + procedure SetParams; + var + i: Integer; + begin + case ObjectGetType(params) of + stArray: + for i := 0 to Length(ps) - 1 do + if (ps[i].Flags * [pfVar, pfOut]) <> [] then + params.AsArray[i] := ctx.ToJson(a[i], index); + stObject: + for i := 0 to Length(ps) - 1 do + if (ps[i].Flags * [pfVar, pfOut]) <> [] then + params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index); + end; + end; + +begin + Result := irSuccess; + index := SO; + case obj.Kind of + tkClass: + begin + t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType)); + m := t.GetMethod(method); + if m = nil then Exit(irMethothodError); + ps := m.GetParameters; + SetLength(a, Length(ps)); + if not GetParams then Exit(irParamError); + if m.IsClassMethod then + begin + v := m.Invoke(obj.AsObject.ClassType, a); + Return := ctx.ToJson(v, index); + SetParams; + end else + begin + v := m.Invoke(obj, a); + Return := ctx.ToJson(v, index); + SetParams; + end; + end; + tkClassRef: + begin + t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass)); + m := t.GetMethod(method); + if m = nil then Exit(irMethothodError); + ps := m.GetParameters; + SetLength(a, Length(ps)); + + if not GetParams then Exit(irParamError); + if m.IsClassMethod then + begin + v := m.Invoke(obj, a); + Return := ctx.ToJson(v, index); + SetParams; + end else + Exit(irError); + end; + else + Exit(irError); + end; +end; + +{$ENDIF} + +{ TSuperEnumerator } + +constructor TSuperEnumerator.Create(const obj: ISuperObject); +begin + FObj := obj; + FCount := -1; + if ObjectIsType(FObj, stObject) then + FObjEnum := FObj.AsObject.GetEnumerator else + FObjEnum := nil; +end; + +destructor TSuperEnumerator.Destroy; +begin + if FObjEnum <> nil then + FObjEnum.Free; +end; + +function TSuperEnumerator.MoveNext: Boolean; +begin + case ObjectGetType(FObj) of + stObject: Result := FObjEnum.MoveNext; + stArray: + begin + inc(FCount); + if FCount < FObj.AsArray.Length then + Result := True else + Result := False; + end; + else + Result := false; + end; +end; + +function TSuperEnumerator.GetCurrent: ISuperObject; +begin + case ObjectGetType(FObj) of + stObject: Result := FObjEnum.Current.Value; + stArray: Result := FObj.AsArray.GetO(FCount); + else + Result := FObj; + end; +end; + +{ TSuperObject } + +constructor TSuperObject.Create(jt: TSuperType); +begin + inherited Create; +{$IFDEF DEBUG} + InterlockedIncrement(debugcount); +{$ENDIF} + + FProcessing := false; + FDataPtr := nil; + FDataType := jt; + case FDataType of + stObject: FO.c_object := TSuperTableString.Create; + stArray: FO.c_array := TSuperArray.Create; + stString: FOString := ''; + else + FO.c_object := nil; + end; +end; + +constructor TSuperObject.Create(b: boolean); +begin + Create(stBoolean); + FO.c_boolean := b; +end; + +constructor TSuperObject.Create(i: SuperInt); +begin + Create(stInt); + FO.c_int := i; +end; + +constructor TSuperObject.Create(d: double); +begin + Create(stDouble); + FO.c_double := d; +end; + +constructor TSuperObject.CreateCurrency(c: Currency); +begin + Create(stCurrency); + FO.c_currency := c; +end; + +destructor TSuperObject.Destroy; +begin +{$IFDEF DEBUG} + InterlockedDecrement(debugcount); +{$ENDIF} + case FDataType of + stObject: FO.c_object.Free; + stArray: FO.c_array.Free; + end; + inherited; +end; + +function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; +function DoEscape(str: PSOChar; len: Integer): Integer; +var + pos, start_offset: Integer; + c: SOChar; + buf: array[0..5] of SOChar; +type + TByteChar = record + case integer of + 0: (a, b: Byte); + 1: (c: WideChar); + end; + begin + if str = nil then + begin + Result := 0; + exit; + end; + pos := 0; start_offset := 0; + with writer do + while pos < len do + begin + c := str[pos]; + case c of + #8,#9,#10,#12,#13,'"','\','/': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + + if(c = #8) then Append(ESC_BS, 2) + else if (c = #9) then Append(ESC_TAB, 2) + else if (c = #10) then Append(ESC_LF, 2) + else if (c = #12) then Append(ESC_FF, 2) + else if (c = #13) then Append(ESC_CR, 2) + else if (c = '"') then Append(ESC_QUOT, 2) + else if (c = '\') then Append(ESC_SL, 2) + else if (c = '/') then Append(ESC_SR, 2); + inc(pos); + start_offset := pos; + end; + else + if (SOIChar(c) > 255) then + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + buf[0] := '\'; + buf[1] := 'u'; + buf[2] := super_hex_chars[TByteChar(c).b shr 4]; + buf[3] := super_hex_chars[TByteChar(c).b and $f]; + buf[4] := super_hex_chars[TByteChar(c).a shr 4]; + buf[5] := super_hex_chars[TByteChar(c).a and $f]; + Append(@buf, 6); + inc(pos); + start_offset := pos; + end else + if (c < #32) or (c > #127) then + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + buf[0] := '\'; + buf[1] := 'u'; + buf[2] := '0'; + buf[3] := '0'; + buf[4] := super_hex_chars[ord(c) shr 4]; + buf[5] := super_hex_chars[ord(c) and $f]; + Append(buf, 6); + inc(pos); + start_offset := pos; + end else + inc(pos); + end; + end; + if(pos - start_offset > 0) then + writer.Append(str + start_offset, pos - start_offset); + Result := 0; + end; + +function DoMinimalEscape(str: PSOChar; len: Integer): Integer; +var + pos, start_offset: Integer; + c: SOChar; +type + TByteChar = record + case integer of + 0: (a, b: Byte); + 1: (c: WideChar); + end; + begin + if str = nil then + begin + Result := 0; + exit; + end; + pos := 0; start_offset := 0; + with writer do + while pos < len do + begin + c := str[pos]; + case c of + #0: + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_ZERO, 6); + inc(pos); + start_offset := pos; + end; + '"': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_QUOT, 2); + inc(pos); + start_offset := pos; + end; + '\': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_SL, 2); + inc(pos); + start_offset := pos; + end; + else + inc(pos); + end; + end; + if(pos - start_offset > 0) then + writer.Append(str + start_offset, pos - start_offset); + Result := 0; + end; + + + procedure _indent(i: shortint; r: boolean); + begin + inc(level, i); + if r then + with writer do + begin +{$IFDEF MSWINDOWS} + Append(TOK_CRLF, 2); +{$ELSE} + Append(TOK_LF, 1); +{$ENDIF} + for i := 0 to level - 1 do + Append(TOK_SP, 1); + end; + end; +var + k,j: Integer; + iter: TSuperObjectIter; + st: AnsiString; + val: ISuperObject; +const + ENDSTR_A: PSOChar = '": '; + ENDSTR_B: PSOChar = '":'; +begin + + if FProcessing then + begin + Result := writer.Append(TOK_NULL, 4); + Exit; + end; + + FProcessing := true; + with writer do + try + case FDataType of + stObject: + if FO.c_object.FCount > 0 then + begin + k := 0; + Append(TOK_CBL, 1); + if indent then _indent(1, false); + if ObjectFindFirst(Self, iter) then + repeat + {$IFDEF SUPER_METHOD} + if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then + begin + {$ENDIF} + if (iter.val = nil) or (not iter.val.Processing) then + begin + if(k <> 0) then + Append(TOK_COM, 1); + if indent then _indent(0, true); + Append(TOK_DQT, 1); + if escape then + doEscape(PSOChar(iter.key), Length(iter.key)) else + DoMinimalEscape(PSOChar(iter.key), Length(iter.key)); + if indent then + Append(ENDSTR_A, 3) else + Append(ENDSTR_B, 2); + if(iter.val = nil) then + Append(TOK_NULL, 4) else + iter.val.write(writer, indent, escape, level); + inc(k); + end; + {$IFDEF SUPER_METHOD} + end; + {$ENDIF} + until not ObjectFindNext(iter); + ObjectFindClose(iter); + if indent then _indent(-1, true); + Result := Append(TOK_CBR, 1); + end else + Result := Append(TOK_OBJ, 2); + stBoolean: + begin + if (FO.c_boolean) then + Result := Append(TOK_TRUE, 4) else + Result := Append(TOK_FALSE, 5); + end; + stInt: + begin + str(FO.c_int, st); + Result := Append(PSOChar(SOString(st))); + end; + stDouble: + Result := Append(PSOChar(FloatToJson(FO.c_double))); + stCurrency: + begin + Result := Append(PSOChar(CurrToJson(FO.c_currency))); + end; + stString: + begin + Append(TOK_DQT, 1); + if escape then + doEscape(PSOChar(FOString), Length(FOString)) else + DoMinimalEscape(PSOChar(FOString), Length(FOString)); + Append(TOK_DQT, 1); + Result := 0; + end; + stArray: + if FO.c_array.FLength > 0 then + begin + Append(TOK_ARL, 1); + if indent then _indent(1, true); + k := 0; + j := 0; + while k < FO.c_array.FLength do + begin + + val := FO.c_array.GetO(k); + {$IFDEF SUPER_METHOD} + if not ObjectIsType(val, stMethod) then + begin + {$ENDIF} + if (val = nil) or (not val.Processing) then + begin + if (j <> 0) then + Append(TOK_COM, 1); + if(val = nil) then + Append(TOK_NULL, 4) else + val.write(writer, indent, escape, level); + inc(j); + end; + {$IFDEF SUPER_METHOD} + end; + {$ENDIF} + inc(k); + end; + if indent then _indent(-1, false); + Result := Append(TOK_ARR, 1); + end else + Result := Append(TOK_ARRAY, 2); + stNull: + Result := Append(TOK_NULL, 4); + else + Result := 0; + end; + finally + FProcessing := false; + end; +end; + +function TSuperObject.IsType(AType: TSuperType): boolean; +begin + Result := AType = FDataType; +end; + +function TSuperObject.AsBoolean: boolean; +begin + case FDataType of + stBoolean: Result := FO.c_boolean; + stInt: Result := (FO.c_int <> 0); + stDouble: Result := (FO.c_double <> 0); + stCurrency: Result := (FO.c_currency <> 0); + stString: Result := (Length(FOString) <> 0); + stNull: Result := False; + else + Result := True; + end; +end; + +function TSuperObject.AsInteger: SuperInt; +var + code: integer; + cint: SuperInt; +begin + case FDataType of + stInt: Result := FO.c_int; + stDouble: Result := round(FO.c_double); + stCurrency: Result := round(FO.c_currency); + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cint, code); + if code = 0 then + Result := cint else + Result := 0; + end; + else + Result := 0; + end; +end; + +function TSuperObject.AsDouble: Double; +var + code: integer; + cdouble: double; +begin + case FDataType of + stDouble: Result := FO.c_double; + stCurrency: Result := FO.c_currency; + stInt: Result := FO.c_int; + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cdouble, code); + if code = 0 then + Result := cdouble else + Result := 0.0; + end; + else + Result := 0.0; + end; +end; + +function TSuperObject.AsCurrency: Currency; +var + code: integer; + cdouble: double; +begin + case FDataType of + stDouble: Result := FO.c_double; + stCurrency: Result := FO.c_currency; + stInt: Result := FO.c_int; + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cdouble, code); + if code = 0 then + Result := cdouble else + Result := 0.0; + end; + else + Result := 0.0; + end; +end; + +function TSuperObject.AsString: SOString; +begin + case FDataType of + stString: Result := FOString; + stNull: Result := ''; + else + Result := AsJSon(false, false); + end; +end; + +function TSuperObject.GetEnumerator: TSuperEnumerator; +begin + Result := TSuperEnumerator.Create(Self); +end; + +procedure TSuperObject.AfterConstruction; +begin + InterlockedDecrement(FRefCount); +end; + +procedure TSuperObject.BeforeDestruction; +begin + if RefCount <> 0 then + raise Exception.Create('Invalid pointer'); +end; + +function TSuperObject.AsArray: TSuperArray; +begin + if FDataType = stArray then + Result := FO.c_array else + Result := nil; +end; + +function TSuperObject.AsObject: TSuperTableString; +begin + if FDataType = stObject then + Result := FO.c_object else + Result := nil; +end; + +function TSuperObject.AsJSon(indent, escape: boolean): SOString; +var + pb: TSuperWriterString; +begin + pb := TSuperWriterString.Create; + try + if(Write(pb, indent, escape, 0) < 0) then + begin + Result := ''; + Exit; + end; + if pb.FBPos > 0 then + Result := pb.FBuf else + Result := ''; + finally + pb.Free; + end; +end; + +class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject; + options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject; +var + tok: TSuperTokenizer; + obj: ISuperObject; +begin + tok := TSuperTokenizer.Create; + obj := ParseEx(tok, s, -1, strict, this, options, put, dt); + if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then + Result := nil else + Result := obj; + tok.Free; +end; + +class function TSuperObject.ParseStream(stream: TStream; strict: Boolean; + partial: boolean; const this: ISuperObject; options: TSuperFindOptions; + const put: ISuperObject; dt: TSuperType): ISuperObject; +const + BUFFER_SIZE = 1024; +var + tok: TSuperTokenizer; + buffera: array[0..BUFFER_SIZE-1] of AnsiChar; + bufferw: array[0..BUFFER_SIZE-1] of SOChar; + bom: array[0..1] of byte; + unicode: boolean; + j, size: Integer; + st: string; +begin + st := ''; + tok := TSuperTokenizer.Create; + + if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then + begin + unicode := true; + size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar); + end else + begin + unicode := false; + stream.Seek(0, soFromBeginning); + size := stream.Read(buffera, BUFFER_SIZE); + end; + + while size > 0 do + begin + if not unicode then + for j := 0 to size - 1 do + bufferw[j] := SOChar(buffera[j]); + ParseEx(tok, bufferw, size, strict, this, options, put, dt); + + if tok.err = teContinue then + begin + if not unicode then + size := stream.Read(buffera, BUFFER_SIZE) else + size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar); + end else + Break; + end; + if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then + Result := nil else + Result := tok.stack[tok.depth].current; + tok.Free; +end; + +class function TSuperObject.ParseFile(const FileName: string; strict: Boolean; + partial: boolean; const this: ISuperObject; options: TSuperFindOptions; + const put: ISuperObject; dt: TSuperType): ISuperObject; +var + stream: TFileStream; +begin + stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite); + try + Result := ParseStream(stream, strict, partial, this, options, put, dt); + finally + stream.Free; + end; +end; + +class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; + strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject; + +const + spaces = [#32,#8,#9,#10,#12,#13]; + delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0]; + reserved = delimiters + spaces; + path = ['a'..'z', 'A'..'Z', '.', '_']; + + function hexdigit(x: SOChar): byte; {$IFDEF HAVE_INLINE} inline;{$ENDIF} + begin + if x <= '9' then + Result := byte(x) - byte('0') else + Result := (byte(x) and 7) + 9; + end; + function min(v1, v2: integer): integer;{$IFDEF HAVE_INLINE} inline;{$ENDIF} + begin if v1 < v2 then result := v1 else result := v2 end; + +var + obj: ISuperObject; + v: SOChar; +{$IFDEF SUPER_METHOD} + sm: TSuperMethod; +{$ENDIF} + numi: SuperInt; + numd: Double; + code: integer; + TokRec: PSuperTokenerSrec; + evalstack: integer; + p: PSOChar; + + function IsEndDelimiter(v: AnsiChar): Boolean; + begin + if tok.depth > 0 then + case tok.stack[tok.depth - 1].state of + tsArrayAdd: Result := v in [',', ']', #0]; + tsObjectValueAdd: Result := v in [',', '}', #0]; + else + Result := v = #0; + end else + Result := v = #0; + end; + +label out, redo_char; +begin + evalstack := 0; + obj := nil; + Result := nil; + TokRec := @tok.stack[tok.depth]; + + tok.char_offset := 0; + tok.err := teSuccess; + + repeat + if (tok.char_offset = len) then + begin + if (tok.depth = 0) and (TokRec^.state = tsEatws) and + (TokRec^.saved_state = tsFinish) then + tok.err := teSuccess else + tok.err := teContinue; + goto out; + end; + + v := str^; + + case v of + #10: + begin + inc(tok.line); + tok.col := 0; + end; + #9: inc(tok.col, 4); + else + inc(tok.col); + end; + +redo_char: + case TokRec^.state of + tsEatws: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else + if (v = '/') then + begin + tok.pb.Reset; + tok.pb.Append(@v, 1); + TokRec^.state := tsCommentStart; + end else begin + TokRec^.state := TokRec^.saved_state; + goto redo_char; + end + end; + + tsStart: + case v of + '"', + '''': + begin + TokRec^.state := tsString; + tok.pb.Reset; + tok.quote_char := v; + end; + '-': + begin + TokRec^.state := tsNumber; + tok.pb.Reset; + tok.is_double := 0; + tok.floatcount := -1; + goto redo_char; + end; + + '0'..'9': + begin + if (tok.depth = 0) then + case ObjectGetType(this) of + stObject: + begin + TokRec^.state := tsIdentifier; + TokRec^.current := this; + goto redo_char; + end; + end; + TokRec^.state := tsNumber; + tok.pb.Reset; + tok.is_double := 0; + tok.floatcount := -1; + goto redo_char; + end; + '{': + begin + TokRec^.state := tsEatws; + TokRec^.saved_state := tsObjectFieldStart; + TokRec^.current := TSuperObject.Create(stObject); + end; + '[': + begin + TokRec^.state := tsEatws; + TokRec^.saved_state := tsArray; + TokRec^.current := TSuperObject.Create(stArray); + end; +{$IFDEF SUPER_METHOD} + '(': + begin + if (tok.depth = 0) and ObjectIsType(this, stMethod) then + begin + TokRec^.current := this; + TokRec^.state := tsParamValue; + end; + end; +{$ENDIF} + 'N', + 'n': + begin + TokRec^.state := tsNull; + tok.pb.Reset; + tok.st_pos := 0; + goto redo_char; + end; + 'T', + 't', + 'F', + 'f': + begin + TokRec^.state := tsBoolean; + tok.pb.Reset; + tok.st_pos := 0; + goto redo_char; + end; + else + TokRec^.state := tsIdentifier; + tok.pb.Reset; + goto redo_char; + end; + + tsFinish: + begin + if(tok.depth = 0) then goto out; + obj := TokRec^.current; + tok.ResetLevel(tok.depth); + dec(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + + tsNull: + begin + tok.pb.Append(@v, 1); + if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then + begin + if (tok.st_pos = 4) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(stNull); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end; + end else + begin + TokRec^.state := tsIdentifier; + tok.pb.FBuf[tok.st_pos] := #0; + dec(tok.pb.FBPos); + goto redo_char; + end; + inc(tok.st_pos); + end; + + tsCommentStart: + begin + if(v = '*') then + begin + TokRec^.state := tsComment; + end else + if (v = '/') then + begin + TokRec^.state := tsCommentEol; + end else + begin + tok.err := teParseComment; + goto out; + end; + tok.pb.Append(@v, 1); + end; + + tsComment: + begin + if(v = '*') then + TokRec^.state := tsCommentEnd; + tok.pb.Append(@v, 1); + end; + + tsCommentEol: + begin + if (v = #10) then + TokRec^.state := tsEatws else + tok.pb.Append(@v, 1); + end; + + tsCommentEnd: + begin + tok.pb.Append(@v, 1); + if (v = '/') then + TokRec^.state := tsEatws else + TokRec^.state := tsComment; + end; + + tsString: + begin + if (v = tok.quote_char) then + begin + TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString)); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsString; + TokRec^.state := tsStringEscape; + end else + begin + tok.pb.Append(@v, 1); + end + end; + + tsEvalProperty: + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current) + end else + if not ObjectIsType(TokRec^.current, stObject) then + begin + tok.err := teEvalObject; + goto out; + end; + tok.pb.Reset; + TokRec^.state := tsIdentifier; + goto redo_char; + end; + + tsEvalArray: + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current) + end else + if not ObjectIsType(TokRec^.current, stArray) then + begin + tok.err := teEvalArray; + goto out; + end; + tok.pb.Reset; + TokRec^.state := tsParamValue; + goto redo_char; + end; +{$IFDEF SUPER_METHOD} + tsEvalMethod: + begin + if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then + begin + tok.pb.Reset; + TokRec^.obj := TSuperObject.Create(stArray); + TokRec^.state := tsMethodValue; + goto redo_char; + end else + begin + tok.err := teEvalMethod; + goto out; + end; + end; + + tsMethodValue: + begin + case v of + ')': + TokRec^.state := tsIdentifier; + else + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + inc(evalstack); + TokRec^.state := tsMethodPut; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + end; + + tsMethodPut: + begin + TokRec^.obj.AsArray.Add(obj); + case v of + ',': + begin + tok.pb.Reset; + TokRec^.saved_state := tsMethodValue; + TokRec^.state := tsEatws; + end; + ')': + begin + if TokRec^.obj.AsArray.Length = 1 then + TokRec^.obj := TokRec^.obj.AsArray.GetO(0); + dec(evalstack); + tok.pb.Reset; + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsEatws; + end; + else + tok.err := teEvalMethod; + goto out; + end; + end; +{$ENDIF} + tsParamValue: + begin + case v of + ']': + TokRec^.state := tsIdentifier; + else + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + inc(evalstack); + TokRec^.state := tsParamPut; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + end; + + tsParamPut: + begin + dec(evalstack); + TokRec^.obj := obj; + tok.pb.Reset; + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsEatws; + if v <> ']' then + begin + tok.err := teEvalArray; + goto out; + end; + end; + + tsIdentifier: + begin + if (this = nil) then + begin + if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then + begin + if not strict then + begin + tok.pb.TrimRight; + TokRec^.current := TSuperObject.Create(tok.pb.Fbuf); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end else + begin + tok.err := teParseString; + goto out; + end; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsStringEscape; + end else + tok.pb.Append(@v, 1); + end else + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then + begin + TokRec^.gparent := TokRec^.parent; + if TokRec^.current = nil then + TokRec^.parent := this else + TokRec^.parent := TokRec^.current; + + case ObjectGetType(TokRec^.parent) of + stObject: + case v of + '.': + begin + TokRec^.state := tsEvalProperty; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + '[': + begin + TokRec^.state := tsEvalArray; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + '(': + begin + TokRec^.state := tsEvalMethod; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + else + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put); + TokRec^.current := put + end else + if (foDelete in options) and (evalstack = 0) then + begin + TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf); + end else + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(dt); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current); + end; + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + TokRec^.state := tsFinish; + goto redo_char; + end; + stArray: + begin + if TokRec^.obj <> nil then + begin + if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then + begin + tok.err := teEvalInt; + TokRec^.obj := nil; + goto out; + end; + numi := TokRec^.obj.AsInteger; + TokRec^.obj := nil; + + TokRec^.current := TokRec^.parent.AsArray.GetO(numi); + case v of + '.': + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsArray.PutO(numi, TokRec^.current); + end else + if (TokRec^.current = nil) then + begin + tok.err := teEvalObject; + goto out; + end; + '[': + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + if (TokRec^.current = nil) then + begin + tok.err := teEvalArray; + goto out; + end; + TokRec^.state := tsEvalArray; + end; + '(': TokRec^.state := tsEvalMethod; + else + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsArray.PutO(numi, put); + TokRec^.current := put; + end else + if (foDelete in options) and (evalstack = 0) then + begin + TokRec^.current := TokRec^.parent.AsArray.Delete(numi); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(numi); + TokRec^.state := tsFinish; + goto redo_char + end; + end else + begin + case v of + '.': + begin + if (foPutValue in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + end; + '[': + begin + if (foPutValue in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + TokRec^.state := tsEvalArray; + end; + '(': + begin + if not (foPutValue in options) then + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else + TokRec^.current := nil; + + TokRec^.state := tsEvalMethod; + end; + else + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsArray.Add(put); + TokRec^.current := put; + end else + if tok.pb.FBPos = 0 then + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + TokRec^.state := tsFinish; + goto redo_char + end; + end; + end; +{$IFDEF SUPER_METHOD} + stMethod: + case v of + '.': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.obj := nil; + end; + '[': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.state := tsEvalArray; + TokRec^.obj := nil; + end; + '(': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.state := tsEvalMethod; + TokRec^.obj := nil; + end; + else + if not (foPutValue in options) or (evalstack > 0) then + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.obj := nil; + TokRec^.state := tsFinish; + goto redo_char + end else + begin + tok.err := teEvalMethod; + TokRec^.obj := nil; + goto out; + end; + end; +{$ENDIF} + end; + end else + tok.pb.Append(@v, 1); + end; + end; + + tsStringEscape: + case v of + 'b', + 'n', + 'r', + 't', + 'f': + begin + if(v = 'b') then tok.pb.Append(TOK_BS, 1) + else if(v = 'n') then tok.pb.Append(TOK_LF, 1) + else if(v = 'r') then tok.pb.Append(TOK_CR, 1) + else if(v = 't') then tok.pb.Append(TOK_TAB, 1) + else if(v = 'f') then tok.pb.Append(TOK_FF, 1); + TokRec^.state := TokRec^.saved_state; + end; + 'u': + begin + tok.ucs_char := 0; + tok.st_pos := 0; + TokRec^.state := tsEscapeUnicode; + end; + 'x': + begin + tok.ucs_char := 0; + tok.st_pos := 0; + TokRec^.state := tsEscapeHexadecimal; + end + else + tok.pb.Append(@v, 1); + TokRec^.state := TokRec^.saved_state; + end; + + tsEscapeUnicode: + begin + if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then + begin + inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4))); + inc(tok.st_pos); + if (tok.st_pos = 4) then + begin + tok.pb.Append(@tok.ucs_char, 1); + TokRec^.state := TokRec^.saved_state; + end + end else + begin + tok.err := teParseString; + goto out; + end + end; + tsEscapeHexadecimal: + begin + if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then + begin + inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4))); + inc(tok.st_pos); + if (tok.st_pos = 2) then + begin + tok.pb.Append(@tok.ucs_char, 1); + TokRec^.state := TokRec^.saved_state; + end + end else + begin + tok.err := teParseString; + goto out; + end + end; + tsBoolean: + begin + tok.pb.Append(@v, 1); + if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then + begin + if (tok.st_pos = 4) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(true); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end else + if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then + begin + if (tok.st_pos = 5) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(false); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end else + begin + TokRec^.state := tsIdentifier; + tok.pb.FBuf[tok.st_pos] := #0; + dec(tok.pb.FBPos); + goto redo_char; + end; + inc(tok.st_pos); + end; + + tsNumber: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then + begin + tok.pb.Append(@v, 1); + if (SOIChar(v) < 256) then + case v of + '.': begin + tok.is_double := 1; + tok.floatcount := 0; + end; + 'e','E': + begin + tok.is_double := 1; + tok.floatcount := -1; + end; + '0'..'9': + begin + + if (tok.is_double = 1) and (tok.floatcount >= 0) then + begin + inc(tok.floatcount); + if tok.floatcount > 4 then + tok.floatcount := -1; + end; + end; + end; + end else + begin + if (tok.is_double = 0) then + begin + val(tok.pb.FBuf, numi, code); + if ObjectIsType(this, stArray) then + begin + if (foPutValue in options) and (evalstack = 0) then + begin + this.AsArray.PutO(numi, put); + TokRec^.current := put; + end else + if (foDelete in options) and (evalstack = 0) then + TokRec^.current := this.AsArray.Delete(numi) else + TokRec^.current := this.AsArray.GetO(numi); + end else + TokRec^.current := TSuperObject.Create(numi); + + end else + if (tok.is_double <> 0) then + begin + if tok.floatcount >= 0 then + begin + p := tok.pb.FBuf; + while p^ <> '.' do inc(p); + for code := 0 to tok.floatcount - 1 do + begin + p^ := p[1]; + inc(p); + end; + p^ := #0; + val(tok.pb.FBuf, numi, code); + case tok.floatcount of + 0: numi := numi * 10000; + 1: numi := numi * 1000; + 2: numi := numi * 100; + 3: numi := numi * 10; + end; + TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^); + end else + begin + val(tok.pb.FBuf, numd, code); + TokRec^.current := TSuperObject.Create(numd); + end; + end else + begin + tok.err := teParseNumber; + goto out; + end; + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end; + + tsArray: + begin + if (v = ']') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + begin + if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + TokRec^.state := tsArrayAdd; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end + end; + + tsArrayAdd: + begin + TokRec^.current.AsArray.Add(obj); + TokRec^.saved_state := tsArraySep; + TokRec^.state := tsEatws; + goto redo_char; + end; + + tsArraySep: + begin + if (v = ']') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = ',') then + begin + TokRec^.saved_state := tsArray; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseArray; + goto out; + end + end; + + tsObjectFieldStart: + begin + if (v = '}') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then + begin + tok.quote_char := v; + tok.pb.Reset; + TokRec^.state := tsObjectField; + end else + if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then + begin + TokRec^.state := tsObjectUnquotedField; + tok.pb.Reset; + goto redo_char; + end else + begin + tok.err := teParseObjectKeyName; + goto out; + end + end; + + tsObjectField: + begin + if (v = tok.quote_char) then + begin + TokRec^.field_name := tok.pb.FBuf; + TokRec^.saved_state := tsObjectFieldEnd; + TokRec^.state := tsEatws; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsObjectField; + TokRec^.state := tsStringEscape; + end else + begin + tok.pb.Append(@v, 1); + end + end; + + tsObjectUnquotedField: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then + begin + TokRec^.field_name := tok.pb.FBuf; + TokRec^.saved_state := tsObjectFieldEnd; + TokRec^.state := tsEatws; + goto redo_char; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsObjectUnquotedField; + TokRec^.state := tsStringEscape; + end else + tok.pb.Append(@v, 1); + end; + + tsObjectFieldEnd: + begin + if (v = ':') then + begin + TokRec^.saved_state := tsObjectValue; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseObjectKeySep; + goto out; + end + end; + + tsObjectValue: + begin + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + TokRec^.state := tsObjectValueAdd; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + + tsObjectValueAdd: + begin + TokRec^.current.AsObject.PutO(TokRec^.field_name, obj); + TokRec^.field_name := ''; + TokRec^.saved_state := tsObjectSep; + TokRec^.state := tsEatws; + goto redo_char; + end; + + tsObjectSep: + begin + if (v = '}') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = ',') then + begin + TokRec^.saved_state := tsObjectFieldStart; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseObjectValueSep; + goto out; + end + end; + end; + inc(str); + inc(tok.char_offset); + until v = #0; + + if(TokRec^.state <> tsFinish) and + (TokRec^.saved_state <> tsFinish) then + tok.err := teParseEof; + + out: + if(tok.err in [teSuccess]) then + begin +{$IFDEF SUPER_METHOD} + if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then + begin + sm := TokRec^.current.AsMethod; + sm(TokRec^.parent, put, Result); + end else +{$ENDIF} + Result := TokRec^.current; + end else + Result := nil; +end; + +procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value); +end; + +procedure TSuperObject.PutB(const path: SOString; Value: Boolean); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutD(const path: SOString; Value: Double); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutC(const path: SOString; Value: Currency); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value)); +end; + +procedure TSuperObject.PutI(const path: SOString; Value: SuperInt); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutS(const path: SOString; const Value: SOString); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + + +{$IFDEF FPC} +function TSuperObject.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; +{$ELSE} +function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; +{$ENDIF} +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer; +var + pb: TSuperWriterStream; +begin + if escape then + pb := TSuperAnsiWriterStream.Create(stream) else + pb := TSuperUnicodeWriterStream.Create(stream); + + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Reset; + pb.Free; + Result := 0; + Exit; + end; + Result := stream.Size; + pb.Free; +end; + +function TSuperObject.CalcSize(indent, escape: boolean): integer; +var + pb: TSuperWriterFake; +begin + pb := TSuperWriterFake.Create; + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Free; + Result := 0; + Exit; + end; + Result := pb.FSize; + pb.Free; +end; + +function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer; +var + pb: TSuperWriterSock; +begin + pb := TSuperWriterSock.Create(socket); + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Free; + Result := 0; + Exit; + end; + Result := pb.FSize; + pb.Free; +end; + +constructor TSuperObject.Create(const s: SOString); +begin + Create(stString); + FOString := s; +end; + +procedure TSuperObject.Clear(all: boolean); +begin + if FProcessing then exit; + FProcessing := true; + try + case FDataType of + stBoolean: FO.c_boolean := false; + stDouble: FO.c_double := 0.0; + stCurrency: FO.c_currency := 0.0; + stInt: FO.c_int := 0; + stObject: FO.c_object.Clear(all); + stArray: FO.c_array.Clear(all); + stString: FOString := ''; +{$IFDEF SUPER_METHOD} + stMethod: FO.c_method := nil; +{$ENDIF} + end; + finally + FProcessing := false; + end; +end; + +procedure TSuperObject.Pack(all: boolean = false); +begin + if FProcessing then exit; + FProcessing := true; + try + case FDataType of + stObject: FO.c_object.Pack(all); + stArray: FO.c_array.Pack(all); + end; + finally + FProcessing := false; + end; +end; + +function TSuperObject.GetN(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, true, self); + if Result = nil then + Result := TSuperObject.Create(stNull); +end; + +procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject); +begin + if Value = nil then + ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else + ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value); +end; + +function TSuperObject.Delete(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, true, self, [foDelete]); +end; + +function TSuperObject.Clone: ISuperObject; +var + ite: TSuperObjectIter; + arr: TSuperArray; + j: integer; +begin + case FDataType of + stBoolean: Result := TSuperObject.Create(FO.c_boolean); + stDouble: Result := TSuperObject.Create(FO.c_double); + stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency); + stInt: Result := TSuperObject.Create(FO.c_int); + stString: Result := TSuperObject.Create(FOString); +{$IFDEF SUPER_METHOD} + stMethod: Result := TSuperObject.Create(FO.c_method); +{$ENDIF} + stObject: + begin + Result := TSuperObject.Create(stObject); + if ObjectFindFirst(self, ite) then + with Result.AsObject do + repeat + PutO(ite.key, ite.val.Clone); + until not ObjectFindNext(ite); + ObjectFindClose(ite); + end; + stArray: + begin + Result := TSuperObject.Create(stArray); + arr := AsArray; + with Result.AsArray do + for j := 0 to arr.Length - 1 do + Add(arr.GetO(j).Clone); + end; + else + Result := nil; + end; +end; + +procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean); +var + prop1, prop2: ISuperObject; + ite: TSuperObjectIter; + arr: TSuperArray; + j: integer; +begin + if ObjectIsType(obj, FDataType) then + case FDataType of + stBoolean: FO.c_boolean := obj.AsBoolean; + stDouble: FO.c_double := obj.AsDouble; + stCurrency: FO.c_currency := obj.AsCurrency; + stInt: FO.c_int := obj.AsInteger; + stString: FOString := obj.AsString; +{$IFDEF SUPER_METHOD} + stMethod: FO.c_method := obj.AsMethod; +{$ENDIF} + stObject: + begin + if ObjectFindFirst(obj, ite) then + with FO.c_object do + repeat + prop1 := FO.c_object.GetO(ite.key); + if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then + prop1.Merge(ite.val) else + if reference then + PutO(ite.key, ite.val) else + if ite.val <> nil then + PutO(ite.key, ite.val.Clone) else + PutO(ite.key, nil) + + until not ObjectFindNext(ite); + ObjectFindClose(ite); + end; + stArray: + begin + arr := obj.AsArray; + with FO.c_array do + for j := 0 to arr.Length - 1 do + begin + prop1 := GetO(j); + prop2 := arr.GetO(j); + if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then + prop1.Merge(prop2) else + if reference then + PutO(j, prop2) else + if prop2 <> nil then + PutO(j, prop2.Clone) else + PutO(j, nil); + end; + end; + end; +end; + +procedure TSuperObject.Merge(const str: SOString); +begin + Merge(TSuperObject.ParseString(PSOChar(str), False), true); +end; + +class function TSuperObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TSuperObject(Result).FRefCount := 1; +end; + +function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType); +end; + +function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString; +var + p1, p2: PSOChar; +begin + Result := ''; + p2 := PSOChar(str); + p1 := p2; + while true do + if p2^ = BeginSep then + begin + if p2 > p1 then + Result := Result + Copy(p1, 0, p2-p1); + inc(p2); + p1 := p2; + while true do + if p2^ = EndSep then Break else + if p2^ = #0 then Exit else + inc(p2); + Result := Result + GetS(copy(p1, 0, p2-p1)); + inc(p2); + p1 := p2; + end + else if p2^ = #0 then + begin + if p2 > p1 then + Result := Result + Copy(p1, 0, p2-p1); + Break; + end else + inc(p2); +end; + +function TSuperObject.GetO(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self); +end; + +function TSuperObject.GetA(const path: SOString): TSuperArray; +var + obj: ISuperObject; +begin + obj := ParseString(PSOChar(path), False, True, Self); + if obj <> nil then + Result := obj.AsArray else + Result := nil; +end; + +function TSuperObject.GetB(const path: SOString): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsBoolean else + Result := false; +end; + +function TSuperObject.GetD(const path: SOString): Double; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +function TSuperObject.GetC(const path: SOString): Currency; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +function TSuperObject.GetI(const path: SOString): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +function TSuperObject.GetDataPtr: Pointer; +begin + Result := FDataPtr; +end; + +function TSuperObject.GetDataType: TSuperType; +begin + Result := FDataType +end; + +function TSuperObject.GetS(const path: SOString): SOString; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer; +var + stream: TFileStream; +begin + stream := TFileStream.Create(FileName, fmCreate); + try + Result := SaveTo(stream, indent, escape); + finally + stream.Free; + end; +end; + +function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; +begin + Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender); +end; + +function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; +type + TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool, + dtMap, dtSeq, dtScalar, dtAny); +var + datatypes: ISuperObject; + names: ISuperObject; + + function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject; + var + o: ISuperObject; + e: TSuperAvlEntry; + begin + o := p[prop]; + if o <> nil then + result := o else + begin + o := p['inherit']; + if (o <> nil) and ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := FindInheritedProperty(prop, e.Value) else + Result := nil; + end else + Result := nil; + end; + end; + + function FindDataType(o: ISuperObject): TDataType; + var + e: TSuperAvlEntry; + obj: ISuperObject; + begin + obj := FindInheritedProperty('type', o); + if obj <> nil then + begin + e := datatypes.AsObject.Search(obj.AsString); + if e <> nil then + Result := TDataType(e.Value.AsInteger) else + Result := dtUnknown; + end else + Result := dtUnknown; + end; + + procedure GetNames(o: ISuperObject); + var + obj: ISuperObject; + f: TSuperObjectIter; + begin + obj := o['name']; + if ObjectIsType(obj, stString) then + names[obj.AsString] := o; + + case FindDataType(o) of + dtMap: + begin + obj := o['mapping']; + if ObjectIsType(obj, stObject) then + begin + if ObjectFindFirst(obj, f) then + repeat + if ObjectIsType(f.val, stObject) then + GetNames(f.val); + until not ObjectFindNext(f); + ObjectFindClose(f); + end; + end; + dtSeq: + begin + obj := o['sequence']; + if ObjectIsType(obj, stObject) then + GetNames(obj); + end; + end; + end; + + function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject; + var + o: ISuperObject; + e: TSuperAvlEntry; + begin + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + o := o.AsObject.GetO(prop); + if o <> nil then + begin + Result := o; + Exit; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := FindInheritedField(prop, e.Value) else + Result := nil; + end else + Result := nil; + end; + + function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean; + var + o: ISuperObject; + e: TSuperAvlEntry; + j: TSuperAvlIterator; + begin + Result := true; + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + j := TSuperAvlIterator.Create(o.AsObject); + try + j.First; + e := j.GetIter; + while e <> nil do + begin + if obj.AsObject.Search(e.Name) = nil then + begin + Result := False; + if assigned(callback) then + callback(sender, veFieldNotFound, name + '.' + e.Name); + end; + j.Next; + e := j.GetIter; + end; + + finally + j.Free; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := InheritedFieldExist(obj, e.Value, name) and Result; + end; + end; + + function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean; + var + o: ISuperObject; + begin + o := FindInheritedProperty(f, p); + case ObjectGetType(o) of + stBoolean: Result := o.AsBoolean; + stNull: Result := Default; + else + Result := default; + if assigned(callback) then + callback(sender, veRuleMalformated, f); + end; + end; + + procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject); + var + o: ISuperObject; + e: TSuperAvlEntry; + i: TSuperAvlIterator; + begin + Result := true; + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + i := TSuperAvlIterator.Create(o.AsObject); + try + i.First; + e := i.GetIter; + while e <> nil do + begin + if list.AsObject.Search(e.Name) = nil then + list[e.Name] := e.Value; + i.Next; + e := i.GetIter; + end; + + finally + i.Free; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + GetInheritedFieldList(list, e.Value); + end; + end; + + function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean; + var + enum: ISuperObject; + i: integer; + begin + Result := false; + enum := FindInheritedProperty('enum', p); + case ObjectGetType(enum) of + stArray: + for i := 0 to enum.AsArray.Length - 1 do + if (o.AsString = enum.AsArray[i].AsString) then + begin + Result := true; + exit; + end; + stNull: Result := true; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + if (not Result) and assigned(callback) then + callback(sender, veValueNotInEnum, name); + end; + + function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean; + var + length, o: ISuperObject; + begin + result := true; + length := FindInheritedProperty('length', p); + case ObjectGetType(length) of + stObject: + begin + o := length.AsObject.GetO('min'); + if (o <> nil) and (o.AsInteger > len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('max'); + if (o <> nil) and (o.AsInteger < len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('minex'); + if (o <> nil) and (o.AsInteger >= len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('maxex'); + if (o <> nil) and (o.AsInteger <= len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + end; + stNull: ; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + end; + end; + + function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean; + var + length, o: ISuperObject; + begin + result := true; + length := FindInheritedProperty('range', p); + case ObjectGetType(length) of + stObject: + begin + o := length.AsObject.GetO('min'); + if (o <> nil) and (o.Compare(obj) = cpGreat) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('max'); + if (o <> nil) and (o.Compare(obj) = cpLess) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('minex'); + if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('maxex'); + if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + end; + stNull: ; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + end; + end; + + + function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean; + var + ite: TSuperAvlIterator; + ent: TSuperAvlEntry; + p2, o2, sequence: ISuperObject; + s: SOString; + i: integer; + uniquelist, fieldlist: ISuperObject; + begin + Result := true; + if (o = nil) then + begin + if getInheritedBool('required', p) then + begin + if assigned(callback) then + callback(sender, veFieldIsRequired, objpath); + result := false; + end; + end else + case FindDataType(p) of + dtStr: + case ObjectGetType(o) of + stString: + begin + Result := Result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtBool: + case ObjectGetType(o) of + stBoolean: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtInt: + case ObjectGetType(o) of + stInt: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtFloat: + case ObjectGetType(o) of + stDouble, stCurrency: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtMap: + case ObjectGetType(o) of + stObject: + begin + // all objects have and match a rule ? + ite := TSuperAvlIterator.Create(o.AsObject); + try + ite.First; + ent := ite.GetIter; + while ent <> nil do + begin + p2 := FindInheritedField(ent.Name, p); + if ObjectIsType(p2, stObject) then + result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else + begin + if assigned(callback) then + callback(sender, veUnexpectedField, objpath + '.' + ent.Name); + result := false; // field have no rule + end; + ite.Next; + ent := ite.GetIter; + end; + finally + ite.Free; + end; + + // all expected field exists ? + Result := InheritedFieldExist(o, p, objpath) and Result; + end; + stNull: {nop}; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + dtSeq: + case ObjectGetType(o) of + stArray: + begin + sequence := FindInheritedProperty('sequence', p); + if sequence <> nil then + case ObjectGetType(sequence) of + stObject: + begin + for i := 0 to o.AsArray.Length - 1 do + result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result; + if getInheritedBool('unique', sequence) then + begin + // type is unique ? + uniquelist := TSuperObject.Create(stObject); + try + for i := 0 to o.AsArray.Length - 1 do + begin + s := o.AsArray.GetO(i).AsString; + if (s <> '') then + begin + if uniquelist.AsObject.Search(s) = nil then + uniquelist[s] := nil else + begin + Result := False; + if Assigned(callback) then + callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']'); + end; + end; + end; + finally + uniquelist := nil; + end; + end; + + // field is unique ? + if (FindDataType(sequence) = dtMap) then + begin + fieldlist := TSuperObject.Create(stObject); + try + GetInheritedFieldList(fieldlist, sequence); + ite := TSuperAvlIterator.Create(fieldlist.AsObject); + try + ite.First; + ent := ite.GetIter; + while ent <> nil do + begin + if getInheritedBool('unique', ent.Value) then + begin + uniquelist := TSuperObject.Create(stObject); + try + for i := 0 to o.AsArray.Length - 1 do + begin + o2 := o.AsArray.GetO(i); + if o2 <> nil then + begin + s := o2.AsObject.GetO(ent.Name).AsString; + if (s <> '') then + if uniquelist.AsObject.Search(s) = nil then + uniquelist[s] := nil else + begin + Result := False; + if Assigned(callback) then + callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name); + end; + end; + end; + finally + uniquelist := nil; + end; + end; + ite.Next; + ent := ite.GetIter; + end; + finally + ite.Free; + end; + finally + fieldlist := nil; + end; + end; + + + end; + stNull: {nop}; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + Result := Result and CheckLength(o.AsArray.Length, p, objpath); + + end; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + dtNumber: + case ObjectGetType(o) of + stInt, + stDouble, stCurrency: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtText: + case ObjectGetType(o) of + stInt, + stDouble, + stCurrency, + stString: + begin + result := result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtScalar: + case ObjectGetType(o) of + stBoolean, + stDouble, + stCurrency, + stInt, + stString: + begin + result := result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtAny:; + else + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + result := false; + end; + Result := Result and CheckEnum(o, p, objpath) + + end; +var + j: integer; + +begin + Result := False; + datatypes := TSuperObject.Create(stObject); + names := TSuperObject.Create; + try + datatypes.I['str'] := ord(dtStr); + datatypes.I['int'] := ord(dtInt); + datatypes.I['float'] := ord(dtFloat); + datatypes.I['number'] := ord(dtNumber); + datatypes.I['text'] := ord(dtText); + datatypes.I['bool'] := ord(dtBool); + datatypes.I['map'] := ord(dtMap); + datatypes.I['seq'] := ord(dtSeq); + datatypes.I['scalar'] := ord(dtScalar); + datatypes.I['any'] := ord(dtAny); + + if ObjectIsType(defs, stArray) then + for j := 0 to defs.AsArray.Length - 1 do + if ObjectIsType(defs.AsArray[j], stObject) then + GetNames(defs.AsArray[j]) else + begin + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + + if ObjectIsType(rules, stObject) then + GetNames(rules) else + begin + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + Result := process(self, rules); + + finally + datatypes := nil; + names := nil; + end; +end; + +function TSuperObject._AddRef: Integer; stdcall; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TSuperObject._Release: Integer; stdcall; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +function TSuperObject.Compare(const str: SOString): TSuperCompareResult; +begin + Result := Compare(TSuperObject.ParseString(PSOChar(str), False)); +end; + +function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult; + function GetIntCompResult(const i: int64): TSuperCompareResult; + begin + if i < 0 then result := cpLess else + if i = 0 then result := cpEqu else + Result := cpGreat; + end; + + function GetDblCompResult(const d: double): TSuperCompareResult; + begin + if d < 0 then result := cpLess else + if d = 0 then result := cpEqu else + Result := cpGreat; + end; + +begin + case DataType of + stBoolean: + case ObjectGetType(obj) of + stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble); + stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency); + stInt: Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stDouble: + case ObjectGetType(obj) of + stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_double - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency); + stInt: Result := GetDblCompResult(FO.c_double - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stCurrency: + case ObjectGetType(obj) of + stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_currency - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency); + stInt: Result := GetDblCompResult(FO.c_currency - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stInt: + case ObjectGetType(obj) of + stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_int - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency); + stInt: Result := GetIntCompResult(FO.c_int - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stString: + case ObjectGetType(obj) of + stBoolean, + stDouble, + stCurrency, + stInt, + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + else + Result := cpError; + end; +end; + +{$IFDEF SUPER_METHOD} +function TSuperObject.AsMethod: TSuperMethod; +begin + if FDataType = stMethod then + Result := FO.c_method else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +constructor TSuperObject.Create(m: TSuperMethod); +begin + Create(stMethod); + FO.c_method := m; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.GetM(const path: SOString): TSuperMethod; +var + v: ISuperObject; +begin + v := ParseString(PSOChar(path), False, True, Self); + if (v <> nil) and (ObjectGetType(v) = stMethod) then + Result := v.AsMethod else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod); +begin + ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.call(const path, param: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False)); +end; +{$ENDIF} + +function TSuperObject.GetProcessing: boolean; +begin + Result := FProcessing; +end; + +procedure TSuperObject.SetDataPtr(const Value: Pointer); +begin + FDataPtr := Value; +end; + +procedure TSuperObject.SetProcessing(value: boolean); +begin + FProcessing := value; +end; + +{ TSuperArray } + +function TSuperArray.Add(const Data: ISuperObject): Integer; +begin + Result := FLength; + PutO(Result, data); +end; + +function TSuperArray.Add(Data: SuperInt): Integer; +begin + Result := Add(TSuperObject.Create(Data)); +end; + +function TSuperArray.Add(const Data: SOString): Integer; +begin + Result := Add(TSuperObject.Create(Data)); +end; + +function TSuperArray.Add(Data: Boolean): Integer; +begin + Result := Add(TSuperObject.Create(Data)); +end; + +function TSuperArray.Add(Data: Double): Integer; +begin + Result := Add(TSuperObject.Create(Data)); +end; + +function TSuperArray.AddC(const Data: Currency): Integer; +begin + Result := Add(TSuperObject.CreateCurrency(Data)); +end; + +function TSuperArray.Delete(index: Integer): ISuperObject; +begin + if (Index >= 0) and (Index < FLength) then + begin + Result := FArray^[index]; + FArray^[index] := nil; + Dec(FLength); + if Index < FLength then + begin + Move(FArray^[index + 1], FArray^[index], + (FLength - index) * SizeOf(Pointer)); + Pointer(FArray^[FLength]) := nil; + end; + end; +end; + +procedure TSuperArray.Insert(index: Integer; const value: ISuperObject); +begin + if (Index >= 0) then + if (index < FLength) then + begin + if FLength = FSize then + Expand(index); + if Index < FLength then + Move(FArray^[index], FArray^[index + 1], + (FLength - index) * SizeOf(Pointer)); + Pointer(FArray^[index]) := nil; + FArray^[index] := value; + Inc(FLength); + end else + PutO(index, value); +end; + +procedure TSuperArray.Clear(all: boolean); +var + j: Integer; +begin + for j := 0 to FLength - 1 do + if FArray^[j] <> nil then + begin + if all then + FArray^[j].Clear(all); + FArray^[j] := nil; + end; + FLength := 0; +end; + +procedure TSuperArray.Pack(all: boolean); +var + PackedCount, StartIndex, EndIndex, j: Integer; +begin + if FLength > 0 then + begin + PackedCount := 0; + StartIndex := 0; + repeat + while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do + Inc(StartIndex); + if StartIndex < FLength then + begin + EndIndex := StartIndex; + while (EndIndex < FLength) and (FArray^[EndIndex] <> nil) do + Inc(EndIndex); + + Dec(EndIndex); + + if StartIndex > PackedCount then + Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer)); + + Inc(PackedCount, EndIndex - StartIndex + 1); + StartIndex := EndIndex + 1; + end; + until StartIndex >= FLength; + FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0); + FLength := PackedCount; + if all then + for j := 0 to FLength - 1 do + FArray^[j].Pack(all); + end; +end; + +constructor TSuperArray.Create; +begin + inherited Create; + FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE; + FLength := 0; + GetMem(FArray, sizeof(Pointer) * FSize); + FillChar(FArray^, sizeof(Pointer) * FSize, 0); +end; + +destructor TSuperArray.Destroy; +begin + Clear; + FreeMem(FArray); + inherited; +end; + +procedure TSuperArray.Expand(max: Integer); +var + new_size: Integer; +begin + if (max < FSize) then + Exit; + if max < (FSize shl 1) then + new_size := (FSize shl 1) else + new_size := max + 1; + ReallocMem(FArray, new_size * sizeof(Pointer)); + FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0); + FSize := new_size; +end; + +function TSuperArray.GetO(const index: Integer): ISuperObject; +begin + if(index >= FLength) then + Result := nil else + Result := FArray^[index]; +end; + +function TSuperArray.GetB(const index: integer): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsBoolean else + Result := false; +end; + +function TSuperArray.GetD(const index: integer): Double; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +function TSuperArray.GetI(const index: integer): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +function TSuperArray.GetS(const index: integer): SOString; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject); +begin + Expand(index); + FArray^[index] := value; + if(FLength <= index) then FLength := index + 1; +end; + +function TSuperArray.GetN(const index: integer): ISuperObject; +begin + Result := GetO(index); + if Result = nil then + Result := TSuperObject.Create(stNull); +end; + +procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject); +begin + if Value <> nil then + PutO(index, Value) else + PutO(index, TSuperObject.Create(stNull)); +end; + +procedure TSuperArray.PutB(const index: integer; Value: Boolean); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +procedure TSuperArray.PutD(const index: integer; Value: Double); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +function TSuperArray.GetC(const index: integer): Currency; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +procedure TSuperArray.PutC(const index: integer; Value: Currency); +begin + PutO(index, TSuperObject.CreateCurrency(Value)); +end; + +procedure TSuperArray.PutI(const index: integer; Value: SuperInt); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +procedure TSuperArray.PutS(const index: integer; const Value: SOString); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +{$IFDEF SUPER_METHOD} +function TSuperArray.GetM(const index: integer): TSuperMethod; +var + v: ISuperObject; +begin + v := GetO(index); + if (ObjectGetType(v) = stMethod) then + Result := v.AsMethod else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod); +begin + PutO(index, TSuperObject.Create(Value)); +end; +{$ENDIF} + +{ TSuperWriterString } + +function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer; + function max(a, b: Integer): integer; begin if a > b then Result := a else Result := b end; +begin + Result := size; + if Size > 0 then + begin + if (FSize - FBPos <= size) then + begin + FSize := max(FSize * 2, FBPos + size + 8); + ReallocMem(FBuf, FSize * SizeOf(SOChar)); + end; + // fast move + case size of + 1: FBuf[FBPos] := buf^; + 2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^; + 4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^; + else + move(buf^, FBuf[FBPos], size * SizeOf(SOChar)); + end; + inc(FBPos, size); + FBuf[FBPos] := #0; + end; +end; + +function TSuperWriterString.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, strlen(buf)); +end; + +constructor TSuperWriterString.Create; +begin + inherited; + FSize := 32; + FBPos := 0; + GetMem(FBuf, FSize * SizeOf(SOChar)); +end; + +destructor TSuperWriterString.Destroy; +begin + inherited; + if FBuf <> nil then + FreeMem(FBuf) +end; + +function TSuperWriterString.GetString: SOString; +begin + SetString(Result, FBuf, FBPos); +end; + +procedure TSuperWriterString.Reset; +begin + FBuf[0] := #0; + FBPos := 0; +end; + +procedure TSuperWriterString.TrimRight; +begin + while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do + begin + dec(FBPos); + FBuf[FBPos] := #0; + end; +end; + +{ TSuperWriterStream } + +function TSuperWriterStream.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, StrLen(buf)); +end; + +constructor TSuperWriterStream.Create(AStream: TStream); +begin + inherited Create; + FStream := AStream; +end; + +procedure TSuperWriterStream.Reset; +begin + FStream.Size := 0; +end; + +{ TSuperWriterStream } + +function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer; +var + Buffer: array[0..1023] of AnsiChar; + pBuffer: PAnsiChar; + i: Integer; +begin + if Size = 1 then + Result := FStream.Write(buf^, Size) else + begin + if Size > SizeOf(Buffer) then + GetMem(pBuffer, Size) else + pBuffer := @Buffer; + try + for i := 0 to Size - 1 do + pBuffer[i] := AnsiChar(buf[i]); + Result := FStream.Write(pBuffer^, Size); + finally + if pBuffer <> @Buffer then + FreeMem(pBuffer); + end; + end; +end; + +{ TSuperUnicodeWriterStream } + +function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer; +begin + Result := FStream.Write(buf^, Size * 2); +end; + +{ TSuperWriterFake } + +function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer; +begin + inc(FSize, Size); + Result := FSize; +end; + +function TSuperWriterFake.Append(buf: PSOChar): Integer; +begin + inc(FSize, Strlen(buf)); + Result := FSize; +end; + +constructor TSuperWriterFake.Create; +begin + inherited Create; + FSize := 0; +end; + +procedure TSuperWriterFake.Reset; +begin + FSize := 0; +end; + +{ TSuperWriterSock } + +function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer; +var + Buffer: array[0..1023] of AnsiChar; + pBuffer: PAnsiChar; + i: Integer; +begin + if Size = 1 then +{$IFDEF FPC} + Result := fpsend(FSocket, buf, size, 0) else +{$ELSE} + Result := send(FSocket, buf^, size, 0) else +{$ENDIF} + begin + if Size > SizeOf(Buffer) then + GetMem(pBuffer, Size) else + pBuffer := @Buffer; + try + for i := 0 to Size - 1 do + pBuffer[i] := AnsiChar(buf[i]); +{$IFDEF FPC} + Result := fpsend(FSocket, pBuffer, size, 0); +{$ELSE} + Result := send(FSocket, pBuffer^, size, 0); +{$ENDIF} + finally + if pBuffer <> @Buffer then + FreeMem(pBuffer); + end; + end; + inc(FSize, Result); +end; + +function TSuperWriterSock.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, StrLen(buf)); +end; + +constructor TSuperWriterSock.Create(ASocket: Integer); +begin + inherited Create; + FSocket := ASocket; + FSize := 0; +end; + +procedure TSuperWriterSock.Reset; +begin + FSize := 0; +end; + +{ TSuperTokenizer } + +constructor TSuperTokenizer.Create; +begin + pb := TSuperWriterString.Create; + line := 1; + col := 0; + Reset; +end; + +destructor TSuperTokenizer.Destroy; +begin + Reset; + pb.Free; + inherited; +end; + +procedure TSuperTokenizer.Reset; +var + i: integer; +begin + for i := depth downto 0 do + ResetLevel(i); + depth := 0; + err := teSuccess; +end; + +procedure TSuperTokenizer.ResetLevel(adepth: integer); +begin + stack[adepth].state := tsEatws; + stack[adepth].saved_state := tsStart; + stack[adepth].current := nil; + stack[adepth].field_name := ''; + stack[adepth].obj := nil; + stack[adepth].parent := nil; + stack[adepth].gparent := nil; +end; + +{ TSuperAvlTree } + +constructor TSuperAvlTree.Create; +begin + FRoot := nil; + FCount := 0; +end; + +destructor TSuperAvlTree.Destroy; +begin + Clear; + inherited; +end; + +function TSuperAvlTree.IsEmpty: boolean; +begin + result := FRoot = nil; +end; + +function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry; +var + deep, old: TSuperAvlEntry; + bf: integer; +begin + if (bal.FBf > 0) then + begin + deep := bal.FGt; + if (deep.FBf < 0) then + begin + old := bal; + bal := deep.FLt; + old.FGt := bal.FLt; + deep.FLt := bal.FGt; + bal.FLt := old; + bal.FGt := deep; + bf := bal.FBf; + if (bf <> 0) then + begin + if (bf > 0) then + begin + old.FBf := -1; + deep.FBf := 0; + end else + begin + deep.FBf := 1; + old.FBf := 0; + end; + bal.FBf := 0; + end else + begin + old.FBf := 0; + deep.FBf := 0; + end; + end else + begin + bal.FGt := deep.FLt; + deep.FLt := bal; + if (deep.FBf = 0) then + begin + deep.FBf := -1; + bal.FBf := 1; + end else + begin + deep.FBf := 0; + bal.FBf := 0; + end; + bal := deep; + end; + end else + begin + (* "Less than" subtree is deeper. *) + + deep := bal.FLt; + if (deep.FBf > 0) then + begin + old := bal; + bal := deep.FGt; + old.FLt := bal.FGt; + deep.FGt := bal.FLt; + bal.FGt := old; + bal.FLt := deep; + + bf := bal.FBf; + if (bf <> 0) then + begin + if (bf < 0) then + begin + old.FBf := 1; + deep.FBf := 0; + end else + begin + deep.FBf := -1; + old.FBf := 0; + end; + bal.FBf := 0; + end else + begin + old.FBf := 0; + deep.FBf := 0; + end; + end else + begin + bal.FLt := deep.FGt; + deep.FGt := bal; + if (deep.FBf = 0) then + begin + deep.FBf := 1; + bal.FBf := -1; + end else + begin + deep.FBf := 0; + bal.FBf := 0; + end; + bal := deep; + end; + end; + Result := bal; +end; + +function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry; +var + unbal, parentunbal, hh, parent: TSuperAvlEntry; + depth, unbaldepth: longint; + cmp: integer; + unbalbf: integer; + branch: TSuperAvlBitArray; + p: Pointer; +begin + inc(FCount); + h.FLt := nil; + h.FGt := nil; + h.FBf := 0; + branch := []; + + if (FRoot = nil) then + FRoot := h + else + begin + unbal := nil; + parentunbal := nil; + depth := 0; + unbaldepth := 0; + hh := FRoot; + parent := nil; + repeat + if (hh.FBf <> 0) then + begin + unbal := hh; + parentunbal := parent; + unbaldepth := depth; + end; + if hh.FHash <> h.FHash then + begin + if hh.FHash < h.FHash then cmp := -1 else + if hh.FHash > h.FHash then cmp := 1 else + cmp := 0; + end else + cmp := CompareNodeNode(h, hh); + if (cmp = 0) then + begin + Result := hh; + //exchange data + p := hh.Ptr; + hh.FPtr := h.Ptr; + h.FPtr := p; + doDeleteEntry(h, false); + dec(FCount); + exit; + end; + parent := hh; + if (cmp > 0) then + begin + hh := hh.FGt; + include(branch, depth); + end else + begin + hh := hh.FLt; + exclude(branch, depth); + end; + inc(depth); + until (hh = nil); + + if (cmp < 0) then + parent.FLt := h else + parent.FGt := h; + + depth := unbaldepth; + + if (unbal = nil) then + hh := FRoot + else + begin + if depth in branch then + cmp := 1 else + cmp := -1; + inc(depth); + unbalbf := unbal.FBf; + if (cmp < 0) then + dec(unbalbf) else + inc(unbalbf); + if cmp < 0 then + hh := unbal.FLt else + hh := unbal.FGt; + if ((unbalbf <> -2) and (unbalbf <> 2)) then + begin + unbal.FBf := unbalbf; + unbal := nil; + end; + end; + + if (hh <> nil) then + while (h <> hh) do + begin + if depth in branch then + cmp := 1 else + cmp := -1; + inc(depth); + if (cmp < 0) then + begin + hh.FBf := -1; + hh := hh.FLt; + end else (* cmp > 0 *) + begin + hh.FBf := 1; + hh := hh.FGt; + end; + end; + + if (unbal <> nil) then + begin + unbal := balance(unbal); + if (parentunbal = nil) then + FRoot := unbal + else + begin + depth := unbaldepth - 1; + if depth in branch then + cmp := 1 else + cmp := -1; + if (cmp < 0) then + parentunbal.FLt := unbal else + parentunbal.FGt := unbal; + end; + end; + end; + result := h; +end; + +function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry; +var + cmp, target_cmp: integer; + match_h, h: TSuperAvlEntry; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + + match_h := nil; + h := FRoot; + + if (stLess in st) then + target_cmp := 1 else + if (stGreater in st) then + target_cmp := -1 else + target_cmp := 0; + + while (h <> nil) do + begin + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := CompareKeyNode(PSOChar(k), h); + if (cmp = 0) then + begin + if (stEqual in st) then + begin + match_h := h; + break; + end; + cmp := -target_cmp; + end + else + if (target_cmp <> 0) then + if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then + match_h := h; + if cmp < 0 then + h := h.FLt else + h := h.FGt; + end; + result := match_h; +end; + +function TSuperAvlTree.Delete(const k: SOString): ISuperObject; +var + depth, rm_depth: longint; + branch: TSuperAvlBitArray; + h, parent, child, path, rm, parent_rm: TSuperAvlEntry; + cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + cmp_shortened_sub_with_path := 0; + branch := []; + + depth := 0; + h := FRoot; + parent := nil; + while true do + begin + if (h = nil) then + exit; + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := CompareKeyNode(k, h); + if (cmp = 0) then + break; + parent := h; + if (cmp > 0) then + begin + h := h.FGt; + include(branch, depth) + end else + begin + h := h.FLt; + exclude(branch, depth) + end; + inc(depth); + cmp_shortened_sub_with_path := cmp; + end; + rm := h; + parent_rm := parent; + rm_depth := depth; + + if (h.FBf < 0) then + begin + child := h.FLt; + exclude(branch, depth); + cmp := -1; + end else + begin + child := h.FGt; + include(branch, depth); + cmp := 1; + end; + inc(depth); + + if (child <> nil) then + begin + cmp := -cmp; + repeat + parent := h; + h := child; + if (cmp < 0) then + begin + child := h.FLt; + exclude(branch, depth); + end else + begin + child := h.FGt; + include(branch, depth); + end; + inc(depth); + until (child = nil); + + if (parent = rm) then + cmp_shortened_sub_with_path := -cmp else + cmp_shortened_sub_with_path := cmp; + + if cmp > 0 then + child := h.FLt else + child := h.FGt; + end; + + if (parent = nil) then + FRoot := child else + if (cmp_shortened_sub_with_path < 0) then + parent.FLt := child else + parent.FGt := child; + + if parent = rm then + path := h else + path := parent; + + if (h <> rm) then + begin + h.FLt := rm.FLt; + h.FGt := rm.FGt; + h.FBf := rm.FBf; + if (parent_rm = nil) then + FRoot := h + else + begin + depth := rm_depth - 1; + if (depth in branch) then + parent_rm.FGt := h else + parent_rm.FLt := h; + end; + end; + + if (path <> nil) then + begin + h := FRoot; + parent := nil; + depth := 0; + while (h <> path) do + begin + if (depth in branch) then + begin + child := h.FGt; + h.FGt := parent; + end else + begin + child := h.FLt; + h.FLt := parent; + end; + inc(depth); + parent := h; + h := child; + end; + + reduced_depth := 1; + cmp := cmp_shortened_sub_with_path; + while true do + begin + if (reduced_depth <> 0) then + begin + bf := h.FBf; + if (cmp < 0) then + inc(bf) else + dec(bf); + if ((bf = -2) or (bf = 2)) then + begin + h := balance(h); + bf := h.FBf; + end else + h.FBf := bf; + reduced_depth := integer(bf = 0); + end; + if (parent = nil) then + break; + child := h; + h := parent; + dec(depth); + if depth in branch then + cmp := 1 else + cmp := -1; + if (cmp < 0) then + begin + parent := h.FLt; + h.FLt := child; + end else + begin + parent := h.FGt; + h.FGt := child; + end; + end; + FRoot := h; + end; + if rm <> nil then + begin + Result := rm.GetValue; + doDeleteEntry(rm, false); + dec(FCount); + end; +end; + +procedure TSuperAvlTree.Pack(all: boolean); +var + node1, node2: TSuperAvlEntry; + list: TList; + i: Integer; +begin + node1 := FRoot; + list := TList.Create; + while node1 <> nil do + begin + if (node1.FLt = nil) then + begin + node2 := node1.FGt; + if (node1.FPtr = nil) then + list.Add(node1) else + if all then + node1.Value.Pack(all); + end + else + begin + node2 := node1.FLt; + node1.FLt := node2.FGt; + node2.FGt := node1; + end; + node1 := node2; + end; + for i := 0 to list.Count - 1 do + Delete(TSuperAvlEntry(list[i]).FName); + list.Free; +end; + +procedure TSuperAvlTree.Clear(all: boolean); +var + node1, node2: TSuperAvlEntry; +begin + node1 := FRoot; + while node1 <> nil do + begin + if (node1.FLt = nil) then + begin + node2 := node1.FGt; + doDeleteEntry(node1, all); + end + else + begin + node2 := node1.FLt; + node1.FLt := node2.FGt; + node2.FGt := node1; + end; + node1 := node2; + end; + FRoot := nil; + FCount := 0; +end; + +function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; +begin + Result := StrComp(PSOChar(k), PSOChar(h.FName)); +end; + +function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer; +begin + Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName)); +end; + +{ TSuperAvlIterator } + +(* Initialize depth to invalid value, to indicate iterator is +** invalid. (Depth is zero-base.) It's not necessary to initialize +** iterators prior to passing them to the "start" function. +*) + +constructor TSuperAvlIterator.Create(tree: TSuperAvlTree); +begin + FDepth := not 0; + FTree := tree; +end; + +procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes); +var + h: TSuperAvlEntry; + d: longint; + cmp, target_cmp: integer; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + h := FTree.FRoot; + d := 0; + FDepth := not 0; + if (h = nil) then + exit; + + if (stLess in st) then + target_cmp := 1 else + if (stGreater in st) then + target_cmp := -1 else + target_cmp := 0; + + while true do + begin + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := FTree.CompareKeyNode(k, h); + if (cmp = 0) then + begin + if (stEqual in st) then + begin + FDepth := d; + break; + end; + cmp := -target_cmp; + end + else + if (target_cmp <> 0) then + if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then + FDepth := d; + if cmp < 0 then + h := h.FLt else + h := h.FGt; + if (h = nil) then + break; + if (cmp > 0) then + include(FBranch, d) else + exclude(FBranch, d); + FPath[d] := h; + inc(d); + end; +end; + +procedure TSuperAvlIterator.First; +var + h: TSuperAvlEntry; +begin + h := FTree.FRoot; + FDepth := not 0; + FBranch := []; + while (h <> nil) do + begin + if (FDepth <> not 0) then + FPath[FDepth] := h; + inc(FDepth); + h := h.FLt; + end; +end; + +procedure TSuperAvlIterator.Last; +var + h: TSuperAvlEntry; +begin + h := FTree.FRoot; + FDepth := not 0; + FBranch := [0..SUPER_AVL_MAX_DEPTH - 1]; + while (h <> nil) do + begin + if (FDepth <> not 0) then + FPath[FDepth] := h; + inc(FDepth); + h := h.FGt; + end; +end; + +function TSuperAvlIterator.MoveNext: boolean; +begin + if FDepth = not 0 then + First else + Next; + Result := GetIter <> nil; +end; + +function TSuperAvlIterator.GetIter: TSuperAvlEntry; +begin + if (FDepth = not 0) then + begin + result := nil; + exit; + end; + if FDepth = 0 then + Result := FTree.FRoot else + Result := FPath[FDepth - 1]; +end; + +procedure TSuperAvlIterator.Next; +var + h: TSuperAvlEntry; +begin + if (FDepth <> not 0) then + begin + if FDepth = 0 then + h := FTree.FRoot.FGt else + h := FPath[FDepth - 1].FGt; + + if (h = nil) then + repeat + if (FDepth = 0) then + begin + FDepth := not 0; + break; + end; + dec(FDepth); + until (not (FDepth in FBranch)) + else + begin + include(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + while true do + begin + h := h.FLt; + if (h = nil) then + break; + exclude(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + end; + end; + end; +end; + +procedure TSuperAvlIterator.Prior; +var + h: TSuperAvlEntry; +begin + if (FDepth <> not 0) then + begin + if FDepth = 0 then + h := FTree.FRoot.FLt else + h := FPath[FDepth - 1].FLt; + if (h = nil) then + repeat + if (FDepth = 0) then + begin + FDepth := not 0; + break; + end; + dec(FDepth); + until (FDepth in FBranch) + else + begin + exclude(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + while true do + begin + h := h.FGt; + if (h = nil) then + break; + include(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + end; + end; + end; +end; + +procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); +begin + Entry.Free; +end; + +function TSuperAvlTree.GetEnumerator: TSuperAvlIterator; +begin + Result := TSuperAvlIterator.Create(Self); +end; + +{ TSuperAvlEntry } + +constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer); +begin + FName := AName; + FPtr := Obj; + FHash := Hash(FName); +end; + +function TSuperAvlEntry.GetValue: ISuperObject; +begin + Result := ISuperObject(FPtr) +end; + +class function TSuperAvlEntry.Hash(const k: SOString): Cardinal; +var + h: cardinal; + i: Integer; +begin + h := 0; + for i := 1 to Length(k) do + h := h*129 + ord(k[i]) + $9e370001; + Result := h; +end; + +procedure TSuperAvlEntry.SetValue(const val: ISuperObject); +begin + ISuperObject(FPtr) := val; +end; + +{ TSuperTableString } + +function TSuperTableString.GetValues: ISuperObject; +var + ite: TSuperAvlIterator; + obj: TSuperAvlEntry; +begin + Result := TSuperObject.Create(stArray); + ite := TSuperAvlIterator.Create(Self); + try + ite.First; + obj := ite.GetIter; + while obj <> nil do + begin + Result.AsArray.Add(obj.Value); + ite.Next; + obj := ite.GetIter; + end; + finally + ite.Free; + end; +end; + +function TSuperTableString.GetNames: ISuperObject; +var + ite: TSuperAvlIterator; + obj: TSuperAvlEntry; +begin + Result := TSuperObject.Create(stArray); + ite := TSuperAvlIterator.Create(Self); + try + ite.First; + obj := ite.GetIter; + while obj <> nil do + begin + Result.AsArray.Add(TSuperObject.Create(obj.FName)); + ite.Next; + obj := ite.GetIter; + end; + finally + ite.Free; + end; +end; + +procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); +begin + if Entry.Ptr <> nil then + begin + if all then Entry.Value.Clear(true); + Entry.Value := nil; + end; + inherited; +end; + +function TSuperTableString.Find(const k: SOString; var value: ISuperObject): Boolean; +var + e: TSuperAvlEntry; +begin + e := Search(k); + if e <> nil then + begin + value := e.Value; + Result := True; + end else + Result := False; +end; + +function TSuperTableString.Exists(const k: SOString): Boolean; +begin + Result := Search(k) <> nil; +end; + +function TSuperTableString.GetO(const k: SOString): ISuperObject; +var + e: TSuperAvlEntry; +begin + e := Search(k); + if e <> nil then + Result := e.Value else + Result := nil +end; + +procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject); +var + entry: TSuperAvlEntry; +begin + entry := Insert(TSuperAvlEntry.Create(k, Pointer(value))); + if entry.FPtr <> nil then + ISuperObject(entry.FPtr)._AddRef; +end; + +procedure TSuperTableString.PutS(const k: SOString; const value: SOString); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetS(const k: SOString): SOString; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +procedure TSuperTableString.PutI(const k: SOString; value: SuperInt); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetI(const k: SOString): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +procedure TSuperTableString.PutD(const k: SOString; value: Double); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +procedure TSuperTableString.PutC(const k: SOString; value: Currency); +begin + PutO(k, TSuperObject.CreateCurrency(Value)); +end; + +function TSuperTableString.GetC(const k: SOString): Currency; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +function TSuperTableString.GetD(const k: SOString): Double; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +procedure TSuperTableString.PutB(const k: SOString; value: Boolean); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetB(const k: SOString): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsBoolean else + Result := False; +end; + +{$IFDEF SUPER_METHOD} +procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod); +begin + PutO(k, TSuperObject.Create(Value)); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperTableString.GetM(const k: SOString): TSuperMethod; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsMethod else + Result := nil; +end; +{$ENDIF} + +procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject); +begin + if value <> nil then + PutO(k, TSuperObject.Create(stNull)) else + PutO(k, value); +end; + +function TSuperTableString.GetN(const k: SOString): ISuperObject; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj else + Result := TSuperObject.Create(stNull); +end; + + +{$IFDEF HAVE_RTTI} + +{ TSuperAttribute } + +constructor TSuperAttribute.Create(const AName: string); +begin + FName := AName; +end; + +{ TSuperRttiContext } + +constructor TSuperRttiContext.Create; +begin + Context := TRttiContext.Create; + SerialFromJson := TDictionary<PTypeInfo, TSerialFromJson>.Create; + SerialToJson := TDictionary<PTypeInfo, TSerialToJson>.Create; + + SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean); + SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime); + SerialFromJson.Add(TypeInfo(TGUID), serialfromguid); + SerialToJson.Add(TypeInfo(Boolean), serialtoboolean); + SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime); + SerialToJson.Add(TypeInfo(TGUID), serialtoguid); +end; + +destructor TSuperRttiContext.Destroy; +begin + SerialFromJson.Free; + SerialToJson.Free; + Context.Free; +end; + +class function TSuperRttiContext.GetFieldName(r: TRttiField): string; +var + o: TCustomAttribute; +begin + for o in r.GetAttributes do + if o is SOName then + Exit(SOName(o).Name); + Result := r.Name; +end; + +class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; +var + o: TCustomAttribute; +begin + if not ObjectIsType(obj, stNull) then Exit(obj); + for o in r.GetAttributes do + if o is SODefault then + Exit(SO(SODefault(o).Name)); + Result := obj; +end; + +function TSuperRttiContext.AsType<T>(const obj: ISuperObject): T; +var + ret: TValue; +begin + if FromJson(TypeInfo(T), obj, ret) then + Result := ret.AsType<T> else + raise exception.Create('Marshalling error'); +end; + +function TSuperRttiContext.AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject; +var + v: TValue; +begin + TValue.Make(@obj, TypeInfo(T), v); + if index <> nil then + Result := ToJson(v, index) else + Result := ToJson(v, so); +end; + +function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; + var Value: TValue): Boolean; + + procedure FromChar; + begin + if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then + begin + Value := string(AnsiString(obj.AsString)[1]); + Result := True; + end else + Result := False; + end; + + procedure FromWideChar; + begin + if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then + begin + Value := obj.AsString[1]; + Result := True; + end else + Result := False; + end; + + procedure FromInt64; + var + i: Int64; + begin + case ObjectGetType(obj) of + stInt: + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSInt64 := obj.AsInteger; + Result := True; + end; + stString: + begin + if TryStrToInt64(obj.AsString, i) then + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSInt64 := i; + Result := True; + end else + Result := False; + end; + else + Result := False; + end; + end; + + procedure FromInt(const obj: ISuperObject); + var + TypeData: PTypeData; + i: Integer; + o: ISuperObject; + begin + case ObjectGetType(obj) of + stInt, stBoolean: + begin + i := obj.AsInteger; + TypeData := GetTypeData(TypeInfo); + if TypeData.MaxValue > TypeData.MinValue then + Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue) else + Result := (i >= TypeData.MinValue) and (i <= Int64(PCardinal(@TypeData.MaxValue)^)); + if Result then + TValue.Make(@i, TypeInfo, Value); + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + FromInt(o) else + Result := False; + end; + else + Result := False; + end; + end; + + procedure fromSet; + var + i: Integer; + begin + case ObjectGetType(obj) of + stInt: + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSLong := obj.AsInteger; + Result := True; + end; + stString: + begin + if TryStrToInt(obj.AsString, i) then + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSLong := i; + Result := True; + end else + Result := False; + end; + else + Result := False; + end; + end; + + procedure FromFloat(const obj: ISuperObject); + var + o: ISuperObject; + begin + case ObjectGetType(obj) of + stInt, stDouble, stCurrency: + begin + TValue.Make(nil, TypeInfo, Value); + case GetTypeData(TypeInfo).FloatType of + ftSingle: TValueData(Value).FAsSingle := obj.AsDouble; + ftDouble: TValueData(Value).FAsDouble := obj.AsDouble; + ftExtended: TValueData(Value).FAsExtended := obj.AsDouble; + ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger; + ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency; + end; + Result := True; + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + FromFloat(o) else + Result := False; + end + else + Result := False; + end; + end; + + procedure FromString; + begin + case ObjectGetType(obj) of + stObject, stArray: + Result := False; + stnull: + begin + Value := ''; + Result := True; + end; + else + Value := obj.AsString; + Result := True; + end; + end; + + procedure FromClass; + var + f: TRttiField; + v: TValue; + begin + case ObjectGetType(obj) of + stObject: + begin + Result := True; + if Value.Kind <> tkClass then + Value := GetTypeData(TypeInfo).ClassType.Create; + for f in Context.GetType(Value.AsObject.ClassType).GetFields do + if f.FieldType <> nil then + begin + v := TValue.Empty; + Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); + if Result then + f.SetValue(Value.AsObject, v) else + Exit; + end; + end; + stNull: + begin + Value := nil; + Result := True; + end + else + // error + Value := nil; + Result := False; + end; + end; + + procedure FromRecord; + var + f: TRttiField; + p: Pointer; + v: TValue; + begin + // 무조건 True를 반환하도록 수정. + // 여기서 false를 반환하면 구조체 추가된 필드때문에 다른값도 들어가지 않게됨 12_1030 13:25 sunk + Result := True; + + TValue.Make(nil, TypeInfo, Value); + for f in Context.GetType(TypeInfo).GetFields do + begin + if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then + begin +{$IFDEF VER210} + p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData; +{$ELSE} + p := TValueData(Value).FValueData.GetReferenceToRawData; +{$ENDIF} + if not FromJson(f.FieldType.Handle, + GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v) then exit; + + f.SetValue(p, v); + end else exit; + end; + +// 원본 소스 12_1030 13:25 sunk +(* + Result := True; + TValue.Make(nil, TypeInfo, Value); + for f in Context.GetType(TypeInfo).GetFields do + begin + if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then + begin +{$IFDEF VER210} + p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData; +{$ELSE} + p := TValueData(Value).FValueData.GetReferenceToRawData; +{$ENDIF} + Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); + if Result then + f.SetValue(p, v) else + begin + //Writeln(f.Name); + Exit; + end; + end else + begin + Result := False; + Exit; + end; + end; +*) + end; + + procedure FromDynArray; + var + i: Integer; + p: Pointer; + pb: PByte; + val: TValue; + typ: PTypeData; + el: PTypeInfo; + begin + case ObjectGetType(obj) of + stArray: + begin + i := obj.AsArray.Length; + p := nil; + DynArraySetLength(p, TypeInfo, 1, @i); + pb := p; + typ := GetTypeData(TypeInfo); + if typ.elType <> nil then + el := typ.elType^ else + el := typ.elType2^; + + Result := True; + for i := 0 to i - 1 do + begin + Result := FromJson(el, obj.AsArray[i], val); + if not Result then + Break; + val.ExtractRawData(pb); + val := TValue.Empty; + Inc(pb, typ.elSize); + end; + if Result then + TValue.MakeWithoutCopy(@p, TypeInfo, Value) else + DynArrayClear(p, TypeInfo); + end; + stNull: + begin + TValue.MakeWithoutCopy(nil, TypeInfo, Value); + Result := True; + end; + else + i := 1; + p := nil; + DynArraySetLength(p, TypeInfo, 1, @i); + pb := p; + typ := GetTypeData(TypeInfo); + if typ.elType <> nil then + el := typ.elType^ else + el := typ.elType2^; + + Result := FromJson(el, obj, val); + val.ExtractRawData(pb); + val := TValue.Empty; + + if Result then + TValue.MakeWithoutCopy(@p, TypeInfo, Value) else + DynArrayClear(p, TypeInfo); + end; + end; + + procedure FromArray; + var + ArrayData: PArrayTypeData; + idx: Integer; + function ProcessDim(dim: Byte; const o: ISuperobject): Boolean; + var + i: Integer; + v: TValue; + a: PTypeData; + begin + if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then + begin + a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData; + if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then + begin + Result := False; + Exit; + end; + Result := True; + if dim = ArrayData.DimCount then + for i := a.MinValue to a.MaxValue do + begin + Result := FromJson(ArrayData.ElType^, o.AsArray[i], v); + if not Result then + Exit; + Value.SetArrayElement(idx, v); + inc(idx); + end + else + for i := a.MinValue to a.MaxValue do + begin + Result := ProcessDim(dim + 1, o.AsArray[i]); + if not Result then + Exit; + end; + end else + Result := False; + end; + var + i: Integer; + v: TValue; + begin + TValue.Make(nil, TypeInfo, Value); + ArrayData := @GetTypeData(TypeInfo).ArrayData; + idx := 0; + if ArrayData.DimCount = 1 then + begin + if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then + begin + Result := True; + for i := 0 to ArrayData.ElCount - 1 do + begin + Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v); + if not Result then + Exit; + Value.SetArrayElement(idx, v); + v := TValue.Empty; + inc(idx); + end; + end else + Result := False; + end else + Result := ProcessDim(1, obj); + end; + + procedure FromClassRef; + var + r: TRttiType; + begin + if ObjectIsType(obj, stString) then + begin + r := Context.FindType(obj.AsString); + if r <> nil then + begin + Value := TRttiInstanceType(r).MetaclassType; + Result := True; + end else + Result := False; + end else + Result := False; + end; + + procedure FromUnknown; + begin + case ObjectGetType(obj) of + stBoolean: + begin + Value := obj.AsBoolean; + Result := True; + end; + stDouble: + begin + Value := obj.AsDouble; + Result := True; + end; + stCurrency: + begin + Value := obj.AsCurrency; + Result := True; + end; + stInt: + begin + Value := obj.AsInteger; + Result := True; + end; + stString: + begin + Value := obj.AsString; + Result := True; + end + else + Value := nil; + Result := False; + end; + end; + + procedure FromInterface; + const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}'; + var + o: ISuperObject; + g: TGuid; + begin + g := GetTypeData(TypeInfo).Guid; + // 델파이 10.3에서 아래처럼 안되서 수정 18_1129 kku +// if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then + if CompareMem(@g, @soguid, SizeOf(TGUID)) then + begin + if obj <> nil then + TValue.Make(@obj, TypeInfo, Value) else + begin + o := TSuperObject.Create(stNull); + TValue.Make(@o, TypeInfo, Value); + end; + Result := True; + end else + Result := False; + end; +var + Serial: TSerialFromJson; +begin + + if TypeInfo <> nil then + begin + if not SerialFromJson.TryGetValue(TypeInfo, Serial) then + case TypeInfo.Kind of + tkChar: FromChar; + tkInt64: FromInt64; + tkEnumeration, tkInteger: FromInt(obj); + tkSet: fromSet; + tkFloat: FromFloat(obj); + tkString, tkLString, tkUString, tkWString: FromString; + tkClass: FromClass; + tkMethod: ; + tkWChar: FromWideChar; + tkRecord: FromRecord; + tkPointer: ; + tkInterface: FromInterface; + tkArray: FromArray; + tkDynArray: FromDynArray; + tkClassRef: FromClassRef; + else + FromUnknown + end else + begin + TValue.Make(nil, TypeInfo, Value); + Result := Serial(Self, obj, Value); + end; + end else + Result := False; +end; + +function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject; + procedure ToInt64; + begin + Result := TSuperObject.Create(SuperInt(Value.AsInt64)); + end; + + procedure ToChar; + begin + Result := TSuperObject.Create(string(Value.AsType<AnsiChar>)); + end; + + procedure ToInteger; + begin + Result := TSuperObject.Create(TValueData(Value).FAsSLong); + end; + + procedure ToFloat; + begin + case Value.TypeData.FloatType of + ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle); + ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble); + ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended); + ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64); + ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr); + end; + end; + + procedure ToString; + begin + Result := TSuperObject.Create(string(Value.AsType<string>)); + end; + + procedure ToClass; + var + o: ISuperObject; + f: TRttiField; + v: TValue; + begin + if TValueData(Value).FAsObject <> nil then + begin + o := index[IntToStr(Integer(Value.AsObject))]; + if o = nil then + begin + Result := TSuperObject.Create(stObject); + index[IntToStr(Integer(Value.AsObject))] := Result; + for f in Context.GetType(Value.AsObject.ClassType).GetFields do + if f.FieldType <> nil then + begin + v := f.GetValue(Value.AsObject); + Result.AsObject[GetFieldName(f)] := ToJson(v, index); + end + end else + Result := o; + end else + Result := nil; + end; + + procedure ToWChar; + begin + Result := TSuperObject.Create(string(Value.AsType<WideChar>)); + end; + + procedure ToVariant; + begin + Result := SO(Value.AsVariant); + end; + + procedure ToRecord; + var + f: TRttiField; + v: TValue; + begin + Result := TSuperObject.Create(stObject); + for f in Context.GetType(Value.TypeInfo).GetFields do + begin +{$IFDEF VER210} + v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData); +{$ELSE} + v := f.GetValue(TValueData(Value).FValueData.GetReferenceToRawData); +{$ENDIF} + Result.AsObject[GetFieldName(f)] := ToJson(v, index); + end; + end; + + procedure ToArray; + var + idx: Integer; + ArrayData: PArrayTypeData; + + procedure ProcessDim(dim: Byte; const o: ISuperObject); + var + dt: PTypeData; + i: Integer; + o2: ISuperObject; + v: TValue; + begin + if ArrayData.Dims[dim-1] = nil then Exit; + dt := GetTypeData(ArrayData.Dims[dim-1]^); + if Dim = ArrayData.DimCount then + for i := dt.MinValue to dt.MaxValue do + begin + v := Value.GetArrayElement(idx); + o.AsArray.Add(toJSon(v, index)); + inc(idx); + end + else + for i := dt.MinValue to dt.MaxValue do + begin + o2 := TSuperObject.Create(stArray); + o.AsArray.Add(o2); + ProcessDim(dim + 1, o2); + end; + end; + var + i: Integer; + v: TValue; + begin + Result := TSuperObject.Create(stArray); + ArrayData := @Value.TypeData.ArrayData; + idx := 0; + if ArrayData.DimCount = 1 then + for i := 0 to ArrayData.ElCount - 1 do + begin + v := Value.GetArrayElement(i); + Result.AsArray.Add(toJSon(v, index)) + end + else + ProcessDim(1, Result); + end; + + procedure ToDynArray; + var + i: Integer; + v: TValue; + begin + Result := TSuperObject.Create(stArray); + for i := 0 to Value.GetArrayLength - 1 do + begin + v := Value.GetArrayElement(i); + Result.AsArray.Add(toJSon(v, index)); + end; + end; + + procedure ToClassRef; + begin + if TValueData(Value).FAsClass <> nil then + Result := TSuperObject.Create(string( + TValueData(Value).FAsClass.UnitName + '.' + + TValueData(Value).FAsClass.ClassName)) else + Result := nil; + end; + + procedure ToInterface; +{$IFNDEF VER210} + var + intf: IInterface; +{$ENDIF} + begin +{$IFDEF VER210} + if TValueData(Value).FHeapData <> nil then + TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else + Result := nil; +{$ELSE} + if TValueData(Value).FValueData <> nil then + begin + intf := IInterface(PPointer(TValueData(Value).FValueData.GetReferenceToRawData)^); + if intf <> nil then + intf.QueryInterface(ISuperObject, Result) else + Result := nil; + end else + Result := nil; +{$ENDIF} + end; + +var + Serial: TSerialToJson; +begin + if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then + case Value.Kind of + tkInt64: ToInt64; + tkChar: ToChar; + tkSet, tkInteger, tkEnumeration: ToInteger; + tkFloat: ToFloat; + tkString, tkLString, tkUString, tkWString: ToString; + tkClass: ToClass; + tkWChar: ToWChar; + tkVariant: ToVariant; + tkRecord: ToRecord; + tkArray: ToArray; + tkDynArray: ToDynArray; + tkClassRef: ToClassRef; + tkInterface: ToInterface; + else + result := nil; + end else + Result := Serial(Self, value, index); +end; + +{ TSuperObjectHelper } + +constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); +var + v: TValue; + ctxowned: Boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + ctxowned := True; + end else + ctxowned := False; + try + v := Self; + if not ctx.FromJson(v.TypeInfo, obj, v) then + raise Exception.Create('Invalid object'); + finally + if ctxowned then + ctx.Free; + end; +end; + +constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil); +begin + FromJson(SO(str), ctx); +end; + +function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject; +var + v: TValue; + ctxowned: boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + ctxowned := True; + end else + ctxowned := False; + try + v := Self; + Result := ctx.ToJson(v, SO); + finally + if ctxowned then + ctx.Free; + end; +end; + +{$ENDIF} + +function StringsToJsonObj(aList: TStrings): ISuperObject; +var + i: Integer; +begin + Result := TSuperObject.Create(stArray); + for i := 0 to aList.Count - 1 do + Result.AsArray.Add(aList[i]); +end; + +procedure LoadStringsFromJsonObj(aObj: ISuperObject; aList: TStrings); +var + i: Integer; +begin + aList.Clear; + try + if (aObj <> nil) and (aObj.AsArray.Length > 0) then + begin + for i := 0 to aObj.AsArray.Length - 1 do + aList.Add(aObj.AsArray[i].AsString); + end; + except + // .. + end; +end; + +function SaveJsonObjToStream(aO: ISuperObject; aStream: TStream; aEncoding: TEncoding = nil): Boolean; +var + ss: TStringStream; +begin + try + if aEncoding = nil then + aEncoding := TEncoding.UTF8; + ss := TStringStream.Create(aO.AsJSon, aEncoding); + try + ss.SaveToStream(aStream); + Result := true; + finally + ss.Free; + end; + except + Result := false; + end; +end; + +function SaveJsonObjToFile(aO: ISuperObject; sPath: String; aEncoding: TEncoding = nil; bIncIndent: Boolean = false): Boolean; +var + ss: TStringStream; +begin + try + if aEncoding = nil then + aEncoding := TEncoding.UTF8; + if bIncIndent then + ss := TStringStream.Create(aO.AsJSon(true), aEncoding) + else + ss := TStringStream.Create(aO.AsJSon, aEncoding); + try + ss.SaveToFile(sPath); + Result := true; + finally + ss.Free; + end; + except + Result := false; + end; +end; + +function LoadJsonObjFromFile(var aO: ISuperObject; sPath: String; aEncoding: TEncoding = nil): Boolean; +var + ss: TStringStream; +begin + Result := false; + if FileExists(sPath) then + begin + if aEncoding = nil then + aEncoding := TEncoding.UTF8; + try + ss := TStringStream.Create('', aEncoding); + try + ss.LoadFromFile(sPath); + aO := SO(ss.DataString); + Result := true; + finally + ss.Free; + end; + except + // + end; + end; +end; + +function SaveJsonObjToEncStream(aO: ISuperObject; aStream: TStream; sPass: String; aEncoding: TEncoding = nil): Boolean; +var + ss: TStringStream; +begin + try + if aEncoding = nil then + aEncoding := TEncoding.UTF8; + ss := TStringStream.Create(EncStrToBinStr(ekAes256cbc, sPass, aO.AsJSon), aEncoding); + try + ss.SaveToStream(aStream); + Result := true; + finally + ss.Free; + end; + except + Result := false; + end; +end; + +function SaveJsonObjToEncFile(aO: ISuperObject; sPath: String; sPass: String; aEncoding: TEncoding = nil): Boolean; +var + ss: TStringStream; +begin + try + if aEncoding = nil then + aEncoding := TEncoding.UTF8; + + ss := TStringStream.Create(EncStrToBinStr(ekAes256cbc, sPass, aO.AsJSon), aEncoding); + try + ss.SaveToFile(sPath); + Result := true; + finally + ss.Free; + end; + except + Result := false; + end; +end; + +function LoadJsonObjFromEncFile(var aO: ISuperObject; sPath: String; sPass: String; aEncoding: TEncoding = nil): Boolean; +var + ss: TStringStream; +begin + Result := false; + if FileExists(sPath) then + begin + if aEncoding = nil then + aEncoding := TEncoding.UTF8; + try + ss := TStringStream.Create('', aEncoding); + try + ss.LoadFromFile(sPath); + aO := SO(DecBinStrToStr(ekAes256cbc, sPass, ss.DataString)); + Result := true; + finally + ss.Free; + end; + except + // + end; + end; +end; + +{$IFDEF DEBUG} +initialization + +finalization + Assert(debugcount = 0, 'Memory leak'); +{$ENDIF} +end. + diff --git a/Tocsg.Lib/VCL/Tocsg.AIP.pas b/Tocsg.Lib/VCL/Tocsg.AIP.pas new file mode 100644 index 00000000..a6d35466 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.AIP.pas @@ -0,0 +1,349 @@ +{*******************************************************} +{ } +{ Tocsg.AIP } +{ } +{ Copyright (C) 2024 kku } +{ } +{*******************************************************} + +unit Tocsg.AIP; + +interface + +uses + System.SysUtils, System.Classes, Winapi.ActiveX; + +const + SIGN_AIP_DRM: array [0..23] of Byte = ($2E, $70, $66, $69, $6C, $65, $03, $00, + $00, $00, $00, $00, $00, $00, $8C, $01, + $00, $00, $0D, $0A, $0D, $0A, $0D, $0A); // .pfile 로 시작 + +function IsAipEncrytedPDF(sPath: String): Boolean; +function GetAipLabelNameFromPDF(sPath: String): String; + +function IsAipEncrytedOldOfficeDoc(sPath, sTempDir: String; nMode: Integer = STGM_READ or STGM_SHARE_EXCLUSIVE): Boolean; +function GetAipLabelNameFromOldOfficeDoc(sPath: String): String; + +function IsAipEncrytedOfficeDoc(sPath, sTempDir: String; nMode: Integer = STGM_READ or STGM_SHARE_EXCLUSIVE): Boolean; +function GetAipLabelNameFromOfficeDoc(sPath: String): String; + +function CheckMsPfileExt(sPath: String): Boolean; +function CheckAipEncSign(sPath: String): Boolean; +function IsAipEncryted(sPath: String; sTempDir: String = ''; nMode: Integer = STGM_READ or STGM_SHARE_EXCLUSIVE): Boolean; +function ConvAipEncExt(sPath: String): String; + +implementation + +uses + Tocsg.Exception, Tocsg.Hex, Winapi.Windows, Tocsg.Strings, Tocsg.Safe, + AbUnzper, System.Zip, Tocsg.Path, Tocsg.OLE.Stg, Tocsg.Files; + +function IsAipEncrytedPDF(sPath: String): Boolean; +var + fs: TFileStream; + pBuf: TBytes; + sDelPath: String; +begin + Result := false; + try + sDelPath := 'C:\ProgramData\HE\AEN\'; + if sPath.ToUpper.StartsWith(sDelPath.ToUpper) then + exit; +// WriteLnFileEndUTF8('C:\ProgramData\HE\ov_log.txt', Format('IsAipEncrytedPDF() .. Path=%s, TempDir=%s', [sPath, sDelPath])); + + if ForceDirectories(sDelPath) then + begin + sDelPath := sDelPath + '$' + ExtractFileName(sPath); + if CopyFile(PChar(sPath), PChar(sDelPath), false) then + begin + try + Guard(fs, TFileStream.Create(sDelPath, fmOpenRead or fmShareDenyNone)); + SetLength(pBuf, 2048); + if fs.Read(pBuf[0], 2048) <> 2048 then + exit; + Result := PosBin(TEncoding.UTF8.GetBytes('MicrosoftIRMServices Protected PDF'), pBuf) <> -1; + finally + if sDelPath <> '' then + DeleteFileForce(sDelPath); + end; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsAipEncryted()'); + end; +end; + +function GetAipLabelNameFromPDF(sPath: String): String; +//const +// p: array [0..13] of Byte = ($FE, $FF, $C7, $7C, $BC, $18, $00, $20, $B8, $08, $C7, $74, $BE, $14); // "일반 레이블" +var + fs: TFileStream; + pBuf, pLabel: TBytes; + nBufLen, nPos, nEnd, nLabelLen: Integer; +begin + Result := 'Unknown'; + try + if not FileExists(sPath) then + exit; + + nBufLen := 1024; + SetLength(pBuf, nBufLen); + + fs := TFileStream.Create(sPath, fmOpenRead or fmShareDenyNone); + // 암호화 레이블로 적용되었는지 확인 + if fs.Read(pBuf[0], nBufLen) <> nBufLen then + exit; + + if PosBin(TEncoding.UTF8.GetBytes('MicrosoftIRMServices Protected PDF'), pBuf) <> -1 then + begin + // 암호화된 레이블 정보 위치 + fs.Seek(27440, soBeginning); + fs.Read(pBuf[0], nBufLen); + end else begin + // 일반 레이블 정보 위치 + fs.Seek(-1024, soEnd); + fs.Read(pBuf[0], nBufLen); + end; + + nPos := PosBin(TEncoding.UTF8.GetBytes('/MSIP_Label_'), pBuf); + if nPos > -1 then + begin + nPos := PosBin(TEncoding.UTF8.GetBytes('_Name ('), pBuf, nPos); + if nPos > -1 then + begin + Inc(nPos, 7); + nEnd := PosBin(TEncoding.UTF8.GetBytes(')'), pBuf, nPos); + nLabelLen := nEnd - nPos; + if (nEnd > -1) and (nLabelLen > 0) then + begin + SetLength(pLabel, nLabelLen); + CopyMemory(pLabel, @pBuf[nPos], nLabelLen); + if pLabel[0] = $FE then + Result := TEncoding.BigEndianUnicode.GetString(pLabel) + else + Result := TEncoding.ANSI.GetString(pLabel); + end; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetAipLabelNameFromPDF()'); + end; +end; + +function IsAipEncrytedOldOfficeDoc(sPath, sTempDir: String; nMode: Integer = STGM_READ or STGM_SHARE_EXCLUSIVE): Boolean; +var +// fs: TFileStream; +// pBuf: TBytes; +// nBufLen: Integer; + pvStg: IStorage; + sData: WideString; + enum: IEnumStatStg; + elt: TStatStg; + sDelPath: String; +begin + Result := false; + try + if sPath.ToUpper.StartsWith(sTempDir.ToUpper) then + exit; +// WriteLnFileEndUTF8('C:\ProgramData\HE\ov_log.txt', Format('IsAipEncrytedOldOfficeDoc() .. Path=%s, TempDir=%s', [sPath, sTempDir])); + + pvStg := nil; + sDelPath := ''; + try + // 쉘 익스텐션 GetIconLocation() 에선 STGM_SHARE_EXCLUSIVE 모드 사용 시 스톱되서 아래처럼 처리 25_0122 14:03:25 kku + if not StgStorageFileOpen(sPath, pvStg, nMode) then + begin + if (sTempDir <> '') and ForceDirectories(sTempDir) then + begin + // MS 파일은 사용중이면 안열려서 이렇게 처리 24_1114 09:24:47 kku + sDelPath := sTempDir + '$' + ExtractFileName(sPath); + if CopyFile(PChar(sPath), PChar(sDelPath), false) then + begin + if not StgStorageFileOpen(sDelPath, pvStg) then + exit; + end else exit; + end else exit; + end; + + if pvStg = nil then + exit; + + enum := nil; + if StgGetEnumElements(pvStg, enum) then + Result := StgGetStatStgLike(enum, 'DRMContent', elt); + finally + enum := nil; + pvStg := nil; + if sDelPath <> '' then + DeleteFileForce(sDelPath); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsAipEncrytedOldOfficeDoc()'); + end; +end; + +function GetAipLabelNameFromOldOfficeDoc(sPath: String): String; +begin + Result := 'Unknown'; +end; + +function IsAipEncrytedOfficeDoc(sPath, sTempDir: String; nMode: Integer = STGM_READ or STGM_SHARE_EXCLUSIVE): Boolean; +var + pvStg: IStorage; + sData: WideString; + sDelPath: String; +begin + Result := false; + try + if sPath.ToUpper.StartsWith(sTempDir.ToUpper) then + exit; +// WriteLnFileEndUTF8('C:\ProgramData\HE\ov_log.txt', Format('IsAipEncrytedOfficeDoc() .. Path=%s, TempDir=%s', [sPath, sTempDir])); + + pvStg := nil; + sDelPath := ''; + try + // 쉘 익스텐션 GetIconLocation() 에선 STGM_SHARE_EXCLUSIVE 모드 사용 시 스톱되서 아래처럼 처리 25_0122 14:03:25 kku + if not StgStorageFileOpen(sPath, pvStg, nMode) then + begin + // MS 파일은 사용중이면 안열려서 이렇게 처리 24_1114 09:24:47 kku + if (sTempDir <> '') and ForceDirectories(sTempDir) then + begin + // MS 파일은 사용중이면 안열려서 이렇게 처리 24_1114 09:24:47 kku + sDelPath := sTempDir + '$' + ExtractFileName(sPath); + if CopyFile(PChar(sPath), PChar(sDelPath), false) then + begin + if not StgStorageFileOpen(sDelPath, pvStg) then + exit; + end else exit; + end else exit; + end; + + if pvStg = nil then + exit; + + Result := StgGetStreamToText(pvStg, 'EncryptedPackage', sData); + finally + pvStg := nil; + if sDelPath <> '' then + DeleteFileForce(sDelPath); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsAipEncrytedOldOfficeDoc()'); + end; +end; + +function GetAipLabelNameFromOfficeDoc(sPath: String): String; +begin + Result := 'Unknown'; +end; + +// MS문서 중 .pfile로 변경 가능성이 있는 확장자인지 체크 25_1222 17:52:57 kku +function CheckMsPfileExt(sPath: String): Boolean; +var + sExt: String; +begin + sExt := GetFileExt(sPath).ToUpper; + Result := (sExt = 'DOC') or (sExt = 'XLS') or (sExt = 'PPT') or + (sExt = 'DOT') or (sExt = 'PPS') or (sExt = 'POT') or + (sExt = 'XLT') or (sExt = 'XLTM') or (sExt = 'XLTX') or + (sExt = 'XPS') or (sExt = 'DOTM') or (sExt = 'PPSM') or + (sExt = 'PPSX') or (sExt = 'PPTM') or (sExt = 'XPS'); +end; + +function CheckAipEncSign(sPath: String): Boolean; +begin + Result := false; + try + if not FileExists(sPath) then + exit; + + Result := CheckSign(sPath, @SIGN_AIP_DRM[0], 24); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. CheckAipEncSign()'); + end; +end; + +function IsAipEncryted(sPath: String; sTempDir: String = ''; nMode: Integer = STGM_READ or STGM_SHARE_EXCLUSIVE): Boolean; +var + sExt: String; +begin + Result := false; + try + if not FileExists(sPath) then + exit; + + if sPath.ToUpper.StartsWith(sTempDir.ToUpper) then + exit; +// WriteLnFileEndUTF8('C:\ProgramData\HE\ov_log.txt', Format('IsAipEncryted() .. Path=%s, TempDir=%s', [sPath, sTempDir])); + + Result := CheckAipEncSign(sPath); + if not Result then + begin + sExt := GetFileExt(sPath).ToUpper; + if sExt = 'PDF' then + begin + Result := IsAipEncrytedPDF(sPath); + end else + if CheckMsPfileExt(sPath) then + begin + Result := IsAipEncrytedOldOfficeDoc(sPath, sTempDir, nMode); + if not Result then + Result := IsAipEncrytedOfficeDoc(sPath, sTempDir, nMode); + end else + if (sExt = 'DOCX') or (sExt = 'XLSX') or (sExt = 'PPTX') or + (sExt = 'DOCM') or (sExt = 'DOTX') or (sExt = 'XLSM') or + (sExt = 'XLSB') then + begin + Result := IsAipEncrytedOfficeDoc(sPath, sTempDir, nMode); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsAipEncryted()'); + end; +end; + +function ConvAipEncExt(sPath: String): String; +var + sExt, sPathNoExt: String; +begin + Result := sPath; + if sPath = '' then + exit; + + sExt := GetFileExt(sPath).ToUpper; + sPathNoExt := CutFileExt(sPath); + + if sExt = 'TXT' then + Result := sPathNoExt + '.ptxt' + else if sExt = 'XML' then + Result := sPathNoExt + '.pxml' + else if sExt = 'PNG' then + Result := sPathNoExt + '.ppng' + else if sExt = 'BMP' then + Result := sPathNoExt + '.pbmp' + else if sExt = 'JPG' then + Result := sPathNoExt + '.pjpg' + else if sExt = 'JPEG' then + Result := sPathNoExt + '.pjpeg' + else if (sExt <> 'DOCX') and (sExt <> 'XLSX') and + (sExt <> 'PPTX') and (sExt <> 'PDF') and + (sExt <> 'XLSB') and (sExt <> 'XLSM') and + (sExt <> 'DOTX') and (sExt <> 'DOCM') and + (sExt <> 'DOC') and (sExt <> 'XLS') and + (sExt <> 'PPT') and (sExt <> 'DOT') and + (sExt <> 'PPS') and (sExt <> 'POT') and + (sExt <> 'XLT') and (sExt <> 'XLTM') and (sExt <> 'XLTX') and + (sExt <> 'XPS') and (sExt <> 'DOTM') and (sExt <> 'PPSM') and + (sExt <> 'PPSX') and (sExt <> 'PPTM') and (sExt <> 'XPS') then + begin + Result := sPath + '.pfile'; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.AppInfo.pas b/Tocsg.Lib/VCL/Tocsg.AppInfo.pas new file mode 100644 index 00000000..aceaaee4 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.AppInfo.pas @@ -0,0 +1,357 @@ +{*******************************************************} +{ } +{ Tocsg.AppInfo } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.AppInfo; + +interface + +uses + Tocsg.Obj, System.SysUtils, System.Classes, Winapi.Windows, + System.Generics.Collections, superobject; + +type + TInstExe = class(TTgObject) + private + nRunCnt_: Integer; + ExeDtList_: TList<TDateTime>; + sPath_, + sFName_: String; + public + Constructor Create(sPath: String); + Destructor Destroy; override; + + property RunCount: Integer read nRunCnt_; + property FileName: String read sFName_; + property ExeDtList: TList<TDateTime> read ExeDtList_; + end; + TInstExeList = class(TList<TInstExe>) + protected + procedure Notify(const Item: TInstExe; Action: TCollectionNotification); override; + public + function GetExeFiles: String; + function GetRunCount: Integer; + end; + + PInstAppEnt = ^TInstAppEnt; + TInstAppEnt = record + sName, + sVersion, + sPublisher, + sUrlInfo, + sInstDir, + sIconPath, + sCopyright, + sDescription, + sUninstStr: String; + dtInst: TDateTime; + InstExeList: TInstExeList; + end; + TTgInstAppList = class(TList<PInstAppEnt>) + protected + procedure Notify(const Item: PInstAppEnt; Action: TCollectionNotification); override; + public + procedure UpdateInstAppList; + + function ToJsonObj: ISuperObject; + function ToJsonObjHE: ISuperObject; + end; + +implementation + +uses + Tocsg.Safe, Tocsg.Registry, System.Win.Registry, Tocsg.Exception, Tocsg.FileInfo, + Tocsg.DateTime, Tocsg.Json, Tocsg.Path, Tocsg.Prefetch, Tocsg.Strings; + +const + REGKEY_UNINSTALL = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\'; + REGKEY_UNINSTALL_WOW64 = 'SOFTWARE\WOW6432Node\Microsoft\Windows\CurrentVersion\Uninstall\'; + +{ TInstExe } + +Constructor TInstExe.Create(sPath: String); +begin + Inherited Create; + sFName_ := ExtractFileName(sPath); + sPath_ := ExtractFilePath(sPath); + ExeDtList_ := TList<TDateTime>.Create; +end; + +Destructor TInstExe.Destroy; +begin + FreeAndNil(ExeDtList_); + Inherited; +end; + +{ TInstExeList } + +procedure TInstExeList.Notify(const Item: TInstExe; Action: TCollectionNotification); +begin + if Action = cnRemoved then + Item.Free; +end; + +function TInstExeList.GetExeFiles: String; +var + i: Integer; +begin + Result := ''; + for i := 0 to Self.Count - 1 do + SumString(Result, Self[i].sFName_, ', '); +end; + +function TInstExeList.GetRunCount: Integer; +var + i: Integer; +begin + Result := 0; + for i := 0 to Self.Count - 1 do + Inc(Result, Self[i].nRunCnt_); +end; + +{ TTgInstAppList } + +procedure TTgInstAppList.Notify(const Item: PInstAppEnt; Action: TCollectionNotification); +begin + if Action = cnRemoved then + begin + if Item.InstExeList <> nil then + FreeAndNil(Item.InstExeList); + Dispose(Item); + end; +end; + +procedure ExtrPfFileInfo(aIExe: TInstExe); +var + wfd: TWin32FindData; + hSc: THandle; + sDir, + sPath, + sFName: String; + pf: TTgPrefetchAnal; + i: Integer; +begin + sDir := GetWindowsDir + 'Prefetch\'; + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + try + sPath := UpperCase(ExcludeTrailingPathDelimiter(aIExe.sPath_)); + Delete(sPath, 1, 2); // C: 빼기 + sFName := UpperCase(aIExe.sFName_); + Guard(pf, TTgPrefetchAnal.Create); + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0) then + begin + if Pos(aIExe.sFName_.ToUpper, String(wfd.cFileName)) > 0 then + begin + if pf.LoadFromFile(sDir + wfd.cFileName) then + begin + if (pf.FileName <> sFName) or (Pos(sPath, pf.FilePath) = 0) then + continue; + + for i := 0 to pf.ExeDtList.Count - 1 do + aIExe.ExeDtList_.Add(pf.ExeDtList[i]); + Inc(aIExe.nRunCnt_, pf.RunCount); + end; + end; + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +procedure ExtractExeFilesFromInstDir(sDir: String; var aList: TInstExeList); +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; + IExe: TInstExe; +begin + if (sDir = '') or not DirectoryExists(sDir) then + exit; + + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin +// if CompareText(wfd.cFileName, 'bin') = 0 then + ExtractExeFilesFromInstDir(sDir + wfd.cFileName, aList); + end else begin +// if (UpperCase(GetFileExt(wfd.cFileName)) = 'EXE') and +// (CompareText(wfd.cFileName, 'setup.exe') <> 0) and +// (CompareText(wfd.cFileName, 'uninstall.exe') <> 0) and +// (CompareText(wfd.cFileName, 'update.exe') <> 0) then + if (UpperCase(GetFileExt(wfd.cFileName)) = 'EXE') then + begin + IExe := TInstExe.Create(sDir + wfd.cFileName); + ExtrPfFileInfo(IExe); + aList.Add(IExe); + end; + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +procedure TTgInstAppList.UpdateInstAppList; + + function GetRegStrValue(aReg: TRegistry; sValName: String): String; inline; + begin + if aReg.ValueExists(sValName) then + Result := aReg.ReadString(sValName) + else + Result := ''; + end; + + procedure AddInstAppFromReg(K: HKEY; sRegKey: String); + var + InstList: TStringList; + Reg: TRegistry; + i: Integer; + sName, sUninstStr: String; + pEnt: PInstAppEnt; + FileInfo: TTgFileInfo; + RegInfo: TRegKeyInfo; + begin + try + Guard(InstList, TStringList.Create); + ExtRegSubKeyToStrings(K, sRegKey, InstList); + if InstList.Count = 0 then + exit; + + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + for i := 0 to InstList.Count - 1 do + begin + if not Reg.OpenKey(InstList[i], false) then + continue; + + try + FileInfo := nil; + try + sName := GetRegStrValue(Reg, 'DisplayName'); + sUninstStr := GetRegStrValue(Reg, 'UninstallString'); + if (sName = '') or (sUninstStr = '') then + continue; + + New(pEnt); + ZeroMemory(pEnt, SizeOf(TInstAppEnt)); + pEnt.sName := sName; + pEnt.sVersion := GetRegStrValue(Reg, 'DisplayVersion'); + pEnt.sPublisher := GetRegStrValue(Reg, 'Publisher'); + pEnt.sUrlInfo := GetRegStrValue(Reg, 'URLInfoAbout'); + pEnt.sInstDir := StringReplace(GetRegStrValue(Reg, 'InstallLocation'), '"', '', [rfReplaceAll]); + if pEnt.sInstDir = '' then + begin + pEnt.sInstDir := ExtractFilePath(StringReplace(sUninstStr, '"', '', [rfReplaceAll])); + if not DirectoryExists(pEnt.sInstDir) then + pEnt.sInstDir := ''; + end; + {$IFNDEF _HE_} + pEnt.InstExeList := TInstExeList.Create; + ExtractExeFilesFromInstDir(pEnt.sInstDir, pEnt.InstExeList); + {$ENDIF} + pEnt.sIconPath := GetRegStrValue(Reg, 'DisplayIcon'); + pEnt.sUninstStr := sUninstStr; + if reg.GetKeyInfo(RegInfo) then + pEnt.dtInst := ConvFileTimeToDateTime_Local(RegInfo.FileTime); + + if FileExists(pEnt.sIconPath) then + begin + FileInfo := TTgFileInfo.Create(pEnt.sIconPath); + pEnt.sCopyright := FileInfo.LegalCopyright; + pEnt.sDescription := FileInfo.Description; + if pEnt.sVersion = '' then + pEnt.sVersion := FileInfo.Version; + if pEnt.sPublisher = '' then + pEnt.sPublisher := FileInfo.Company; + end; + Add(pEnt); + except + continue; + end; + finally + Reg.CloseKey; + if FileInfo <> nil then + FreeAndNil(FileInfo); + end; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. AddInstAppFromReg()'); + end; + end; + +var + sCurUserSid: String; +begin + Clear; + + sCurUserSid := GetRegRecentUserSid; + + if sCurUserSid <> '' then + begin + AddInstAppFromReg(HKEY_USERS, sCurUserSid + '\' + REGKEY_UNINSTALL); + AddInstAppFromReg(HKEY_USERS, sCurUserSid + '\' + REGKEY_UNINSTALL_WOW64); + end; + + AddInstAppFromReg(HKEY_LOCAL_MACHINE, REGKEY_UNINSTALL); + AddInstAppFromReg(HKEY_LOCAL_MACHINE, REGKEY_UNINSTALL_WOW64); +end; + +function TTgInstAppList.ToJsonObj: ISuperObject; +var + i: Integer; +begin + Result := TSuperObject.Create(stArray); + for i := 0 to Count - 1 do + Result.AsArray.Add(TTgJson.ValueToJsonObject<TInstAppEnt>(Items[i]^)); +end; + +function TTgInstAppList.ToJsonObjHE: ISuperObject; +var + i: Integer; + pEnt: PInstAppEnt; + O: ISuperObject; +begin + Result := TSuperObject.Create(stArray); + for i := 0 to Count - 1 do + begin + pEnt := Items[i]; + O := SO; + + with pEnt^ do + begin + O.S['Name'] := sName; + O.S['Version'] := sVersion; + O.S['Publisher'] := sPublisher; + O.S['UrlInfo'] := sUrlInfo; + O.S['InstDir'] := sInstDir; + O.S['IconPath'] := sIconPath; + O.S['Copyright'] := sCopyright; + O.S['Description'] := sDescription; + O.I['InstDT'] := DelphiToJavaDateTime(dtInst); + end; + Result.AsArray.Add(O); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Binary.pas b/Tocsg.Lib/VCL/Tocsg.Binary.pas new file mode 100644 index 00000000..9607e653 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Binary.pas @@ -0,0 +1,73 @@ +unit Tocsg.Binary; + +interface + +uses + Winapi.Windows, System.SysUtils, System.Classes; + +function ConvBytesToHexStr(pBuf: PByte; dwSize: DWORD): AnsiString; +function ConvHexStrToBytes(sSrc: String; var pBuf: TBytes): Integer; + +implementation + +uses + Tocsg.Exception; + +function ConvBytesToHexStr(pBuf: PByte; dwSize: DWORD): AnsiString; +var + i: Integer; + sTemp, sHex: AnsiString; +begin + Result := ''; + try + // for i := 0 to dwSize - 1 do + // Result := Result + Format('%.2x', [pBuf[i]]); + + // 속도 개선 25_0415 14:45:22 kku + SetLength(sTemp, dwSize * 2); + for i := 0 to dwSize - 1 do + begin + sHex := Format('%.2x', [pBuf[i]]); + CopyMemory(@sTemp[(i * 2) + 1], @sHex[1], 2); + end; + Result := sTemp; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ConvBytesToHexStr()'); + end; +end; + +function ConvHexStrToBytes(sSrc: String; var pBuf: TBytes): Integer; +var + HexList: TStringList; + i, nLen: Integer; +begin + nLen := Length(sSrc); + if (nLen mod 2) <> 0 then + begin + sSrc := '0' + sSrc; + Inc(nLen); + end; + + HexList := TStringList.Create; + try + i := 0; + while i < nLen do + begin + HexList.Add(sSrc.Substring(i, 2)); + Inc(i, 2); + end; + + Result := HexList.Count; + if Result <= 0 then + exit; + + SetLength(pBuf, Result); + for i := 0 to HexList.Count - 1 do + pBuf[i] := StrToIntDef('$' + HexList[i], 0); + finally + FreeAndNil(HexList); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Bluetooth.pas b/Tocsg.Lib/VCL/Tocsg.Bluetooth.pas new file mode 100644 index 00000000..98e6db47 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Bluetooth.pas @@ -0,0 +1,667 @@ +{*******************************************************} +{ } +{ Tocsg.Bluetooth } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.Bluetooth; + +interface + +uses + EM.jwabluetoothapis, Tocsg.Obj, Tocsg.Thread, System.Classes, + System.SysUtils, Winapi.Windows, System.Generics.Collections; + +const + BT_DEVICE_CLASS_MISC = $0; + BT_DEVICE_CLASS_COMPUTER = $1; + BT_DEVICE_CLASS_PHONE = $2; + BT_DEVICE_CLASS_LANACCESSPOINT = $3; + BT_DEVICE_CLASS_AV = $4; + BT_DEVICE_CLASS_PERIPHERAL = $5; + BT_DEVICE_CLASS_IMAGING = $6; + BT_DEVICE_CLASS_UNCLASSIFIED = $1F; + +type + PBtDevEnt = ^TBtDevEnt; + TBtDevEnt = record + sAddress: String; + dtLastSeen, + dtLastUsed: TDateTime; + dInfo: BLUETOOTH_DEVICE_INFO; + end; + + TBluetoothDevice = class(TTgObject) + protected + BTDeviceList_: TList<PBtDevEnt>; + procedure OnBTDeviceNotify(Sender: TObject; const Item: PBtDevEnt; + Action: TCollectionNotification); + function GetCount: Integer; + function GetBTDeviceByIndex(nIndex: Integer): PBtDevEnt; + public + Constructor Create; + Destructor Destroy; override; + + function RefreshBTDevice(pbWorkStop: PBoolean = nil): Boolean; + + property Count: Integer read GetCount; + property Items[nIndex: Integer]: PBtDevEnt read GetBTDeviceByIndex; default; + end; + + PBtRdiEnt = ^TBtRdiEnt; + TBtRdiEnt = record + sAddress: String; + dInfo: BLUETOOTH_RADIO_INFO; + end; + + TBluetoothRadio = class(TTgObject) + protected + BTRadioList_: TList<PBtRdiEnt>; + procedure OnBTRadioNotify(Sender: TObject; const Item: PBtRdiEnt; + Action: TCollectionNotification); + function GetCount: Integer; + function GetBTRadioByIndex(nIndex: Integer): PBtRdiEnt; + public + Constructor Create; + Destructor Destroy; override; + + function RefreshBTRadio: Boolean; + + property Count: Integer read GetCount; + property Items[nIndex: Integer]: PBtRdiEnt read GetBTRadioByIndex; default; + end; + + TBTChangeState = (csDetection, csConnected, csRemembered, csAuthenticated, csLastSeen, csLastUsed); + TBTChangeStates = set of TBTChangeState; + + TBtDevChangeNotify = procedure(pEnt: PBtDevEnt; csBT: TBTChangeStates; var bPrevent: Boolean) of object; + + TThdBtDevNotify = class(TTgThread) + private + bSync_: Boolean; + BTDevice_: TBluetoothDevice; + DcBTDevice_: TDictionary<String,PBtDevEnt>; + + procedure OnBTDeviceNotify(Sender: TObject; const Item: PBtDevEnt; + Action: TCollectionNotification); + protected + evChangeBTDevice_: TBtDevChangeNotify; + + pBTEntry_: PBtDevEnt; + csBT_: TBTChangeStates; + bPreventBtDevs_: Boolean; + + function GetBTDeviceState(aEnt: PBtDevEnt): TBTChangeStates; + procedure Execute; override; + + procedure ProcessBTDeviceNotify; + public + Constructor Create(bSync: Boolean = false); + Destructor Destroy; override; + + procedure ResetBTDevice; + + property OnChangeBTDevice: TBtDevChangeNotify write evChangeBTDevice_; + property PreventBtDevs: Boolean write bPreventBtDevs_; + end; + + procedure BtDevTypeToStr(dwClassOfDevice: DWORD; var sMajor, sMinor: String); + +function SetBtDevsEnable(bVal: Boolean): Integer; + +implementation + +uses + System.DateUtils, Tocsg.DateTime, Tocsg.Strings, Tocsg.Driver, Tocsg.Convert, + Tocsg.Exception; + +function SetBtDevsEnable(bVal: Boolean): Integer; +var + hDev: HDEVINFO; + sdd: TSPDevInfoData; + i: Integer; + dwBufSize, + dwStatus, dwProblem, + dwPropertyRegDataType: DWORD; + pBuf: Pointer; +begin + Result := 0; + + try + hDev := SetupDiGetClassDevs(@GUID_DEVCLASS_BLUETOOTH, nil, 0, DIGCF_PRESENT); + if hDev = INVALID_HANDLE_VALUE then + exit; + + pBuf := nil; + try + ZeroMemory(@sdd, SizeOf(sdd)); + sdd.cbSize := SizeOf(sdd); + + i := 0; + while SetupDiEnumDeviceInfo(hDev, i, sdd) do + begin + dwBufSize := 0; + if pBuf <> nil then + begin + FreeMem(pBuf); + pBuf := nil; + end; + + while not SetupDiGetDeviceRegistryProperty(hDev, sdd, + SPDRP_HARDWAREID, dwPropertyRegDataType, pBuf, dwBufSize, dwBufSize) do + begin + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + if pBuf <> nil then + FreeMem(pBuf); + pBuf := AllocMem(dwBufSize); + end else break; + end; + + if pBuf <> nil then + begin + if (CompareText('BTH\MS_BTHLE', String(PChar(pBuf))) <> 0) and + (CompareText('BTH\MS_BTHBRB', String(PChar(pBuf))) <> 0) then + begin + dwStatus := 0; + dwProblem := 0; + + if CM_Get_DevNode_Status(dwStatus, dwProblem, sdd.DevInst, 0) = CR_SUCCESS then + begin +// var bDisabled: Boolean := (((dwStatus and DN_HAS_PROBLEM) = 0) and (dwProblem = CM_PROB_DISABLED)); +// if bVal = bDisabled then + begin + var PropChangeParams: TSPPropChangeParams; + ZeroMemory(@PropChangeParams, SizeOf(PropChangeParams)); + PropChangeParams.ClassInstallHeader.cbSize := SizeOf(TSPClassInstallHeader); + PropChangeParams.ClassInstallHeader.InstallFunction := DIF_PROPERTYCHANGE; + PropChangeParams.Scope := DICS_FLAG_GLOBAL; + PropChangeParams.StateChange := BooleanToInt(bVal, DICS_ENABLE, DICS_DISABLE); + + if SetupDiSetClassInstallParams(hDev, @sdd, PSPClassInstallHeader(@PropChangeParams), SizeOf(PropChangeParams)) then + begin + // 64bit OS 에서는 64bit 프로그램 에서만 실행 가능하다 22_0621 13:59:21 kku + if SetupDiCallClassInstaller(DIF_PROPERTYCHANGE, hDev, @sdd) then + Inc(Result); + end; + end; + end; + end; + end; + + Inc(i); + end; + + finally + SetupDiDestroyDeviceInfoList(hDev); + if pBuf <> nil then + FreeMem(pBuf); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. SetBtDevsEnable()'); + end; +end; + +{ TBluetoothDevice } + +Constructor TBluetoothDevice.Create; +begin + Inherited Create; + BTDeviceList_ := TList<PBtDevEnt>.Create; + BTDeviceList_.OnNotify := OnBTDeviceNotify; +end; + +Destructor TBluetoothDevice.Destroy; +begin + FreeAndNil(BTDeviceList_); + Inherited; +end; + +procedure TBluetoothDevice.OnBTDeviceNotify(Sender: TObject; const Item: PBtDevEnt; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +function TBluetoothDevice.GetCount: Integer; +begin + Result := BTDeviceList_.Count; +end; + +function TBluetoothDevice.GetBTDeviceByIndex(nIndex: Integer): PBtDevEnt; +begin + Result := nil; + if (nIndex >= 0) and (nIndex < BTDeviceList_.Count) then + Result := BTDeviceList_[nIndex]; +end; + +function TBluetoothDevice.RefreshBTDevice(pbWorkStop: PBoolean = nil): Boolean; +var + hFind: HBLUETOOTH_DEVICE_FIND; + BtDevSchParam: BLUETOOTH_DEVICE_SEARCH_PARAMS; + BtDevInfo: BLUETOOTH_DEVICE_INFO; + pInfo: PBtDevEnt; +begin + Result := false; + + BTDeviceList_.Clear; + + ZeroMemory(@BtDevSchParam, SizeOf(BtDevSchParam)); + BtDevSchParam.dwSize := SizeOf(BtDevSchParam); + BtDevSchParam.fReturnAuthenticated := true; + BtDevSchParam.fReturnRemembered := true; + BtDevSchParam.fReturnUnknown := true; + BtDevSchParam.fReturnConnected := true; +// BtDevSchParam.fIssueInquiry := true; +// BtDevSchParam.cTimeoutMultiplier := 10; + + ZeroMemory(@BtDevInfo, SizeOf(BtDevInfo)); + BtDevInfo.dwSize := SizeOf(BtDevInfo); + hFind := BluetoothFindFirstDevice(BtDevSchParam, BtDevInfo); + + try + if hFind <> 0 then + begin + repeat + New(pInfo); + ZeroMemory(pInfo, SizeOf(TBtDevEnt)); + + BluetoothUpdateDeviceRecord(BtDevInfo); + pInfo.dInfo := BtDevInfo; + pInfo.sAddress := Format('%.2x:%.2x:%.2x:%.2x:%.2x:%.2x', + [BtDevInfo.Address.rgBytes[5], BtDevInfo.Address.rgBytes[4], + BtDevInfo.Address.rgBytes[3], BtDevInfo.Address.rgBytes[2], + BtDevInfo.Address.rgBytes[1], BtDevInfo.Address.rgBytes[0]]); + + pInfo.dtLastSeen := ConvSystemTimeToDateTime_Local(BtDevInfo.stLastSeen); + try + if BtDevInfo.stLastUsed.wYear <> 0 then + pInfo.dtLastUsed := ConvSystemTimeToDateTime_Local(BtDevInfo.stLastUsed) + else + pInfo.dtLastUsed := 0; + except + pInfo.dtLastUsed := 0; + end; + BTDeviceList_.Add(pInfo); + + if (pbWorkStop <> nil) and (pbWorkStop^ = true) then + exit; + until (hFind <> 0) and not BluetoothFindNextDevice(hFind, BtDevInfo); + Result := true; + end; + finally + if hFind <> 0 then + begin + BluetoothFindDeviceClose(hFind); + end; + end; +end; + +{ TBluetoothRadio } + +Constructor TBluetoothRadio.Create; +begin + BTRadioList_ := TList<PBtRdiEnt>.Create; + BTRadioList_.OnNotify := OnBTRadioNotify; +end; + +Destructor TBluetoothRadio.Destroy; +begin + FreeAndNil(BTRadioList_); + Inherited; +end; + +procedure TBluetoothRadio.OnBTRadioNotify(Sender: TObject; const Item: PBtRdiEnt; + Action: TCollectionNotification); +begin + if Action = cnRemoved then + Dispose(Item); +end; + +function TBluetoothRadio.GetCount: Integer; +begin + Result := BTRadioList_.Count; +end; + +function TBluetoothRadio.GetBTRadioByIndex(nIndex: Integer): PBtRdiEnt; +begin + Result := nil; + if (nIndex >= 0) and (nIndex < BTRadioList_.Count) then + Result := BTRadioList_[nIndex]; +end; + +function TBluetoothRadio.RefreshBTRadio: Boolean; +var + hFind: HBLUETOOTH_RADIO_FIND; + hRadio: THandle; + BtRadiFindParam: BLUETOOTH_FIND_RADIO_PARAMS; + BtRadiInfo: BLUETOOTH_RADIO_INFO; + pInfo: PBtRdiEnt; +begin + Result := false; + + BTRadioList_.Clear; + + ZeroMemory(@BtRadiFindParam, SizeOf(BtRadiFindParam)); + BtRadiFindParam.dwSize := SizeOf(BtRadiFindParam); + ZeroMemory(@BtRadiInfo, SizeOf(BtRadiInfo)); + BtRadiInfo.dwSize := SizeOf(BtRadiInfo); + hRadio := 0; + + hFind := BluetoothFindFirstRadio(@BtRadiFindParam, hRadio); + + try + if hFind <> 0 then + begin + repeat + if BluetoothGetRadioInfo(hRadio, BtRadiInfo) = 0 then + begin + New(pInfo); + ZeroMemory(pInfo, SizeOf(TBtDevEnt)); + + pInfo.dInfo := BtRadiInfo; + pInfo.sAddress := Format('%.2x:%.2x:%.2x:%.2x:%.2x:%.2x', + [BtRadiInfo.Address.rgBytes[5], BtRadiInfo.Address.rgBytes[4], + BtRadiInfo.Address.rgBytes[3], BtRadiInfo.Address.rgBytes[2], + BtRadiInfo.Address.rgBytes[1], BtRadiInfo.Address.rgBytes[0]]); + + BTRadioList_.Add(pInfo); + end; + until (hFind <> 0) and not BluetoothFindNextRadio(hFind, hRadio); + Result := true; + end; + finally + if hFind <> 0 then + begin + BluetoothFindRadioClose(hFind); + end; + end; +end; + +{ TThdBtDevNotify } + +Constructor TThdBtDevNotify.Create(bSync: Boolean = false); +begin + Inherited Create; + bSync_ := bSync; + DcBTDevice_ := TDictionary<String,PBtDevEnt>.Create; + DcBTDevice_.OnValueNotify := OnBTDeviceNotify; + BTDevice_ := TBluetoothDevice.Create; + bPreventBtDevs_ := false; +end; + +Destructor TThdBtDevNotify.Destroy; +begin + Inherited; + FreeAndNil(BTDevice_); + FreeAndNil(DcBTDevice_); +end; + +procedure TThdBtDevNotify.OnBTDeviceNotify(Sender: TObject; const Item: PBtDevEnt; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +procedure TThdBtDevNotify.ResetBTDevice; +begin + Lock; + try + DcBTDevice_.Clear; + finally + Unlock; + end; +end; + +procedure TThdBtDevNotify.ProcessBTDeviceNotify; +var + bPrevent: Boolean; +begin + if Assigned(evChangeBTDevice_) then + begin + evChangeBTDevice_(pBTEntry_, csBT_, bPrevent); + if bPrevent then + bPreventBtDevs_ := true; + end; +end; + +function TThdBtDevNotify.GetBTDeviceState(aEnt: PBtDevEnt): TBTChangeStates; +var + pEntry: PBtDevEnt; +begin + Result := []; + + Lock; + try + if DcBTDevice_.ContainsKey(aEnt.sAddress) then + pEntry := DcBTDevice_[aEnt.sAddress] + else + pEntry := nil; + finally + Unlock; + end; + + if pEntry <> nil then + begin + if pEntry.dInfo.fConnected <> aEnt.dInfo.fConnected then + Include(Result, csConnected); + if pEntry.dInfo.fRemembered <> aEnt.dInfo.fRemembered then + Include(Result, csRemembered); + if pEntry.dInfo.fAuthenticated <> aEnt.dInfo.fAuthenticated then + Include(Result, csAuthenticated); + // LastSeen은 BluetoothFindFirstDevice 이거 돌릴때마다 변경 12_1102 17:37 kku +// if not SameDateTime(pEntry.dtLastSeen, aEnt.dtLastSeen) then +// Include(Result, csLastSeen); + if not SameDateTime(pEntry.dtLastUsed, aEnt.dtLastUsed) then + Include(Result, csLastUsed); + pEntry^ := aEnt^; + end else begin + New(pEntry); + pEntry^ := aEnt^; + Lock; + try + DcBTDevice_.Add(pEntry.sAddress, pEntry); + finally + Unlock; + end; + Include(Result, csDetection); +// if pEntry.dInfo.fConnected then +// Include(Result, csConnected); +// if pEntry.dInfo.fRemembered then +// Include(Result, csRemembered); +// if pEntry.dInfo.fAuthenticated then +// Include(Result, csAuthenticated); + end; +end; + +procedure TThdBtDevNotify.Execute; +var + i: Integer; + dwPvTick: DWORD; +begin + dwPvTick := 0; + while not Terminated and not GetWorkStop do + begin + if BTDevice_.RefreshBTDevice(@bWorkStop_) then + for i := 0 to BTDevice_.Count - 1 do + begin + if bWorkStop_ then + break; + + pBTEntry_ := BTDevice_[i]; + + csBT_ := GetBTDeviceState(pBTEntry_); + if csBT_ <> [] then + begin + if bSync_ then + Synchronize(ProcessBTDeviceNotify) + else + ProcessBTDeviceNotify; + end; + end + else Sleep(1000); + + if bPreventBtDevs_ then + begin + bPreventBtDevs_ := false; + SetBtDevsEnable(false); + dwPvTick := GetTickCount; + end; + + if (dwPvTick <> 0) and ((GetTickCount - dwPvTick) >= 4000) then + begin + dwPvTick := 0; + SetBtDevsEnable(true); + end; + + Sleep(1000); + end; +end; + +// 디바이스 타입 구하기 = 개노가닥 2010-12-16 kku +// 참고 : http://slexy.org/view/s2vpOPLzA7 +procedure BtDevTypeToStr(dwClassOfDevice: DWORD; var sMajor, sMinor: String); +var + ucMajor, + ucMinor: BYTE; +begin + ucMajor := BYTE((dwClassOfDevice and $0000FF00) shr 8); + ucMinor := BYTE(dwClassOfDevice and $000000FF); + + case ucMajor of + BT_DEVICE_CLASS_MISC : sMajor := 'Misc'; + BT_DEVICE_CLASS_COMPUTER : sMajor := 'Computer'; + BT_DEVICE_CLASS_PHONE : sMajor := 'Phone'; + BT_DEVICE_CLASS_LANACCESSPOINT : sMajor := 'LanAccessPoint'; + BT_DEVICE_CLASS_AV : sMajor := 'Audio/Video'; + BT_DEVICE_CLASS_PERIPHERAL : sMajor := 'Peripheral'; + BT_DEVICE_CLASS_IMAGING : sMajor := 'Imaging'; + BT_DEVICE_CLASS_UNCLASSIFIED : sMajor := 'Unclassified'; + end; + + case (ucMajor and $0F) of + 0 : sMinor := 'None'; + 1 : + case ((ucMinor and $0F) shr 2) of + 0 : sMinor := 'Uncategorised'; + 1 : sMinor := 'Desktop'; + 2 : sMinor := 'Server'; + 3 : sMinor := 'Laptop'; + 4 : sMinor := 'Handheld'; + 5 : sMinor := 'Palm'; + 6 : sMinor := 'Wearable'; + end; + 2 : + case ((ucMinor and $0F) shr 2) of + 0 : sMinor := 'Uncategorised'; + 1 : sMinor := 'Mobile'; + 2 : sMinor := 'Cordless'; + 3 : sMinor := 'Smart phone'; + 4 : sMinor := 'Wired modem or voice gateway'; + 5 : sMinor := 'Common ISDN access'; + 6 : sMinor := 'Sim card reader'; + end; + 3 : + begin + if ((ucMinor and $0F) shr 2) = 0 then + sMinor := 'Uncategorised' + else + case (((ucMinor and $0F) shr 2) div 8) of + 0 : sMinor := 'Fully available'; + 1 : sMinor := '1-17%% available'; + 2 : sMinor := '17-33%% utilised'; + 3 : sMinor := '33-50%% utilised'; + 4 : sMinor := '50-67%% utilised'; + 5 : sMinor := '67-83%% utilised'; + 6 : sMinor := '83-99%% utilised'; + 7 : sMinor := 'No service available'; + end; + end; + 4 : + case ((ucMinor and $0F) shr 2) of + 0 : sMinor := 'Uncategorised'; + 1 : sMinor := 'Device conforms to the Headset profile'; + 2 : sMinor := 'Hands-free'; + 3 : sMinor := 'Reserved'; + 4 : sMinor := 'Microphone'; + 5 : sMinor := 'Loudspeaker'; + 6 : sMinor := 'Headphones'; + 7 : sMinor := 'Portable audio'; + 8 : sMinor := 'Car audio'; + 9 : sMinor := 'Set-top box'; + 10 : sMinor := 'HiFi audio device'; + 11 : sMinor := 'VCR'; + 12 : sMinor := 'Video camera'; + 13 : sMinor := 'Camcorder'; + 14 : sMinor := 'Video monitor'; + 15 : sMinor := 'Video display and loudspeaker'; + 16 : sMinor := 'Video conferencing'; + 17 : sMinor := 'Reserved'; + 18 : sMinor := 'Gaming/toy'; + end; + 5 : + begin + case (((ucMinor and $0F) shr 2) and 48) of + 16 : sMinor := 'Keyboard'; + 32 : sMinor := 'Pointing device'; + 48 : + begin + sMinor := 'Combo keyboard/pointing device'; + sMinor := sMinor + ' - '; + + case (((ucMinor and $0F) shr 2) and 15) of + 1 : sMinor := sMinor + 'Joystick'; + 2 : sMinor := sMinor + 'Gamepad'; + 3 : sMinor := sMinor + 'Remote control'; + 4 : sMinor := sMinor + 'Sensing device'; + 5 : sMinor := sMinor + 'Digitiser tablet'; + 6 : sMinor := sMinor + 'Card reader'; + else + sMinor := sMinor + 'Reserved'; + end; + end; + end; + end; + 6 : + if (((ucMinor and $0F) shr 2) and 4) <> 0 then + sMinor := 'Display' + else if (((ucMinor and $0F) shr 2) and 8) <> 0 then + sMinor := 'Camera' + else if (((ucMinor and $0F) shr 2) and 16) <> 0 then + sMinor := 'Scanner' + else if (((ucMinor and $0F) shr 2) and 32) <> 0 then + sMinor := 'Printer'; + 7 : + case ((ucMinor and $0F) shr 2) of + 1 : sMinor := 'Wrist watch'; + 2 : sMinor := 'Pager'; + 3 : sMinor := 'Jacket'; + 4 : sMinor := 'Helmet'; + 5 : sMinor := 'Glasses'; + end; + 8 : + case ((ucMinor and $0F) shr 2) of + 1 : sMinor := 'Robot'; + 2 : sMinor := 'Vehicle'; + 3 : sMinor := 'Doll/action figure'; + 4 : sMinor := 'Controller'; + 5 : sMinor := 'Game'; + end; + end; + + if sMinor = '' then + sMinor := 'None'; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Capture.pas b/Tocsg.Lib/VCL/Tocsg.Capture.pas new file mode 100644 index 00000000..48402b53 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Capture.pas @@ -0,0 +1,454 @@ +{*******************************************************} +{ } +{ Tocsg.Capture } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.Capture; + +interface + +uses + System.SysUtils, Vcl.Graphics, Vcl.Imaging.jpeg, Winapi.Windows, + System.Classes; + +type + TJPEGDataHelper = class helper for Vcl.Imaging.jpeg.TJPEGData + public + function GetJpgDataStream: TStream; + end; + + TJPEGImageHelper = class helper for Vcl.Imaging.jpeg.TJPEGImage + public + function GetJpgStream: TStream; + end; + +function CaptureDesktopAsJPEG: TJPEGImage; +function CaptureDesktopAsJpegStream(aStream: TStream): Boolean; +function CaptureDesktopAsJpegFile(sPath: String): Boolean; +function CaptureDesktopAsBITMAP: Vcl.Graphics.TBitmap; +function CaptureWindowAsJPEG(hWindow: HWND): TJPEGImage; +function CaptureWindowAsJpegFile(hWindow: HWND; sPath: String): Boolean; +function CaptureWindowAsBitmap(hWindow: HWND; pxFormat: TPixelFormat = pf24bit): Vcl.Graphics.TBitmap; +function CaptureWindowClientAsJPEG(hWindow: HWND): TJPEGImage; + +implementation + +uses + Tocsg.Safe, Tocsg.Exception, Vcl.Forms, Winapi.DwmApi; + +const + CaptureBlt = $40000000; + +{ TJPEGDataHelper } + +function TJPEGDataHelper.GetJpgDataStream: TStream; +begin + with Self do + Result := FData; +end; + +{ TJPEGImageHelper } + +function TJPEGImageHelper.GetJpgStream: TStream; +begin +// TJPEGImage.SaveToStream() 참조 + with Self do + begin + JPEGNeeded; + if TJPEGData(FImage) <> nil then + Result := TJPEGData(FImage).GetJpgDataStream + else + Result := nil; + end; +end; + +function CaptureDesktopAsJPEG: TJPEGImage; +var + DC: HDC; + BM: Vcl.Graphics.TBitmap; + nLeft, nTop, + nWidth, nHeight: Integer; +begin + DC := 0; + BM := nil; + Result := nil; + + try + // GetDC에서 CreateDC로 변경 + DC := CreateDC('Display', nil, nil, nil); +// DC := GetDC(0); + if DC <> 0 then + begin + try + nLeft := GetSystemMetrics(SM_XVIRTUALSCREEN); + nTop := GetSystemMetrics(SM_YVIRTUALSCREEN); + + nWidth := GetSystemMetrics(SM_CXVIRTUALSCREEN); + nHeight := GetSystemMetrics(SM_CYVIRTUALSCREEN); + + // nWidth := GetDeviceCaps(DC, HORZRES); + // nHeight := GetDeviceCaps(DC, VERTRES); + +// Guard(BM, Vcl.Graphics.TBitmap.Create); +// BM.Width := nWidth; +// BM.Height := nHeight; +// +// if BitBlt(BM.Canvas.Handle, +// 0, +// 0, +// nWidth, +// nHeight, +// DC, +// nLeft, +// nTop, +// SRCCOPY) then +// begin +// Result := TJPEGImage.Create; +// Result.Assign(BM); +// end; + + BM := Vcl.Graphics.TBitmap.Create; + BM.Width := nWidth; + BM.Height := nHeight; + + if BitBlt(BM.Canvas.Handle, + 0, + 0, + nWidth, + nHeight, + DC, + nLeft, + nTop, + SRCCOPY + CaptureBlt) then // CaptureBlt 추가, 윈도우 7 이하 투명 효과된 윈도우 캡쳐지원 + begin + Result := TJPEGImage.Create; + Result.Assign(BM); + end; + finally + if DC <> 0 then + DeleteDC(DC); +// ReleaseDC(0, DC); + if BM <> nil then // + FreeAndNil(BM); // + end; + end; + except + on E: Exception do + begin +// ETgException.TraceException(E, Format('Fail .. CaptureDesktopAsJPEG(), sStep = %s', [sStep])); + ETgException.TraceException(E, 'Fail .. CaptureDesktopAsJPEG()'); + Result := nil; + exit; + end; + end; +end; + +function CaptureDesktopAsJpegStream(aStream: TStream): Boolean; +var + DC: HDC; + BM: Vcl.Graphics.TBitmap; + jpg: TJPEGImage; + nLeft, nTop, + nWidth, nHeight: Integer; +begin + Result := false; + DC := 0; + BM := nil; + jpg := nil; + + try + try + // GetDC에서 CreateDC로 변경 + DC := CreateDC('Display', nil, nil, nil); +// DC := GetDC(0); +// DC := GetDC(GetDesktopWindow); + if DC <> 0 then + begin + // 듀얼도 전체 캡쳐되도록 변경 + nLeft := GetSystemMetrics(SM_XVIRTUALSCREEN); + nTop := GetSystemMetrics(SM_YVIRTUALSCREEN); + + nWidth := GetSystemMetrics(SM_CXVIRTUALSCREEN); + nHeight := GetSystemMetrics(SM_CYVIRTUALSCREEN); + + BM := Vcl.Graphics.TBitmap.Create; + BM.Width := nWidth; + BM.Height := nHeight; + + if BitBlt(BM.Canvas.Handle, + 0, + 0, + nWidth, + nHeight, + DC, + nLeft, + nTop, + SRCCOPY + CaptureBlt) then // CaptureBlt 추가, 윈도우 7 이하 투명 효과된 윈도우 캡쳐지원 + begin + DeleteDC(DC); +// ReleaseDC(0, DC); + DC := 0; + + jpg := TJPEGImage.Create; + jpg.Assign(BM); + FreeAndNil(BM); + + jpg.SaveToStream(aStream); + Result := true; + end; + end; + except + on E: Exception do + begin +// ETgException.TraceException(E, 'Fail .. CaptureDesktopAsJpegStream()'); + ETgException.TraceException(E, Format('Fail .. CaptureDesktopAsJpegStream(), Left = %d, Top = %d, Width = %d, Height = %d', + [nLeft, nTop, nWidth, nHeight])); + exit; + end; + end; + finally + if jpg <> nil then + FreeAndNil(jpg); + if BM <> nil then // + FreeAndNil(BM); // + if DC <> 0 then + DeleteDC(DC); +// ReleaseDC(0, DC); + end; +end; + +function CaptureDesktopAsJpegFile(sPath: String): Boolean; +var + fs: TFileStream; +begin + try + Guard(fs, TFileStream.Create(sPath, fmCreate)); + Result := CaptureDesktopAsJpegStream(fs); + except + Result := false; + end; +end; + +function CaptureDesktopAsBITMAP: Vcl.Graphics.TBitmap; +var + DC: HDC; + nLeft, nTop, + nWidth, nHeight: Integer; +begin + DC := 0; + Result := nil; + + try + // GetDC에서 CreateDC로 변경 + DC := CreateDC('Display', nil, nil, nil); +// DC := GetDC(0); + if DC <> 0 then + begin + try + nLeft := GetSystemMetrics(SM_XVIRTUALSCREEN); + nTop := GetSystemMetrics(SM_YVIRTUALSCREEN); + + nWidth := GetSystemMetrics(SM_CXVIRTUALSCREEN); + nHeight := GetSystemMetrics(SM_CYVIRTUALSCREEN); + + Result := Vcl.Graphics.TBitmap.Create; + Result.Width := nWidth; + Result.Height := nHeight; + + if not BitBlt(Result.Canvas.Handle, + 0, + 0, + nWidth, + nHeight, + DC, + nLeft, + nTop, + SRCCOPY + CaptureBlt) then // CaptureBlt 추가, 윈도우 7 이하 투명 효과된 윈도우 캡쳐지원 + begin + FreeAndNil(Result); + end; + finally + if DC <> 0 then + DeleteDC(DC); +// ReleaseDC(0, DC); + end; + end; + except + on E: Exception do + begin + ETgException.TraceException(E, 'Fail .. CaptureDesktopAsBMP()'); + Result := nil; + exit; + end; + end; +end; + +function CaptureWindowAsJPEG(hWindow: HWND): TJPEGImage; +var + DC: HDC; + RT: TRect; + BM: Vcl.Graphics.TBitmap; + bGetWindRect: Boolean; +begin + Result := nil; + +// GetDC에서 CreateDC로 변경 + DC := CreateDC('Display', nil, nil, nil); +// DC := GetDC(hWindow); + if DC <> 0 then + begin + ZeroMemory(@RT, SizeOf(TRect)); + + // 기존 GetWindowRect()으로 창 크기를 가져오면 창테두리가 플랫하지 않고, + // 무엇보다 Scale이 100% 이상일 경우 창 크기와 위치가 밀리는 문제가 있다. + // 그래서 아래처럼 보완. DwmGetWindowAttribute()은 비스타, 서버 2008 이상만 지원함 + bGetWindRect := DwmGetWindowAttribute(hWindow, DWMWA_EXTENDED_FRAME_BOUNDS, @RT, SizeOf(RT)) = S_OK; + if not bGetWindRect then + bGetWindRect := GetWindowRect(hWindow, RT); + + if bGetWindRect then + begin + try + Guard(BM, Vcl.Graphics.TBitmap.Create); + BM.Width := RT.Width; + BM.Height := RT.Height; + + if BitBlt(BM.Canvas.Handle, + 0, + 0, + RT.Width, + RT.Height, + DC, + RT.Left, + RT.Top, + SRCCOPY + CaptureBlt) then // CaptureBlt 추가, 윈도우 7 이하 투명 효과된 윈도우 캡쳐지원 + begin + if (BM.Width + BM.Height) > 0 then + begin + Result := TJPEGImage.Create; + Result.Assign(BM); + end; + end; + except + Result := nil; + exit; + end; + end; + DeleteDC(DC); +// ReleaseDC(0, DC); + end; +end; + +function CaptureWindowAsJpegFile(hWindow: HWND; sPath: String): Boolean; +var + jpg: TJPEGImage; +begin + jpg := CaptureWindowAsJPEG(hWindow); + if jpg <> nil then + begin + Result := true; + jpg.SaveToFile(sPath); + jpg.Free; + end; +end; + +function CaptureWindowAsBitmap(hWindow: HWND; pxFormat: TPixelFormat = pf24bit): Vcl.Graphics.TBitmap; +var + DC: HDC; + RT: TRect; + bGetWindRect: Boolean; +begin + Result := nil; + +// GetDC에서 CreateDC로 변경 + DC := CreateDC('Display', nil, nil, nil); +// DC := GetDC(0); + if DC <> 0 then + begin + ZeroMemory(@RT, SizeOf(TRect)); + + // 기존 GetWindowRect()으로 창 크기를 가져오면 창테두리가 플랫하지 않고, + // 무엇보다 Scale이 100% 이상일 경우 창 크기와 위치가 밀리는 문제가 있다. + // 그래서 아래처럼 보완. DwmGetWindowAttribute()은 비스타, 서버 2008 이상만 지원함 + bGetWindRect := DwmGetWindowAttribute(hWindow, DWMWA_EXTENDED_FRAME_BOUNDS, @RT, SizeOf(RT)) = S_OK; + if not bGetWindRect then + bGetWindRect := GetWindowRect(hWindow, RT); + + if bGetWindRect then + begin + try + Result := Vcl.Graphics.TBitmap.Create; + Result.Width := RT.Width; + Result.Height := RT.Height; + Result.PixelFormat := pxFormat; + + if not BitBlt(Result.Canvas.Handle, + 0, + 0, + RT.Width, + RT.Height, + DC, + RT.Left, + RT.Top, + SRCCOPY + CaptureBlt) then // CaptureBlt 추가, 윈도우 7 이하 투명 효과된 윈도우 캡쳐지원 + begin + FreeAndNil(Result); + end; + except + Result := nil; + exit; + end; + end; + DeleteDC(DC); +// ReleaseDC(0, DC); + end; +end; + +function CaptureWindowClientAsJPEG(hWindow: HWND): TJPEGImage; +var + DC: HDC; + RT: TRect; + BM: Vcl.Graphics.TBitmap; +begin + Result := nil; + +// GetDC에서 CreateDC로 변경 + DC := CreateDC('Display', nil, nil, nil); +// DC := GetDC(hWindow); + if DC <> 0 then + begin + ZeroMemory(@RT, SizeOf(TRect)); + if GetClientRect(hWindow, RT) then + begin + try + Guard(BM, Vcl.Graphics.TBitmap.Create); + BM.Width := RT.Width; + BM.Height := RT.Height; + + if BitBlt(BM.Canvas.Handle, + 0, + 0, + RT.Width, + RT.Height, + DC, + RT.Left, + RT.Top, + SRCCOPY + CaptureBlt) then // CaptureBlt 추가, 윈도우 7 이하 투명 효과된 윈도우 캡쳐지원 + begin + Result := TJPEGImage.Create; + Result.Assign(BM); + end; + except + Result := nil; + exit; + end; + end; + DeleteDC(DC); +// ReleaseDC(0, DC); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Cert.pas b/Tocsg.Lib/VCL/Tocsg.Cert.pas new file mode 100644 index 00000000..181457a8 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Cert.pas @@ -0,0 +1,163 @@ +{*******************************************************} +{ } +{ Tocsg.Cert } +{ } +{ Copyright (C) 2025 kku } +{ } +{*******************************************************} + +unit Tocsg.Cert; + +interface + +uses + Winapi.Windows; + +//const +// CERT_QUERY_OBJECT_FILE = $00000001; +// CERT_QUERY_CONTENT_FLAG_PKCS7_SIGNED_EMBED = $00000020; +// CERT_QUERY_FORMAT_FLAG_BINARY = $00000002; +// CMSG_SIGNER_INFO_PARAM = 6; +// CERT_NAME_SIMPLE_DISPLAY_TYPE = 4; +// CERT_X500_NAME_STR = 3; +// CERT_FIND_SUBJECT_CERT = $0000000B; +// +// X509_ASN_ENCODING = $00000001; // X.509 인증서 인코딩 +// PKCS_7_ASN_ENCODING = $00010000; // PKCS#7 서명 인코딩 +// ENCODING_TYPE = (X509_ASN_ENCODING or PKCS_7_ASN_ENCODING); +// +//type +// HCERTSTORE = Pointer; +// HCRYPTMSG = Pointer; +// PCCERT_CONTEXT = ^CERT_CONTEXT; +// +//function CryptQueryObject(dwObjectType: DWORD; pvObject: PChar; +// dwExpectedContentTypeFlags, dwExpectedFormatTypeFlags: DWORD; +// dwFlags: DWORD; var pdwMsgAndCertEncodingType, pdwContentType, +// pdwFormatType: DWORD; var phCertStore: HCERTSTORE; +// var phMsg: HCRYPTMSG; ppvContext: Pointer): BOOL; stdcall; +// external 'Crypt32.dll'; +// +//function CryptMsgGetParam(hCryptMsg: HCRYPTMSG; dwParamType, dwIndex: DWORD; +// pvData: Pointer; var pcbData: DWORD): BOOL; stdcall; +// external 'Crypt32.dll'; +// +//function CertNameToStr(dwCertEncodingType: DWORD; pName: PCERT_NAME_BLOB; +// dwStrType: DWORD; psz: PChar; csz: DWORD): DWORD; stdcall; +// external 'Crypt32.dll' name 'CertNameToStrW'; +// +//function CertFindCertificateInStore(hCertStore: HCERTSTORE; +// dwCertEncodingType: DWORD; dwFindFlags: DWORD; +// dwFindType: DWORD; pvFindPara: Pointer; +// pPrevCertContext: PCCERT_CONTEXT): PCCERT_CONTEXT; stdcall; +// external 'Crypt32.dll'; +// +//function CertFreeCertificateContext(pCertContext: PCCERT_CONTEXT): BOOL; stdcall; +// external 'Crypt32.dll'; +// +//function CertCloseStore(hCertStore: HCERTSTORE; dwFlags: DWORD): BOOL; stdcall; +// external 'Crypt32.dll'; +// +//function CryptMsgClose(hCryptMsg: HCRYPTMSG): BOOL; stdcall; +// external 'Crypt32.dll'; + +function IsFileSigned(const FileName: string): Boolean; + +implementation + +function IsFileSigned(const FileName: string): Boolean; +var + WinTrustData: WINTRUST_DATA; + WinTrustFileInfo: WINTRUST_FILE_INFO; + GuidAction: TGUID; +begin + Result := False; + // GUID 설정 (WINTRUST_ACTION_GENERIC_VERIFY_V2) + GuidAction := WINTRUST_ACTION_GENERIC_VERIFY_V2; + // WINTRUST_FILE_INFO 초기화 + ZeroMemory(@WinTrustFileInfo, SizeOf(WinTrustFileInfo)); + WinTrustFileInfo.cbStruct := SizeOf(WinTrustFileInfo); + WinTrustFileInfo.pcwszFilePath := PWideChar(WideString(FileName)); + WinTrustFileInfo.hFile := 0; + WinTrustFileInfo.pgKnownSubject := nil; + // WINTRUST_DATA 초기화 + ZeroMemory(@WinTrustData, SizeOf(WinTrustData)); + WinTrustData.cbStruct := SizeOf(WinTrustData); + WinTrustData.dwUIChoice := WTD_UI_NONE; // UI 없음 + WinTrustData.fdwRevocationChecks := WTD_REVOKE_NONE; // 인증서 폐기 목록(CRL) 체크 안 함 + WinTrustData.dwUnionChoice := WTD_CHOICE_FILE; // 파일 검사 + WinTrustData.pFile := @WinTrustFileInfo; // 검사할 파일 정보 + WinTrustData.dwStateAction := 0; + WinTrustData.hWVTStateData := 0; + WinTrustData.pwszURLReference := nil; + WinTrustData.dwProvFlags := WTD_SAFER_FLAG; + // 서명 확인 + Result := WinVerifyTrust(0, GuidAction, @WinTrustData) = ERROR_SUCCESS; +end; + +//function GetCertificateInfo(const FileName: string): string; +//var +// hFile: THandle; +// hFileMapping: THandle; +// pbFile: Pointer; +// hStore: HCERTSTORE; +// hMsg: HCRYPTMSG; +// CertContext: PCCERT_CONTEXT; +// Encoding, ContentType, FormatType: DWORD; +// SignerInfo: PCMSG_SIGNER_INFO; +// dwSignerInfo: DWORD; +// IssuerName, SubjectName: array[0..1023] of Char; +//begin +// Result := '서명 정보 없음'; +// +// // 파일 열기 +// if not CryptQueryObject(CERT_QUERY_OBJECT_FILE, PChar(FileName), +// CERT_QUERY_CONTENT_FLAG_PKCS7_SIGNED_EMBED, +// CERT_QUERY_FORMAT_FLAG_BINARY, 0, Encoding, +// ContentType, FormatType, hStore, hMsg, nil) then +// begin +// Exit; +// end; +// +// // 서명자 정보 크기 확인 +// if not CryptMsgGetParam(hMsg, CMSG_SIGNER_INFO_PARAM, 0, nil, dwSignerInfo) then +// begin +// Exit; +// end; +// +// // 서명자 정보 가져오기 +// GetMem(SignerInfo, dwSignerInfo); +// try +// if not CryptMsgGetParam(hMsg, CMSG_SIGNER_INFO_PARAM, 0, SignerInfo, dwSignerInfo) then +// begin +// Exit; +// end; +// +// // 인증서 찾기 +// CertContext := CertFindCertificateInStore(hStore, ENCODING_TYPE, +// 0, CERT_FIND_SUBJECT_CERT, @SignerInfo^.Issuer, nil); +// +// if Assigned(CertContext) then +// begin +// // 발급자 정보 +// CertNameToStr(CERT_X500_NAME_STR, @CertContext^.pCertInfo^.Issuer, +// CERT_NAME_SIMPLE_DISPLAY_TYPE, IssuerName, SizeOf(IssuerName)); +// +// // 서명자 정보 +// CertNameToStr(CERT_X500_NAME_STR, @CertContext^.pCertInfo^.Subject, +// CERT_NAME_SIMPLE_DISPLAY_TYPE, SubjectName, SizeOf(SubjectName)); +// +// Result := Format('발급자: %s' + sLineBreak + '서명자: %s', [IssuerName, SubjectName]); +// end; +// finally +// FreeMem(SignerInfo); +// if Assigned(CertContext) then +// CertFreeCertificateContext(CertContext); +// if hStore <> nil then +// CertCloseStore(hStore, 0); +// if hMsg <> nil then +// CryptMsgClose(hMsg); +// end; +//end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Clipboard.pas b/Tocsg.Lib/VCL/Tocsg.Clipboard.pas new file mode 100644 index 00000000..790b03c0 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Clipboard.pas @@ -0,0 +1,635 @@ +{*******************************************************} +{ } +{ Tocsg.Clipboard } +{ } +{ Copyright (C) 2019 kku } +{ } +{*******************************************************} +unit Tocsg.Clipboard; + +// 잠깐 만들던건.. 여기 Tocsg.Clipboard_Old +interface + +uses + System.SysUtils, Vcl.Clipbrd, Winapi.Windows, Winapi.Messages, System.Classes; + +//const +// arrCbImgFormat: array [0..26] of DWORD = ( +// CF_DIB, CF_DIBV5, CF_BITMAP, +// // 윈도우 기본 캡쳐 시 사용되는 이미지 포맷 25_0306 16:31:21 kku +// 491661, 49350, 50384, 50209, 48171, +// // 엑셀 셀 복사 시 사용하는 이미지 포맷 +// 16, +// // 엑셀, 파워포인트에서 사용하는 이미지 포맷 +// 49718, +// // 파워포인트에서 사용하는 이미지 포맷 +// 50706, 49350, 49523, 49161, 50707, 49348, +// 49171, 49431, 50703, 49436, 50152, 49166, +// 49349, 49935, 49360, 49298, 14 +// ); + +// 클립보드 수행시 뜨는 포맷 목록들 +//Text +//Debug Output: OnDrawClipboard() - FormatCount : 4 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(0) : 13 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(1) : 16 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(2) : 1 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(3) : 7 Process kku Assister.exe (4708) +//Capture +//Debug Output: OnDrawClipboard() - FormatCount : 3 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(0) : 2 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(1) : 8 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(2) : 17 Process kku Assister.exe (4708) +//File +//Debug Output: OnDrawClipboard() - FormatCount : 11 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(0) : 49161 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(1) : 49359 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(2) : 50043 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(3) : 50044 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(4) : 49439 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(5) : 49414 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(6) : 49463 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(7) : 15 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(8) : 49158 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(9) : 49159 Process kku Assister.exe (4708) +//Debug Output: OnDrawClipboard() - Format(10) : 49171 Process kku Assister.exe (4708) +type +// AllocateHWnd사용으로 thread에서 사용주의 + TDrawClipboard = class; + TNotifyClipboard = procedure(Sender: TDrawClipboard) of object; + TDrawClipboard = class(TClipboard) + private + hWnd_: HWND; + hNextCBWnd_, + hAllocHWND_: HWND; + bReseting_: Boolean; + procedure WndProc(var msg: TMessage); override; + protected + evDrawCB_: TNotifyClipboard; + procedure SetDrawCBEvent(evDrawCB: TNotifyClipboard); + procedure process_WM_CHANGECBCHAIN(var msg: TMessage); + procedure process_WM_DRAWCLIPBOARD(var msg: TMessage); +// procedure process_WM_CLIPBOARDUPDATE(var msg: TMessage); + public + Constructor Create(h: HWND = 0); + Destructor Destroy; override; + procedure Stop; + procedure Reset; + + property OnDrawClipboard: TNotifyClipboard read evDrawCB_ write SetDrawCBEvent; + property NextCBWnd: HWND read hNextCBWnd_ write hNextCBWnd_; + end; + + TClipboardHelper = class helper for TClipboard + public + function GetSize: Integer; + end; + + +function CopyToClipboard(const S: String; bDoClear: Boolean): Boolean; +function ClearClipboard(bImageOnly: Boolean = false): Boolean; +function OpenCloseClipboardTest: Boolean; +function IsClipboardEmpty: Boolean; +function GetClipboardSize: Integer; +function GetClipboardHandles: String; + +var + CF_HTML: DWORD; + CF_BS1Empty: DWORD; +{ +Clipboard has 8 Formats. +49161 = DataObject +49268 = Shell IDList Array +15 = CF_hDrop +49158 = FileName +49159 = FileNameW +49389 = Preferred DropEffect +49380 = Shell Object Offsets +49171 = Ole Private Data +} +implementation +uses + Vcl.Forms, Tocsg.Exception, Tocsg.Trace, Tocsg.Safe, Vcl.Graphics, + System.Generics.Collections, Tocsg.Strings; + +{ TDrawClipboard } + +Constructor TDrawClipboard.Create(h: HWND = 0); +begin + Inherited Create; + hWnd_ := h; + bReseting_ := false; + + hAllocHWND_ := 0; + Reset; +// hAllocHWND_ := AllocateHWnd(WndProc); +// ASSERT(AddClipboardFormatListener(hAllocHWND_) = true); +end; + +Destructor TDrawClipboard.Destroy; +begin + Stop; +// RemoveClipboardFormatListener(hAllocHWND_); +// DeallocateHWnd(hAllocHWND_); +// hAllocHWND_ := 0; + Inherited; +end; + +procedure TDrawClipboard.Stop; +begin + if hAllocHWND_ <> 0 then + begin + if hNextCBWnd_ <> 0 then + begin + ChangeClipboardChain(hAllocHWND_, hNextCBWnd_); + hNextCBWnd_ := 0; + end; + DeallocateHWnd(hAllocHWND_); + hAllocHWND_ := 0; + end else + if hWnd_ <> 0 then + begin + if hNextCBWnd_ <> 0 then + begin + ChangeClipboardChain(hWnd_, hNextCBWnd_); + hNextCBWnd_ := 0; + end; + end; +end; + +procedure TDrawClipboard.Reset; +begin +// bReseting_ := true; // 초기화 할때 재감지 되도록 다시 롤백 24_0716 18:06:45 kku + try + Stop; + if hWnd_ <> 0 then + begin + hNextCBWnd_ := SetClipboardViewer(hWnd_); + end else begin + hAllocHWND_ := AllocateHWnd(WndProc); + hNextCBWnd_ := SetClipboardViewer(hAllocHWND_); + end; + finally + bReseting_ := false; + end; +end; + +procedure TDrawClipboard.SetDrawCBEvent(evDrawCB: TNotifyClipboard); +begin + if @evDrawCB_ <> @evDrawCB then + evDrawCB_ := evDrawCB; +end; + +procedure TDrawClipboard.WndProc(var msg: TMessage); +begin + case msg.Msg of + WM_CHANGECBCHAIN : process_WM_CHANGECBCHAIN(msg); + WM_DRAWCLIPBOARD : process_WM_DRAWCLIPBOARD(msg); +// WM_CLIPBOARDUPDATE : process_WM_CLIPBOARDUPDATE(msg); + else + msg.Result := DefWindowProc(hAllocHWND_, msg.Msg, msg.WParam, msg.LParam); + end; +end; + +procedure TDrawClipboard.process_WM_CHANGECBCHAIN(var msg: TMessage); +begin + with TWMChangeCBChain(msg) do + begin + if (Remove = hNextCBWnd_) then + hNextCBWnd_ := Next + else if hNextCBWnd_ <> 0 then + SendMessage(hNextCBWnd_, WM_CHANGECBCHAIN, Remove, Next); + end; +end; + +procedure TDrawClipboard.process_WM_DRAWCLIPBOARD(var msg: TMessage); +begin + if bReseting_ then + exit; + +// msg as TWMDrawClipboard + if Assigned(evDrawCB_) then + evDrawCB_(Self); + if hNextCBWnd_ <> 0 then + SendMessage(hNextCBWnd_, msg.Msg, msg.WParam, msg.LParam); +// SendMessage(hNextCBWnd_, WM_DRAWCLIPBOARD, 0, 0); +end; + +//procedure TDrawClipboard.process_WM_CLIPBOARDUPDATE(var msg: TMessage); +//begin +// if Assigned(evDrawCB_) then +// evDrawCB_(Self); +//end; + +{ +// 클립보드에 CF_HTML 형태로 입력 +// _____________________________________________________________________________ +procedure SetClipBoardHTML(s: String); +const + START_FRAGMENT='<!--StartFragment-->'; + END_FRAGMENT ='<!--EndFragment-->'; +var + gMem: HGLOBAL; + pBytes: PByteArray; + i: Integer; + tmpStr: String; + LBuffer: TBytes; +begin + // HTML Format에 맞게 세팅 + tmpStr:='Version:1.0'+#13#10; + tmpStr:=tmpStr+'StartHTML:~~~~~~~~'+#13#10; + tmpStr:=tmpStr+'EndHTML:########'+#13#10; + tmpStr:=tmpStr+'StartFragment:~~~~~~~~'+#13#10; + tmpStr:=tmpStr+'EndFragment:########'+#13#10; + tmpStr:=tmpStr+'<html><body>'+#13#10; + tmpStr:=tmpStr+'<!--StartFragment-->'+s+'<!--EndFragment-->'+#13#10; + tmpStr:=StringReplace(tmpStr, '~~~~~~~~', Format('%.08d', [Pos('<html', tmpStr)-1]), [rfReplaceAll]); + tmpStr:=StringReplace(tmpStr, '########', Format('%.08d', [Pos(END_FRAGMENT, tmpStr)+Length(END_FRAGMENT)]), [rfReplaceAll]); + // 버퍼에 복사 + SetLength(LBuffer, Length(tmpStr)+1); + for i:=0 to Length(tmpStr) do LBuffer[i]:=Byte(tmpStr[i+1]); + // 클립보드용 버퍼에 복사 + gMem:=GlobalAlloc(GHND, Length(LBuffer)*2); + pBytes:=GlobalLock(gMem); + try + for i:=0 to Length(LBuffer)+1 do pBytes[i]:=LBuffer[i]; + finally + GlobalUnlock(gMem); + end; + // 클립보드에 쓰기 + OpenClipBoard(0); + EmptyClipBoard; + SetClipBoardData(RegisterClipBoardFormat('HTML Format'), gMem); + CloseClipBoard; +end; +// 클립보드의 CF_HTML 포맷데이터 가져오기 +// _____________________________________________________________________________ +function GetClipBoardHTML: String; +var + gMem: HGLOBAL; + pBytes: PByteArray; + lenBuffer: DWORD; + i: Integer; + CF_HTML: UINT; +begin + Result:=''; + // CF_HTML 등록 + CF_HTML:=RegisterClipboardFormat('HTML Format'); + // 클립보드를 열어 CF_HTML 데이터가 있으면 읽어와서 반환 + OpenClipBoard(0); + if ClipBoard.HasFormat(CF_HTML) then begin + gMem:=GetClipboardData(CF_HTML); + pBytes:=GlobalLock(gMem); + try + lenBuffer:=Length(PChar(pBytes))*2; + SetLength(Result, lenBuffer); + for i:=0 to lenBuffer do Result[i+1]:=Chr(pBytes[i]); + Result:=TEncoding.UTF8.GetString(TBytes(pBytes), 0, lenBuffer); + finally + GlobalUnlock(gMem); + end; + end; + CloseClipBoard; +end; +} + +{ TClipboardHelper } + +const +{$IF DEFINED(UNICODE)} + CTextFormat = CF_UNICODETEXT; +{$ELSE} + CTextFormat = CF_TEXT; +{$ENDIF} + +function TClipboardHelper.GetSize: Integer; +var + Data: THandle; +begin + Result := 0; + try + Open; + Data := GetClipboardData(CTextFormat); + try + if Data <> 0 then + Result := GlobalSize(Data); + finally + if Data <> 0 then + GlobalUnlock(Data); + Close; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. GetSize()'); + end; +end; + +{ Function } + +function OpenAndClearClipboard: Boolean; +begin + Result := OpenClipboard(0); + if Result then + EmptyClipboard; +end; + +function CopyToClipboard(const S: String; bDoClear: Boolean): Boolean; +var + nDataSize, nBufferSize: Integer; + hData: HGLOBAL; + pData: Pointer; +begin + nDataSize := Length(S) * 2; + if nDataSize > 0 then + begin + if bDoClear then + begin + if not OpenAndClearClipboard then + begin + Result := false; + exit; + end; + end; + nBufferSize := nDataSize + 2; + hData := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE, nBufferSize); + if hData <> 0 then + begin + pData := GlobalLock(hData); + if pData <> nil then + begin + Move(S[1], pData^, nBufferSize); + GlobalUnlock(hData); + SetClipboardData(CF_UNICODETEXT, hData); + end; + end; + if bDoClear then + CloseClipboard; + end; + Result := True; +end; + +procedure RemoveClipboardImageFormat; +type + PCbEnt = ^TCbEnt; + TCbEnt = record + uType: UINT; + pData: Pointer; + nSize: Integer; + end; +var + uFormat: UINT; + CbTxtFmtList: TList<PCbEnt>; // 해제 필요 + pEnt: PCbEnt; + hData: THandle; + hCopy: THandle; + pData: Pointer; + i: Integer; +begin + CbTxtFmtList := TList<PCbEnt>.Create; + try + uFormat := EnumClipboardFormats(0); + while uFormat <> 0 do + begin + case uFormat of + CF_TEXT, + CF_OEMTEXT, + CF_UNICODETEXT : ; + else begin + if uFormat <> CF_HTML then + begin + uFormat := EnumClipboardFormats(uFormat); + continue; + end; + end; + end; + + if (uFormat <> CF_HTML) and (uFormat > 16) then + begin + uFormat := EnumClipboardFormats(uFormat); + continue; + end; + + New(pEnt); + ZeroMemory(pEnt, SizeOf(TCbEnt)); + pEnt.uType := uFormat; + CbTxtFmtList.Add(pEnt); + uFormat := EnumClipboardFormats(uFormat); + end; + + for pEnt in CbTxtFmtList do + begin + hData := GetClipboardData(pEnt.uType); + if hData <> 0 then + begin + try + pEnt.nSize := GlobalSize(hData); + except + // 사이즈 가져올때 오류 발생 가능성 + continue; + end; + + if pEnt.nSize > 0 then + begin + pEnt.pData := AllocMem(pEnt.nSize); + pData := GlobalLock(hData); + try + Move(pData^, pEnt.pData^, pEnt.nSize); + finally + GlobalUnlock(hData); + end; + end; + end; + end; + + // 클립보드 비우기 + EmptyClipboard; + + // 기존 클립보드 데이터를 복원 + for pEnt in CbTxtFmtList do + begin + hData := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE, pEnt.nSize); + if hData <> 0 then + begin + try + pData := GlobalLock(hData); + try + CopyMemory(pData, pEnt.pData, pEnt.nSize); + finally + GlobalUnlock(hData); + end; + SetClipboardData(pEnt.uType, hData); + except + GlobalFree(hData); + end; + end; + + if pEnt.pData <> nil then + begin + FreeMem(pEnt.pData); + pEnt.pData := nil; + end; + end; + finally + FreeAndNil(CbTxtFmtList); + end; +end; + +function ClearClipboard(bImageOnly: Boolean = false): Boolean; +var + i: Integer; + hData: THandle; + pData: Pointer; +begin + Result := false; + try +// Guard(CB, TClipboard.Create); +// CB.AsText := ''; +// Result := CB.AsText = ''; +// CB.Clear + +//bImageOnly := true; + if not OpenClipboard(0) then + begin + // todo : 실패하면 재시도 할지... 25_0310 10:12:10 kku + {$IFDEF DEBUG} + TTgTrace.T('ClearClipboard() .. Fail .. OpenClipboard()'); + {$ENDIF} + exit; + end; + + try + if bImageOnly then + begin +// TTgTrace.T('ClearClipboard() .. Image'); + RemoveClipboardImageFormat; + end else begin + EmptyClipboard; + end; + + {$IFDEF _HE_} + hData := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE, 1); + if hData <> 0 then + begin + try + pData := GlobalLock(hData); + try + CopyMemory(pData, PAnsiChar(#0), 1); + SetClipboardData(CF_BS1Empty, hData); + finally + GlobalUnlock(hData); + end; + except + GlobalFree(hData); + end; + end; + {$ENDIF} + + Result := true; + finally + CloseClipboard; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ClearClipboard()'); + end; +end; + +function OpenCloseClipboardTest: Boolean; +begin + Result := false; + try + if not OpenClipboard(0) then + exit; + CloseClipboard; + Result := true; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. OpenCloseClipboardTest()'); + end; +end; + +function IsClipboardEmpty: Boolean; +var + uFormat: UINT; + i, nCnt: Integer; +begin +// 사용하지 않음. 나중에 지워도 됨 25_0310 10:11:31 kku + Result := false; + + if not OpenClipboard(0) then + exit; + + try + nCnt := 0; + while uFormat <> 0 do + begin + Inc(nCnt); + uFormat := EnumClipboardFormats(uFormat); + end; + Result := nCnt > 0; + finally + CloseClipboard; + end; +end; + +function GetClipboardSize: Integer; +var + uFormat: UINT; + hData: THandle; +begin +// 사용하지 않음. 나중에 지워도 됨 25_0310 10:11:31 kku + Result := 0; + if not OpenClipboard(0) then + exit; + try + uFormat := EnumClipboardFormats(0); + while uFormat <> 0 do + begin + hData := GetClipboardData(uFormat); + try + if hData <> 0 then + Inc(Result, GlobalSize(hData)); + except + {$IFDEF DEBUG} + TTgTrace.T('Fail .. GetClipboardSize() .. GlobalSize() .. hData = %d', [hData]); + {$ENDIF} + end; + uFormat := EnumClipboardFormats(uFormat); + end; + finally + CloseClipboard; + end; +end; + +function GetClipboardHandles: String; +var + uFormat: UINT; + hData: THandle; +begin +// 사용하지 않음. 나중에 지워도 됨 25_0310 10:11:31 kku + Result := ''; + if not OpenClipboard(0) then + begin + TTgTrace.T('Fail .. GetClipboardHandles() .. 1, Error=%d', [GetLastError]); + exit; + end; + try + uFormat := EnumClipboardFormats(0); + if uFormat = 0 then + TTgTrace.T('Fail .. GetClipboardHandles() .. 2'); + while uFormat <> 0 do + begin + hData := GetClipboardData(uFormat); + SumString(Result, IntToStr(hData), '|'); + uFormat := EnumClipboardFormats(uFormat); + end; + finally + CloseClipboard; + end; +end; + +Initialization + CF_HTML := RegisterClipboardFormat('HTML Format'); + CF_BS1Empty := RegisterClipboardFormat('BSOne CB Empty'); { Do not localize } + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.CommonData.pas b/Tocsg.Lib/VCL/Tocsg.CommonData.pas new file mode 100644 index 00000000..be336fd7 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.CommonData.pas @@ -0,0 +1,132 @@ +{*******************************************************} +{ } +{ Tocsg.CommonData } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.CommonData; + +interface + +uses + Tocsg.Obj, System.SysUtils, Winapi.Windows; + +type + TTgFileMapping<T> = class(TTgObject) + protected + hMap_: THandle; + nAllocSize_: Integer; + bFreeData_: Boolean; + public + Data: ^T; + + Constructor Create(const sMapFileName: String; const nShareSize: Integer = -1); + Destructor Destroy; override; + + function IsAvailable: Boolean; + + property AllocSize: Integer read nAllocSize_; + property LastError; + property DoFreeData: Boolean write bFreeData_; + end; + +implementation + +Constructor TTgFileMapping<T>.Create(const sMapFileName: String; const nShareSize: Integer = -1); +var + pSd: PSecurityDescriptor; + sa: TSecurityAttributes; + bInit: Boolean; +begin + Inherited Create; + + hMap_ := 0; + Data := nil; + bFreeData_ := true; + + if nShareSize > 0 then + nAllocSize_ := nShareSize // 크기를 지정 해줄수 있도록 옵션 추가 14_1027 16:05:05 kku + else + nAllocSize_ := SizeOf(T); + + bInit := false; + hMap_ := OpenFileMapping(FILE_MAP_WRITE or FILE_MAP_READ, false, PChar(sMapFileName)); + if hMap_ = 0 then + begin + New(pSd); + try + if not InitializeSecurityDescriptor(pSd, SECURITY_DESCRIPTOR_REVISION) then + begin + nLastError_ := GetLastError; + exit; + end; + + if not SetSecurityDescriptorDacl(pSd, true, nil, false) then + begin + nLastError_ := GetLastError; + exit; + end; + + sa.nLength := SizeOf(sa); + sa.lpSecurityDescriptor := pSd; + sa.bInheritHandle := TRUE; + + hMap_ := CreateFileMapping(THandle(-1), + @sa, + PAGE_READWRITE, + 0, + nAllocSize_, + PChar(sMapFileName)); + bInit := true; + finally + Dispose(pSd); + end; + end; + + if hMap_ <> 0 then + begin + Data := mapViewOfFile(hMap_, + FILE_MAP_ALL_ACCESS, + 0, + 0, + nAllocSize_); + + if Data = nil then + begin + nLastError_ := GetLastError; + CloseHandle(hMap_); + hMap_ := 0; + end else begin + if bInit then + ZeroMemory(Data, nAllocSize_); + nLastError_ := ERROR_SUCCESS; + end; + end else + nLastError_ := GetLastError; +end; + +Destructor TTgFileMapping<T>.Destroy; +begin + if (Data <> nil) and bFreeData_ then + begin + UnmapViewOfFile(Data); + Data := nil; + end; + + if hMap_ <> 0 then + begin + CloseHandle(hMap_); + hMap_ := 0; + end; + + Inherited; +end; + +function TTgFileMapping<T>.IsAvailable: Boolean; +begin + Result := Data <> nil; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Controls.pas b/Tocsg.Lib/VCL/Tocsg.Controls.pas new file mode 100644 index 00000000..ea9d0935 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Controls.pas @@ -0,0 +1,217 @@ +{*******************************************************} +{ } +{ Tocsg.Controls } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Controls; + +interface + +uses + Vcl.Menus, Tocsg.Obj, Vcl.Controls, System.SysUtils, System.Classes, + System.Generics.Collections, Vcl.StdCtrls; + +type + TManagerInputControlsData = class(TTgObject) + private + sIniPath_: String; + InputCtrlList_: TList<TControl>; + public + Constructor Create(const sIniPath: String); + Destructor Destroy; override; + procedure RegInputCtrl(aCtrl: TControl); + procedure Save; + procedure Load(bInitClear: Boolean = false); + end; + +procedure SetSubMenuVisible(aMenuItem: TMenuItem; bVal: Boolean); inline; +procedure SetChildControlEnable(aParentCtrl: TWinControl; bVal: Boolean); inline; + +implementation + +uses + System.IniFiles, Tocsg.Safe, Tocsg.Strings; + +{ TManagerInputControlsData } + +Constructor TManagerInputControlsData.Create(const sIniPath: String); +begin + Inherited Create; + sIniPath_ := sIniPath; + InputCtrlList_ := TList<TControl>.Create; +end; + +Destructor TManagerInputControlsData.Destroy; +begin + FreeAndNil(InputCtrlList_); + Inherited; +end; + +procedure TManagerInputControlsData.RegInputCtrl(aCtrl: TControl); +var + i: Integer; +begin + i := InputCtrlList_.IndexOf(aCtrl); + if i = -1 then + InputCtrlList_.Add(aCtrl); +end; + +procedure TManagerInputControlsData.Save; + function GetDivStrings(aStrings: TStrings): String; + var + i: Integer; + begin + Result := ''; + for i := 0 to aStrings.Count - 1 do + Result := Result + aStrings[i] + ';'; + end; +var + i, n: Integer; + ini: TIniFile; + sTemp: String; +begin + Guard(ini, TIniFile.Create(sIniPath_)); + for i := 0 to InputCtrlList_.Count - 1 do + if InputCtrlList_[i] is TEdit then + begin + ini.WriteString('TEdit', InputCtrlList_[i].Name, TEdit(InputCtrlList_[i]).Text); + end else + if InputCtrlList_[i] is TMemo then + begin + sTemp := StringReplace(TMemo(InputCtrlList_[i]).Text, #13#10, '§#', [rfReplaceAll]); + ini.WriteString('TMemo', InputCtrlList_[i].Name, sTemp); + end else + if InputCtrlList_[i] is TCheckBox then + begin + ini.WriteBool('TCheckBox', InputCtrlList_[i].Name, TCheckBox(InputCtrlList_[i]).Checked); + end else + if InputCtrlList_[i] is TRadioButton then + begin + + ini.WriteBool('TCheckBox', InputCtrlList_[i].Name, TRadioButton(InputCtrlList_[i]).Checked); + + end else + if InputCtrlList_[i] is TComboBox then + begin + case TComboBox(InputCtrlList_[i]).Style of + csDropDown : + begin + sTemp := TComboBox(InputCtrlList_[i]).Text; + n := TComboBox(InputCtrlList_[i]).Items.IndexOf(sTemp); + if n = -1 then + begin + if TComboBox(InputCtrlList_[i]).Items.Count > 0 then + TComboBox(InputCtrlList_[i]).Items.Insert(0, sTemp) + else + TComboBox(InputCtrlList_[i]).Items.Add(sTemp); + end else begin + if TComboBox(InputCtrlList_[i]).Items.Count > 1 then + begin + TComboBox(InputCtrlList_[i]).Items.Delete(n); + TComboBox(InputCtrlList_[i]).Items.Insert(0, sTemp); + TComboBox(InputCtrlList_[i]).Text := sTemp; + end; + end; + ini.WriteString('TComboBox', InputCtrlList_[i].Name, GetDivStrings(TComboBox(InputCtrlList_[i]).Items)); + end; + csDropDownList : + begin + ini.WriteInteger('TComboBox.List', InputCtrlList_[i].Name, TComboBox(InputCtrlList_[i]).ItemIndex); + end; + end; + end; +end; + +procedure TManagerInputControlsData.Load(bInitClear: Boolean = false); +var + i: Integer; + ini: TIniFile; + TempStrings: TStringList; +begin + if FileExists(sIniPath_) then + begin + Guard(TempStrings, TStringList.Create); + Guard(ini, TIniFile.Create(sIniPath_)); + for i := 0 to InputCtrlList_.Count - 1 do + if InputCtrlList_[i] is TEdit then + begin + if bInitClear or ini.ValueExists('TEdit', InputCtrlList_[i].Name) then + TEdit(InputCtrlList_[i]).Text := ini.ReadString('TEdit', InputCtrlList_[i].Name, ''); + end else + if InputCtrlList_[i] is TMemo then + begin + if bInitClear or ini.ValueExists('TMemo', InputCtrlList_[i].Name) then + TMemo(InputCtrlList_[i]).Text := StringReplace(ini.ReadString('TMemo', InputCtrlList_[i].Name, ''), '§#', #13#10, [rfReplaceAll]); + end else + if InputCtrlList_[i] is TCheckBox then + begin + if bInitClear or ini.ValueExists('TCheckBox', InputCtrlList_[i].Name) then + TCheckBox(InputCtrlList_[i]).Checked := ini.ReadBool('TCheckBox', InputCtrlList_[i].Name, false); + end else + if InputCtrlList_[i] is TRadioButton then + begin + if bInitClear or ini.ValueExists('TRadioButton', InputCtrlList_[i].Name) then + TRadioButton(InputCtrlList_[i]).Checked := ini.ReadBool('TRadioButton', InputCtrlList_[i].Name, false); + end else + if InputCtrlList_[i] is TComboBox then + begin + case TComboBox(InputCtrlList_[i]).Style of + csDropDown : + begin + TComboBox(InputCtrlList_[i]).Clear; + TComboBox(InputCtrlList_[i]).Text := ''; + SplitString(ini.ReadString('TComboBox', InputCtrlList_[i].Name, ''), ';', TempStrings); + if TempStrings.Count > 0 then + begin + TComboBox(InputCtrlList_[i]).Items.AddStrings(TempStrings); + TComboBox(InputCtrlList_[i]).ItemIndex := 0; + end; + end; + csDropDownList : + begin + if bInitClear or ini.ValueExists('TComboBox.List', InputCtrlList_[i].Name) then + TComboBox(InputCtrlList_[i]).ItemIndex := ini.ReadInteger('TComboBox.List', InputCtrlList_[i].Name, 0); + end; + end; + end; + end else + if bInitClear then + begin + for i := 0 to InputCtrlList_.Count - 1 do + if InputCtrlList_[i] is TEdit then + begin + TEdit(InputCtrlList_[i]).Text := ''; + end else + if InputCtrlList_[i] is TComboBox then + begin + case TComboBox(InputCtrlList_[i]).Style of + csDropDown : + begin + TComboBox(InputCtrlList_[i]).Clear; + TComboBox(InputCtrlList_[i]).Text := ''; + end; + end; + end; + end; +end; + +procedure SetSubMenuVisible(aMenuItem: TMenuItem; bVal: Boolean); +var + i: Integer; +begin + for i := 0 to aMenuItem.Count - 1 do + aMenuItem[i].Visible := bVal; +end; + +procedure SetChildControlEnable(aParentCtrl: TWinControl; bVal: Boolean); +var + i: Integer; +begin + for i := 0 to aParentCtrl.ControlCount - 1 do + aParentCtrl.Controls[i].Enabled := bVal; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Convert.pas b/Tocsg.Lib/VCL/Tocsg.Convert.pas new file mode 100644 index 00000000..d7bd7062 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Convert.pas @@ -0,0 +1,137 @@ +{*******************************************************} +{ } +{ Tocsg.Convert } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Convert; + +interface + +uses + Winapi.Windows, System.SysUtils, Tocsg.Obj, System.Classes; + +type + TTgRtti = class(TTgObject) + public + class function Int64ToSetType<T>(aInt: Int64): T; + class function SetTypeToInt64<T>(aSet: T): Int64; + class function SetTypeToStr<T>(aSet: T): String; + class function StrToSetType<T>(aStr: String): T; + end; + +function ByteSizeToStr(ullSize: ULONGLONG): String; inline; +function BooleanToStr(const bVal: Boolean; const sTrue, sFalse: String): String; inline; +function BooleanToInt(const bVal: Boolean; const nTrue, nFalse: Integer): Integer; inline; +function BooleanToFloat(const bVal: Boolean; const fTrue, fFalse: Double): Double; inline; + +function FileToBase64(sPath: String): String; + +implementation + +uses + Tocsg.Binary, System.Rtti, Soap.EncdDecd, Tocsg.Exception, Tocsg.Safe; + +{ TTgRtti } + +class function TTgRtti.Int64ToSetType<T>(aInt: Int64): T; +var + v: TValue; +begin + TValue.Make(nil, TypeInfo(T), v); + TValueData(v).FAsSInt64 := aInt; + Result := v.AsType<T>; +end; + +class function TTgRtti.SetTypeToInt64<T>(aSet: T): Int64; +var + v: TValue; +begin + v := TValue.From<T>(aSet); + Result := TValueData(v).FAsSInt64; +end; + +class function TTgRtti.SetTypeToStr<T>(aSet: T): String; +var + nSize: Integer; + pBuf: Pointer; +begin + nSize := SizeOf(aSet); + pBuf := AllocMem(nSize); + try + CopyMemory(pBuf, @aSet, nSize); + Result := ConvBytesToHexStr(pBuf, nSize); + finally + FreeMem(pBuf); + end; +end; + +class function TTgRtti.StrToSetType<T>(aStr: String): T; +var + nSize: Integer; + pBuf: TBytes; +begin + ConvHexStrToBytes(aStr, pBuf); + nSize := Length(pBuf); + if nSize = SizeOf(Result) then + CopyMemory(@Result, pBuf, nSize); +end; + +function ByteSizeToStr(ullSize: ULONGLONG): String; +begin + if (ullSize >= 1024) and (ullSize <= 1048576) then + Result := Format('%d KB', [Round(ullSize / 1024)]) + else if (ullSize >= 1048576) and (ullSize < 1073741824) then + Result := Format('%d MB', [Round(ullSize / 1048576)]) + else if (ullSize >= 1073741824) and (ullSize < 1099511627776) then + Result := Format('%d GB', [Round(ullSize / 1073741824)]) + else if ullSize >= 1099511627776 then + Result := Format('%d TB', [Round(ullSize / 1099511627776)]) + else + Result := Format('%d Byte', [ullSize]); +end; + +function BooleanToStr(const bVal: Boolean; const sTrue, sFalse: String): String; +begin + if bVal then + Result := sTrue + else + Result := sFalse; +end; + +function BooleanToInt(const bVal: Boolean; const nTrue, nFalse: Integer): Integer; +begin + if bVal then + Result := nTrue + else + Result := nFalse; +end; + +function BooleanToFloat(const bVal: Boolean; const fTrue, fFalse: Double): Double; +begin + if bVal then + Result := fTrue + else + Result := fFalse; +end; + +function FileToBase64(sPath: String): String; +var + ms: TMemoryStream; +begin + Result := ''; + try + if not FileExists(sPath) then + exit; + Guard(ms, TMemoryStream.Create); + ms.LoadFromFile(sPath); + Result := EncodeBase64(ms.Memory, ms.Size); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. FileToBase64()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.DateTime.pas b/Tocsg.Lib/VCL/Tocsg.DateTime.pas new file mode 100644 index 00000000..d76eea68 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.DateTime.pas @@ -0,0 +1,657 @@ +{*******************************************************} +{ } +{ Tocsg.DateTime } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.DateTime; + +interface + +uses + System.Generics.Collections, System.Generics.Defaults, System.SysUtils, + Winapi.Windows; + +type + TDateTimeList = TList<TDateTime>; + + TDateTimeComparer = class(TComparer<TDateTime>) + public + function Compare(const Left, Right: TDateTime): Integer; override; + end; + +function ConvStrToDateTime(sDtStr: String): TDateTime; {$IFDEF RELEASE} inline; {$ENDIF} +function ConvSecToProgTime(dwSec: DWORD): String; inline; +function ConvSecBetweenToProgTime(dtNow, dtThen: TDateTime): String; + +function GetBootTime: TDateTime; +function GetLocalIncUtcMin: Integer; // 로컬 타임존 UTC+분 + +function ConvFileTimeToDateTime(const aFileTime: TFileTime): TDateTime; +function ConvFileTimeToDateTime_Local(const aFileTime: TFileTime): TDateTime; +function ConvSystemTimeToDateTime(const st: TSystemTime): TDateTime; +function ConvSystemTimeToDateTime_Local(const st: TSystemTime): TDateTime; +function ConvDateTimeToSystemTime(dt: TDateTime): TSystemTime; +function ConvDateTimeToSystemTime_Local(dt: TDateTime): TSystemTime; +function ConvDateTimeToFileTime(dt: TDateTime): TFileTime; +function ConvUtcToLocal(dt: TDateTime): TDateTime; +function ConvLocalToUtc(dt: TDateTime): TDateTime; + +function ConvTimeToDateTime(t: Integer): TDateTime; +function ConvTimestampToDateTime(llTime: LONGLONG): TDateTime; +function ConvChromeTimestampToDateTime(llTime: LONGLONG): TDateTime; +function ConvTimestampToFileTime_Local(llTime: LONGLONG): TFileTime; +function ConvTimestampToFileTime(llTime: LONGLONG): TFileTIme; +function ConvJavaToDelphiDateTime(const llVal: LONGLONG; bUtc0: Boolean = false): TDateTime; + +function ConvStrDtToDateTime(const sDateTime: String): TDateTime; +function UnixTimeToDateTime(llDT: LONGLONG): TDateTime; + +function AppendTime(dt: TDateTime; wHour, wMin, wSec, wMSec: WORD): TDateTime; + +function RawStrToDateTime(const RawStr: string): TDateTime; + +function JavaDtToDelphiDt(const dt: int64): TDateTime; +function DelphiDtToJavaDt(const dt: TDateTime): int64; + +implementation + +uses + System.DateUtils, Tocsg.Exception; + +{ TDateTimeComparer } + +function TDateTimeComparer.Compare(const Left, Right: TDateTime): Integer; +begin + Result := CompareDateTime(Right, Left); +end; + +{ Other } + +function ConvStrToDateTime(sDtStr: String): TDateTime; +var + wLen, wYear, wMonth, wDay, wHour, wMin, wSec: WORD; +begin + Result := 0; + + sDtStr := StringReplace(sDtStr, '-', '', [rfReplaceAll]); + sDtStr := StringReplace(sDtStr, ':', '', [rfReplaceAll]); + sDtStr := StringReplace(sDtStr, ' ', '', [rfReplaceAll]); + + wLen := sDtStr.Length; + if wLen >= 8 then + begin + wYear := StrToIntDef(Copy(sDtStr, 1, 4), 0); + wMonth := StrToIntDef(Copy(sDtStr, 5, 2), 0); + wDay := StrToIntDef(Copy(sDtStr, 7, 2), 0); + if wLen >= 14 then + begin + wHour := StrToIntDef(Copy(sDtStr, 9, 2), 0); + wMin := StrToIntDef(Copy(sDtStr, 11, 2), 0); + wSec := StrToIntDef(Copy(sDtStr, 13, 2), 0); + end else begin + wHour := 0; + wMin := 0; + wSec := 0; + end; + + try + Result := EncodeDateTime(wYear, wMonth, wDay, wHour, wMin, wSec, 0); + except + exit; + end; + end; +end; + +function ConvSecToProgTime(dwSec: DWORD): String; +var + dwMin, + dwHour, dwDay: DWORD; +begin + dwMin := (dwSec div 60) mod 60; + dwHour := (dwSec div 60 div 60) mod 24; + dwDay := dwSec div 60 div 60 div 24; + dwSec := dwSec mod 60; + if dwDay > 0 then + begin + if (dwHour + dwMin + dwSec) = 0 then + Result := Format('%dDay', [dwDay]) + else + Result := Format('%dDay, %.2d:%.2d:%.2d', [dwDay, dwHour, dwMin, dwSec]); + end else + Result := Format('%.2d:%.2d:%.2d', [dwHour, dwMin, dwSec]); +end; + +function ConvSecBetweenToProgTime(dtNow, dtThen: TDateTime): String; +begin + Result := ConvSecToProgTime(SecondsBetween(dtNow, dtThen)); +end; + +function GetBootTime: TDateTime; +begin + Result := IncMilliSecond(now, LONGLONG(-1) * GetTickCount); +end; + +function GetLocalIncUtcMin: Integer; +begin + Result := (TTimeZone.Local.UtcOffset.Hours * 60) + TTimeZone.Local.UtcOffset.Minutes; +end; + +function ConvFileTimeToDateTime(const aFileTime: TFileTime): TDateTime; +var + nDosTime: Integer; +begin + Result := 0; + try + if WinApi.Windows.FileTimeToDosDateTime(aFileTime, LongRec(nDosTime).Hi, + LongRec(nDosTime).Lo) then + try + Result := FileDateToDateTime(nDosTime); + except + On EConvertError do + exit; + end; + except + exit; + end; +end; + +function ConvFileTimeToDateTime_Local(const aFileTime: TFileTime): TDateTime; +var + lcFT : TFileTime; + lc: Integer; +begin + Result := 0; + if WinApi.Windows.FileTimeToLocalFileTime(aFileTime, lcFT) then + begin + if WinApi.Windows.FileTimeToDosDateTime(lcFT, LongRec(lc).Hi, LongRec(lc).Lo) then + try + Result := FileDateToDateTime(lc); + except + On EConvertError do + exit; + end; + end; +end; + +function ConvSystemTimeToDateTime(const st: TSystemTime): TDateTime; +var + ft: TFileTime; +begin + Result := 0; + + if SystemTimeToFileTime(st, ft) then + Result := ConvFileTimeToDateTime(ft); +end; + +function ConvSystemTimeToDateTime_Local(const st: TSystemTime): TDateTime; +var + ft: TFileTime; +begin + Result := 0; + + if SystemTimeToFileTime(st, ft) then + Result := ConvFileTimeToDateTime_Local(ft); +end; + +function ConvDateTimeToSystemTime(dt: TDateTime): TSystemTime; +begin + try + if not FileTimeToSystemTime(ConvDateTimeToFileTime(dt), Result) then + ZeroMemory(@Result, SizeOf(Result)); + except + on E: Exception do + begin + ETgException.TraceException(E, 'Fail .. ConvDateTimeToSystemTime()'); + ZeroMemory(@Result, SizeOf(Result)); + end; + end; +end; + +function ConvDateTimeToSystemTime_Local(dt: TDateTime): TSystemTime; +var + lcFT: TFileTime; +begin + ZeroMemory(@Result, SizeOf(Result)); + try + if WinApi.Windows.FileTimeToLocalFileTime(ConvDateTimeToFileTime(dt), lcFT) then + FileTimeToSystemTime(lcFT, Result); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ConvDateTimeToSystemTime_Local()'); + end; +end; + +function ConvDateTimeToFileTime(dt: TDateTime): TFileTime; +var + LocalFileTime, Ft: TFileTime; + SystemTime: TSystemTime; +begin + Result.dwLowDateTime := 0; + Result.dwHighDateTime := 0; + try + DateTimeToSystemTime(dt, SystemTime); + SystemTimeToFileTime(SystemTime, LocalFileTime); + LocalFileTimeToFileTime(LocalFileTime, Ft); + Result := Ft; + except + ZeroMemory(@Result, SizeOf(Result)); + end; +end; + +function ConvUtcToLocal(dt: TDateTime): TDateTime; +var + tzi: TTimeZoneInformation; + lt, ut: TSystemTime; +begin + Result := 0; + try + GetTimeZoneInformation(tzi); + DateTimeToSystemTime(dt, ut); + SystemTimeToTzSpecificLocalTime(@tzi, ut, lt); + Result := SystemTimeToDateTime(lt); + except + + end; +end; + +function ConvLocalToUtc(dt: TDateTime): TDateTime; +begin + Result := 0; + try + Result := TTimeZone.Local.ToUniversalTime(Now); + except + + end; +end; + +function ConvTimeToDateTime(t: Integer): TDateTime; +var + sysTime, sysTime1 : TSystemTime; +begin + DateTimeToSystemTime(EncodeDate(1970, 1, 1) + (t / 86400), sysTime); + SystemTimeToTzSpecificLocalTime(nil, sysTime, sysTime1); + Result := SystemTimeToDateTime(sysTime1); +end; + +function ConvTimestampToDateTime(llTime: LONGLONG): TDateTime; +var + nTime: Integer; + ft: TFileTime; +begin + Result := 0; +// 이 값이 들어오는 경우가 있는데.. +// 이 경우는 FileDateToDateTime() 여기서 예외가 발생해서 미리 체크함 20_0522 09:26:30 sunk + if llTime <> 116444736000000000 then + begin + CopyMemory(@ft, @llTime, SizeOf(LONGLONG)); + try + FileTimeToDosDateTime(ft, LongRec(nTime).Hi, LongRec(nTime).Lo); + if nTime > 0 then + Result := FileDateToDateTime(nTime); + except +// On EConvertError do +// exit; + end; + end; +end; + +function ConvChromeTimestampToDateTime(llTime: LONGLONG): TDateTime; +begin +{ +u : Unix timestamp eg: 1378615325 +j : JavaScript timestamp eg: 1378615325177 +c : Chrome timestamp eg: 13902597987770000 +w : Windows timestamp eg: 139025979877700000 + +u = (j / 1000) +u = (c - 116444736000000) / 10000000 +u = (w - 1164447360000000) / 100000000 + +j = (u * 1000) +j = (c - 116444736000000) / 10000 +j = (w - 1164447360000000) / 100000 + +c = (u * 10000000) + 116444736000000 +c = (j * 10000) + 116444736000000 +c = (w / 10) + +w = (u * 100000000) + 1164447360000000 +w = (j * 100000) + 1164447360000000 +w = (c * 10) +} + if llTime > 116444736000000 then + Result := ConvTimestampToDateTime(llTime * 10) + else + Result := 0; +end; + +function ConvTimestampToFileTime_Local(llTime: LONGLONG): TFileTime; +var + ft, + localft: TFileTime; +begin + CopyMemory(@ft, @llTime, SizeOf(LONGLONG)); + + try + FileTimeToLocalFileTime(ft, localft); // 생성일 기준 + Result := localft; + except + ZeroMemory(@Result, SizeOf(Result)); + end; +end; + +function ConvTimestampToFileTime(llTime: LONGLONG): TFileTIme; +var + ft: TFileTime; +begin + CopyMemory(@ft, @llTime, SizeOf(LONGLONG)); + Result := ft; +end; + +// superobject.pas에 있는거 가져옴 +function ConvJavaToDelphiDateTime(const llVal: LONGLONG; bUtc0: Boolean = false): TDateTime; +var + t: TSystemTime; +begin + DateTimeToSystemTime(25569 + (llVal / 86400000), t); + if not bUtc0 then + SystemTimeToTzSpecificLocalTime(nil, t, t); + Result := SystemTimeToDateTime(t); +end; + +function ConvStrDtToDateTime(const sDateTime: String): TDateTime; +var + wLen, wYear, wMonth, wDay, wHour, wMin, wSec: WORD; +begin + Result := 0; + + wLen := Length(sDateTime); + if wLen >= 8 then + begin + wYear := StrToIntDef(Copy(sDateTime, 1, 4), 0); + wMonth := StrToIntDef(Copy(sDateTime, 5, 2), 0); + wDay := StrToIntDef(Copy(sDateTime, 7, 2), 0); + if wLen >= 14 then + begin + wHour := StrToIntDef(Copy(sDateTime, 9, 2), 0); + wMin := StrToIntDef(Copy(sDateTime, 11, 2), 0); + wSec := StrToIntDef(Copy(sDateTime, 13, 2), 0); + end else begin + wHour := 0; + wMin := 0; + wSec := 0; + end; + + try + Result := EncodeDateTime(wYear, wMonth, wDay, wHour, wMin, wSec, 0); + except + Result := 0; + end; + end; +end; + +function UnixTimeToDateTime(llDT: LONGLONG): TDateTime; +begin + Result := (llDT / 86400) + 25569; +end; + +function AppendTime(dt: TDateTime; wHour, wMin, wSec, wMSec: WORD): TDateTime; +var + wYear, wMonth, wDay: WORD; +begin + try + DecodeDate(dt, wYear, wMonth, wDay); + Result := EncodeDateTime(wYear, wMonth, wDay, wHour, wMin, wSec, wMSec); + except + Result := dt; + end; +end; + +function RawStrToDateTime(const RawStr: string): TDateTime; +var + v: Int64; +begin + v := StrToInt64(RawStr); + Result := PDouble(@v)^; +end; + +// superobject.pas에서 가져옴 +function DayLightCompareDate(const date: PSystemTime; + const compareDate: PSystemTime): Integer; +var + limit_day, dayinsecs, weekofmonth: Integer; + First: Word; +begin + if (date^.wMonth < compareDate^.wMonth) then + begin + Result := -1; (* We are in a month before the date limit. *) + Exit; + end; + + if (date^.wMonth > compareDate^.wMonth) then + begin + Result := 1; (* We are in a month after the date limit. *) + Exit; + end; + + (* if year is 0 then date is in day-of-week format, otherwise + * it's absolute date. + *) + if (compareDate^.wYear = 0) then + begin + (* compareDate.wDay is interpreted as number of the week in the month + * 5 means: the last week in the month *) + weekofmonth := compareDate^.wDay; + (* calculate the day of the first DayOfWeek in the month *) + First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1; + limit_day := First + 7 * (weekofmonth - 1); + (* check needed for the 5th weekday of the month *) + if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth]) then + dec(limit_day, 7); + end + else + limit_day := compareDate^.wDay; + + (* convert to seconds *) + limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60; + dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond; + (* and compare *) + + if dayinsecs < limit_day then + Result := -1 else + if dayinsecs > limit_day then + Result := 1 else + Result := 0; (* date is equal to the date limit. *) +end; + +function CompTimeZoneID(const pTZinfo: PTimeZoneInformation; + lpFileTime: PFileTime; islocal: Boolean): LongWord; +var + ret: Integer; + beforeStandardDate, afterDaylightDate: Boolean; + llTime: Int64; + SysTime: TSystemTime; + ftTemp: TFileTime; +begin + llTime := 0; + + if (pTZinfo^.DaylightDate.wMonth <> 0) then + begin + (* if year is 0 then date is in day-of-week format, otherwise + * it's absolute date. + *) + if ((pTZinfo^.StandardDate.wMonth = 0) or + ((pTZinfo^.StandardDate.wYear = 0) and + ((pTZinfo^.StandardDate.wDay < 1) or + (pTZinfo^.StandardDate.wDay > 5) or + (pTZinfo^.DaylightDate.wDay < 1) or + (pTZinfo^.DaylightDate.wDay > 5)))) then + begin + SetLastError(ERROR_INVALID_PARAMETER); + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + if (not islocal) then + begin + llTime := PInt64(lpFileTime)^; + dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000); + PInt64(@ftTemp)^ := llTime; + lpFileTime := @ftTemp; + end; + + FileTimeToSystemTime(lpFileTime^, SysTime); + + (* check for daylight savings *) + ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate); + if (ret = -2) then + begin + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + beforeStandardDate := ret < 0; + + if (not islocal) then + begin + dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000); + PInt64(@ftTemp)^ := llTime; + FileTimeToSystemTime(lpFileTime^, SysTime); + end; + + ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate); + if (ret = -2) then + begin + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + afterDaylightDate := ret >= 0; + + Result := TIME_ZONE_ID_STANDARD; + if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then + begin + (* Northern hemisphere *) + if( beforeStandardDate and afterDaylightDate) then + Result := TIME_ZONE_ID_DAYLIGHT; + end else (* Down south *) + if( beforeStandardDate or afterDaylightDate) then + Result := TIME_ZONE_ID_DAYLIGHT; + end else + (* No transition date *) + Result := TIME_ZONE_ID_UNKNOWN; +end; + +function GetTimezoneBias(const pTZinfo: PTimeZoneInformation; + lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean; +var + bias: LongInt; + tzid: LongWord; +begin + bias := pTZinfo^.Bias; + tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal); + + if( tzid = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + if (tzid = TIME_ZONE_ID_DAYLIGHT) then + inc(bias, pTZinfo^.DaylightBias) + else if (tzid = TIME_ZONE_ID_STANDARD) then + inc(bias, pTZinfo^.StandardBias); + pBias^ := bias; + Result := True; +end; + +function TzSpecificLocalTimeToSystemTime( + const lpTimeZoneInformation: PTimeZoneInformation; + const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL; +var + ft: TFileTime; + lBias: LongInt; + t: Int64; + tzinfo: TTimeZoneInformation; +begin + if (lpTimeZoneInformation <> nil) then + tzinfo := lpTimeZoneInformation^ + else + if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + + if (not SystemTimeToFileTime(lpLocalTime^, ft)) then + begin + Result := False; + Exit; + end; + t := PInt64(@ft)^; + if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then + begin + Result := False; + Exit; + end; + (* convert minutes to 100-nanoseconds-ticks *) + inc(t, Int64(lBias) * 600000000); + PInt64(@ft)^ := t; + Result := FileTimeToSystemTime(ft, lpUniversalTime^); +end; + +function SystemTimeToTzSpecificLocalTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpUniversalTime, lpLocalTime: PSystemTime): BOOL; +var + ft: TFileTime; + lBias: LongInt; + llTime: Int64; + tzinfo: TTimeZoneInformation; +begin + if (lpTimeZoneInformation <> nil) then + tzinfo := lpTimeZoneInformation^ else + if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + + if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then + begin + Result := False; + Exit; + end; + llTime := PInt64(@ft)^; + if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then + begin + Result := False; + Exit; + end; + (* convert minutes to 100-nanoseconds-ticks *) + dec(llTime, Int64(lBias) * 600000000); + PInt64(@ft)^ := llTime; + Result := FileTimeToSystemTime(ft, lpLocalTime^); +end; + +function JavaDtToDelphiDt(const dt: int64): TDateTime; +var + t: TSystemTime; +begin + DateTimeToSystemTime(25569 + (dt / 86400000), t); + SystemTimeToTzSpecificLocalTime(nil, @t, @t); + Result := SystemTimeToDateTime(t); +end; + +function DelphiDtToJavaDt(const dt: TDateTime): int64; +var + t: TSystemTime; +begin + DateTimeToSystemTime(dt, t); + TzSpecificLocalTimeToSystemTime(nil, @t, @t); + Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000) +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Delete.pas b/Tocsg.Lib/VCL/Tocsg.Delete.pas new file mode 100644 index 00000000..5cf3908a --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Delete.pas @@ -0,0 +1,266 @@ +{*******************************************************} +{ } +{ Tocsg.Delete } +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.Delete; + +interface + +uses + System.SysUtils, System.Classes, ADODB2000; + +function DeleteFileSelf(sPath: String = ''; aAddList: TStringList = nil): String; +function PerfectDeleteFile(sPath: String; nOvrCnt: Integer = 1; bDetail: Boolean = false; sTmpDirName: String = ''): Boolean; + +procedure ClearRecentFolder(sUName: String = ''); +procedure ClearAutoJumpLists(sUName: String = ''; bIgrFav: Boolean = true); +procedure ClearUserTempFolder(bKvTmpOnly: Boolean = true); + +implementation + +uses + Tocsg.Strings, Tocsg.Path, Tocsg.Safe, Winapi.Windows, Tocsg.Shell, + Tocsg.Files; + +function DeleteFileSelf(sPath: String = ''; aAddList: TStringList = nil): String; +var + sName, + sRName, + sCmdSelfDel: String; + CmdList: TStringList; + i: Integer; +begin + Result := ''; + + if sPath = '' then + sPath := GetRunExePath; + + sName := ExtractFileName(sPath); + sRName := GetRandomStr(4, 8); + sPath := ExtractFilePath(sPath); + + Guard(CmdList, TStringList.Create); + CmdList.Add('timeout 1'); + CmdList.Add(Format('taskkill /f /pid %d', [GetCurrentProcessId])); + CmdList.Add('timeout 1'); + CmdList.Add(Format('taskkill /f /pid %d', [GetCurrentProcessId])); + CmdList.Add('timeout 1'); + CmdList.Add(Format('cd "%s"', [sPath])); +// CmdList.Add(Format('ren ".\%s" "%s"', [sName, sRName])); + CmdList.Add('timeout 1'); +// CmdList.Add(Format('del "%s"', [sRName])); + CmdList.Add(Format('del .\"%s"', [sName])); + CmdList.Add('timeout 1'); + if aAddList <> nil then + for i := 0 to aAddList.Count - 1 do + begin + CmdList.Add(Format('del "%s"', [aAddList[i]])); + end; + + sCmdSelfDel := Format('$d-%s.cmd', [GetRandomStr(4, 6)]); + CmdList.Add(Format('del ".\%s"', [sCmdSelfDel])); + + try + Result := sPath + sCmdSelfDel; + CmdList.SaveToFile(Result); + except + exit; + end; + + Sleep(500); +// ExecuteAppAsUser(GetCurrentProcessId, 'cmd.exe', Format('/C "%s"', [sPath + sCmdSelfDel]), SW_HIDE); + ExecutePath_hide('cmd.exe', Format('/C "%s"', [sPath + sCmdSelfDel])); +end; + +function PerfectDeleteFile(sPath: String; nOvrCnt: Integer = 1; bDetail: Boolean= false; sTmpDirName: String = ''): Boolean; +const + BUF_LEN = 65536; +var + fs: TFileStream; + dwWrite: DWORD; + arrBuf: array [0 .. BUF_LEN-1] of Byte; + i: Integer; +begin + Result := false; + if not FileExists(sPath) then + exit; + + if nOvrCnt <= 0 then + nOvrCnt := 1; + + try + if bDetail then + begin + if sTmpDirName <> '' then + begin + // 위치 정보 변경 + var sTmpPath: String := sPath[1] + ':\' + IncludeTrailingBackslash(sTmpDirName); // ':\@TmpPd\'; + if ForceDirectories(sTmpPath) then + begin + sTmpPath := sTmpPath + GetRandomStr(5, 8); + if MoveFile_wait(sPath, sTmpPath, 1) then + sPath := sTmpPath; + end; + end; + end; + + // 내용 삭제 + fs := TFileStream.Create(sPath, fmOpenReadWrite); + try + for i := 0 to nOvrCnt - 1 do + begin + ZeroMemory(@arrBuf, BUF_LEN); + fs.Position := 0; + while fs.Size > fs.Position do + begin + if BUF_LEN > (fs.Size - fs.Position) then + dwWrite := fs.Size - fs.Position + else + dwWrite := BUF_LEN; + + if fs.Write(arrBuf, dwWrite) <> dwWrite then + break; + end; + end; + + if bDetail then + begin + // 크기 초기화 + fs.Size := 0; + end; + finally + fs.Free; + end; + + if bDetail then + begin + // 시간 정보 초기화 + SetFileDateTime(sPath, 0, 0, 0); + end; + except +// on E: Exception do +// ETgException.TraceException(E, 'Fail .. PerfectDeleteFile()'); + end; + + Result := DeleteFileForce(sPath); +end; + +procedure ClearRecentFolder(sUName: String = ''); +var + sDir: String; + FileList: TStringList; + i: Integer; +begin + if sUName = '' then + begin + sDir := GetUserDir + 'AppData\Roaming\Microsoft\Windows\Recent\' + end else begin + sDir := GetWindowsDir; + if sDir = '' then + exit; + + sDir := sDir[1] + Format(':\Users\%s\AppData\Roaming\Microsoft\Windows\Recent\', [sUName]); + end; + + if DirectoryExists(sDir) then + begin + Guard(FileList, TStringList.Create); + ExtrFilesFromDir(sDir, FileList, false, 'lnk'); + for i := 0 to FileList.Count - 1 do + DeleteFile(PChar(sDir + FileList[i])); +// DeleteDirSub(sDir, false); // 이렇게 하면 즐겨 찾기까지 모두 삭제됨 23_1219 16:50:53 kku + end; +end; + +procedure ClearAutoJumpLists(sUName: String = ''; bIgrFav: Boolean = true); +var + sDir: String; + FileList: TStringList; + i: Integer; +begin + if sUName = '' then + begin + sDir := GetUserDir + 'AppData\Roaming\Microsoft\Windows\Recent\AutomaticDestinations\' + end else begin + sDir := GetWindowsDir; + if sDir = '' then + exit; + + sDir := sDir[1] + Format(':\Users\%s\AppData\Roaming\Microsoft\Windows\Recent\AutomaticDestinations\', [sUName]); + end; + + if DirectoryExists(sDir) then + begin + Guard(FileList, TStringList.Create); + if bIgrFav then + FileList.Add('f01b4d95cf55d32a.automaticDestinations-ms'); // 즐겨찾기 제외 + DeleteDirSub(sDir, false, false, FileList); + end; +end; + +procedure ClearUserTempFolder(bKvTmpOnly: Boolean = true); +var + sWinDir, + sUsersDir: String; + UserList: TStringList; + i: Integer; + + procedure ClearWinTempKvOnly; + var + wfd: TWin32FindData; + hSc: THandle; + sDir, sPath, sFName: String; + begin + sDir := sWinDir + 'Temp\'; + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if UpperCase(wfd.cFileName).StartsWith('KV_') then + DeleteDir(sDir + wfd.cFileName); + end else begin + sFName := UpperCase(wfd.cFileName); + if GetFileExt(sFName) = 'TMP' then + begin + if sFName.StartsWith('KP') or sFName.StartsWith('KV') or sFName.StartsWith('KY') then + DeleteFile(PChar(sDir + wfd.cFileName)); + end; + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; + end; + +begin + sWinDir := GetWindowsDir; + if sWinDir = '' then + exit; + + sUsersDir := sWinDir[1] + ':\Users\'; + if not DirectoryExists(sUsersDir) then + exit; + + Guard(UserList, TStringList.Create); + ExtrDirFromDir(sUsersDir, UserList); + for i := 0 to UserList.Count - 1 do + DeleteDirSub(Format('%s\AppData\Local\Temp\', [sUsersDir + UserList[i]]), true, false, nil, true); + + if bKvTmpOnly then + ClearWinTempKvOnly + else + DeleteDirSub(sWinDir + 'Temp\', true, false, nil, true); // 25_1021 13:31:14 kku +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Disk.pas b/Tocsg.Lib/VCL/Tocsg.Disk.pas new file mode 100644 index 00000000..0ed26992 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Disk.pas @@ -0,0 +1,523 @@ +{*******************************************************} +{ } +{ Tocsg.Disk } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Disk; + +interface + +uses + System.SysUtils, Winapi.Windows, System.Generics.Collections; + +const + DISKPART_FMT_SELECT = 'select disk %d'; + DISKPART_SET_ATTRIBUTES_READONLY = 'attributes disk set readonly'; + DISKPART_DEL_ATTRIBUTES_READONLY = 'attributes disk clear readonly'; + DISKPART_OFFLINE_DISK = 'offline disk'; + DISKPART_ONLINE_DISK = 'online disk'; + +type + PDriveExtent = ^TDriveExtent; + TDriveExtent = record + dwDiskNumber : DWORD; + liStartingOffset : LARGE_INTEGER; + liExtentLength : LARGE_INTEGER; + end; + + PDiskExtents = ^TDiskExtents; + TDiskExtents = record + dwNumberOfDriveExtents: DWORD; + Extents: array [0..0] of TDriveExtent; + end; + + PDriveExtentEntry = ^TDriveExtentEntry; + TDriveExtentEntry = record + wDiskNum: WORD; + sDrive: String; + ullStartSector, + ullTotalSectors: ULONGLONG; + end; + TDriveEntentList = TList<PDriveExtentEntry>; + + TTgDriveExtent = class(TObject) + private + lstEntry_: TDriveEntentList; + procedure OnEntryNotify(Sender: TObject; const Item: PDriveExtentEntry; + Action: TCollectionNotification); + function GetCount: Integer; + function GetItem(nIndex: Integer): PDriveExtentEntry; + public + Constructor Create; + Destructor Destroy; override; + procedure RefreshDriveExtent; + + property Count: Integer read GetCount; + property Items[nIndex: Integer]: PDriveExtentEntry read GetItem; + end; + + PDevPathLetter = ^TDevPathLetter; + TDevPathLetter = record + cLetter: Char; + sDevicePath: String; + end; + TDevPathLetterList = class(TList<PDevPathLetter>) + protected + procedure Notify(const Item: PDevPathLetter; Action: TCollectionNotification); override; + end; + +function GetDriveFromMask(dwMask: DWORD): String; +function GetDrivesFromMask(dwMask: DWORD; bLetterOnly: Boolean = false; bFixedOnly: Boolean = false): String; +function GetDrivesDevPathLetterList(aList: TDevPathLetterList): Integer; +function GetDrivesVolNumLetterList(aList: TDevPathLetterList): Integer; + +function GetDriveExtent(const sDrive: String): TDriveExtent; + +function GetDriveSize(const sDrive: String): ULONGLONG; +function GetDriveFree(const sDrive: String): ULONGLONG; + +function GetVolumeSerial(const sDrive: String): DWORD; +function GetVolumeName(const sDrive: String): String; +function GetVolumeFilesystem(const sDrive: String): String; + +function GetDriveTypeToStr(nType: Integer): String; +function IsReadOnlyByWriteProbe(const sDrive: String): Integer; +procedure SetDriveReadOnly(sDrive: String; nDiskNum: Integer; bVal: Boolean); + +implementation + +uses + Tocsg.Strings, Tocsg.Exception, System.Classes, Tocsg.Path, Tocsg.Safe, + Tocsg.Process, Tocsg.Files; + +function GetDriveFromMask(dwMask: DWORD): String; +var + wLetter: Word; +begin + wLetter := Ord('A'); + while (dwMask and 1) = 0 do + begin + dwMask := dwMask shr 1; + Inc(wLetter); + end; + Result := Format('%s:\', [Char(wLetter)]); +end; + +function GetDrivesFromMask(dwMask: DWORD; bLetterOnly: Boolean = false; bFixedOnly: Boolean = false): String; +var + ucDrive: Byte; + sDrive: String; +begin + Result := ''; + for ucDrive := 0 to 31 do + if (dwMask and (1 shl ucDrive)) > 0 then + if bLetterOnly then + begin + if bFixedOnly then + begin + sDrive := Format('%s:\', [Char(ucDrive + 65)]); + if (GetDriveType(PChar(sDrive)) <> DRIVE_FIXED) then + continue; + end; + + SumString(Result, Char(ucDrive + 65), ','); + end else begin + sDrive := Format('%s:\', [Char(ucDrive + 65)]); + if bFixedOnly and (GetDriveType(PChar(sDrive)) <> DRIVE_FIXED) then + continue; + + SumString(Result, sDrive, ','); + end; +end; + +function GetDrivesDevPathLetterList(aList: TDevPathLetterList): Integer; +var + dwMask: DWORD; + ucDrive: Byte; + cDrive: Char; + pEnt: PDevPathLetter; + arrPath: array [0..MAX_PATH] of Char; +begin + try + Result := 0; + dwMask := GetLogicalDrives; + for ucDrive := 0 to 31 do + if (dwMask and (1 shl ucDrive)) > 0 then + begin + cDrive := Char(ucDrive + 65); + if GetDriveExtent(cDrive).liExtentLength.QuadPart <> 0 then + begin + ZeroMemory(@arrPath, SizeOf(arrPath)); + QueryDosDevice(PChar(cDrive + ':'), @arrPath, MAX_PATH); + if arrPath <> '' then + begin + New(pEnt); + pEnt.cLetter := cDrive; + pEnt.sDevicePath := arrPath; + aList.Add(pEnt); + Inc(Result); + end; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetDrivesDevPathLetterList()'); + end; +end; + +function GetDrivesVolNumLetterList(aList: TDevPathLetterList): Integer; +var + dwMask: DWORD; + ucDrive: Byte; + cDrive: Char; + pEnt: PDevPathLetter; + sVolNum: String; +begin + Result := 0; + dwMask := GetLogicalDrives; + for ucDrive := 0 to 31 do + if (dwMask and (1 shl ucDrive)) > 0 then + begin + cDrive := Char(ucDrive + 65); + if GetDriveExtent(cDrive).liExtentLength.QuadPart <> 0 then + begin + sVolNum := IntToHex(GetVolumeSerial(cDrive + ':\'), 3); + if sVolNum <> '' then + begin + New(pEnt); + pEnt.cLetter := cDrive; + pEnt.sDevicePath := sVolNum; + aList.Add(pEnt); + Inc(Result); + end; + end; + end; +end; + +function GetDriveExtent(const sDrive: String): TDriveExtent; +var + hVolume: THandle; + DiskExtents: PDiskExtents; + dwOutBytes: DWORD; + sDrivePath: String; +begin + ZeroMemory(@Result, SizeOf(Result)); + Result.dwDiskNumber := 999; + sDrivePath := Format('\\.\%s:', [sDrive[1]]); + + hVolume := CreateFile(PChar(sDrivePath), + 0,//GENERIC_READ or GENERIC_WRITE, // GENERIC_READ 이걸 넣어주면 딜레이가 많이 생긴다.. 15_0202 16:26:50 sunk + FILE_SHARE_READ,// or FILE_SHARE_WRITE, + nil, + OPEN_EXISTING, + 0, + 0); + +// hVolume := CreateFile(PChar(sDrivePath), +// GENERIC_READ, // or GENERIC_WRITE, +// FILE_SHARE_READ,// or FILE_SHARE_WRITE, +// nil, +// OPEN_EXISTING, +// FILE_FLAG_NO_BUFFERING or FILE_FLAG_SEQUENTIAL_SCAN, +// 0); + + if hVolume < 1 then + exit; + + DiskExtents := AllocMem(MAX_PATH); + try + if DeviceIoControl(hVolume, + IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS, + nil, + 0, + DiskExtents, + MAX_PATH, + dwOutBytes, + nil) then + begin + if DiskExtents.dwNumberOfDriveExtents > 0 then + Result := DiskExtents.Extents[0]; + end; +// else // imdisk로 마운트한 드라이브 정보를 가져오기 위해서 아래처럼 시도 하지만.. 정보를 제대로 가져오지 못하는 상황이다 15_0202 17:45:02 sunk +// if DeviceIoControl(hVolume, +// IOCTL_DISK_GET_DRIVE_GEOMETRY, +// nil, +// 0, +// @DriveExtent, +// SizeOf(DriveExtent), +// dwOutBytes, +// nil) then +// begin +// Result := DriveExtent; +// end; + + // todo : IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS 이걸로 안되는거 IOCTL_DISK_GET_DRIVE_GEOMETRY_EX 이걸로 한번더 확인해 보기 + + finally + Finalize(DiskExtents); + FreeMem(DiskExtents, Max_Path); + CloseHandle(hVolume); + end; +end; + +function GetDriveSize(const sDrive: String): ULONGLONG; +var + bResult: Boolean; + llAvail, + llTotal, + llFree: TLargeInteger; +begin + Result := 0; + +// 윈도우 xp에서 빈디스크 에러 메시지 걸러내기 2012-01-25 sunk +// 보안, 가상 드라이브의 경우 IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS가 항상 실패 25_0423 08:45:20 kku +// if GetDriveExtent(sDrive[1]).liExtentLength.QuadPart = 0 then +// exit; + + bResult := GetDiskFreeSpaceEx(PChar(sDrive), llAvail, llTotal, @llFree); + if bResult = true then + Result := llTotal; +end; + +function GetDriveFree(const sDrive: String): ULONGLONG; +var + FSectorsPerCluster, + FBytesPerSector, + FNumberOfFreeClusters, + + FTotalNumberOfClusters: DWORD; +begin + Result := 0; + if sDrive = '' then + exit; + + if GetDriveExtent(sDrive[1]).liExtentLength.QuadPart = 0 then + exit; + + FSectorsPerCluster := 0; + FBytesPerSector := 0; + FNumberOfFreeClusters := 0; + FTotalNumberOfClusters := 0; + + // GetDiskFreeSpace() API 호출 + GetDiskFreeSpace( + PChar(sDrive), + FSectorsPerCluster, + FBytesPerSector, + FNumberOfFreeClusters, + FTotalNumberOfClusters + ); + Result := ULONGLONG(FBytesPerSector) * FSectorsPerCluster * FNumberOfFreeClusters; +end; + +function GetVolumeSerial(const sDrive: String): DWORD; +var + sVolumeName: array [0..255] of Char; + dwMaxComponentLen: DWORD; + sFileSystemName: array[0..255] of Char; + dwFileSystemFlag: DWORD; + bResult: Boolean; +// ErrCode: DWORD; +begin + Result := 0; + bResult := GetVolumeInformation(PWideChar(sDrive), sVolumeName, 256, + @Result, dwMaxComponentLen, dwFileSystemFlag, + sFileSystemName, 256); + + if not bResult then + begin +// ErrCode := GetLastError; +// OutputDebugString(PChar('GetVolumeInformation Fail!! Error Code : ' + IntToStr(ErrCode))); + end; +end; + +function GetVolumeName(const sDrive: String): String; +var + sVolumeName: array [0..255] of Char; + dwVolumeSerial: DWORD; + dwMaxComponentLen: DWORD; + sFileSystemName: array[0..255] of Char; + dwFileSystemFlag: DWORD; +begin + Result := ''; + if GetVolumeInformation(PChar(sDrive), sVolumeName, 256, + @dwVolumeSerial, dwMaxComponentLen, dwFileSystemFlag, + sFileSystemName, 256) then Result := sVolumeName; +end; + +function GetVolumeFilesystem(const sDrive: String): String; +var + sVolumeName: array [0..255] of Char; + dwVolumeSerial: DWORD; + dwMaxComponentLen: DWORD; + sFileSystemName: array[0..255] of Char; + dwFileSystemFlag: DWORD; +begin + Result := ''; + if GetVolumeInformation(PChar(sDrive), sVolumeName, 256, + @dwVolumeSerial, dwMaxComponentLen, dwFileSystemFlag, + sFileSystemName, 256) then Result := sFileSystemName; +end; + +function GetDriveTypeToStr(nType: Integer): String; +begin + case nType of + DRIVE_FIXED : Result := 'FIXED'; + DRIVE_CDROM : Result := 'CDROM'; + DRIVE_REMOVABLE : Result := 'REMOVABLE'; + else Result := 'Unknown'; + end; +end; + +// 0 : 쓰기 가능, 1 : 읽기 전용, 2 : 권한 없음, 3 : 공간 부족 +function IsReadOnlyByWriteProbe(const sDrive: String): Integer; +var + sTmpPath: string; + h: THandle; +begin + Result := 0; + // 루트에 직접 파일 쓰기 시도 (권한 문제를 피하려면 하위 폴더를 탐색해서 시도해도 됨) + sTmpPath := IncludeTrailingPathDelimiter(sDrive) + '_wr_probe_.tmp'; + + if FileExists(sTmpPath) then + DeleteFile(PChar(sTmpPath)); + + h := CreateFile(PChar(sTmpPath), + GENERIC_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE, + nil, + CREATE_NEW, + FILE_ATTRIBUTE_TEMPORARY or FILE_FLAG_DELETE_ON_CLOSE, + 0); + if h = INVALID_HANDLE_VALUE then + begin + case GetLastError of + ERROR_WRITE_PROTECT : Result := 1; + ERROR_ACCESS_DENIED : Result := 2; + ERROR_DISK_FULL : Result := 3; + end + end else + CloseHandle(h); +end; + +// ThdUsbMon.pas 에서 SetReadOnly() 을 가져옴 25_1015 16:21:30 kku +procedure SetDriveReadOnly(sDrive: String; nDiskNum: Integer; bVal: Boolean); +var + StrList: TStringList; + sTemp, + sDrvPath, + sScptPath: String; + nTO, + nRst: Integer; + fs: TFileStream; +begin + if sDrive = '' then + exit; + + if nDiskNum <= 0 then + exit; + + sScptPath := GetRunExePathDir + Format('$d-scrpt=%d.txt', [GetTickCount]); + Guard(StrList, TStringList.Create); + StrList.Add(Format(DISKPART_FMT_SELECT, [nDiskNum])); + if bVal then + StrList.Add(DISKPART_SET_ATTRIBUTES_READONLY) + else + StrList.Add(DISKPART_DEL_ATTRIBUTES_READONLY); + StrList.SaveToFile(sScptPath, TEncoding.ANSI); + ExecuteAppWaitUntilTerminate('diskpart.exe', Format('/s "%s"', [sScptPath]), SW_HIDE, 10000); + DeleteFile_wait(PChar(sScptPath), 2); +end; + +{ TTgDriveExtent } + +Constructor TTgDriveExtent.Create; +begin + Inherited Create; + lstEntry_ := TDriveEntentList.Create; + lstEntry_.OnNotify := OnEntryNotify; + RefreshDriveExtent; +end; + +Destructor TTgDriveExtent.Destroy; +begin + FreeAndNil(lstEntry_); + Inherited; +end; + +procedure TTgDriveExtent.OnEntryNotify(Sender: TObject; const Item: PDriveExtentEntry; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +function TTgDriveExtent.GetCount: Integer; +begin + Result := lstEntry_.Count; +end; + +function TTgDriveExtent.GetItem(nIndex: Integer): PDriveExtentEntry; +begin + Result := nil; + if (nIndex > -1) and (nIndex < lstEntry_.Count) then + Result := lstEntry_[nIndex]; +end; + +procedure TTgDriveExtent.RefreshDriveExtent; +var + dwDriveMask: DWORD; + ucDrive: Byte; + sDrive: String; + Extent: TDriveExtent; + pEntry: PDriveExtentEntry; +begin + lstEntry_.Clear; + + dwDriveMask := GetLogicalDrives; + for ucDrive := 0 to 31 do + if (dwDriveMask and (1 shl ucDrive)) > 0 then + begin + sDrive := Format('%s:\', [Char(ucDrive + 65)]); + Extent := GetDriveExtent(sDrive); + if Extent.liExtentLength.QuadPart > 0 then + begin + case GetDriveType(PChar(sDrive)) of + DRIVE_UNKNOWN, + DRIVE_REMOTE, + DRIVE_CDROM: continue; + end; + + New(pEntry); + ZeroMemory(pEntry, SizeOf(TDriveExtentEntry)); + pEntry.sDrive := sDrive; + with Extent do + begin + pEntry.wDiskNum := dwDiskNumber; + pEntry.ullStartSector := liStartingOffset.QuadPart div 512; + pEntry.ullTotalSectors := liExtentLength.QuadPart div 512; + end; + lstEntry_.Add(pEntry); + end; + end; +end; + +{ TDevPathLetterList } + +procedure TDevPathLetterList.Notify(const Item: PDevPathLetter; Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +end. + diff --git a/Tocsg.Lib/VCL/Tocsg.DllEntry.pas b/Tocsg.Lib/VCL/Tocsg.DllEntry.pas new file mode 100644 index 00000000..f99966c6 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.DllEntry.pas @@ -0,0 +1,81 @@ +{*******************************************************} +{ } +{ Tocsg.DllEntry } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.DllEntry; + +interface + +uses + Tocsg.Obj, System.SysUtils, Winapi.Windows; + +type + TTgDllEntry = class(TTgObject) + private + dwPID_: DWORD; + sDllPath_, + sDllName_, + sModulePath_, + sModuleName_: String; + public + Constructor Create; + Destructor Destroy; override; + + property PID: DWORD read dwPID_; + property ModulePath: String read sModulePath_; + property ModuleName: String read sModuleName_; + property DllPath: String read sDllPath_; + property DllName: String read sDllName_; + end; + +implementation + +uses + Tocsg.KERNEL32; + +{ TTgDllEntry } + +Constructor TTgDllEntry.Create; + + procedure InitInformation; + var + sPath: array [0..512] of Char; + hm: HMODULE; + begin + dwPID_ := GetCurrentProcessId; + GetModuleFileName(0, sPath, 512); + sModulePath_ := sPath; + sModuleName_ := ExtractFileName(sPath); + + sDllPath_ := ''; + sDllName_ := ''; + + // 추가 16_0112 16:14:56 kku + if GetModuleHandleEx(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, 'InstallWindowActiveHook', @hm) and (hm <> 0) then + begin + sDllPath_ := GetModuleName(hm); + if sDllPath_ <> '' then + begin + sDllName_ := ExtractFileName(sDllPath_); + sDllPath_ := ExtractFilePath(sDllPath_); + end; + end; + end; + +begin + Inherited Create; + InitInformation; + _Trace('[%s] DllEntry::%s.Create()', [ClassName, ModuleName]); +end; + +Destructor TTgDllEntry.Destroy; +begin + _Trace('[%s] DllEntry::%s.Destroy()', [ClassName, ModuleName]); + Inherited; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Driver.pas b/Tocsg.Lib/VCL/Tocsg.Driver.pas new file mode 100644 index 00000000..e6450f7b --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Driver.pas @@ -0,0 +1,2151 @@ +{*******************************************************} +{ } +{ Tocsg.Driver } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.Driver; + +interface + +uses + Winapi.Windows, EM.winioctl, System.Classes, System.SysUtils, Tocsg.Obj; + +const + FAIL_EJECT = '!FAIL'; + METHOD_BUFFERED = 0; + METHOD_IN_DIRECT = 1; + METHOD_OUT_DIRECT = 2; + METHOD_NEITHER = 3; + + IOCTL_DISK_BASE = FILE_DEVICE_DISK; + + IOCTL_VOLUME_BASE = DWORD('V'); + {$EXTERNALSYM IOCTL_VOLUME_BASE} + + IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS = ( + (IOCTL_VOLUME_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or + (0 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS} + +/////// GPT를 인식하기 위해 추가 2011-02-10 sunk + IOCTL_DISK_GET_PARTITION_INFO = ( + (IOCTL_DISK_BASE shl 16) or (FILE_READ_ACCESS shl 14) or + ($0001 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_GET_PARTITION_INFO} + + IOCTL_DISK_SET_PARTITION_INFO = ( + (IOCTL_DISK_BASE shl 16) or ((FILE_READ_ACCESS or FILE_WRITE_ACCESS) shl 14) or + ($0002 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_SET_PARTITION_INFO} + + IOCTL_DISK_GET_DRIVE_LAYOUT = ( + (IOCTL_DISK_BASE shl 16) or (FILE_READ_ACCESS shl 14) or + ($0003 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_GET_DRIVE_LAYOUT} + + IOCTL_DISK_SET_DRIVE_LAYOUT = ( + (IOCTL_DISK_BASE shl 16) or ((FILE_READ_ACCESS or FILE_WRITE_ACCESS) shl 14) or + ($0004 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_SET_DRIVE_LAYOUT} + + IOCTL_VOLUME_IS_CLUSTERED = ( + (IOCTL_VOLUME_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or + (12 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_VOLUME_IS_CLUSTERED} + + IOCTL_DISK_GET_PARTITION_INFO_EX = ( + (IOCTL_DISK_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0012 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_GET_PARTITION_INFO_EX} + + IOCTL_DISK_SET_PARTITION_INFO_EX = ( + (IOCTL_DISK_BASE shl 16) or ((FILE_READ_ACCESS or FILE_WRITE_ACCESS) shl 14) or + ($0013 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_SET_PARTITION_INFO_EX} + + IOCTL_DISK_GET_DRIVE_LAYOUT_EX = ( + (IOCTL_DISK_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0014 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_GET_DRIVE_LAYOUT_EX} + + IOCTL_DISK_SET_DRIVE_LAYOUT_EX = ( + (IOCTL_DISK_BASE shl 16) or ((FILE_READ_ACCESS or FILE_WRITE_ACCESS) shl 14) or + ($0015 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_SET_DRIVE_LAYOUT_EX} + + IOCTL_STORAGE_GET_DEVICE_NUMBER = ( + (IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0420 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_STORAGE_GET_DEVICE_NUMBER} + + IOCTL_DISK_GET_LENGTH_INFO = ( + (IOCTL_DISK_BASE shl 16) or (FILE_READ_ACCESS shl 14) or + ($0017 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_GET_LENGTH_INFO} + + IOCTL_DISK_GET_DRIVE_GEOMETRY_EX = ( + (IOCTL_DISK_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0028 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_DISK_GET_DRIVE_GEOMETRY_EX} + + IOCTL_STORAGE_QUERY_PROPERTY = ( + (IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0500 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_STORAGE_QUERY_PROPERTY} + + IOCTL_STORAGE_GET_MEDIA_TYPES_EX = ( + (IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0301 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_STORAGE_GET_MEDIA_TYPES_EX} + + IOCTL_STORAGE_MEDIA_REMOVAL = ( + (IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or + ($0201 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_STORAGE_MEDIA_REMOVAL} + + IOCTL_STORAGE_EJECTION_CONTROL = $2D0940;//CTL_CODE(IOCTL_STORAGE_BASE, $0250, METHOD_BUFFERED, FILE_ANY_ACCESS); //$2D0940 + {$EXTERNALSYM IOCTL_STORAGE_EJECTION_CONTROL} + + IOCTL_STORAGE_EJECT_MEDIA = ( + (IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or + ($0202 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM IOCTL_STORAGE_EJECT_MEDIA} + + FSCTL_LOCK_VOLUME = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0006 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_LOCK_VOLUME} + + FSCTL_UNLOCK_VOLUME = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0007 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_UNLOCK_VOLUME} + + FSCTL_DISMOUNT_VOLUME = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0008 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_DISMOUNT_VOLUME} + + FSCTL_IS_VOLUME_MOUNTED = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($000A shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_IS_VOLUME_MOUNTED} + + FSCTL_FILESYSTEM_GET_STATISTICS = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0018 shl 2) or METHOD_BUFFERED); // FILESYSTEM_STATISTICS + {$EXTERNALSYM FSCTL_FILESYSTEM_GET_STATISTICS} + + FSCTL_GET_NTFS_VOLUME_DATA = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0019 shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_GET_NTFS_VOLUME_DATA} + + FSCTL_GET_NTFS_FILE_RECORD = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($001A shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_GET_NTFS_FILE_RECORD} + + FSCTL_GET_VOLUME_BITMAP = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($001B shl 2) or METHOD_NEITHER); + {$EXTERNALSYM FSCTL_GET_VOLUME_BITMAP} + + FSCTL_GET_RETRIEVAL_POINTERS = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($001C shl 2) or METHOD_NEITHER); + {$EXTERNALSYM FSCTL_GET_RETRIEVAL_POINTERS} + + FSCTL_MOVE_FILE = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or + ($001D shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_MOVE_FILE} + + FSCTL_IS_VOLUME_DIRTY = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($001E shl 2) or METHOD_BUFFERED); + {$EXTERNALSYM FSCTL_IS_VOLUME_DIRTY} + + FSCTL_ALLOW_EXTENDED_DASD_IO = ( + (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or + ($0020 shl 2) or METHOD_NEITHER); + {$EXTERNALSYM FSCTL_ALLOW_EXTENDED_DASD_IO} + + GUID_DEVINTERFACE_DISK: TGUID = ( + D1:$53f56307; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_DISK} + GUID_DEVINTERFACE_CDROM: TGUID = ( + D1:$53f56308; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); +// GUID_DEVINTERFACE_CDROM: TGUID = '{53f56308-b6bf-11d0-94f2-00a0c91efb8b}'; + {$EXTERNALSYM GUID_DEVINTERFACE_CDROM} + GUID_DEVINTERFACE_PARTITION: TGUID = ( + D1:$53f5630a; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_PARTITION} + GUID_DEVINTERFACE_TAPE: TGUID = ( + D1:$53f5630b; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_TAPE} + GUID_DEVINTERFACE_WRITEONCEDISK: TGUID = ( + D1:$53f5630c; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_WRITEONCEDISK} + GUID_DEVINTERFACE_VOLUME: TGUID = ( + D1:$53f5630d; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_VOLUME} + GUID_DEVINTERFACE_MEDIUMCHANGER: TGUID = ( + D1:$53f56310; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_MEDIUMCHANGER} + GUID_DEVINTERFACE_FLOPPY: TGUID = ( + D1:$53f56311; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_FLOPPY} + GUID_DEVINTERFACE_CDCHANGER: TGUID = ( + D1:$53f56312; D2:$b6bf; D3:$11d0; D4:($94, $f2, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_CDCHANGER} + GUID_DEVINTERFACE_STORAGEPORT: TGUID = ( + D1:$2accfe60; D2:$c130; D3:$11d2; D4:($b0, $82, $00, $a0, $c9, $1e, $fb, $8b)); + {$EXTERNALSYM GUID_DEVINTERFACE_STORAGEPORT} + GUID_DEVINTERFACE_COMPORT: TGUID = ( + D1:$86e0d1e0; D2:$8089; D3:$11d0; D4:($9c, $e4, $08, $00, $3e, $30, $1f, $73)); + {$EXTERNALSYM GUID_DEVINTERFACE_COMPORT} + GUID_DEVINTERFACE_SERENUM_BUS_ENUMERATOR: TGUID = ( + D1:$4D36E978; D2:$E325; D3:$11CE; D4:($BF, $C1, $08, $00, $2B, $E1, $03, $18)); + {$EXTERNALSYM GUID_DEVINTERFACE_SERENUM_BUS_ENUMERATOR} + + GUID_DEVCLASS_NET: TGUID = ( + D1:$4d36e972; D2:$e325; D3:$11ce; D4:($bf, $c1, $08, $00, $2b, $e1, $03, $18)); + {$EXTERNALSYM GUID_DEVCLASS_NET} + + GUID_DEVCLASS_BLUETOOTH: TGUID = ( + D1:$e0cbf06c; D2:$cd8b; D3:$4647; D4:($bb, $8a, $26, $3b, $43, $f0, $f9, $74)); + {$EXTERNALSYM GUID_DEVCLASS_BLUETOOTH} + + GUID_DEVCLASS_USB: TGUID = ( + D1:$36fc9e60; D2:$c465; D3:$11cf; D4:($80, $56, $44, $45, $53, $54, $00, $00)); + {$EXTERNALSYM GUID_DEVCLASS_USB} + + GUID_DEVCLASS_USB_DEVICE: TGUID = ( + D1:$88bae032; D2:$5a81; D3:$49f0; D4:($bc, $3d, $a4, $ff, $13, $82, $16, $d6)); + {$EXTERNALSYM GUID_DEVCLASS_USB} + + GUID_DEVCLASS_WPD: TGUID = ( + D1:$eec5ad98; D2:$8080; D3:$425f; D4:($92, $2a, $da, $bf, $3d, $e3, $f6, $9a)); + {$EXTERNALSYM GUID_DEVCLASS_WPD} + + DIGCF_DEFAULT = $00000001; + DIGCF_PRESENT = $00000002; + DIGCF_ALLCLASSES = $00000004; + DIGCF_PROFILE = $00000008; + DIGCF_DEVICEINTERFACE = $00000010; + + SPDRP_DEVICEDESC = $00000000; // 설명 + SPDRP_HARDWAREID = $00000001; + SPDRP_COMPATIBLEIDS = $00000002; + SPDRP_UNUSED0 = $00000003; + SPDRP_SERVICE = $00000004; + SPDRP_UNUSED1 = $00000005; + SPDRP_UNUSED2 = $00000006; + SPDRP_CLASS = $00000007; + SPDRP_CLASSGUID = $00000008; + SPDRP_DRIVER = $00000009; + SPDRP_CONFIGFLAGS = $0000000A; + SPDRP_MFG = $0000000B; // 업체명 + SPDRP_FRIENDLYNAME = $0000000C; + SPDRP_LOCATION_INFORMATION = $0000000D; + SPDRP_PHYSICAL_DEVICE_OBJECT_NAME = $0000000E; + SPDRP_CAPABILITIES = $0000000F; + SPDRP_UI_NUMBER = $00000010; + SPDRP_UPPERFILTERS = $00000011; + SPDRP_LOWERFILTERS = $00000012; + SPDRP_BUSTYPEGUID = $00000013; + SPDRP_LEGACYBUSTYPE = $00000014; + SPDRP_BUSNUMBER = $00000015; + SPDRP_ENUMERATOR_NAME = $00000016; + SPDRP_SECURITY = $00000017; + SPDRP_SECURITY_SDS = $00000018; + SPDRP_DEVTYPE = $00000019; + SPDRP_EXCLUSIVE = $0000001A; + SPDRP_CHARACTERISTICS = $0000001B; + SPDRP_ADDRESS = $0000001C; + SPDRP_UI_NUMBER_DESC_FORMAT = $0000001D; + SPDRP_DEVICE_POWER_DATA = $0000001E; + SPDRP_REMOVAL_POLICY = $0000001F; + SPDRP_LOCATION_PATHS = $00000023; + SPDRP_BASE_CONTAINERID = $00000024; + SPDRP_MAXIMUM_PROPERTY = $00000025; + + DN_ROOT_ENUMERATED = $00000001; // Was enumerated by ROOT + DN_DRIVER_LOADED = $00000002; // Has Register_Device_Driver + DN_ENUM_LOADED = $00000004; // Has Register_Enumerator + DN_STARTED = $00000008; // Is currently configured + DN_MANUAL = $00000010; // Manually installed + DN_NEED_TO_ENUM = $00000020; // May need reenumeration + DN_NOT_FIRST_TIME = $00000040; // Has received a config + DN_HARDWARE_ENUM = $00000080; // Enum generates hardware ID + DN_LIAR = $00000100; // Lied about can reconfig once + DN_HAS_MARK = $00000200; // Not CM_Create_DevInst lately + DN_HAS_PROBLEM = $00000400; // Need device installer + DN_FILTERED = $00000800; // Is filtered + DN_MOVED = $00001000; // Has been moved + DN_DISABLEABLE = $00002000; // Can be disabled + DN_REMOVABLE = $00004000; // Can be removed + DN_PRIVATE_PROBLEM = $00008000; // Has a private problem + DN_MF_PARENT = $00010000; // Multi function parent + DN_MF_CHILD = $00020000; // Multi function child + DN_WILL_BE_REMOVED = $00040000; // DevInst is being removed + + CR_SUCCESS = 0; + CM_PROB_NOT_CONFIGURED = $00000001; // no config for device + CM_PROB_DEVLOADER_FAILED = $00000002; // service load failed + CM_PROB_OUT_OF_MEMORY = $00000003; // out of memory + CM_PROB_ENTRY_IS_WRONG_TYPE = $00000004; // + CM_PROB_LACKED_ARBITRATOR = $00000005; // + CM_PROB_BOOT_CONFIG_CONFLICT = $00000006; // boot config conflict + CM_PROB_FAILED_FILTER = $00000007; // + CM_PROB_DEVLOADER_NOT_FOUND = $00000008; // Devloader not found + CM_PROB_INVALID_DATA = $00000009; // Invalid ID + CM_PROB_FAILED_START = $0000000A; // + CM_PROB_LIAR = $0000000B; // + CM_PROB_NORMAL_CONFLICT = $0000000C; // config conflict + CM_PROB_NOT_VERIFIED = $0000000D; // + CM_PROB_NEED_RESTART = $0000000E; // requires restart + CM_PROB_REENUMERATION = $0000000F; // + CM_PROB_PARTIAL_LOG_CONF = $00000010; // + CM_PROB_UNKNOWN_RESOURCE = $00000011; // unknown res type + CM_PROB_REINSTALL = $00000012; // + CM_PROB_REGISTRY = $00000013; // + CM_PROB_VXDLDR = $00000014; // WINDOWS 95 ONLY + CM_PROB_WILL_BE_REMOVED = $00000015; // devinst will remove + CM_PROB_DISABLED = $00000016; // devinst is disabled + CM_PROB_DEVLOADER_NOT_READY = $00000017; // Devloader not ready + CM_PROB_DEVICE_NOT_THERE = $00000018; // device doesn't exist + CM_PROB_MOVED = $00000019; // + CM_PROB_TOO_EARLY = $0000001A; // + CM_PROB_NO_VALID_LOG_CONF = $0000001B; // no valid log config + CM_PROB_FAILED_INSTALL = $0000001C; // install failed + CM_PROB_HARDWARE_DISABLED = $0000001D; // device disabled + CM_PROB_CANT_SHARE_IRQ = $0000001E; // can't share IRQ + CM_PROB_FAILED_ADD = $0000001F; // driver failed add + CM_PROB_DISABLED_SERVICE = $00000020; // service's Start = 4 + CM_PROB_TRANSLATION_FAILED = $00000021; // resource translation failed + CM_PROB_NO_SOFTCONFIG = $00000022; // no soft config + CM_PROB_BIOS_TABLE = $00000023; // device missing in BIOS table + CM_PROB_IRQ_TRANSLATION_FAILED = $00000024; // IRQ translator failed + CM_PROB_FAILED_DRIVER_ENTRY = $00000025; // DriverEntry() failed. + CM_PROB_DRIVER_FAILED_PRIOR_UNLOAD = $00000026; // Driver should have unloaded. + CM_PROB_DRIVER_FAILED_LOAD = $00000027; // Driver load unsuccessful. + CM_PROB_DRIVER_SERVICE_KEY_INVALID = $00000028; // Error accessing driver's service key + CM_PROB_LEGACY_SERVICE_NO_DEVICES = $00000029; // Loaded legacy service created no devices + CM_PROB_DUPLICATE_DEVICE = $0000002A; // Two devices were discovered with the same name + CM_PROB_FAILED_POST_START = $0000002B; // The drivers set the device state to failed + CM_PROB_HALTED = $0000002C; // This device was failed post start via usermode + CM_PROB_PHANTOM = $0000002D; // The devinst currently exists only in the registry + CM_PROB_SYSTEM_SHUTDOWN = $0000002E; // The system is shutting down + CM_PROB_HELD_FOR_EJECT = $0000002F; // The device is offline awaiting removal + CM_PROB_DRIVER_BLOCKED = $00000030; // One or more drivers is blocked from loading + CM_PROB_REGISTRY_TOO_LARGE = $00000031; // System hive has grown too large + CM_PROB_SETPROPERTIES_FAILED = $00000032; // Failed to apply one or more registry properties + CM_PROB_WAITING_ON_DEPENDENCY = $00000033; // Device is stalled waiting on a dependency to start + CM_PROB_UNSIGNED_DRIVER = $00000034; // Failed load driver due to unsigned image. + CM_PROB_USED_BY_DEBUGGER = $00000035; // Device is being used by kernel debugger + CM_PROB_DEVICE_RESET = $00000036; // Device is being reset + CM_PROB_CONSOLE_LOCKED = $00000037; // Device is blocked while console is locked + CM_PROB_NEED_CLASS_CONFIG = $00000038; // Device needs extended class configuration to start + CM_PROB_GUEST_ASSIGNMENT_FAILED = $00000039; // Assignment to guest partition failed + + CM_REMOVE_UI_OK = $00000000; + CM_REMOVE_UI_NOT_OK = $00000001; + CM_REMOVE_NO_RESTART = $00000002; + CM_REMOVE_BITS = $00000003; + + DIF_SELECTDEVICE = $00000001; + DIF_INSTALLDEVICE = $00000002; + DIF_ASSIGNRESOURCES = $00000003; + DIF_PROPERTIES = $00000004; + DIF_REMOVE = $00000005; + DIF_FIRSTTIMESETUP = $00000006; + DIF_FOUNDDEVICE = $00000007; + DIF_SELECTCLASSDRIVERS = $00000008; + DIF_VALIDATECLASSDRIVERS = $00000009; + DIF_INSTALLCLASSDRIVERS = $0000000A; + DIF_CALCDISKSPACE = $0000000B; + DIF_DESTROYPRIVATEDATA = $0000000C; + DIF_VALIDATEDRIVER = $0000000D; + DIF_DETECT = $0000000F; + DIF_INSTALLWIZARD = $00000010; + DIF_DESTROYWIZARDDATA = $00000011; + DIF_PROPERTYCHANGE = $00000012; + DIF_ENABLECLASS = $00000013; + DIF_DETECTVERIFY = $00000014; + DIF_INSTALLDEVICEFILES = $00000015; + DIF_UNREMOVE = $00000016; + DIF_SELECTBESTCOMPATDRV = $00000017; + DIF_ALLOW_INSTALL = $00000018; + DIF_REGISTERDEVICE = $00000019; + DIF_NEWDEVICEWIZARD_PRESELECT = $0000001A; + DIF_NEWDEVICEWIZARD_SELECT = $0000001B; + DIF_NEWDEVICEWIZARD_PREANALYZE = $0000001C; + DIF_NEWDEVICEWIZARD_POSTANALYZE = $0000001D; + DIF_NEWDEVICEWIZARD_FINISHINSTALL = $0000001E; + DIF_UNUSED1 = $0000001F; + DIF_INSTALLINTERFACES = $00000020; + DIF_DETECTCANCEL = $00000021; + DIF_REGISTER_COINSTALLERS = $00000022; + DIF_ADDPROPERTYPAGE_ADVANCED = $00000023; + DIF_ADDPROPERTYPAGE_BASIC = $00000024; + DIF_RESERVED1 = $00000025; + DIF_TROUBLESHOOTER = $00000026; + DIF_POWERMESSAGEWAKE = $00000027; + DIF_ADDREMOTEPROPERTYPAGE_ADVANCED = $00000028; + DIF_UPDATEDRIVER_UI = $00000029; + DIF_FINISHINSTALL_ACTION = $0000002A; + DIF_RESERVED2 = $00000030; + + DICS_FLAG_GLOBAL = $00000001; // make change in all hardware profiles + DICS_FLAG_CONFIGSPECIFIC = $00000002; // make change in specified profile only + DICS_FLAG_CONFIGGENERAL = $00000004; // 1 or more hardware profile-specific + + DICS_ENABLE = $00000001; + DICS_DISABLE = $00000002; + DICS_PROPCHANGE = $00000003; + DICS_START = $00000004; + DICS_STOP = $00000005; + // changes to follow. + +// +// Support for GUID Partition Table (GPT) disks. +// + +// +// There are currently two ways a disk can be partitioned. With a traditional +// AT-style master boot record (PARTITION_STYLE_MBR) and with a new, GPT +// partition table (PARTITION_STYLE_GPT). RAW is for an unrecognizable +// partition style. There are a very limited number of things you can +// do with a RAW partititon. +// + +type + GUID = TGUID; + {$NODEFINE GUID} + LPGUID = ^GUID; + {$NODEFINE LPGUID} + CLSID = TGUID; + {$NODEFINE CLSID} + + ULONG64 = Int64; + {$EXTERNALSYM ULONG64} + PULONG64 = ^ULONG64; + {$EXTERNALSYM PULONG64} + DWORD64 = Int64; + {$EXTERNALSYM DWORD64} + PDWORD64 = ^DWORD64; + {$EXTERNALSYM PDWORD64} + UINT64 = Int64; + {$EXTERNALSYM UINT64} + PUINT64 = ^UINT64; + {$EXTERNALSYM PUINT64} + + PPREVENT_MEDIA_REMOVAL = ^PREVENT_MEDIA_REMOVAL; + {$EXTERNALSYM PPREVENT_MEDIA_REMOVAL} + _PREVENT_MEDIA_REMOVAL = record + PreventMediaRemoval: ByteBool; + end; + {$EXTERNALSYM _PREVENT_MEDIA_REMOVAL} + PREVENT_MEDIA_REMOVAL = _PREVENT_MEDIA_REMOVAL; + {$EXTERNALSYM PREVENT_MEDIA_REMOVAL} + TPreventMediaRemoval = PREVENT_MEDIA_REMOVAL; + PPreventMediaRemoval = PPREVENT_MEDIA_REMOVAL; + + PSTORAGE_DEVICE_NUMBER = ^STORAGE_DEVICE_NUMBER; + {$EXTERNALSYM PSTORAGE_DEVICE_NUMBER} + _STORAGE_DEVICE_NUMBER = record + // + // The FILE_DEVICE_XXX type for this device. + // + DeviceType: DEVICE_TYPE; + // + // The number of this device + // + DeviceNumber: DWORD; + // + // If the device is partitionable, the partition number of the device. + // Otherwise -1 + // + PartitionNumber: DWORD; + end; + {$EXTERNALSYM _STORAGE_DEVICE_NUMBER} + STORAGE_DEVICE_NUMBER = _STORAGE_DEVICE_NUMBER; + {$EXTERNALSYM STORAGE_DEVICE_NUMBER} + TStorageDeviceNumber = STORAGE_DEVICE_NUMBER; + PStorageDeviceNumber = PSTORAGE_DEVICE_NUMBER; + + + _PARTITION_STYLE = ( + PARTITION_STYLE_MBR, + PARTITION_STYLE_GPT, + PARTITION_STYLE_RAW); + {$EXTERNALSYM _PARTITION_STYLE} + PARTITION_STYLE = _PARTITION_STYLE; + {$EXTERNALSYM PARTITION_STYLE} + TPartitionStyle = PARTITION_STYLE; + +// +// The following structure defines information in a GPT partition that is +// not common to both GPT and MBR partitions. +// + + PPARTITION_INFORMATION_GPT = ^PARTITION_INFORMATION_GPT; + {$EXTERNALSYM PPARTITION_INFORMATION_GPT} + _PARTITION_INFORMATION_GPT = record + PartitionType: GUID; // Partition type. See table 16-3. + PartitionId: GUID; // Unique GUID for this partition. + Attributes: DWORD64; // See table 16-4. + Name: array [0..35] of WCHAR; // Partition Name in Unicode. + end; + {$EXTERNALSYM _PARTITION_INFORMATION_GPT} + PARTITION_INFORMATION_GPT = _PARTITION_INFORMATION_GPT; + {$EXTERNALSYM PARTITION_INFORMATION_GPT} + TPartitionInformationGpt = PARTITION_INFORMATION_GPT; + PPartitionInformationGpt = PPARTITION_INFORMATION_GPT; + + +{ + _PREVENT_MEDIA_REMOVAL = record + PreventMediaRemoval : Boolean; + end; + PREVENT_MEDIA_REMOVAL = _PREVENT_MEDIA_REMOVAL; + } + +// +// The following are GPT partition attributes applicable for any +// partition type. These attributes are not OS-specific +// + +const + GPT_ATTRIBUTE_PLATFORM_REQUIRED = $0000000000000001; + {$EXTERNALSYM GPT_ATTRIBUTE_PLATFORM_REQUIRED} + +// +// The following are GPT partition attributes applicable when the +// PartitionType is PARTITION_BASIC_DATA_GUID. +// + + GPT_BASIC_DATA_ATTRIBUTE_NO_DRIVE_LETTER = DWORD($8000000000000000); + {$EXTERNALSYM GPT_BASIC_DATA_ATTRIBUTE_NO_DRIVE_LETTER} + GPT_BASIC_DATA_ATTRIBUTE_HIDDEN = $4000000000000000; + {$EXTERNALSYM GPT_BASIC_DATA_ATTRIBUTE_HIDDEN} + GPT_BASIC_DATA_ATTRIBUTE_READ_ONLY = $1000000000000000; + {$EXTERNALSYM GPT_BASIC_DATA_ATTRIBUTE_READ_ONLY} + +// +// The following structure defines information in an MBR partition that is not +// common to both GPT and MBR partitions. +// + +type + PPARTITION_INFORMATION_MBR = ^PARTITION_INFORMATION_MBR; + {$EXTERNALSYM PPARTITION_INFORMATION_MBR} + _PARTITION_INFORMATION_MBR = record + PartitionType: BYTE; + BootIndicator: BOOLEAN; + RecognizedPartition: BOOLEAN; + HiddenSectors: DWORD; + end; + {$EXTERNALSYM _PARTITION_INFORMATION_MBR} + PARTITION_INFORMATION_MBR = _PARTITION_INFORMATION_MBR; + {$EXTERNALSYM PARTITION_INFORMATION_MBR} + TPartitionInformationMbr = PARTITION_INFORMATION_MBR; + PPartitionInformationMbr = PPARTITION_INFORMATION_MBR; + +// +// The structure SET_PARTITION_INFO_EX is used with the ioctl +// IOCTL_SET_PARTITION_INFO_EX to set information about a specific +// partition. Note that for MBR partitions, you can only set the partition +// signature, whereas GPT partitions allow setting of all fields that +// you can get. +// + + SET_PARTITION_INFORMATION_MBR = SET_PARTITION_INFORMATION; + {$EXTERNALSYM SET_PARTITION_INFORMATION_MBR} + TSetPartitionInformationMbr = SET_PARTITION_INFORMATION_MBR; + SET_PARTITION_INFORMATION_GPT = PARTITION_INFORMATION_GPT; + {$EXTERNALSYM SET_PARTITION_INFORMATION_GPT} + TSetPartitionInformationGpt = SET_PARTITION_INFORMATION_GPT; + + PSET_PARTITION_INFORMATION_EX = ^SET_PARTITION_INFORMATION_EX; + {$EXTERNALSYM PSET_PARTITION_INFORMATION_EX} + _SET_PARTITION_INFORMATION_EX = record + PartitionStyle: PARTITION_STYLE; + case Integer of + 0: (Mbr: SET_PARTITION_INFORMATION_MBR); + 1: (Gpt: SET_PARTITION_INFORMATION_GPT); + end; + {$EXTERNALSYM _SET_PARTITION_INFORMATION_EX} + SET_PARTITION_INFORMATION_EX = _SET_PARTITION_INFORMATION_EX; + {$EXTERNALSYM SET_PARTITION_INFORMATION_EX} + TSetPartitionInformationEx = SET_PARTITION_INFORMATION_EX; + PSetPartitionInformationEx = PSET_PARTITION_INFORMATION_EX; + +// +// The structure CREATE_DISK_GPT with the ioctl IOCTL_DISK_CREATE_DISK +// to initialize an virgin disk with an empty GPT partition table. +// + + PCREATE_DISK_GPT = ^CREATE_DISK_GPT; + {$EXTERNALSYM PCREATE_DISK_GPT} + _CREATE_DISK_GPT = record + DiskId: GUID; // Unique disk id for the disk. + MaxPartitionCount: DWORD; // Maximim number of partitions allowable. + end; + {$EXTERNALSYM _CREATE_DISK_GPT} + CREATE_DISK_GPT = _CREATE_DISK_GPT; + {$EXTERNALSYM CREATE_DISK_GPT} + TCreateDiskGpt = CREATE_DISK_GPT; + PCreateDiskGpt = PCREATE_DISK_GPT; + +// +// The structure CREATE_DISK_MBR with the ioctl IOCTL_DISK_CREATE_DISK +// to initialize an virgin disk with an empty MBR partition table. +// + + PCREATE_DISK_MBR = ^CREATE_DISK_MBR; + {$EXTERNALSYM PCREATE_DISK_MBR} + _CREATE_DISK_MBR = record + Signature: DWORD; + end; + {$EXTERNALSYM _CREATE_DISK_MBR} + CREATE_DISK_MBR = _CREATE_DISK_MBR; + {$EXTERNALSYM CREATE_DISK_MBR} + TCreateDiskMbr = CREATE_DISK_MBR; + PCreateDiskMbr = PCREATE_DISK_MBR; + + PCREATE_DISK = ^CREATE_DISK; + {$EXTERNALSYM PCREATE_DISK} + _CREATE_DISK = record + PartitionStyle: PARTITION_STYLE; + case Integer of + 0: (Mbr: CREATE_DISK_MBR); + 1: (Gpt: CREATE_DISK_GPT); + end; + {$EXTERNALSYM _CREATE_DISK} + CREATE_DISK = _CREATE_DISK; + {$EXTERNALSYM CREATE_DISK} + TCreateDisk = CREATE_DISK; + PCreateDisk = PCREATE_DISK; + +// +// The structure GET_LENGTH_INFORMATION is used with the ioctl +// IOCTL_DISK_GET_LENGTH_INFO to obtain the length, in bytes, of the +// disk, partition, or volume. +// + + PGET_LENGTH_INFORMATION = ^GET_LENGTH_INFORMATION; + {$EXTERNALSYM PGET_LENGTH_INFORMATION} + _GET_LENGTH_INFORMATION = record + Length: LARGE_INTEGER; + end; + {$EXTERNALSYM _GET_LENGTH_INFORMATION} + GET_LENGTH_INFORMATION = _GET_LENGTH_INFORMATION; + {$EXTERNALSYM GET_LENGTH_INFORMATION} + TGetLengthInformation = GET_LENGTH_INFORMATION; + PGetLengthInformation = PGET_LENGTH_INFORMATION; + +// +// The PARTITION_INFORMATION_EX structure is used with the +// IOCTL_DISK_GET_DRIVE_LAYOUT_EX, IOCTL_DISK_SET_DRIVE_LAYOUT_EX, +// IOCTL_DISK_GET_PARTITION_INFO_EX and IOCTL_DISK_GET_PARTITION_INFO_EX calls. +// + + PPARTITION_INFORMATION_EX = ^PARTITION_INFORMATION_EX; + {$EXTERNALSYM PPARTITION_INFORMATION_EX} + _PARTITION_INFORMATION_EX = record + PartitionStyle: PARTITION_STYLE; + StartingOffset: LARGE_INTEGER; + PartitionLength: LARGE_INTEGER; + PartitionNumber: DWORD; + RewritePartition: BOOLEAN; + case Integer of + 0: (Mbr: PARTITION_INFORMATION_MBR); + 1: (Gpt: PARTITION_INFORMATION_GPT); + end; + {$EXTERNALSYM _PARTITION_INFORMATION_EX} + PARTITION_INFORMATION_EX = _PARTITION_INFORMATION_EX; + {$EXTERNALSYM PARTITION_INFORMATION_EX} + TPartitionInformationEx = PARTITION_INFORMATION_EX; + PPartitionInformationEx = PPARTITION_INFORMATION_EX; + +// +// GPT specific drive layout information. +// + + PDRIVE_LAYOUT_INFORMATION_GPT = ^DRIVE_LAYOUT_INFORMATION_GPT; + {$EXTERNALSYM PDRIVE_LAYOUT_INFORMATION_GPT} + _DRIVE_LAYOUT_INFORMATION_GPT = record + DiskId: GUID; + StartingUsableOffset: LARGE_INTEGER; + UsableLength: LARGE_INTEGER; + MaxPartitionCount: DWORD; + end; + {$EXTERNALSYM _DRIVE_LAYOUT_INFORMATION_GPT} + DRIVE_LAYOUT_INFORMATION_GPT = _DRIVE_LAYOUT_INFORMATION_GPT; + {$EXTERNALSYM DRIVE_LAYOUT_INFORMATION_GPT} + TDriveLayoutInformationGpt = DRIVE_LAYOUT_INFORMATION_GPT; + PDriveLayoutInformationGpt = PDRIVE_LAYOUT_INFORMATION_GPT; + +// +// MBR specific drive layout information. +// + + PDRIVE_LAYOUT_INFORMATION_MBR = ^DRIVE_LAYOUT_INFORMATION_MBR; + {$EXTERNALSYM PDRIVE_LAYOUT_INFORMATION_MBR} + _DRIVE_LAYOUT_INFORMATION_MBR = record + Signature: DWORD; + end; + {$EXTERNALSYM _DRIVE_LAYOUT_INFORMATION_MBR} + DRIVE_LAYOUT_INFORMATION_MBR = _DRIVE_LAYOUT_INFORMATION_MBR; + {$EXTERNALSYM DRIVE_LAYOUT_INFORMATION_MBR} + TDriveLayoutInformationMbr = DRIVE_LAYOUT_INFORMATION_MBR; + PDriveLayoutInformationMbr = PDRIVE_LAYOUT_INFORMATION_MBR; + +// +// The structure DRIVE_LAYOUT_INFORMATION_EX is used with the +// IOCTL_SET_DRIVE_LAYOUT_EX and IOCTL_GET_DRIVE_LAYOUT_EX calls. +// + + PDRIVE_LAYOUT_INFORMATION_EX = ^DRIVE_LAYOUT_INFORMATION_EX; + {$EXTERNALSYM PDRIVE_LAYOUT_INFORMATION_EX} + _DRIVE_LAYOUT_INFORMATION_EX = record + PartitionStyle: DWORD; + PartitionCount: DWORD; + Union: record + case Integer of + 0: (Mbr: DRIVE_LAYOUT_INFORMATION_MBR); + 1: (Gpt: DRIVE_LAYOUT_INFORMATION_GPT); + end; + PartitionEntry: array [0..0] of PARTITION_INFORMATION_EX; + end; + {$EXTERNALSYM _DRIVE_LAYOUT_INFORMATION_EX} + DRIVE_LAYOUT_INFORMATION_EX = _DRIVE_LAYOUT_INFORMATION_EX; + {$EXTERNALSYM DRIVE_LAYOUT_INFORMATION_EX} + TDriveLayoutInformationEx = DRIVE_LAYOUT_INFORMATION_EX; + PDriveLayoutInformationEx = PDRIVE_LAYOUT_INFORMATION_EX; +/////// GPT를 인식하기 위해 추가 2011-02-10 sunk + +// 파일 클러스터 관련 ----------------------------------------------------- +type +// +// Structure for FSCTL_GET_VOLUME_BITMAP +// + + PSTARTING_LCN_INPUT_BUFFER = ^STARTING_LCN_INPUT_BUFFER; + {$EXTERNALSYM PSTARTING_LCN_INPUT_BUFFER} + STARTING_LCN_INPUT_BUFFER = record + StartingLcn: LARGE_INTEGER; + end; + {$EXTERNALSYM STARTING_LCN_INPUT_BUFFER} + TStartingLcnInputBuffer = STARTING_LCN_INPUT_BUFFER; + PStartingLcnInputBuffer = PSTARTING_LCN_INPUT_BUFFER; + + PVOLUME_BITMAP_BUFFER = ^VOLUME_BITMAP_BUFFER; + {$EXTERNALSYM PVOLUME_BITMAP_BUFFER} + VOLUME_BITMAP_BUFFER = record + StartingLcn: LARGE_INTEGER; + BitmapSize: LARGE_INTEGER; + Buffer: array [0..0] of BYTE; + end; + {$EXTERNALSYM VOLUME_BITMAP_BUFFER} + TVolumeBitmapBuffer = VOLUME_BITMAP_BUFFER; + PVolumeBitmapBuffer = PVOLUME_BITMAP_BUFFER; + +// +// Structure for FSCTL_GET_RETRIEVAL_POINTERS +// + + PSTARTING_VCN_INPUT_BUFFER = ^STARTING_VCN_INPUT_BUFFER; + {$EXTERNALSYM PSTARTING_VCN_INPUT_BUFFER} + STARTING_VCN_INPUT_BUFFER = record + StartingVcn: LARGE_INTEGER; + end; + {$EXTERNALSYM STARTING_VCN_INPUT_BUFFER} + TStartingVcnInputBuffer = STARTING_VCN_INPUT_BUFFER; + PStartingVcnInputBuffer = PSTARTING_VCN_INPUT_BUFFER; + + TRPBExtends = record + NextVcn: LARGE_INTEGER; + Lcn: LARGE_INTEGER; + end; + + PRETRIEVAL_POINTERS_BUFFER = ^RETRIEVAL_POINTERS_BUFFER; + {$EXTERNALSYM PRETRIEVAL_POINTERS_BUFFER} + RETRIEVAL_POINTERS_BUFFER = record + ExtentCount: DWORD; + StartingVcn: LARGE_INTEGER; + Extends: array [0..0] of TRPBExtends; + end; + {$EXTERNALSYM RETRIEVAL_POINTERS_BUFFER} + TRetrievalPointersBuffer = RETRIEVAL_POINTERS_BUFFER; + PRetrievalPointersBuffer = PRETRIEVAL_POINTERS_BUFFER; + +// +// Structures for FSCTL_GET_NTFS_FILE_RECORD +// + + PNTFS_FILE_RECORD_INPUT_BUFFER = ^NTFS_FILE_RECORD_INPUT_BUFFER; + {$EXTERNALSYM PNTFS_FILE_RECORD_INPUT_BUFFER} + NTFS_FILE_RECORD_INPUT_BUFFER = record + FileReferenceNumber: LARGE_INTEGER; + end; + {$EXTERNALSYM NTFS_FILE_RECORD_INPUT_BUFFER} + TNtfsFileRecordInputBuffer = NTFS_FILE_RECORD_INPUT_BUFFER; + PNtfsFileRecordInputBuffer = PNTFS_FILE_RECORD_INPUT_BUFFER; + + PNTFS_FILE_RECORD_OUTPUT_BUFFER = ^NTFS_FILE_RECORD_OUTPUT_BUFFER; + {$EXTERNALSYM PNTFS_FILE_RECORD_OUTPUT_BUFFER} + NTFS_FILE_RECORD_OUTPUT_BUFFER = record + FileReferenceNumber: LARGE_INTEGER; + FileRecordLength: DWORD; + FileRecordBuffer: array [0..0] of BYTE; + end; + {$EXTERNALSYM NTFS_FILE_RECORD_OUTPUT_BUFFER} + TNtfsFileRecordOutputBuffer = NTFS_FILE_RECORD_OUTPUT_BUFFER; + PNtfsFileRecordOutputBuffer = PNTFS_FILE_RECORD_OUTPUT_BUFFER; + +// +// Structure for FSCTL_MOVE_FILE +// + + PMOVE_FILE_DATA = ^MOVE_FILE_DATA; + {$EXTERNALSYM PMOVE_FILE_DATA} + MOVE_FILE_DATA = record + FileHandle: THandle; + StartingVcn: LARGE_INTEGER; + StartingLcn: LARGE_INTEGER; + ClusterCount: DWORD; + end; + {$EXTERNALSYM MOVE_FILE_DATA} + TMoveFileData = MOVE_FILE_DATA; + PMoveFileData = PMOVE_FILE_DATA; + + +// 추가 22_0616 16:13:02 kku --------------------------------------------------- + PHDEVINFO = ^HDEVINFO; + HDEVINFO = THandle; + PCONFIGRET = ^CONFIGRET; + CONFIGRET = DWORD; + PDEVINST = ^DEVINST; + DEVINST = DWORD; + PPNP_VETO_TYPE = ^PNP_VETO_TYPE; + PNP_VETO_TYPE = DWORD; + HMACHINE = THandle; + + PSPDeviceInterfaceData = ^TSPDeviceInterfaceData; +// 64bit에서는 packed 처리하면 안된다.. 22_0616 23:18:35 kku + SP_DEVICE_INTERFACE_DATA = {$IFNDEF WIN64} packed {$ENDIF} record + cbSize : DWORD; + InterfaceClassGuid : TGUID; + Flags : DWORD; + Reserved : ULONG_PTR; + end; + TSPDeviceInterfaceData = SP_DEVICE_INTERFACE_DATA; + + PSPDeviceInterfaceDetailDataA = ^TSPDeviceInterfaceDetailDataA; + PSPDeviceInterfaceDetailDataW = ^TSPDeviceInterfaceDetailDataW; + SP_DEVICE_INTERFACE_DETAIL_DATA_A = {$IFNDEF WIN64} packed {$ENDIF} record + cbSize : DWORD; + DevicePath : array [0..0] of AnsiChar; + end; + SP_DEVICE_INTERFACE_DETAIL_DATA_W = {$IFNDEF WIN64} packed {$ENDIF} record + cbSize : DWORD; + DevicePath : array [0..0] of WideChar; + end; + + TSPDeviceInterfaceDetailDataA = SP_DEVICE_INTERFACE_DETAIL_DATA_A; + TSPDeviceInterfaceDetailDataW = SP_DEVICE_INTERFACE_DETAIL_DATA_W; + TSPDeviceInterfaceDetailData = TSPDeviceInterfaceDetailDataW; + PSPDeviceInterfaceDetailData = ^TSPDeviceInterfaceDetailDataW; + + PSPDevInfoData = ^TSPDevInfoData; + SP_DEVINFO_DATA = {$IFNDEF WIN64} packed {$ENDIF} record + cbSize : DWORD; + ClassGuid : TGUID; + DevInst : DWORD; + Reserved : ULONG_PTR; + end; + TSPDevInfoData = SP_DEVINFO_DATA; + + DI_FUNCTION = UINT; + PSPClassInstallHeader = ^TSPClassInstallHeader; + SP_CLASSINSTALL_HEADER = {$IFNDEF WIN64} packed {$ENDIF} record + cbSize: DWORD; + InstallFunction: DI_FUNCTION; + end; + TSPClassInstallHeader = SP_CLASSINSTALL_HEADER; + + PSPPropChangeParams = ^TSPPropChangeParams; + SP_PROPCHANGE_PARAMS = {$IFNDEF WIN64} packed {$ENDIF} record + ClassInstallHeader: TSPClassInstallHeader; + StateChange: DWORD; + Scope: DWORD; + HwProfile: DWORD; + end; + TSPPropChangeParams = SP_PROPCHANGE_PARAMS; + + function SetupDiGetClassDevsW(ClassGuid: PGUID; const Enumerator: PWideChar; hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall; external 'SetupApi.dll' name 'SetupDiGetClassDevsW'; + function SetupDiGetClassDevsA(ClassGuid: PGUID; const Enumerator: PAnsiChar; hwndParent:HWND; Flags: DWORD): HDEVINFO; stdcall; external 'SetupApi.dll' name 'SetupDiGetClassDevsA'; + function SetupDiGetClassDevs(ClassGuid: PGUID; const Enumerator: PChar; hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall; external 'SetupApi.dll' name 'SetupDiGetClassDevsW'; + + function SetupDiEnumDeviceInfo(DeviceInfoSet: HDEVINFO; + MemberIndex: DWORD; var DeviceInfoData: TSPDevInfoData): LongBool; stdcall; external 'SetupApi.dll' name 'SetupDiEnumDeviceInfo'; + + function SetupDiGetDeviceRegistryPropertyA(DeviceInfoSet: HDEVINFO; + const DeviceInfoData: TSPDevInfoData; Property_: DWORD; + var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD; + var RequiredSize: DWORD): LongBool; stdcall; external 'SetupApi.dll' name 'SetupDiGetDeviceRegistryPropertyA'; + function SetupDiGetDeviceRegistryPropertyW(DeviceInfoSet: HDEVINFO; + const DeviceInfoData: TSPDevInfoData; Property_: DWORD; + var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD; + var RequiredSize: DWORD): LongBool; stdcall; external 'SetupApi.dll' name 'SetupDiGetDeviceRegistryPropertyW'; + function SetupDiGetDeviceRegistryProperty(DeviceInfoSet: HDEVINFO; + const DeviceInfoData: TSPDevInfoData; Property_: DWORD; + var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD; + var RequiredSize: DWORD): LongBool; stdcall; external 'SetupApi.dll' name 'SetupDiGetDeviceRegistryPropertyW'; + + function SetupDiSetClassInstallParamsA(DeviceInfoSet: HDEVINFO; + DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader; + ClassInstallParamsSize: DWORD): LongBool; stdcall; external 'SetupApi.dll' name 'SetupDiSetClassInstallParamsA'; + function SetupDiSetClassInstallParamsW(DeviceInfoSet: HDEVINFO; + DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader; + ClassInstallParamsSize: DWORD): LongBool; stdcall; external 'SetupApi.dll' name 'SetupDiSetClassInstallParamsW'; + function SetupDiSetClassInstallParams(DeviceInfoSet: HDEVINFO; + DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader; + ClassInstallParamsSize: DWORD): LongBool; stdcall; external 'SetupApi.dll' name 'SetupDiSetClassInstallParamsW'; + + function SetupDiCallClassInstaller(InstallFunction: DI_FUNCTION; + DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData): LongBool; stdcall; external 'SetupApi.dll' name 'SetupDiCallClassInstaller'; + + function SetupDiEnumDeviceInterfaces(DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData; + const InterfaceClassGuid: TGUID; MemberIndex: DWORD; var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall; external 'SetupApi.dll'; + + function SetupDiGetDeviceInterfaceDetailW(DeviceInfoSet: HDEVINFO; DeviceInterfaceData: PSPDeviceInterfaceData; + DeviceInterfaceDetailData: PSPDeviceInterfaceDetailData; DeviceInterfaceDetailDataSize: DWORD; + var RequiredSize: DWORD; Device: PSPDevInfoData): BOOL; stdcall; external 'SetupApi.dll' name 'SetupDiGetDeviceInterfaceDetailW'; + function SetupDiGetDeviceInterfaceDetailA(DeviceInfoSet: HDEVINFO; DeviceInterfaceData: PSPDeviceInterfaceData; + DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataA; DeviceInterfaceDetailDataSize: DWORD; + var RequiredSize: DWORD; Device: PSPDevInfoData): BOOL; stdcall; external 'SetupApi.dll' name 'SetupDiGetDeviceInterfaceDetailA'; + function SetupDiGetDeviceInterfaceDetail(DeviceInfoSet: HDEVINFO; DeviceInterfaceData: PSPDeviceInterfaceData; + DeviceInterfaceDetailData: PSPDeviceInterfaceDetailData; DeviceInterfaceDetailDataSize: DWORD; + var RequiredSize: DWORD; Device: PSPDevInfoData): BOOL; stdcall; external 'SetupApi.dll' name 'SetupDiGetDeviceInterfaceDetailW'; + function SetupDiDestroyDeviceInfoList(DeviceInfoSet: HDEVINFO): BOOL; stdcall; external 'SetupApi.dll' name 'SetupDiDestroyDeviceInfoList'; + + function SetupDiRemoveDevice(DeviceInfoSet: HDEVINFO; var DeviceInfoData: TSPDevInfoData): BOOL; stdcall; external 'SetupApi.dll' name 'SetupDiRemoveDevice'; + + function CM_Get_Parent(var dnDevInstParent: DEVINST; dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall; external 'CfgMgr32.dll'; + function CM_Query_And_Remove_SubTreeW(dnAncestor: DEVINST; pVetoType: PPNP_VETO_TYPE; pszVetoName: PWideChar; + ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall; external 'SetupApi.dll' name 'CM_Query_And_Remove_SubTreeW'; + function CM_Query_And_Remove_SubTreeA(dnAncestor: DEVINST;pVetoType: PPNP_VETO_TYPE; pszVetoName: PAnsiChar; + ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall; external 'SetupApi.dll' name 'CM_Query_And_Remove_SubTreeA'; + function CM_Query_And_Remove_SubTree(dnAncestor: DEVINST;pVetoType: PPNP_VETO_TYPE; pszVetoName: PChar; + ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall; external 'SetupApi.dll' name 'CM_Query_And_Remove_SubTreeW'; + function CM_Request_Device_EjectW(dnDevInst: DEVINST; pVetoType: PPNP_VETO_TYPE; pszVetoName: PWideChar; + ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall; external 'SetupApi.dll' name 'CM_Request_Device_EjectW'; + function CM_Request_Device_EjectA(dnDevInst: DEVINST; pVetoType: PPNP_VETO_TYPE; pszVetoName: PAnsiChar; + ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall; external 'SetupApi.dll' name 'CM_Request_Device_EjectA'; + function CM_Request_Device_Eject(dnDevInst: DEVINST; pVetoType: PPNP_VETO_TYPE; pszVetoName: PChar; + ulNameLength: ULONG; ulFlags: ULONG):CONFIGRET; stdcall; external 'SetupApi.dll' name 'CM_Request_Device_EjectW'; + + function CM_Get_Device_IDA(dnDevInst: DEVINST; Buffer: PAnsiChar; + BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall; external 'cfgmgr32.dll' name 'CM_Get_Device_IDA'; + function CM_Get_Device_IDW(dnDevInst: DEVINST; Buffer: PWideChar; + BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall; external 'cfgmgr32.dll' name 'CM_Get_Device_IDW'; + function CM_Get_Device_ID(dnDevInst: DEVINST; Buffer: PChar; + BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall; external 'cfgmgr32.dll' name 'CM_Get_Device_IDW'; + + function CM_Get_DevNode_Status(var ulStatus: ULONG; var ulProblemNumber: ULONG; + dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall; external 'cfgmgr32.dll' name 'CM_Get_DevNode_Status'; + function CM_Get_DevNode_Status_Ex(var ulStatus: ULONG; var ulProblemNumber: ULONG; + dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall; external 'cfgmgr32.dll' name 'CM_Get_DevNode_Status_Ex'; + +// 추가 22_0616 16:13:02 kku --------------------------------------------------- + +// ------------------------------------------------------------------------ + function CTL_CODE(const dwDeviceType, dwFunc, dwMethod, dwAccess: DWORD): DWORD; + function ConvSerialToStr(sSerNum: AnsiString): AnsiString; + + +type + TTgDriver = class(TTgObject) + protected + sDeviceName_: String; + hDevice_: THandle; + + function GetDeviceHandle: THandle; virtual; + public + Constructor Create; virtual; + Destructor Destroy; override; + + function OpenDevice(const sDeviceName: String; + dwDesireAccess: DWORD = GENERIC_READ or GENERIC_WRITE; + dwShareMode: DWORD = FILE_SHARE_READ or FILE_SHARE_WRITE; + dwFlagsAndAttributes: DWORD = 0): Integer; virtual; + function CloseDevice: Boolean; virtual; + + function ReadIO(dwCode: DWORD; pBuf: Pointer; + dwSize: DWORD; pdwByteReturn: PDWORD = nil): Boolean; + function WriteIO(dwCode: DWORD; pBuf: Pointer; + dwSize: DWORD; pdwByteReturn: PDWORD = nil): Boolean; + function ReadWriteIO(dwCode: DWORD; pInBuf: Pointer; dwInSize: DWORD; + pOutBuf: Pointer; dwOutSize: DWORD; + pdwByteReturn: PDWORD = nil): Boolean; + + function IsOpen: Boolean; virtual; + + property Handle: THandle read GetDeviceHandle; + property DeviceName: String read sDeviceName_; + end; + +{ +var + IOCTL_DISK_GET_LENGTH_INFO: DWORD; + IOCTL_DISK_GET_DRIVE_GEOMETRY_EX: DWORD; + IOCTL_STORAGE_QUERY_PROPERTY: DWORD; + IOCTL_STORAGE_GET_MEDIA_TYPES_EX: DWORD; + IOCTL_STORAGE_EJECTION_CONTROL: DWORD; + IOCTL_STORAGE_MEDIA_REMOVAL: DWORD; + IOCTL_STORAGE_EJECT_MEDIA: DWORD; + FSCTL_DISMOUNT_VOLUME : DWORD; + FSCTL_LOCK_VOLUME : DWORD; + FSCTL_UNLOCK_VOLUME : DWORD; + FSCTL_IS_VOLUME_MOUNTED:DWORD; + FSCTL_ALLOW_EXTENDED_DASD_IO : DWORD; + //IOCTL_STORAGE_EJECT_MEDIA : DWORD; + + IOCTL_WDMAUD_OPEN_DEVICE : DWORD = $1d8014; + IOCTL_WDMAUD_REMOVE_DEVICE : DWORD = $1d8008; + IOCTL_WDMAUD_AUX_GET_VOLUME : DWORD = $1d801c; + + //IOCTL_STORAGE_GET_DEVICE_NUMBER : DWORD = $2D1080; +} + +type + PDriveInfo = ^TDriveInfo; + TDriveInfo = record + sDrive, + sSerial, + sClass, + sClassGuid, + sDesc, + sFriendlyName: String; + llSize: LONGLONG; + nDiskNum: Integer; + end; + +function FlushDriveBuffers(const sDrive: String): Boolean; +function DeviceIoCtrl(hDevice : DWORD; dwCode: DWORD; pdwByteReturn: PDWORD = nil): Boolean; +function GetDriveDetail(sDrive: String; pInfo: PDriveInfo; bAddInfo: Boolean = false): Boolean; +function ForceEjectDrive(sDrive: String): Boolean; +function EjectDrive(sDrive: String; aIgrList: TStringList = nil; bOnlyUsb: Boolean = true; bForceEject: Boolean = false): String; +function EjectDrive2(sDrive: String; aIgrList: TStringList = nil; bOnlyUsb: Boolean = true; bForceEject: Boolean = false; bForceEjectFirst: Boolean = false): String; // 내장 cdrom 제거 23_0223 16:23:32 kku +function SetUsbDevEnableByDevPath(sDevPath: String; bVal: Boolean): Boolean; +function RemoveUsbDevEnableByDevPath(sDevPath: String): Integer; + +implementation + +uses + Tocsg.Path, + Tocsg.Safe, Tocsg.Exception, Tocsg.Convert, Tocsg.Disk, Tocsg.Trace, + Tocsg.Shell, Tocsg.Process; + +//CTL_CODE(IOCTL_STORAGE_BASE, $0250, METHOD_BUFFERED, FILE_READ_ACCESS); +function CTL_CODE(const dwDeviceType, dwFunc, dwMethod, dwAccess: DWORD): DWORD; +begin + Result := (dwDeviceType shl 16) or + (dwAccess shl 14) or + (dwFunc shl 2) or + dwMethod; +end; + +function ConvSerialToStr(sSerNum: AnsiString): AnsiString; +var + i, nStrLen: Integer; + sPair: AnsiString; + B: Byte; + Ch: AnsiChar Absolute B; +begin + Result := ''; + nStrLen := Length(sSerNum); + + if Odd(nStrLen) then + exit; + + i := 1; + + while i < nStrLen do + begin + sPair := Copy(sSerNum, i, 2); + HexToBin(PAnsiChar(sPair), PAnsiChar(@B), 1); + Result := Result + AnsiChar(B); + Inc(i, 2); + end; + + i := 1; + + nStrLen := Length(Result); + while i < nStrLen do + begin + Ch := Result[i]; + Result[i] := Result[i + 1]; + Result[i + 1] := Ch; + Inc(i, 2); + end; +end; + +{ TTgDriver } + +Constructor TTgDriver.Create; +begin + Inherited Create; + + hDevice_ := 0; +end; + +Destructor TTgDriver.Destroy; +begin + CloseDevice; + + Inherited; +end; + +function TTgDriver.GetDeviceHandle: THandle; +begin + Result := hDevice_; +end; + +// 성공 - 0, 그외 실패 +function TTgDriver.OpenDevice(const sDeviceName: String; + dwDesireAccess: DWORD = GENERIC_READ or GENERIC_WRITE; + dwShareMode: DWORD = FILE_SHARE_READ or FILE_SHARE_WRITE; + dwFlagsAndAttributes: DWORD = 0): Integer; +var + h: THandle; +begin + if hDevice_ <> 0 then + CloseDevice; + + if sDeviceName = '' then + begin + Result := ERROR_FILE_NOT_FOUND; + exit; + end; + +// if (GetVersion and $ff) >= 5 then +// sDeviceName := '\\.\Global\' + sDriverName +// else +// sDeviceName := '\\.\' + sDriverName; + + h := CreateFile(PChar(sDeviceName), + dwDesireAccess, + dwShareMode, + nil, + OPEN_EXISTING, + dwFlagsAndAttributes,//FILE_FLAG_NO_BUFFERING or FILE_FLAG_SEQUENTIAL_SCAN, + 0); + + if h = INVALID_HANDLE_VALUE then + begin + Result := GetLastError; + exit; + end; + + hDevice_ := h; + sDeviceName_ := sDeviceName; + +// 일단 플러시 실패해도 상관없으니깐 그냥 실행만 시켜준다. +// 09_1111 추가 sunk +// if FlushFileBuffers(h) then // 물리 디스크는 안되나부다.. +// _Trace('OpenDevice() - FlushFileBuffers .. success') +// else +// _Trace('OpenDevice() - FlushFileBuffers .. fail'); + + Result := ERROR_SUCCESS; +end; + +function TTgDriver.CloseDevice: Boolean; +begin + Result := false; + + if hDevice_ <> 0 then + begin + CloseHandle(hDevice_); + hDevice_ := 0; + + Result := true; + end; +end; + +function TTgDriver.ReadIO(dwCode: DWORD; pBuf: Pointer; + dwSize: DWORD; pdwByteReturn: PDWORD = nil): Boolean; +var + dwByteReturned: DWORD; +begin + Result := false; + + if hDevice_ = 0 then + exit; + + dwByteReturned := 0; + + Result := DeviceIoControl(hDevice_, + dwCode, + nil, + 0, + pBuf, + dwSize, + dwByteReturned, + nil); + + if Result and (pdwByteReturn <> nil) then + pdwByteReturn^ := dwByteReturned; +end; + +function TTgDriver.WriteIO(dwCode: DWORD; pBuf: Pointer; + dwSize: DWORD; pdwByteReturn: PDWORD = nil): Boolean; +var + dwByteReturned: DWORD; +begin + Result := false; + + if hDevice_ = 0 then + exit; + + Result := DeviceIoControl(hDevice_, + dwCode, + pBuf, + dwSize, + nil, + 0, + dwByteReturned, + nil); + + if Result and (pdwByteReturn <> nil) then + pdwByteReturn^ := dwByteReturned; +end; + +// 드라이버에 데이터 보내고 받기 +// 성공 - bytereturn +// 드라이버가 열러있지 않음, 오류 - -1 +function TTgDriver.ReadWriteIO(dwCode: DWORD; pInBuf: Pointer; dwInSize: DWORD; + pOutBuf: Pointer; dwOutSize: DWORD; + pdwByteReturn: PDWORD = nil): Boolean; +var + dwByteReturned: DWORD; +begin + Result := false; + + if hDevice_ = 0 then + exit; + + Result := DeviceIoControl(hDevice_, + dwCode, + pInBuf, + dwInSize, + pOutBuf, + dwOutSize, + dwByteReturned, + nil); + + if Result and (pdwByteReturn <> nil) then + pdwByteReturn^ := dwByteReturned; +end; + +function TTgDriver.IsOpen: Boolean; +begin + Result := (hDevice_ <> 0) and (hDevice_ <> INVALID_HANDLE_VALUE); +end; + +function FlushDriveBuffers(const sDrive: String): Boolean; +var + hVolume: THandle; + sDrivePath: String; +begin + Result := false; + sDrivePath := Format('\\.\%s:', [sDrive[1]]); + hVolume := CreateFile(PChar(sDrivePath), + GENERIC_READ or GENERIC_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE, + nil, + OPEN_EXISTING, + 0, + 0); + + if hVolume < 1 then + exit; + + Result := FlushFileBuffers(hVolume); + CloseHandle(hVolume); +end; + +function DeviceIoCtrl(hDevice : DWORD; dwCode: DWORD; pdwByteReturn: PDWORD = nil): Boolean; +var + dwByteReturned: DWORD; +begin + Result := false; + + if hDevice = 0 then + exit; + + Result := DeviceIoControl(hDevice, + dwCode, + nil, + 0, + nil, + 0, + dwByteReturned, + nil); + + if Result and (pdwByteReturn <> nil) then + pdwByteReturn^ := dwByteReturned; +end; + +function GetDevPropertyStr(hDev: HDEVINFO; spdd: TSPDevInfoData; dwProperty: DWORD): String; +var + c: Integer; + pBuf: Pointer; + dwBufSize, + dwPropertyRegDataType: DWORD; +begin + Result := ''; + try + pBuf := nil; + dwBufSize := 0; + try + while not SetupDiGetDeviceRegistryProperty(hDev, spdd, + dwProperty, dwPropertyRegDataType, pBuf, dwBufSize, dwBufSize) do + begin + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + if pBuf <> nil then + FreeMem(pBuf); + pBuf := AllocMem(dwBufSize); + end else break; + end; + + if pBuf <> nil then + Result := String(PChar(pBuf)); + finally + if pBuf <> nil then + FreeMem(pBuf); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetDevPropertyStr()'); + end; +end; + +function GetDriveDetail(sDrive: String; pInfo: PDriveInfo; bAddInfo: Boolean = false): Boolean; +var + sVol: String; + Drv: TTgDriver; + sdn: STORAGE_DEVICE_NUMBER; + dwIdx, + dwLen: DWORD; + DevGuid: TGuid; + hDev: HDEVINFO; + sdid: TSPDeviceInterfaceData; + pBuf: TBytes; + spdd: TSPDevInfoData; + DevInstParent: DEVINST; + sDevName: array [0..255] of Char; +begin + Result := false; + + ZeroMemory(pInfo, SizeOf(TDriveInfo)); + pInfo.sDrive := sDrive; + pInfo.nDiskNum := -1; + pInfo.llSize := GetDriveSize(sDrive); +// if pInfo.llSize = 0 then +// begin +// var DrvEx: TDriveExtent := GetDriveExtent(sDrive); +// pInfo.llSize := DrvEx.liExtentLength.QuadPart; +// end; + + if sDrive = '' then + exit; + + sVol := Format('\\.\%s:', [sDrive[1]]); + Guard(Drv, TTgDriver.Create); + if Drv.OpenDevice(sVol, 0) <> ERROR_SUCCESS then + exit; + + if not Drv.ReadIO(IOCTL_STORAGE_GET_DEVICE_NUMBER, @sdn, SizeOf(sdn), @dwLen) then + exit; + Drv.CloseDevice; + + if sdn.DeviceNumber = -1 then + exit; + pInfo.nDiskNum := sdn.DeviceNumber; + + case GetDriveType(PChar(sDrive)) of +// DRIVE_FIXED, +// DRIVE_REMOVABLE : DevGuid := GUID_DEVINTERFACE_DISK; + DRIVE_CDROM : DevGuid := GUID_DEVINTERFACE_CDROM; + else DevGuid := GUID_DEVINTERFACE_DISK; + end; + + hDev := SetupDiGetClassDevs(@DevGuid, nil, 0, DIGCF_PRESENT or DIGCF_DEVICEINTERFACE); + if hDev = INVALID_HANDLE_VALUE then + exit; + + try + dwIdx := 0; + while True do + begin + ZeroMemory(@sdid, SizeOf(sdid)); + sdid.cbSize := SizeOf(sdid); + if not SetupDiEnumDeviceInterfaces(hDev, nil, DevGuid, dwIdx, sdid) then + break; + + SetupDiGetDeviceInterfaceDetail(hDev, @sdid, nil, 0, dwLen, nil); + if (dwLen > 0) and (dwLen < 204800) then + begin + SetLength(pBuf, dwLen); + PSPDeviceInterfaceDetailData(@pBuf[0]).cbSize := SizeOf(TSPDeviceInterfaceDetailData); + + ZeroMemory(@spdd, SizeOf(spdd)); + spdd.cbSize := SizeOf(spdd); + + if SetupDiGetDeviceInterfaceDetail(hDev, @sdid, + PSPDeviceInterfaceDetailData(@pBuf[0]), dwLen, dwLen, @spdd) then + begin + if Drv.OpenDevice(PChar(@pBuf[4]), 0) = ERROR_SUCCESS then + begin + if not Drv.ReadIO(IOCTL_STORAGE_GET_DEVICE_NUMBER, @sdn, SizeOf(sdn), @dwLen) then + exit; + Drv.CloseDevice; + + if sdn.DeviceNumber = pInfo.nDiskNum then + begin + pInfo.sFriendlyName := GetDevPropertyStr(hDev, spdd, SPDRP_FRIENDLYNAME); + if bAddInfo then + begin + pInfo.sClass := GetDevPropertyStr(hDev, spdd, SPDRP_CLASS); + pInfo.sClassGuid := GetDevPropertyStr(hDev, spdd, SPDRP_CLASSGUID); + pInfo.sDesc := GetDevPropertyStr(hDev, spdd, SPDRP_DEVICEDESC); + end; + + ZeroMemory(@sDevName, SizeOf(sDevName)); + CM_Get_Parent(DevInstParent, spdd.DevInst, 0); + CM_Get_Device_ID(DevInstParent, sDevName, 256, 0); + + pInfo.sSerial := sDevName; + + Result := true; + exit; + end; + end; + end; + end; + Inc(dwIdx); + end; + finally + SetupDiDestroyDeviceInfoList(hDev); + end; +end; + +// for BS1 +function ForceEjectDrive(sDrive: String): Boolean; +var + sEjectMd: String; +begin + TTgTrace.T('ForceEjectDrive() ..', 1); + Result := false; + try +// if not DirectoryExists(sDrive) then +// exit; + + sEjectMd := GetRunExePathDir + 'Bs1uef.dat'; + if not FileExists(sEjectMd) then + sEjectMd := GetRunExePathDir + 'conf\Bs1uef.dat'; + + if FileExists(sEjectMd) then + begin + ExecuteAppWaitUntilTerminate(sEjectMd, Format('%s: -f', [sDrive[1]]), SW_HIDE, 10000); + if not DirectoryExists(sDrive) then + Result := true; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ForceEjectDrive()'); + end; +end; + +function LockAndDismountVolume(const DriveLetter: Char): Boolean; +var + h: THandle; + bytes: DWORD; + path: string; + i: Integer; +begin + path := Format('\\.\%s:', [UpCase(DriveLetter)]); + h := CreateFile(PChar(path), GENERIC_READ or GENERIC_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0); + if h = INVALID_HANDLE_VALUE then Exit(False); + try + // 락은 충돌 잦으니 여러 번 재시도 + for i := 1 to 20 do + if DeviceIoControl(h, FSCTL_LOCK_VOLUME, nil, 0, nil, 0, bytes, nil) then Break + else Sleep(150); // 잠시 대기 후 재시도 + + if not DeviceIoControl(h, FSCTL_LOCK_VOLUME, nil, 0, nil, 0, bytes, nil) then + Exit(False); + + // 언마운트(파일시스템 분리) + Result := DeviceIoControl(h, FSCTL_DISMOUNT_VOLUME, nil, 0, nil, 0, bytes, nil); + finally + CloseHandle(h); + end; +end; + +function EjectDrive(sDrive: String; aIgrList: TStringList = nil; + bOnlyUsb: Boolean = true; bForceEject: Boolean = false): String; +var + sVol: String; + sDevName: array [0..255] of Char; + Drv: TTgDriver; + sdn: STORAGE_DEVICE_NUMBER; + dwIdx, + dwLen: DWORD; + VetoType: PNP_VETO_TYPE; + sVetoName: PChar; + nType, nDiskNum: Integer; + DevGuid: TGuid; + hDev: HDEVINFO; + sdid: TSPDeviceInterfaceData; + pBuf: TBytes; + spdd: TSPDevInfoData; + DevInstParent: DEVINST; + bIsCdRom, + bSuccess: Boolean; + DrvEx: TDriveExtent; + i: Integer; +begin + Result := FAIL_EJECT; + + if sDrive = '' then + begin +// TTgTrace.T('Fail .. EjectDrive() .. 1'); + exit; + end; + +// bIsCdRom := GetDriveType(PChar(sDrive)) = DRIVE_CDROM; + sVol := Format('\\.\%s:', [sDrive[1]]); + Guard(Drv, TTgDriver.Create); + if Drv.OpenDevice(sVol, 0) <> ERROR_SUCCESS then + begin +// TTgTrace.T('Fail .. EjectDrive() .. 2'); + exit; + end; + + ZeroMemory(@sdn, SizeOf(sdn)); + sdn.DeviceNumber := 999; + if not Drv.ReadIO(IOCTL_STORAGE_GET_DEVICE_NUMBER, @sdn, SizeOf(sdn), @dwLen) then + exit; + Drv.CloseDevice; + nDiskNum := sdn.DeviceNumber; + +// DrvEx := GetDriveExtent(sDrive); +// if DrvEx.liExtentLength.QuadPart = 0 then +// begin +// TTgTrace.T('Fail .. EjectDrive() .. Size null .. Drive=%s', [sDrive]); +// exit; +// end; + +// nDiskNum := DrvEx.dwDiskNumber; + if (nDiskNum = -1) or (nDiskNum = 999) then + begin +// TTgTrace.T('Fail .. EjectDrive() .. Not found disknum .. Drive=%s', [sDrive], 1); + exit; + end; + +// TTgTrace.T('EjectDrive() .. Drive=%s, DiskNum=%d', [sDrive, nDiskNum], 1); + + nType := GetDriveType(PChar(sDrive)); + case nType of + DRIVE_FIXED, + DRIVE_REMOVABLE : DevGuid := GUID_DEVINTERFACE_DISK; + DRIVE_CDROM : DevGuid := GUID_dEVINTERFACE_CDROM; + end; + + hDev := SetupDiGetClassDevs(@DevGuid, nil, 0, DIGCF_PRESENT or DIGCF_DEVICEINTERFACE); + if hDev = INVALID_HANDLE_VALUE then + begin +// TTgTrace.T('Fail .. EjectDrive() .. 5'); + exit; + end; + + try + dwIdx := 0; + while True do + begin + ZeroMemory(@sdid, SizeOf(sdid)); + sdid.cbSize := SizeOf(sdid); + if not SetupDiEnumDeviceInterfaces(hDev, nil, DevGuid, dwIdx, sdid) then + break; + +// TTgTrace.T('EjectDrive() .. SetupDiGetDeviceInterfaceDetail .. Init'); + SetupDiGetDeviceInterfaceDetail(hDev, @sdid, nil, 0, dwLen, nil); + if (dwLen > 0) and (dwLen < 204800) then + begin + SetLength(pBuf, dwLen); + PSPDeviceInterfaceDetailData(@pBuf[0]).cbSize := SizeOf(TSPDeviceInterfaceDetailData); + + ZeroMemory(@spdd, SizeOf(spdd)); + spdd.cbSize := SizeOf(spdd); + + if SetupDiGetDeviceInterfaceDetail(hDev, @sdid, + PSPDeviceInterfaceDetailData(@pBuf[0]), dwLen, dwLen, @spdd) then + begin +// TTgTrace.T('EjectDrive() .. SetupDiGetDeviceInterfaceDetail .. Success'); + if Drv.OpenDevice(PChar(@pBuf[4]), 0) = ERROR_SUCCESS then + begin +// TTgTrace.T('EjectDrive() .. OpenDevice .. Success'); + if not Drv.ReadIO(IOCTL_STORAGE_GET_DEVICE_NUMBER, @sdn, SizeOf(sdn), @dwLen) then + begin +// TTgTrace.T('EjectDrive() .. ReadIO .. Fail'); + exit; + end; +// TTgTrace.T('EjectDrive() .. ReadIO .. Success, DiskNum=%d', [sdn.DeviceNumber]); + Drv.CloseDevice; + + if sdn.DeviceNumber = nDiskNum then + begin + DevInstParent := 0; + ZeroMemory(@sDevName, SizeOf(sDevName)); + CM_Get_Parent(DevInstParent, spdd.DevInst, 0); + CM_Get_Device_ID(DevInstParent, sDevName, 256, 0); + +// TTgTrace.T('EjectDrive() .. DevName=%s', [sDevName]); + +// if bIsCdRom and (Pos('CDROM', UpperCase(sDevName)) = 0) then +// begin +// TTgTrace.T('EjectDrive() .. No CDROM, DiskNum=%d', [sdn.DeviceNumber]); +// Inc(dwIdx); +// continue; +// end; + +// TTgTrace.T('EjectDrive() .. Found CDROM, DiskNum=%d', [sdn.DeviceNumber]); +// if bOnlyUsb and (Pos('USB', UpperCase(sDevName)) <> 1) then +// begin +// TTgTrace.T('Fail .. EjectDrive() .. 7'); +// exit; +// end; + + if aIgrList <> nil then + begin +// if aIgrList.CaseSensitive then +// aIgrList.CaseSensitive := false; +// if aIgrList.IndexOf(sDevName) <> -1 then +// begin +// Result := ''; +// exit; +// end; + + // 비교방식 변경 25_0324 10:12:22 kku + var sChkDevName: String := UpperCase(sDevName); + for i := 0 to aIgrList.Count - 1 do + if Pos(UpperCase(aIgrList[i]), sDevName) > 0 then + begin + Result := ''; + exit; + end; + end; + +// TTgTrace.T('EjectDrive() .. DevName=%s, DiskNum=%d', [sDevName, nDiskNum], 1); + + VetoType := 0; + sVetoName := nil; + +// var ss: TStringStream; +// Guard(ss, TStringStream.Create('', TEncoding.ANSI)); +// if GetCmdTextToStream('mountvol.exe', Format('%s: /L', [sDrive[1]]), ss, 5000) then +// begin +// ExecutePath('mountvol.exe', Format('%s: /D', [sDrive[1]])); +// Sleep(500); +// bSuccess := CM_Request_Device_Eject(DevInstParent, @VetoType, sVetoName, MAX_PATH, 0) = CR_SUCCESS; +// ExecutePath('mountvol.exe', Format('%s: %s', [sDrive[1], StringReplace(Trim(ss.DataString), #13#10, '', [rfReplaceAll])])); +//// if not DirectoryExists(sDrive) then +//// Result := sDevName; +// end; + +// LockAndDismountVolume(sDrive[1]); + + bSuccess := CM_Request_Device_Eject(DevInstParent, @VetoType, sVetoName, MAX_PATH, 0) = CR_SUCCESS; + if bSuccess and (VetoType = 0) then + begin +// ShowMessage(Format('%d - %s', [sdn.DeviceNumber, sDevName])); + Result := sDevName; + end else begin + TTgTrace.T('Fail .. EjectDrive() .. VetoType=%d, LastError=%d', [VetoType, GetLastError], 1); + + if bForceEject then + begin + if ForceEjectDrive(sDrive) then + Result := sDevName; + end; + +// ExecutePath('mountvol.exe', Format('%s: /P', [sDrive[1]])); +// Sleep(500); +// if not DirectoryExists(sDrive) then +// begin +// Result := sDevName; +// end; + end; + exit; + end; + end; +// else +// TTgTrace.T('EjectDrive() .. OpenDevice .. Fail'); + end; +// else +// TTgTrace.T('EjectDrive() .. SetupDiGetDeviceInterfaceDetail .. Fail'); + end; + Inc(dwIdx); + end; + finally + SetupDiDestroyDeviceInfoList(hDev); + end; + +// if Result = FAIL_EJECT then +// TTgTrace.T('Fail .. EjectDrive() .. end'); +end; + +function EjectDrive2(sDrive: String; aIgrList: TStringList = nil; bOnlyUsb: Boolean = true; bForceEject: Boolean = false; bForceEjectFirst: Boolean = false): String; +var + sVol: String; + sDevName: array [0..255] of Char; + Drv: TTgDriver; + sdn: STORAGE_DEVICE_NUMBER; + dwIdx, + dwLen: DWORD; + VetoType: PNP_VETO_TYPE; + sVetoName: PChar; + nType, nDiskNum: Integer; + DevGuid: TGuid; + hDev: HDEVINFO; + sdid: TSPDeviceInterfaceData; + pBuf: TBytes; + spdd: TSPDevInfoData; + DevInstParent: DEVINST; + bSuccess: Boolean; + DrvEx: TDriveExtent; + i: Integer; +begin + Result := FAIL_EJECT; + + if sDrive = '' then + exit; + + sVol := Format('\\.\%s:', [sDrive[1]]); + Guard(Drv, TTgDriver.Create); + if Drv.OpenDevice(sVol, 0) <> ERROR_SUCCESS then + exit; + + ZeroMemory(@sdn, SizeOf(sdn)); + sdn.DeviceNumber := 999; + if not Drv.ReadIO(IOCTL_STORAGE_GET_DEVICE_NUMBER, @sdn, SizeOf(sdn), @dwLen) then + exit; + Drv.CloseDevice; +// + nDiskNum := sdn.DeviceNumber; + +// nDiskNum := GetDriveExtent(sDrive).dwDiskNumber; + +// DrvEx := GetDriveExtent(sDrive); +// if DrvEx.liExtentLength.QuadPart = 0 then +// begin +// TTgTrace.T('Fail .. EjectDrive2() .. Size null .. Drive=%s', [sDrive]); +// exit; +// end; +// nDiskNum := DrvEx.dwDiskNumber; + + if (nDiskNum = -1) or (nDiskNum = 999) then + begin + TTgTrace.T('Fail .. EjectDrive2() .. Not found disknum .. Drive=%s', [sDrive], 1); + exit; + end; + + TTgTrace.T('EjectDrive2() .. Drive=%s, DiskNum=%d', [sDrive, nDiskNum], 1); +// TTgTrace.T('EjectDrive2() .. Drive=%s, DiskNum=%d', [sDrive, nDiskNum]); + + nType := GetDriveType(PChar(sDrive)); + case nType of + DRIVE_FIXED, + DRIVE_REMOVABLE : DevGuid := GUID_DEVINTERFACE_DISK; + DRIVE_CDROM : DevGuid := GUID_DEVINTERFACE_CDROM; + end; + + hDev := SetupDiGetClassDevs(@DevGuid, nil, 0, DIGCF_PRESENT or DIGCF_DEVICEINTERFACE); + if hDev = INVALID_HANDLE_VALUE then + exit; + + try + dwIdx := 0; + while True do + begin + ZeroMemory(@sdid, SizeOf(sdid)); + sdid.cbSize := SizeOf(sdid); + if not SetupDiEnumDeviceInterfaces(hDev, nil, DevGuid, dwIdx, sdid) then + break; + + SetupDiGetDeviceInterfaceDetail(hDev, @sdid, nil, 0, dwLen, nil); + if (dwLen > 0) and (dwLen < 204800) then + begin + SetLength(pBuf, dwLen); + PSPDeviceInterfaceDetailData(@pBuf[0]).cbSize := SizeOf(TSPDeviceInterfaceDetailData); + + ZeroMemory(@spdd, SizeOf(spdd)); + spdd.cbSize := SizeOf(spdd); + + if SetupDiGetDeviceInterfaceDetail(hDev, @sdid, + PSPDeviceInterfaceDetailData(@pBuf[0]), dwLen, dwLen, @spdd) then + begin + if Drv.OpenDevice(PChar(@pBuf[4]), 0) = ERROR_SUCCESS then + begin + if not Drv.ReadIO(IOCTL_STORAGE_GET_DEVICE_NUMBER, @sdn, SizeOf(sdn), @dwLen) then + exit; + Drv.CloseDevice; + + if sdn.DeviceNumber = nDiskNum then + begin + DevInstParent := 0; + ZeroMemory(@sDevName, SizeOf(sDevName)); + CM_Get_Parent(DevInstParent, spdd.DevInst, 0); + CM_Get_Device_ID(DevInstParent, sDevName, 256, 0); + +// if Pos('CDROM', UpperCase(sDevName)) = 0 then +// begin +// Inc(dwIdx); +// continue; +// end; + + if bOnlyUsb and (Pos('USB', UpperCase(sDevName)) <> 1) then + exit; + + TTgTrace.T('EjectDrive2() .. DevName=%s, DiskNum=%d', [sDevName, nDiskNum], 1); +// TTgTrace.T('EjectDrive() .. DevName=%s, DiskNum=%d', [sDevName, nDiskNum]); + + if aIgrList <> nil then + begin +// if aIgrList.CaseSensitive then +// aIgrList.CaseSensitive := false; +// if aIgrList.IndexOf(sDevName) <> -1 then +// begin +// Result := ''; +// exit; +// end; + + // 비교방식 변경 25_0324 10:12:22 kku + var sChkDevName: String := UpperCase(sDevName); + for i := 0 to aIgrList.Count - 1 do + if Pos(UpperCase(aIgrList[i]), sDevName) > 0 then + begin + Result := ''; + exit; + end; + end; + + VetoType := 0; + sVetoName := nil; + if bForceEjectFirst then + begin + if ForceEjectDrive(sDrive) then + begin + Result := sDevName; + exit; + end else + bSuccess := CM_Query_And_Remove_SubTree(DevInstParent, @VetoType, sVetoName, MAX_PATH, CM_REMOVE_NO_RESTART) = CR_SUCCESS; + end else begin + bSuccess := CM_Query_And_Remove_SubTree(DevInstParent, @VetoType, sVetoName, MAX_PATH, CM_REMOVE_NO_RESTART) = CR_SUCCESS; // EjectDrive()와 다른점 23_0223 16:24:47 kku +// bSuccess := CM_Query_And_Remove_SubTree(DevInstParent, nil, nil, 0, CM_REMOVE_NO_RESTART) = CR_SUCCESS; // EjectDrive()와 다른점 23_0223 16:24:47 kku + end; + + if bSuccess and (VetoType = 0) then + begin + // ShowMessage(Format('%d - %s', [sdn.DeviceNumber, sDevName])); + Result := sDevName; + end else begin + TTgTrace.T('Fail .. EjectDrive2() .. VetoType=%d, LastError=%d', [VetoType, GetLastError], 1); + + if bForceEject then + begin + if ForceEjectDrive(sDrive) then + Result := sDevName; + end; +// var ss: TStringStream; +// Guard(ss, TStringStream.Create('', TEncoding.ANSI)); +// if GetCmdTextToStream('mountvol.exe', Format('%s: /P', [sDrive[1]]), ss, 5000) then +// begin +// ExecutePath('mountvol.exe', Format('%s: /P', [sDrive[1]])); +// Sleep(500); +// if not DirectoryExists(sDrive) then +// Result := sDevName; +// end; + end; + exit; + end; + end; + end; + end; + Inc(dwIdx); + end; + finally + SetupDiDestroyDeviceInfoList(hDev); + end; +end; + +function SetUsbDevEnableByDevPath(sDevPath: String; bVal: Boolean): Boolean; +var + hDev: HDEVINFO; + sdd: TSPDevInfoData; + i, c: Integer; + dwBufSize, + dwStatus, dwProblem, + dwPropertyRegDataType: DWORD; + pBuf: Pointer; + sInfo: String; + InfoList: TStringList; +begin + Result := false; + + try + hDev := SetupDiGetClassDevs(@GUID_DEVCLASS_USB, nil, 0, DIGCF_PRESENT); + if hDev = INVALID_HANDLE_VALUE then + exit; + + pBuf := nil; + try + ZeroMemory(@sdd, SizeOf(sdd)); + sdd.cbSize := SizeOf(sdd); + + Guard(InfoList, TStringList.Create); + + i := 0; + while SetupDiEnumDeviceInfo(hDev, i, sdd) do + begin + dwBufSize := 0; + if pBuf <> nil then + begin + FreeMem(pBuf); + pBuf := nil; + end; + + while not SetupDiGetDeviceRegistryProperty(hDev, sdd, + SPDRP_HARDWAREID, dwPropertyRegDataType, pBuf, dwBufSize, dwBufSize) do + begin + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + if pBuf <> nil then + FreeMem(pBuf); + pBuf := AllocMem(dwBufSize); + end else break; + end; + + if pBuf <> nil then + begin + sInfo := ''; + InfoList.Clear; + for c := 0 to (dwBufSize div 2) - 1 do + begin + if PChar(pBuf)[c] = #0 then + begin + if sInfo <> '' then + begin + InfoList.Add(sInfo); + sInfo := ''; + end; + end else + sInfo := sInfo + PChar(pBuf)[c]; + end; + + if sInfo <> '' then + InfoList.Add(sInfo); + + for c := 0 to InfoList.Count - 1 do + begin + if Pos(InfoList[c], sDevPath) > 0 then + begin + dwStatus := 0; + dwProblem := 0; + + if CM_Get_DevNode_Status(dwStatus, dwProblem, sdd.DevInst, 0) = CR_SUCCESS then + begin + var PropChangeParams: TSPPropChangeParams; + ZeroMemory(@PropChangeParams, SizeOf(PropChangeParams)); + PropChangeParams.ClassInstallHeader.cbSize := SizeOf(TSPClassInstallHeader); + PropChangeParams.ClassInstallHeader.InstallFunction := DIF_PROPERTYCHANGE; + PropChangeParams.Scope := DICS_FLAG_GLOBAL; + PropChangeParams.StateChange := BooleanToInt(bVal, DICS_ENABLE, DICS_DISABLE); + + if SetupDiSetClassInstallParams(hDev, @sdd, PSPClassInstallHeader(@PropChangeParams), SizeOf(PropChangeParams)) then + begin + // 64bit OS 에서는 64bit 프로그램 에서만 실행 가능하다 22_0621 13:59:21 kku + Result := SetupDiCallClassInstaller(DIF_PROPERTYCHANGE, hDev, @sdd); + end; + end; + + exit; + end; + end; + end; + + Inc(i); + end; + + finally + SetupDiDestroyDeviceInfoList(hDev); + if pBuf <> nil then + FreeMem(pBuf); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. SetUsbDevEnableByDevPath()'); + end; +end; + +// Result .. -1 = Fail API, 0 = Not found, 1 = Success, 2 = Fail Remove +function _RemoveUsbDevEnableByDevPath(pClassGuid: PGUID; sDevPath: String): Integer; +var + hDev: HDEVINFO; + sdd: TSPDevInfoData; + i, c: Integer; + dwBufSize, + dwStatus, dwProblem, + dwPropertyRegDataType: DWORD; + pBuf: Pointer; + sInfo: String; + InfoList: TStringList; +begin + Result := -1; + + try + hDev := SetupDiGetClassDevs(pClassGuid, nil, 0, DIGCF_PRESENT); + if hDev = INVALID_HANDLE_VALUE then + exit; + + pBuf := nil; + try + ZeroMemory(@sdd, SizeOf(sdd)); + sdd.cbSize := SizeOf(sdd); + + Guard(InfoList, TStringList.Create); + + i := 0; + while SetupDiEnumDeviceInfo(hDev, i, sdd) do + begin + dwBufSize := 0; + if pBuf <> nil then + begin + FreeMem(pBuf); + pBuf := nil; + end; + + while not SetupDiGetDeviceRegistryProperty(hDev, sdd, + SPDRP_HARDWAREID, dwPropertyRegDataType, pBuf, dwBufSize, dwBufSize) do + begin + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + if pBuf <> nil then + FreeMem(pBuf); + pBuf := AllocMem(dwBufSize); + end else break; + end; + + if pBuf <> nil then + begin + sInfo := ''; + InfoList.Clear; + for c := 0 to (dwBufSize div 2) - 1 do + begin + if PChar(pBuf)[c] = #0 then + begin + if sInfo <> '' then + begin + InfoList.Add(sInfo); + sInfo := ''; + end; + end else + sInfo := sInfo + PChar(pBuf)[c]; + end; + + if sInfo <> '' then + InfoList.Add(sInfo); + + for c := 0 to InfoList.Count - 1 do + begin + if Pos(InfoList[c], sDevPath) > 0 then + begin + dwStatus := 0; + dwProblem := 0; + + if CM_Get_DevNode_Status(dwStatus, dwProblem, sdd.DevInst, 0) = CR_SUCCESS then + begin + if SetupDiRemoveDevice(hDev, sdd) then + Result := 1 + else + Result := 2; + end; + + exit; + end; + end; + end; + + Inc(i); + end; + Result := 0; + finally + SetupDiDestroyDeviceInfoList(hDev); + if pBuf <> nil then + FreeMem(pBuf); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. SetUsbDevEnableByDevPath()'); + end; +end; + +function RemoveUsbDevEnableByDevPath(sDevPath: String): Integer; +begin + Result := _RemoveUsbDevEnableByDevPath(@GUID_DEVCLASS_USB, sDevPath); + if Result = 0 then + begin + // 애플 장치는 여기로 (범용 직렬 버스 장치) 따로 잡힌다... 그래서 별도 추가 처리 22_0707 09:23:40 kku + Result := _RemoveUsbDevEnableByDevPath(@GUID_DEVCLASS_USB_DEVICE, sDevPath); + end; + if Result = 0 then + begin + // MTP 장치등... 추가 23_0323 13:47:12 kku + Result := _RemoveUsbDevEnableByDevPath(@GUID_DEVCLASS_WPD, sDevPath); + end; +end; + +{ +initialization + IOCTL_DISK_GET_LENGTH_INFO := CTL_CODE(IOCTL_DISK_BASE, $0017, METHOD_BUFFERED, FILE_READ_ACCESS); + IOCTL_DISK_GET_DRIVE_GEOMETRY_EX := CTL_CODE(IOCTL_DISK_BASE, $0028, METHOD_BUFFERED, FILE_ANY_ACCESS); + IOCTL_STORAGE_QUERY_PROPERTY := CTL_CODE(IOCTL_STORAGE_BASE, $0500, METHOD_BUFFERED, FILE_ANY_ACCESS);//$2D1400 + IOCTL_STORAGE_GET_MEDIA_TYPES_EX := CTL_CODE(IOCTL_STORAGE_BASE, $0301, METHOD_BUFFERED, FILE_ANY_ACCESS); + IOCTL_STORAGE_MEDIA_REMOVAL := CTL_CODE(IOCTL_STORAGE_BASE, $0201, METHOD_BUFFERED, FILE_READ_ACCESS); + IOCTL_STORAGE_EJECTION_CONTROL := $2D0940;//CTL_CODE(IOCTL_STORAGE_BASE, $0250, METHOD_BUFFERED, FILE_ANY_ACCESS); //$2D0940 + IOCTL_STORAGE_EJECT_MEDIA := CTL_CODE(IOCTL_STORAGE_BASE, $0202, METHOD_BUFFERED, FILE_READ_ACCESS); + + FSCTL_DISMOUNT_VOLUME := CTL_CODE(FILE_DEVICE_FILE_SYSTEM,8,METHOD_BUFFERED,FILE_ANY_ACCESS); + FSCTL_LOCK_VOLUME := CTL_CODE(FILE_DEVICE_FILE_SYSTEM,6,METHOD_BUFFERED,FILE_ANY_ACCESS); + FSCTL_UNLOCK_VOLUME := CTL_CODE(FILE_DEVICE_FILE_SYSTEM,7,METHOD_BUFFERED,FILE_ANY_ACCESS); + FSCTL_IS_VOLUME_MOUNTED := CTL_CODE(FILE_DEVICE_FILE_SYSTEM,10,METHOD_BUFFERED,FILE_ANY_ACCESS); + FSCTL_ALLOW_EXTENDED_DASD_IO := CTL_CODE(FILE_DEVICE_FILE_SYSTEM,32,METHOD_BUFFERED,FILE_ANY_ACCESS); + //IOCTL_STORAGE_MEDIA_REMOVAL := ($2d shl 16) or (1 shl 14) or ($201 shl 2) or 0; + //IOCTL_STORAGE_EJECT_MEDIA := ($2d shl 16) or (1 shl 14) or ($202 shl 2) or 0; +} + +end. + diff --git a/Tocsg.Lib/VCL/Tocsg.Encrypt.pas b/Tocsg.Lib/VCL/Tocsg.Encrypt.pas new file mode 100644 index 00000000..985bb9db --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Encrypt.pas @@ -0,0 +1,825 @@ +{*******************************************************} +{ } +{ Tocsg.Encrypt } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.Encrypt; + +interface + +uses + Tocsg.Obj, System.Classes, System.SysUtils, Tocsg.Exception, Winapi.Windows, + aes_type; + +const + BUF_LEN_32K = 1024 * 32; + BUF_LEN_64K = 1024 * 64; + +type + TTgEncKind = (ekNone, ekAes128cbc, ekAes192cbc, ekAes256cbc); + TTgPassHash = (phNone, phSha1, phSha256); + TTgEncrypt = class(TTgObject) + private + bEncInit_, + bDecInit_: Boolean; + + evWorkBegin_: TTgEvtWorkBegin; + evWorkEnd_: TTgEvtWorkEnd; + evWork_: TTgEvtWork; + sPass_: String; + + // AES + nBit_: Integer; + ACtx_: TAESContext; + ABlk_: TAESBlock; + AesKeyBuf_: TBytes; + + cFillPassChar_: AnsiChar; + protected + EncKind_: TTgEncKind; + procedure WorkBeginEvent(llMax: LONGLONG); + procedure WorkEndEvent(llPos, llMax: LONGLONG); + procedure WorkEvent(llPos: LONGLONG); + + procedure SetPassword(const sPass: String); + procedure SetEncryptKind(aEncKind: TTgEncKind); + + procedure ClearAlgo; + public + Constructor Create; overload; + Constructor Create(const aPassword: String; aEncryptKind: TTgEncKind = ekAes256cbc; cFillPassChar: AnsiChar = '*'); overload; + Constructor Create(pKey: TBytes; aEncryptKind: TTgEncKind = ekAes256cbc); overload; + + class function CheckSign(aStream: TStream; sSign: AnsiString): Boolean; overload; + class function CheckSign(sPath: String; sSign: AnsiString): Boolean; overload; + + procedure InitEncrypt; + procedure FinalEncrypt; + + procedure InitDecrypt; + procedure FinalDecrypt; + + function DecryptBuffer(pSrcBuf: Pointer; nBufLen: Integer; bDoUnpadding: Boolean = false): TBytes; + function EncryptBuffer(pSrcBuf: Pointer; nBufLen: Integer; bDoPadding: Boolean = false): TBytes; + + function EncryptBufferEx(pSrcBuf: Pointer; const dwBufLen: DWORD): TBytes; + function DecryptBufferEx(pSrcBuf: Pointer; const dwBufLen: DWORD): TBytes; + + function EncryptStream(SrcStream, DesStream: TStream; sSig: AnsiString = ''; aPassHash: TTgPassHash = phSha1): Boolean; + function DecryptStream(SrcStream, DesStream: TStream; sSig: AnsiString = ''; aPassHash: TTgPassHash = phSha1): Boolean; + + property OnWorkBegin: TTgEvtWorkBegin write evWorkBegin_; + property OnWorkEnd: TTgEvtWorkEnd write evWorkEnd_; + property OnWork: TTgEvtWork write evWork_; + + property EncKind: TTgEncKind read EncKind_ write SetEncryptKind; + end; + + EKzEncrypt = class(ETgException); + +function EncStrToBinStr(aEncAlgo: TTgEncKind; const sPass, sSrcStr: String): String; +function DecBinStrToStr(aEncAlgo: TTgEncKind; const sPass, sSrcStr: String): String; + +implementation + +uses +// EM.SHA1, + + Tocsg.Safe, Tocsg.Binary, aes_cbc, Tocsg.Hash, EM.Tocsg.hash; + +function BlockPadding(aData: Pointer; nDataSize, nBlockSize: Integer; var aBuf: TBytes): Integer; +var + m: WORD; +begin + Result := 0; + try + if nDataSize < nBlockSize then + begin + Result := nBlockSize; + SetLength(aBuf, nBlockSize); + // PKCS7 �е� 18_0410 09:43:58 kku + FillMemory(aBuf, nBlockSize, nBlockSize - nDataSize); + end else begin + m := nDataSize mod nBlockSize; + if m > 0 then + Result := nDataSize + nBlockSize - m + else + Result := nDataSize + nBlockSize; + + SetLength(aBuf, Result); + + // PKCS7 �е� 18_0410 09:43:58 kku + if m > 0 then + FillMemory(aBuf, Result, nBlockSize - m) + else + FillMemory(aBuf, Result, nBlockSize); + end; + CopyMemory(aBuf, aData, nDataSize); + except + on E: Exception do + begin + EKzEncrypt.TraceException(E, 'Fail .. BlockPadding()'); + Result := 0; + end; + end; +end; + +// PKCS7 �е� Ȯ�� �� ���� ������ ũ�� ���� 18_0410 09:44:29 kku +procedure UnpaddingPKCS7(var aDecBuf: TBytes; nBlockSize: Integer); +var + nLen, nCutLen, i: Integer; +begin + nLen := Length(aDecBuf); + if nLen < nBlockSize then + exit; + + nCutLen := aDecBuf[nLen - 1]; + if nCutLen > nBlockSize then + exit; + + for i := nLen - nCutLen to nLen - 1 do + begin + if aDecBuf[i] <> nCutLen then + exit; + end; + +// �� ���� ä���ش�. +// AnsiString�� ��� ������ �������� ����� �� �ִ�. 18_0410 10:05:39 kku + ZeroMemory(@aDecBuf[nLen - nCutLen], nCutLen); + + SetLength(aDecBuf, nLen - nCutLen); +end; + +function StrKeyToBitPadding(const sKey: AnsiString; wBit: WORD; var aBuf: TBytes; cFillChar: AnsiChar = #0): WORD; +var + wKeyLen: WORD; +begin + SetLength(aBuf, 0); + Result := 0; + + case wBit of + 128, 192, 256 : ; + else exit; + end; + + try + SetLength(aBuf, wBit); + FillChar(aBuf[0], wBit, cFillChar); + + wKeyLen := Length(sKey); + if wKeyLen > wBit then + CopyMemory(aBuf, @sKey[1], wBit) + else + CopyMemory(aBuf, @sKey[1], wKeyLen); + Result := Length(aBuf) * 8; + except + on E: Exception do + EKzEncrypt.TraceException(E, 'Fail .. StrKeyToBitPadding()'); + end; +end; + +{ TTgEncrypt } + +Constructor TTgEncrypt.Create; +begin + Inherited Create; + nBit_ := 0; + bEncInit_ := false; + bDecInit_ := false; + EncKind_ := ekNone; + cFillPassChar_ := '*'; +end; + +Constructor TTgEncrypt.Create(const aPassword: String; aEncryptKind: TTgEncKind = ekAes256cbc; cFillPassChar: AnsiChar = '*'); +begin + Create; + sPass_ := aPassword; + cFillPassChar_ := cFillPassChar; + SetEncryptKind(aEncryptKind); +end; + +Constructor TTgEncrypt.Create(pKey: TBytes; aEncryptKind: TTgEncKind = ekAes256cbc); +var + nLen: Integer; +begin + Create; + nLen := Length(pKey); + SetLength(AesKeyBuf_, nLen); + CopyMemory(AesKeyBuf_, pKey, nLen); + SetEncryptKind(aEncryptKind); +end; + +procedure TTgEncrypt.InitEncrypt; +begin + if not bEncInit_ then + begin + case EncKind_ of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin + ZeroMemory(@ACtx_, SizeOf(ACtx_)); + if AES_CBC_Init_Encr(AesKeyBuf_[0], nBit_, ABlk_, ACtx_) <> 0 then + begin + _Trace('Faill .. InitEncrypt() .. AES_CBC_Init_Encr() ..'); + exit; + end; + end; + end; + bEncInit_ := true; + end; +end; + +procedure TTgEncrypt.FinalEncrypt; +begin + bEncInit_ := false; +end; + +// ���� ũ�Ⱑ �Ѿ�� �ڿ����� �Ϻ�ȣȭ �ȵ� +function TTgEncrypt.EncryptBuffer(pSrcBuf: Pointer; nBufLen: Integer; bDoPadding: Boolean = false): TBytes; +var + nLen: Integer; + pInBuf: TBytes; +begin + SetLength(Result, 0); + if not bEncInit_ then + exit; + + try + case EncKind_ of + ekNone: + begin + SetLength(Result, nBufLen); + CopyMemory(Result, pSrcBuf, nBufLen); + end; + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin + if bDoPadding then + begin + nLen := BlockPadding(pSrcBuf, nBufLen, AESBLKSIZE, pInBuf); + ASSERT(nLen >= AESBLKSIZE); + end else begin + nLen := nBufLen; + SetLength(pInBuf, nLen); + CopyMemory(pInBuf, pSrcBuf, nBufLen); + end; + SetLength(Result, nLen); + + if AES_CBC_Encrypt(pInBuf, Result, nLen, ACtx_) <> 0 then + begin + _Trace('Faill .. EncryptBuffer() .. AES_CBC_Encrypt() ..'); + SetLength(Result, nBufLen); + CopyMemory(Result, pSrcBuf, nBufLen); + exit; + end; + end; + end; + except + on E: Exception do + EKzEncrypt.TraceException(Self, E, 'Fail .. CryptBuffer()'); + end; +end; + +procedure TTgEncrypt.InitDecrypt; +begin + if not bDecInit_ then + begin + case EncKind_ of + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin + ZeroMemory(@ACtx_, SizeOf(ACtx_)); + if AES_CBC_Init_Decr(AesKeyBuf_[0], nBit_, ABlk_, ACtx_) <> 0 then + begin + _Trace('Faill .. InitDecrypt() .. AES_CBC_Init_Decr() ..'); + exit; + end; + end; + end; + bDecInit_ := true; + end; +end; + +procedure TTgEncrypt.FinalDecrypt; +begin + bDecInit_ := false; +end; + +function TTgEncrypt.DecryptBuffer(pSrcBuf: Pointer; nBufLen: Integer; bDoUnpadding: Boolean = false): TBytes; +begin + SetLength(Result, 0); + if not bDecInit_ then + exit; + + try + case EncKind_ of + ekNone: + begin + SetLength(Result, nBufLen); + CopyMemory(Result, pSrcBuf, nBufLen); + end; + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin + SetLength(Result, nBufLen); + if AES_CBC_Decrypt(pSrcBuf, Result, nBufLen, ACtx_) <> 0 then + begin + _Trace('Faill .. EncryptBuffer() .. AES_CBC_Decrypt() ..'); + SetLength(Result, nBufLen); + CopyMemory(Result, pSrcBuf, nBufLen); + exit; + end; + + if bDoUnpadding then + UnpaddingPKCS7(Result, AESBLKSIZE); + end; + end; + except + on E: Exception do + EKzEncrypt.TraceException(Self, E, 'Fail .. DecryptBuffer()'); + end; +end; + +// 32kb ������ �߶� �Ϻ�ȣȭ 14_0704 17:58:13 kku +function TTgEncrypt.EncryptBufferEx(pSrcBuf: Pointer; const dwBufLen: DWORD): TBytes; +var + dwRead, + dwReaded: DWORD; + nLen: Integer; + pInBuf: TBytes; +begin + case EncKind_ of + ekNone: + begin + SetLength(Result, dwBufLen); + CopyMemory(Result, pSrcBuf, dwBufLen); + end; + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin +// if not bAEncInit_ then +// begin + ZeroMemory(@ACtx_, SizeOf(ACtx_)); + if AES_CBC_Init_Encr(AesKeyBuf_[0], nBit_, ABlk_, ACtx_) <> 0 then + begin + _Trace('Faill .. EncryptBufferEx() .. AES_CBC_Init_Encr() ..'); + EncKind_ := ekNone; + Result := EncryptBufferEx(pSrcBuf, dwBufLen); + exit; + end; +// bAEncInit_ := true; +// end; + + nLen := BlockPadding(pSrcBuf, dwBufLen, AESBLKSIZE, pInBuf); + SetLength(Result, nLen); + + dwReaded := 0; + while dwReaded < nLen do + begin + dwRead := nLen - dwReaded; + if dwRead > BUF_LEN_32K then + dwRead := BUF_LEN_32K; + + if AES_CBC_Encrypt(@pInBuf[dwReaded], @Result[dwReaded], dwRead, ACtx_) <> 0 then + begin + _Trace('Faill .. EncryptBufferEx() .. AES_CBC_Encrypt() ..'); + SetLength(Result, dwBufLen); + CopyMemory(Result, pSrcBuf, dwBufLen); + exit; + end; + + Inc(dwReaded, dwRead); + end; + end; + end; +end; + +function TTgEncrypt.DecryptBufferEx(pSrcBuf: Pointer; const dwBufLen: DWORD): TBytes; +var + dwRead, + dwReaded: DWORD; +begin + case EncKind_ of + ekNone: + begin + SetLength(Result, dwBufLen); + CopyMemory(Result, pSrcBuf, dwBufLen); + end; + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin +// if not bADecInit_ then +// begin + ZeroMemory(@ACtx_, SizeOf(ACtx_)); + if AES_CBC_Init_Decr(AesKeyBuf_[0], nBit_, ABlk_, ACtx_) <> 0 then + begin + _Trace('Faill .. DecryptBufferEx() .. AES_CBC_Init_Decr() ..'); + EncKind_ := ekNone; + Result := EncryptBufferEx(pSrcBuf, dwBufLen); + exit; + end; +// bADecInit_ := true; +// end; + + SetLength(Result, dwBufLen); + ZeroMemory(Result, dwBufLen); + dwReaded := 0; + while dwReaded < dwBufLen do + begin + dwRead := dwBufLen - dwReaded; + if dwRead > BUF_LEN_32K then + dwRead := BUF_LEN_32K; + + if AES_CBC_Decrypt(@TBytes(pSrcBuf)[dwReaded], @Result[dwReaded], dwRead, ACtx_) <> 0 then + begin + _Trace('Faill .. DecryptBufferEx() .. AES_CBC_Encrypt() ..'); + SetLength(Result, dwBufLen); + CopyMemory(Result, pSrcBuf, dwBufLen); + exit; + end; + + Inc(dwReaded, dwRead); + end; + UnpaddingPKCS7(Result, AESBLKSIZE); + end; + end; +end; + +function TTgEncrypt.EncryptStream(SrcStream, DesStream: TStream; sSig: AnsiString = ''; aPassHash: TTgPassHash = phSha1): Boolean; +var + nPassLen: Integer; + pBufIn: array[0..BUF_LEN_64K-1] of Byte; + pBufOut: TBytes; + nRead, nWrite, nBufOutLen: Integer; +begin + Result := true; + + nPassLen := Length(sPass_); + if nPassLen < 4 then + begin + Result := false; + _Trace('EncryptStream() - �н����尡 4�ڸ� �����Դϴ�.'); + exit; + end; + + SrcStream.Position := 0; + + if (sSig <> '') or (aPassHash <> phNone) then + DesStream.Position := 0; + + if sSig <> '' then + DesStream.Write(sSig[1], Length(sSig)); + + case aPassHash of + phNone : ; + phSha1 : + begin + var SHA1Hash: TSHA1Hash; + var PassSHA1: TSHA1Digest; + Guard(SHA1Hash, TSHA1Hash.Create); + SHA1Hash.SetBuffer(PWideChar(sPass_), nPassLen*2); + + if not SHA1Hash.WorkFinalToDigest(PassSHA1) then + begin + Result := false; + _Trace('EncryptStream() - �н������� �ؽø� ������ ������ �߻��Ͽ����ϴ�.'); + exit; + end; + + if DesStream.Write(PassSHA1, SizeOf(PassSHA1)) <> SizeOf(PassSHA1) then + begin + Result := false; + _Trace('EncryptStream() - �ؽ� ���� ����'); + exit; + end; + end; + phSha256 : + begin + var SHA256Hash: TSHA256Hash; + var PassSHA256: TSHA256Digest; + Guard(SHA256Hash, TSHA256Hash.Create); + SHA256Hash.SetBuffer(PWideChar(sPass_), nPassLen*2); + + if not SHA256Hash.WorkFinalToDigest(PassSHA256) then + begin + Result := false; + _Trace('EncryptStream() - �н������� �ؽø� ������ ������ �߻��Ͽ����ϴ�.'); + exit; + end; + + if DesStream.Write(PassSHA256, SizeOf(PassSHA256)) <> SizeOf(PassSHA256) then + begin + Result := false; + _Trace('EncryptStream() - �ؽ� ���� ����'); + exit; + end; + end; + end; + + WorkBeginEvent(SrcStream.Size); + + InitEncrypt; + try + Repeat + nRead := SrcStream.Read(pBufIn, BUF_LEN_64K); + pBufOut := EncryptBuffer(@pBufIn, nRead, SrcStream.Position = SrcStream.Size); + nBufOutLen := Length(pBufOut); + nWrite := DesStream.Write(pBufOut[0], nBufOutLen); + if nBufOutLen <> nWrite then + begin + Result := false; + _Trace('EncryptStream() - ��ȣȭ ���� ����'); + exit; + end; + WorkEvent(DesStream.Size); + Until nRead <> BUF_LEN_64K; + finally + FinalEncrypt; + end; + + WorkEndEvent(DesStream.Size, SrcStream.Size); +end; + +function TTgEncrypt.DecryptStream(SrcStream, DesStream: TStream; sSig: AnsiString = ''; aPassHash: TTgPassHash = phSha1): Boolean; +var + pBufIn: array[0..BUF_LEN_64K-1] of Byte; + pBufOut: TBytes; + nRead, nWrite, nBufOutLen: Integer; +begin + Result := true; + + if (sSig <> '') or (aPassHash <> phNone) then + SrcStream.Position := 0; + DesStream.Position := 0; + + if SrcStream.Size = 0 then + begin + Result := false; + _Trace('DecryptStream() - ��ȣȭ �� �����Ͱ� �������� �ʽ��ϴ�.'); + exit; + end; + + if sSig <> '' then + begin + var nLen: Integer := Length(sSig); + SetLength(pBufOut, nLen); + SrcStream.Read(pBufOut[0], nLen); + if not CompareMem(@pBufOut[0], @sSig[1], nLen) then + begin + _Trace('DecryptStream() - �ñ״�ó ���� �ٸ��ϴ�.'); + Result := false; + exit; + end; + end; + + case aPassHash of + phNone : ; + phSha1 : + begin + var PassSHA1: TSHA1Digest; + var CheckPass: TSHA1Digest; + var SHA1Hash: TSHA1Hash; + var nPassLen: Integer := Length(sPass_); + + Guard(SHA1Hash, TSHA1Hash.Create); + SHA1Hash.SetBuffer(PWideChar(sPass_), nPassLen*2); + + if not SHA1Hash.WorkFinalToDigest(PassSHA1) then + begin + Result := false; + _Trace('DecryptStream() - �н������� �ؽø� ������ ������ �߻��Ͽ����ϴ�.'); + exit; + end; + + if SrcStream.Read(CheckPass, SizeOf(CheckPass)) <> SizeOf(CheckPass) then + begin + Result := false; + _Trace('DecryptStream() - ��� ��Ƽ�� �б� ����.'); + exit; + end; + + if not CompareMem(@PassSHA1, @CheckPass, SizeOf(PassSHA1)) then + begin + Result := false; + _Trace('DecryptStream() - Error Message'); + exit; + end; + end; + phSha256 : + begin + var PassSHA256: TSHA256Digest; + var CheckPass: TSHA256Digest; + var SHA256Hash: TSHA256Hash; + var nPassLen: Integer := Length(sPass_); + + Guard(SHA256Hash, TSHA1Hash.Create); + SHA256Hash.SetBuffer(PWideChar(sPass_), nPassLen*2); + + if not SHA256Hash.WorkFinalToDigest(PassSHA256) then + begin + Result := false; + _Trace('DecryptStream() - �н������� �ؽø� ������ ������ �߻��Ͽ����ϴ�.'); + exit; + end; + + if SrcStream.Read(CheckPass, SizeOf(CheckPass)) <> SizeOf(CheckPass) then + begin + Result := false; + _Trace('DecryptStream() - ��� ��Ƽ�� �б� ����.'); + exit; + end; + + if not CompareMem(@PassSHA256, @CheckPass, SizeOf(PassSHA256)) then + begin + Result := false; + _Trace('DecryptStream() - Error Message'); + exit; + end; + end; + end; + + WorkBeginEvent(SrcStream.Size); + + InitDecrypt; + try + Repeat + nRead := SrcStream.Read(pBufIn, BUF_LEN_64K); + pBufOut := DecryptBuffer(@pBufIn, nRead, SrcStream.Position = SrcStream.Size); + nBufOutLen := Length(pBufOut); + nWrite := DesStream.Write(pBufOut[0], nBufOutLen); + if nBufOutLen <> nWrite then + begin + Result := false; + _Trace('DecryptStream() - ��ȣȭ ���� ����'); + exit; + end; + WorkEvent(DesStream.Size); + Until nRead <> BUF_LEN_64K; + finally + FinalDecrypt; + end; + + WorkEndEvent(DesStream.Size, SrcStream.Size); + + SrcStream.Position := 0; + DesStream.Position := 0; +end; + +procedure TTgEncrypt.WorkBeginEvent(llMax: LONGLONG); +begin + if Assigned(evWorkBegin_) then + evWorkBegin_(Self, llMax); +end; + +procedure TTgEncrypt.WorkEndEvent(llPos, llMax: LONGLONG); +begin + if Assigned(evWorkEnd_) then + evWorkEnd_(Self, llPos, llMax); +end; + +procedure TTgEncrypt.WorkEvent(llPos: LONGLONG); +begin + if Assigned(evWork_) then + evWork_(Self, llPos); +end; + +procedure TTgEncrypt.SetPassword(const sPass: String); +begin + if sPass_ <> sPass then + sPass_ := sPass; +end; + +procedure TTgEncrypt.SetEncryptKind(aEncKind: TTgEncKind); +begin + if EncKind_ <> aEncKind then + begin + ClearAlgo; + case aEncKind of + ekNone : ; + ekAes256cbc, + ekAes192cbc, + ekAes128cbc : + begin + case aEncKind of + ekAes256cbc : nBit_ := 256; + ekAes192cbc : nBit_ := 192; + else + nBit_ := 128; + end; + + if sPass_ <> '' then + begin + if not StrKeyToBitPadding(sPass_, nBit_, AesKeyBuf_, cFillPassChar_) = nBit_ then + begin + EncKind_ := ekNone; + exit; + end; + end; + CopyMemory(@ABlk_, AesKeyBuf_, AESBLKSIZE); + end; + end; + EncKind_ := aEncKind; + end; +end; + +procedure TTgEncrypt.ClearAlgo; +begin +// +end; + +// test �ȵ� 22_0906 12:38:17 kku +class function TTgEncrypt.CheckSign(aStream: TStream; sSign: AnsiString): Boolean; +var + nLen: Integer; + pBuf: TBytes; +begin + Result := false; + + try + nLen := Length(sSign); + SetLength(pBuf, nLen); + + aStream.Position := 0; + if aStream.Read(pBuf[0], nLen) <> nLen then + exit; + + Result := CompareMem(@pBuf[0], @sSign[1], nLen); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. CheckSign() .. 1', 5); + end; +end; + +class function TTgEncrypt.CheckSign(sPath: String; sSign: AnsiString): Boolean; +var + fs: TFileStream; +begin + Result := false; + try + Guard(fs, TFileStream.Create(sPath, fmOpenRead)); + Result := CheckSign(fs, sSign); + except + {$IFDEF DEBUG} + // �ǻ���� �αװ� �ʹ� ���� ���� + on E: Exception do + ETgException.TraceException(E, 'Fail .. CheckSign() .. 2', 5); + {$ENDIF} + end; +end; + +function EncStrToBinStr(aEncAlgo: TTgEncKind; const sPass, sSrcStr: String): String; +var + enc: TTgEncrypt; + pBuf: TBytes; + nLen: Integer; +begin + Result := ''; + nLen := Length(sSrcStr); + if nLen > 0 then + begin + try + Guard(enc, TTgEncrypt.Create(sPass, aEncAlgo)); + pBuf := enc.EncryptBufferEx(@sSrcStr[1], nLen * 2); + Result := ConvBytesToHexStr(PByte(pBuf), Length(pBuf)); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. EncStrToBinStr() ...', 1); + end; + end; +end; + +function DecBinStrToStr(aEncAlgo: TTgEncKind; const sPass, sSrcStr: String): String; +var + enc: TTgEncrypt; + pBuf: TBytes; + nLen: Integer; +// sDec: String; +begin + Result := ''; + try + Guard(enc, TTgEncrypt.Create(sPass, aEncAlgo)); + nLen := ConvHexStrToBytes(sSrcStr, pBuf); + if nLen = 0 then + exit; + + pBuf := enc.DecryptBufferEx(@pBuf[0], nLen); +// nLen := Length(pBuf); // 복호화 길이와 실체 복호화된 버퍼의 길이가 다르다 + Result := TEncoding.Unicode.GetString(pBuf); +// sDec := StrPas(PChar(@pBuf[0])); +// Result := Copy(sDec, 1, nLen div 2); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. DecBinStrToStr() ...', 1); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Exception.pas b/Tocsg.Lib/VCL/Tocsg.Exception.pas new file mode 100644 index 00000000..e78ac822 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Exception.pas @@ -0,0 +1,74 @@ +{*******************************************************} +{ } +{ Tocsg.Exception } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Exception; + +interface + +uses + System.SysUtils; + +type + ETgException = class(Exception) + public + class procedure TraceException(E: Exception; nLogLv: Integer = 0); overload; + class procedure TraceException(E: Exception; const sInfo: String; nLogLv: Integer = 0); overload; + class procedure TraceException(E: Exception; const sFormat: String; const Args: array of const; nLogLv: Integer = 0); overload; + class procedure TraceException(Sender: TObject; E: Exception; nLogLv: Integer = 0); overload; + class procedure TraceException(Sender: TObject; E: Exception; const sInfo: String; nLogLv: Integer = 0); overload; + class procedure TraceException(Sender: TObject; E: Exception; const sFormat: String; const Args: array of const; nLogLv: Integer = 0); overload; + end; + +implementation + +uses + Tocsg.Trace, Tocsg.Obj; + +class procedure ETgException.TraceException(E: Exception; nLogLv: Integer = 0); +begin + TTgTrace.T(Format('ETgException .. %s, Msg="%s"', [E.ClassName, E.Message]), nLogLv); +end; + +class procedure ETgException.TraceException(E: Exception; const sInfo: String; nLogLv: Integer = 0); +begin + TTgTrace.T(Format('ETgException .. %s, Msg="%s", Info = %s', [E.ClassName, E.Message, sInfo]), nLogLv); +end; + +class procedure ETgException.TraceException(E: Exception; const sFormat: String; const Args: array of const; nLogLv: Integer = 0); +var + str: String; +begin + FmtStr(str, sFormat, Args); + TraceException(E, str, nLogLv); +end; + +class procedure ETgException.TraceException(Sender: TObject; E: Exception; nLogLv: Integer = 0); +begin + if Sender <> nil then + TTgTrace.T(Format('%s :: ETgException .. %s, Msg="%s"', [Sender.ClassName, E.ClassName, E.Message]), nLogLv) + else + TTgTrace.T(Format('Unknown Class :: ETgException .. %s - %s', [E.ClassName, E.Message]), nLogLv) +end; + +class procedure ETgException.TraceException(Sender: TObject; E: Exception; const sInfo: String; nLogLv: Integer = 0); +begin + if Sender <> nil then + TTgTrace.T(Format('%s :: ETgException .. %s, Msg="%s" : Info = %s', [Sender.ClassName, E.ClassName, E.Message, sInfo]), nLogLv) + else + TTgTrace.T(Format('Unknown Class :: ETgException .. %s, Msg="%s" : Info = %s', [E.ClassName, E.Message, sInfo]), nLogLv); +end; + +class procedure ETgException.TraceException(Sender: TObject; E: Exception; const sFormat: String; const Args: array of const; nLogLv: Integer = 0); +var + str: String; +begin + FmtStr(str, sFormat, Args); + TraceException(Sender, E, str, nLogLv); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Export.pas b/Tocsg.Lib/VCL/Tocsg.Export.pas new file mode 100644 index 00000000..55d38683 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Export.pas @@ -0,0 +1,665 @@ +{*******************************************************} +{ } +{ Tocsg.Export } +{ } +{ Copyright (C) 2023 kku } +{ } +{*******************************************************} + +unit Tocsg.Export; + +interface + +uses + System.SysUtils, Winapi.Windows, System.Classes, Winapi.ActiveX, VirtualTrees; + +const + xlCsv = 6; + xlXls = 43; + xlHtml = 44; + xlNxl = -2003; + xlCell = -4143; + xlText = -4158; + xlLeft = -4131; + xlRight = -4152; + xlCenter = -4108; + xlQualityStandard = $00000000; + xlQualityMinimum = $00000001; + xlTypePDF = $00000000; + xlTypeXPS = $00000001; + +type + TFnExportExpert = reference to procedure(vExcel: Variant); + + XlFixedFormatType = TOleEnum; + XlFixedFormatQuality = TOleEnum; + + TExportTargetKind = (etkAll, etkSelected, etkChecked); + +function ExportCSV_VT(vt: TVirtualStringTree; sExportPath: String; + aEncoding: TEncoding; aExpTgKind: TExportTargetKind = etkAll; pRootNode: PVirtualNode = nil): Boolean; +function ExportCSV_VT_Div(vt: TVirtualStringTree; sExportPath: String; + aEncoding: TEncoding; nDivCount: Integer; aExpTgKind: TExportTargetKind = etkAll; bHitsCount: Boolean = false): Boolean; +function ExportXLS_VT(vt: TVirtualStringTree; const sSheetCaption, sExportPath: String; + FnExportExpert: TFnExportExpert = nil; aExpTgKind: TExportTargetKind = etkAll): Boolean; +function ExportXLS_VT_Div(vt: TVirtualStringTree; const sSheetCaption, sExportPath: String; nDivCount: Integer; + FnExportExpert: TFnExportExpert = nil; aExpTgKind: TExportTargetKind = etkAll): Boolean; +function ExportHanCell_VT(vt: TVirtualStringTree; const sSheetCaption, sExportPath: String; + aExpTgKind: TExportTargetKind = etkAll): Boolean; + +function ExportXlsFromCsv(const sCsvPath, sOutPath: String; aCsvEncoding: TEncoding): Boolean; + +implementation + +uses + System.Win.ComObj, System.Variants, Vcl.Graphics, Tocsg.Safe, Tocsg.Exception, + Tocsg.VTUtil, VirtualTrees.Types, Tocsg.Strings, Tocsg.Path; + +function ExportCSV_VT(vt: TVirtualStringTree; sExportPath: String; + aEncoding: TEncoding; aExpTgKind: TExportTargetKind = etkAll; pRootNode: PVirtualNode = nil): Boolean; +var + pNode: PVirtualNode; + StrList: TStringList; + sData: String; + i: Integer; +begin + Result := false; + + Guard(StrList, TStringList.Create); + + sData := ''; + for i := 0 to vt.Header.Columns.Count - 1 do + begin + if coVisible in vt.Header.Columns[i].Options then + SumString(sData, '"' + vt.Header.Columns[i].Text + '"', ','); + end; + StrList.Add(sData); + + case aExpTgKind of + etkAll : pNode := vt.GetFirst; + etkSelected : pNode := vt.GetFirstSelected; + etkChecked : pNode := vt.GetFirstChecked; + else pNOde := nil; + end; + + while pNode <> nil do + begin + sData := ''; + + if (pRootNode = nil) or (pRootNode = pNode.Parent) then + begin + for i := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[i].Options then + SumString(sData, '"' + StringReplace(vt.Text[pNode, i], '"', '', [rfReplaceAll]) + '"', ','); + + if sData <> '' then + StrList.Add(sData); + end; + + case aExpTgKind of + etkAll : pNode := vt.GetNext(pNode); + etkSelected : pNode := vt.GetNextSelected(pNode); + etkChecked : pNode := vt.GetNextChecked(pNode); + end; + end; + + if GetFileExt(sExportPath).ToUpper <> 'CSV' then + sExportPath := sExportPath + '.csv'; + + StrList.SaveToFile(sExportPath, aEncoding); + + Result := true; +end; + +function ExportCSV_VT_Div(vt: TVirtualStringTree; sExportPath: String; + aEncoding: TEncoding; nDivCount: Integer; aExpTgKind: TExportTargetKind = etkAll; bHitsCount: Boolean = false): Boolean; +var + pNode: PVirtualNode; + StrList: TStringList; + sExt, + sExcludeExtPath, + sSavePath, + sData: String; + i, nFileNum, + nAddedCnt: Integer; + + procedure InitData; + var + c: Integer; + begin + nAddedCnt := 0; + StrList.Clear; + + sData := ''; + for c := 0 to vt.Header.Columns.Count - 1 do + begin + if coVisible in vt.Header.Columns[c].Options then + SumString(sData, vt.Header.Columns[c].Text, ','); + end; + StrList.Add(sData); + end; + + procedure SaveData; + begin + Inc(nFileNum); + sSavePath := Format('%s - %.3d%s', [sExcludeExtPath, nFileNum, sExt]); + StrList.SaveToFile(sSavePath, aEncoding); + InitData; + end; + +begin + Result := false; + + if GetFileExt(sExportPath).ToUpper <> 'CSV' then + sExportPath := sExportPath + '.csv'; + + sExt := ExtractFileExt(sExportPath); + sExcludeExtPath := CutFileExt(sExportPath); + nFileNum := 0; + + case aExpTgKind of + etkAll : pNode := vt.GetFirst; + etkSelected : pNode := vt.GetFirstSelected; + etkChecked : pNode := vt.GetFirstChecked; + else pNode := nil; + end; + + Guard(StrList, TStringList.Create); + InitData; + + while pNode <> nil do + begin + sData := ''; + + for i := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[i].Options then + SumString(sData, '"' + StringReplace(vt.Text[pNode, i], '"', '', [rfReplaceAll]) + '"', ','); + + if sData <> '' then + begin + StrList.Add(sData); + Inc(nAddedCnt); + if nAddedCnt >= nDivCount then + SaveData; + end; + + case aExpTgKind of + etkAll : pNode := vt.GetNext(pNode); + etkSelected : pNode := vt.GetNextSelected(pNode); + etkChecked : pNode := vt.GetNextChecked(pNode); + end; + end; + + if nAddedCnt > 0 then + SaveData; + Result := true; +end; + +function ExportXLS_VT(vt: TVirtualStringTree; const sSheetCaption, sExportPath: String; FnExportExpert: TFnExportExpert = nil; aExpTgKind: TExportTargetKind = etkAll): Boolean; +var + vExcel, vWorkBook: Variant; + vArrData: OleVariant; + i, nRow, nCol: Integer; + pNode: PVirtualNode; + dwRecordCnt, + dwColumnCnt: DWORD; + ClassID: TCLSID; +begin + Result := false; + + if not Succeeded(CLSIDFromProgID(PWideChar(WideString('Excel.Application')), ClassID)) then + exit; + + try + vExcel := CreateOleObject('Excel.Application'); + except + on E: Exception do + begin + ETgException.TraceException(E, 'ExportXLS_VT() .. fail CreateOleObject(Excel.Application) ..'); + exit; + end; + end; + + try + try + vWorkBook := vExcel.WorkBooks.Add; + + if Assigned(FnExportExpert) then + FnExportExpert(vExcel); + + dwRecordCnt := 0; + case aExpTgKind of + etkAll : dwRecordCnt := VT_CountTotalNode(vt); + etkSelected : dwRecordCnt := vt.SelectedCount; + etkChecked : dwRecordCnt := VT_CountVisibleCheckedNode(vt); + end; + + // 엑셀 내보내기는 60000 미만으로 해야한다 + if dwRecordCnt > 60000 then + exit; + + dwColumnCnt := 0; + for nCol := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[nCol].Options then + Inc(dwColumnCnt); + + nRow := 0; + vArrData := VarArrayCreate([0, dwRecordCnt, 0, dwColumnCnt - 1], varVariant); + i := 0; + for nCol := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[nCol].Options then + begin + vArrData[nRow, i] := vt.Header.Columns[nCol].Text; + Inc(i); + end; + + case aExpTgKind of + etkAll : pNode := vt.GetFirst; + etkSelected : pNode := vt.GetFirstSelected; + etkChecked : pNode := vt.GetFirstChecked; + else pNode := nil; + end; + + while pNode <> nil do + begin + Inc(nRow); + i := 0; + for nCol := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[nCol].Options then + begin + vArrData[nRow, i] := vt.Text[pNode, nCol]; + Inc(i); + end; + + case aExpTgKind of + etkAll : pNode := vt.GetNext(pNode); + etkSelected : pNode := vt.GetNextSelected(pNode); + etkChecked : pNode := vt.GetNextChecked(pNode); + end; + end; + + vWorkBook := vExcel.WorkSheets.Add; + vExcel.Sheets[1].Name := DeleteChars(':\/?*[]', sSheetCaption); + + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[1, dwColumnCnt]].Select; + vExcel.Selection.Interior.ColorIndex := 15; + vExcel.Selection.Interior.Pattern := 1; + vExcel.Selection.Borders.LineStyle := 1; + vExcel.Selection.Font.Name := 'Tahoma';//'굴림'; + vExcel.Selection.Font.Size := 10; + vExcel.Selection.Font.Bold := True; + vExcel.Selection.Font.Color := clBlack; + // 가로 타이틀 정렬 + vExcel.Selection.VerticalAlignment := 2; + vExcel.Selection.HorizontalAlignment := 3; + + vExcel.Range[vExcel.Cells[2, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Select; + vExcel.Selection.Font.Size := 10; + vExcel.Selection.Font.Name := 'Tahoma';//'굴림'; + vExcel.Selection.VerticalAlignment := 1; + vExcel.Selection.HorizontalAlignment := 1; + + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].NumberFormatLocal := WideString('@'); // 문자열 강제 지정 + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Value := vArrData; + + vExcel.Range[vExcel.Cells[2, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Select; + vExcel.Selection.VerticalAlignment := 2; + vExcel.Selection.HorizontalAlignment := 2; + + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Select; + vExcel.Selection.Columns.AutoFit; + finally + vExcel.DisplayAlerts := False; + vExcel.Visible := False; + vWorkBook.Saveas(sExportPath); +// vWorkBook.ExportAsFixedFormat(xlTypePDF, sExportPath); + vExcel.Quit; + vExcel := Unassigned; + end; + except + on E: Exception do + begin + ETgException.TraceException(E, 'ExportXLS_VT() ..'); + exit; + end; + end; + + Result := true; +end; + +function ExportXLS_VT_Div(vt: TVirtualStringTree; const sSheetCaption, sExportPath: String; nDivCount: Integer; FnExportExpert: TFnExportExpert = nil; aExpTgKind: TExportTargetKind = etkAll): Boolean; +var + vExcel, vWorkBook: Variant; + vArrData: OleVariant; + i, nRow, nCol, nFileNum: Integer; + pNode: PVirtualNode; + dwRecordCnt, + dwColumnCnt: DWORD; + sExt, + sSavePath, + sExcludeExtPath: String; + + function InitData: Boolean; + var + c: Integer; + begin + Result := false; + try + vExcel := CreateOleObject('Excel.Application'); + except + on E: Exception do + begin + ETgException.TraceException(E, 'Fail .. ExportXLS_VT_Div() .. fail CreateOleObject(Excel.Application) ..'); + exit; + end; + end; + + try + vWorkBook := vExcel.WorkBooks.Add; + + if Assigned(FnExportExpert) then + FnExportExpert(vExcel); + + case aExpTgKind of + etkAll : dwRecordCnt := VT_CountTotalNode(vt); + etkSelected : dwRecordCnt := vt.SelectedCount; + etkChecked : dwRecordCnt := VT_CountVisibleCheckedNode(vt); + end; + + dwColumnCnt := 0; + for c := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[c].Options then + Inc(dwColumnCnt); + + nRow := 0; + vArrData := VarArrayCreate([0, dwRecordCnt, 0, dwColumnCnt - 1], varVariant); + i := 0; + for c := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[c].Options then + begin + vArrData[nRow, i] := vt.Header.Columns[c].Text; + Inc(i); + end; + except + on E: Exception do + begin + ETgException.TraceException(E, 'Fail .. ExportXLS_VT_Div() .. InitData()'); + exit; + end; + end; + Result := true; + end; + + function SaveData: Boolean; + begin + vWorkBook := vExcel.WorkSheets.Add; + vExcel.Sheets[1].Name := DeleteChars(':\/?*[]', sSheetCaption); + + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[1, dwColumnCnt]].Select; + vExcel.Selection.Interior.ColorIndex := 15; + vExcel.Selection.Interior.Pattern := 1; + vExcel.Selection.Borders.LineStyle := 1; + vExcel.Selection.Font.Name := 'Tahoma';//'굴림'; + vExcel.Selection.Font.Size := 10; + vExcel.Selection.Font.Bold := True; + vExcel.Selection.Font.Color := clBlack; + // 가로 타이틀 정렬 + vExcel.Selection.VerticalAlignment := 2; + vExcel.Selection.HorizontalAlignment := 3; + + vExcel.Range[vExcel.Cells[2, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Select; + vExcel.Selection.Font.Size := 10; + vExcel.Selection.Font.Name := 'Tahoma';//'굴림'; + vExcel.Selection.VerticalAlignment := 1; + vExcel.Selection.HorizontalAlignment := 1; + + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].NumberFormatLocal := WideString('@'); // 문자열 강제 지정 + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Value := vArrData; + + vExcel.Range[vExcel.Cells[2, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Select; + vExcel.Selection.VerticalAlignment := 2; + vExcel.Selection.HorizontalAlignment := 2; + + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Select; + vExcel.Selection.Columns.AutoFit; + + + Inc(nFileNum); + sSavePath := Format('%s - %.3d.%s', [sExcludeExtPath, nFileNum, sExt]); + + + vExcel.DisplayAlerts := False; + vExcel.Visible := False; + vWorkBook.Saveas(sSavePath); + vExcel.Quit; + vExcel := Unassigned; + + Result := InitData; + end; + +begin + Result := false; + + sExt := ExtractFileExt(sExportPath); + sExcludeExtPath := CutFileExt(sExportPath); + + if not InitData then + exit; + + try + pNode := nil; + try + case aExpTgKind of + etkAll : pNode := vt.GetFirst; + etkSelected : pNode := vt.GetFirstSelected; + etkChecked : pNode := vt.GetFirstChecked; + end; + + while pNode <> nil do + begin + Inc(nRow); + i := 0; + for nCol := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[nCol].Options then + begin + vArrData[nRow, i] := vt.Text[pNode, nCol]; + Inc(i); + end; + + if nRow >= nDivCount then + if not SaveData then + exit; + + case aExpTgKind of + etkAll : pNode := vt.GetNext(pNode); + etkSelected : pNode := vt.GetNextSelected(pNode); + etkChecked : pNode := vt.GetNextChecked(pNode); + end; + end; + + if nRow > 1 then + if not SaveData then + exit; + finally + vExcel.Quit; + vExcel := Unassigned; + end; + except + on E: Exception do + begin + ETgException.TraceException(E, 'ExportXLS_VT_Div() ..'); + exit; + end; + end; + + Result := true; +end; + +function ExportHanCell_VT(vt: TVirtualStringTree; const sSheetCaption, sExportPath: String; aExpTgKind: TExportTargetKind = etkAll): Boolean; +var + vHancell: OleVariant; + vWorkBook, + vWorkSheet: Variant; + i, nRow, nCol: Integer; + pNode: PVirtualNode; +begin + Result := false; + try + vHancell := CreateOleObject('HCell.Application'); // 한컴 오피스 네오 체험판의 한셀만 설치되어 있다면 작동하지 않음 + except + on E: Exception do + begin + ETgException.TraceException(E, 'ExportHanCell_VT() .. fail CreateOleObject(HCell.Application) ..'); + exit; + end; + end; + + try + vHancell.visible := False; + vWorkBook := vHancell.Workbooks.Add; + + try + vWorkSheet := vWorkBook.WorkSheets.Add; + except + vWorkSheet := vWorkBook.Sheets.Add; + end; + + vWorkSheet.Name := sSheetCaption; + + pNode := nil; + try + i := 0; + for nCol := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[nCol].Options then + begin + vWorkSheet.Cells[1, 1 + i].Value := vt.Header.Columns[nCol].Text; + Inc(i); + end; + + case aExpTgKind of + etkAll : pNode := vt.GetFirst; + etkSelected : pNode := vt.GetFirstSelected; + etkChecked : pNode := vt.GetFirstChecked; + end; + + nRow := 0; + while pNode <> nil do + begin + i := 0; + for nCol := 0 to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[nCol].Options then + begin + vWorkSheet.Cells[2 + nRow, 1 + i].Value := vt.Text[pNode, nCol]; + Inc(i); + end; + + case aExpTgKind of + etkAll : pNode := vt.GetNext(pNode); + etkSelected : pNode := vt.GetNextSelected(pNode); + etkChecked : pNode := vt.GetNextChecked(pNode); + end; + Inc(nRow); + end; + + vWorkBook.SaveAs(OleVariant(sExportPath)); + finally + vHancell.workbooks.close; + vHancell.Quit; + vHancell := Unassigned; + end; + except + on E: Exception do + begin + ETgException.TraceException(E, 'ExportXLS_VT() ..'); + exit; + end; + end; + + Result := true; +end; + +function ExportXlsFromCsv(const sCsvPath, sOutPath: String; aCsvEncoding: TEncoding): Boolean; +var + CsvStrList, + ColumnList: TStringList; + vExcel, vWorkBook: Variant; + vArrData: OleVariant; + i, nRow, nCol: Integer; + dwRecordCnt, + dwColumnCnt: DWORD; +begin + Result := false; + + if not FileExists(sCsvPath) then + exit; + + Guard(CsvStrList, TStringList.Create); + CsvStrList.LoadFromFile(sCsvPath, aCsvEncoding); + + if CsvStrList.Count = 0 then + exit; + + Guard(ColumnList, TStringList.Create); + + try + vExcel := CreateOleObject('Excel.Application'); + except + on E: Exception do + begin + ETgException.TraceException(E, 'ExportXLS_fromCVS() .. fail CreateOleObject(Excel.Application) ..'); + exit; + end; + end; + + try + try + vWorkBook := vExcel.WorkBooks.Add; + + dwRecordCnt := CsvStrList.Count; + + SplitString2(CsvStrList[CsvStrList.Count-1], ',', ColumnList); + dwColumnCnt := ColumnList.Count; + + vArrData := VarArrayCreate([0, dwRecordCnt, 0, dwColumnCnt-1], varVariant); + for nRow := 0 to dwRecordCnt - 1 do + begin + i := 0; + SplitString2(CsvStrList[nRow], ',', ColumnList); + for nCol := 0 to ColumnList.Count - 1 do + begin + vArrData[nRow, i] := ColumnList[nCol]; + Inc(i); + end; + end; + + vWorkBook := vExcel.WorkSheets.Add; + vExcel.Sheets[1].Name := 'Untitle'; + + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].NumberFormatLocal := WideString('@'); // 문자열 강제 지정 + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Value := vArrData; + + vExcel.Range[vExcel.Cells[2, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Select; + vExcel.Selection.VerticalAlignment := 2; + vExcel.Selection.HorizontalAlignment := 2; + + vExcel.Range[vExcel.Cells[1, 1], vExcel.Cells[dwRecordCnt + 1, dwColumnCnt]].Select; + vExcel.Selection.Columns.AutoFit; + finally + vExcel.DisplayAlerts := False; + vExcel.Visible := False; + vWorkBook.Saveas(sOutPath); + vExcel.Quit; + vExcel := Unassigned; + end; + except + on E: Exception do + begin + ETgException.TraceException(E, 'ExportXLS_VT() ..'); + exit; + end; + end; + + Result := true; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.FileInfo.pas b/Tocsg.Lib/VCL/Tocsg.FileInfo.pas new file mode 100644 index 00000000..295c7dc4 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.FileInfo.pas @@ -0,0 +1,394 @@ +{*******************************************************} +{ } +{ Tocsg.Export } +{ } +{ Copyright (C) 2024 kku } +{ } +{*******************************************************} + +unit Tocsg.FileInfo; + +interface + +uses + System.SysUtils, Winapi.Windows, superobject, System.Classes; + +const + FmtID_SummaryInformation : TGUID = '{F29F85E0-4FF9-1068-AB91-08002B27B3D9}'; + FMTID_DocSummaryInformation : TGUID = '{D5CDD502-2E9C-101B-9397-08002B2CF9AE}'; + FMTID_UserDefinedProperties : TGUID = '{D5CDD505-2E9C-101B-9397-08002B2CF9AE}'; + IID_IPropertySetStorage : TGUID = '{0000013A-0000-0000-C000-000000000046}'; + +// Summary Information + PID_TITLE = 2; + PID_SUBJECT = 3; + PID_AUTHOR = 4; + PID_KEYWORDS = 5; + PID_COMMENTS = 6; + PID_TEMPLATE = 7; + PID_LASTAUTHOR = 8; + PID_REVNUMBER = 9; + PID_EDITTIME = 10; + PID_LASTPRINTED = 11; + PID_CREATE_DTM = 12; + PID_LASTSAVE_DTM = 13; + PID_PAGECOUNT = 14; + PID_WORDCOUNT = 15; + PID_CHARCOUNT = 16; + PID_THUMBNAIL = 17; + PID_APPNAME = 18; + PID_SECURITY = 19; + +// Document Summary Information + PID_CATEGORY = 2; + PID_PRESFORMAT = 3; + PID_BYTECOUNT = 4; + PID_LINECOUNT = 5; + PID_PARCOUNT = 6; + PID_SLIDECOUNT = 7; + PID_NOTECOUNT = 8; + PID_HIDDENCOUNT = 9; + PID_MMCLIPCOUNT = 10; + PID_SCALE = 11; + PID_HEADINGPAIR = 12; + PID_DOCPARTS = 13; + PID_MANAGER = 14; + PID_COMPANY = 15; + PID_LINKSDIRTY = 16; + PID_CHARCOUNT2 = 17; + +type + TTgFilePropInfo = record + FileName, + FilePath, + Company, + Description, + Version, + InternalName, + LegalCopyright, + LegalTradeMarks, + OriginalFileName, + ProductName, + ProductVersion, + Comments: String; + end; + + TTgFileInfo = class(TObject) + private + FilePropInfo_: TTgFilePropInfo; + public + Constructor Create(const sPath: String); + + function FileProgToJsonObj: ISuperObject; + + property FileName: String read FilePropInfo_.FileName; + property FilePath: String read FilePropInfo_.FilePath; + property Company: String read FilePropInfo_.Company; + property Description: String read FilePropInfo_.Description; + property Version: String read FilePropInfo_.Version; + property InternalName: String read FilePropInfo_.InternalName; + property LegalCopyright: String read FilePropInfo_.LegalCopyright; + property LegalTradeMarks: String read FilePropInfo_.LegalTradeMarks; + property OriginalFileName: String read FilePropInfo_.OriginalFileName; + property ProductName: String read FilePropInfo_.ProductName; + property ProductVersion: String read FilePropInfo_.ProductVersion; + property Comments: String read FilePropInfo_.Comments; + end; + +function FileSummaryToList(sPath: String; aList: TStrings): Integer; +function PropPidToStr(const wVal: WORD): String; +//function GetAipLabel(sPath: String): String; + +implementation + +uses + Tocsg.Strings, Tocsg.Json, Tocsg.Exception, Winapi.ActiveX, System.Win.ComObj, + Tocsg.Trace, Tocsg.DateTime; + +type + PLandCodepage = ^TLandCodepage; + TLandCodepage = record + wLanguage, + wCodePage: WORD; + end; + +{ TTgFileInfo } + +Constructor TTgFileInfo.Create(const sPath: String); + + function GetVerQueryValue(pInfo: Pointer; const sLang, sField: String): String; + var + dwVerSize: DWORD; + pVer: Pointer; + begin + Result := ''; + VerQueryValue(pInfo, PChar(Format('\StringFileInfo\%s\%s', [sLang, sField])), pVer, dwVerSize); + if dwVerSize > 0 then + begin + SetLength(Result, dwVerSize); + StrLCopy(PChar(Result), pVer, dwVerSize); + Result := DeleteNullTail(Result); + Result := StringReplace(Result, #13, ' ', [rfReplaceAll]); + Result := StringReplace(Result, #10, '', [rfReplaceAll]); + end; + end; + + procedure GetFileInfo; + var + dwLen, + dwInfoSize: DWORD; + pInfo, pLang: Pointer; + sLang: String; + begin + if FileExists(sPath) then + begin + dwInfoSize := GetFileVersionInfoSize(PChar(sPath), dwInfoSize); + if dwInfoSize = 0 then + exit; + + pInfo := AllocMem(dwInfoSize); + try + if GetFileVersionInfo(PChar(sPath), 0, dwInfoSize, pInfo) then + if VerQueryValue(pInfo, '\VarFileInfo\Translation\', pLang, dwLen) then + begin + sLang := Format('%.4x%.4x', [PLandCodepage(pLang).wLanguage, PLandCodepage(pLang).wCodePage]); + + with FilePropInfo_ do + begin + Company := GetVerQueryValue(pInfo, sLang, 'CompanyName'); + Description := GetVerQueryValue(pInfo, sLang, 'FileDescription'); + Version := GetVerQueryValue(pInfo, sLang, 'FileVersion'); + InternalName := GetVerQueryValue(pInfo, sLang, 'InternalName'); + LegalCopyright := GetVerQueryValue(pInfo, sLang, 'LegalCopyright'); + LegalTradeMarks := GetVerQueryValue(pInfo, sLang, 'LegalTradeMarks'); + OriginalFileName := GetVerQueryValue(pInfo, sLang, 'OriginalFilename'); + ProductName := GetVerQueryValue(pInfo, sLang, 'ProductName'); + ProductVersion := GetVerQueryValue(pInfo, sLang, 'ProductVersion'); + Comments := GetVerQueryValue(pInfo, sLang, 'Comments'); + end; + end; + finally + FreeMem(pInfo, dwInfoSize); + end; + end; + end; + +begin + Inherited Create; + + ZeroMemory(@FilePropInfo_, SizeOf(FilePropInfo_)); + + FilePropInfo_.FilePath := sPath; + FilePropInfo_.FileName := ExtractFileName(FilePropInfo_.FilePath); + + GetFileInfo; + + if FilePropInfo_.Description = '' then + FilePropInfo_.Description := FilePropInfo_.FileName; +end; + +function TTgFileInfo.FileProgToJsonObj: ISuperObject; +begin + Result := TTgJson.ValueToJsonObject<TTgFilePropInfo>(FilePropInfo_); +end; + +function FileSummaryToList(sPath: String; aList: TStrings): Integer; +var + Stg: IStorage; + PropSetStg: IPropertySetStorage; + PropStg: IPropertyStorage; + PropEnum: IEnumSTATPROPSTG; + HR : HResult; + PropStat: STATPROPSTG; + nCnt, i: Integer; + PropSpec: array of TPropSpec; + PropVariant: array of TPropVariant; + sTemp: String; +begin + Result := 0; + try + aList.Clear; + + if not Succeeded(StgOpenStorage(PChar(sPath), nil, STGM_READ or + STGM_SHARE_DENY_WRITE, + nil, 0, Stg)) then + begin + TTgTrace.T('Fail .. StgOpenStorage() .. Path=%s', [sPath], 1); + exit; + end; + + PropSetStg := Stg as IPropertySetStorage; + if not Succeeded(PropSetStg.Open(FmtID_SummaryInformation, + STGM_READ or STGM_SHARE_EXCLUSIVE, PropStg)) then + begin + TTgTrace.T('Fail .. PropSetStg.Open() .. Path=%s', [sPath], 1); + exit; + end; + + if not Succeeded(PropStg.Enum(PropEnum)) then + begin + TTgTrace.T('Fail .. PropStg.Enum() .. Path=%s', [sPath], 1); + exit; + end; + + nCnt := 0; + HR := PropEnum.Next(1, PropStat, nil); + while HR = S_OK do + begin + SetLength(PropSpec, nCnt + 1); + PropSpec[nCnt].ulKind := PRSPEC_PROPID; + PropSpec[nCnt].propid := PropStat.propid; + HR := PropEnum.Next(1, PropStat, nil); + Inc(nCnt); + end; + + if nCnt = 0 then + begin + TTgTrace.T('Fail .. Not found PropSpec .. Path=%s', [sPath], 1); + exit; + end; + + SetLength(PropVariant, nCnt); + if PropStg.ReadMultiple(nCnt, @PropSpec[0], @PropVariant[0]) <> S_OK then + begin + TTgTrace.T('Fail .. PropStg.ReadMultiple() .. Path=%s', [sPath], 1); + exit; + end; + + for i := 0 to nCnt - 1 do + begin + case PropVariant[i].vt of + VT_LPSTR : + if Assigned(PropVariant[i].pszVal) then + begin + if IsUTF8_AnsiChar(PropVariant[i].pszVal) then + sTemp := UTF8String(PropVariant[i].pszVal) + else + sTemp := AnsiString(PropVariant[i].pszVal); + aList.AddObject(sTemp, TObject(PropSpec[i].propid)); + end; + VT_FILETIME : + if PropSpec[i].propid = PID_EDITTIME then + aList.AddObject(Format('%g', [Comp(PropVariant[I].filetime) / 1.0E9]), TObject(PropSpec[i].propid)) + else + aList.AddObject(DateTimeToStr(ConvFileTimeToDateTime_Local(PropVariant[i].filetime)), TObject(PropSpec[i].propid)); + VT_I4 : + aList.AddObject(IntToStr(PropVariant[i].lVal), TObject(PropSpec[i].propid)); + end; + end; + + Result := aList.Count; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. FileDetailToList()'); + end; +end; + +function PropPidToStr(const wVal: WORD): String; +begin + case wVal of + PID_TITLE : Result := 'Title'; + PID_SUBJECT : Result := 'Subject'; + PID_AUTHOR : Result := 'Author'; + PID_KEYWORDS : Result := 'Keywords'; + PID_COMMENTS : Result := 'Comments'; + PID_TEMPLATE : Result := 'Template'; + PID_LASTAUTHOR : Result := 'Last Saved By'; + PID_REVNUMBER : Result := 'Revision Number'; + PID_EDITTIME : Result := 'Total Editing Time'; + PID_LASTPRINTED : Result := 'Last Printed'; + PID_CREATE_DTM : Result := 'Create Time/Date'; + PID_LASTSAVE_DTM : Result := 'Last Saved Time/Date'; + PID_PAGECOUNT : Result := 'Number of Pages'; + PID_WORDCOUNT : Result := 'Number of Words'; + PID_CHARCOUNT : Result := 'Number of Characters'; + PID_THUMBNAIL : Result := 'Thumbnail'; + PID_APPNAME : Result := 'Creating Application'; + PID_SECURITY : Result := 'Security'; + else Result := '$' + IntToHex(wVal, 8); + end +end; + +// "사용자 지정"을 통한 AIP 적용 유무는 정확도가 떨어져서 사용하지 않기로 함 24_0905 09:35:30 kku +//function GetAipLabel(sPath: String): String; +//var +// Stg: IStorage; +// PropSetStg: IPropertySetStorage; +// PropStg: IPropertyStorage; +// PropEnum: IEnumSTATPROPSTG; +// HR : HResult; +// PropStat: STATPROPSTG; +// nCnt: Integer; +// PropSpec: array of TPropSpec; +// PropVariant: array of TPropVariant; +// sSpecName: String; +//begin +// Result := ''; +// try +// if not Succeeded(StgOpenStorage(PChar(sPath), nil, STGM_READ or +// STGM_SHARE_DENY_WRITE, +// nil, 0, Stg)) then +// begin +// // 일반파일 대상으로 하면 로그가 너무 많이 떠서 비활성 24_0221 14:28:23 kku +//// TTgTrace.T('Fail .. StgOpenStorage() .. Path=%s', [sPath], 1); +// exit; +// end; +// +// PropSetStg := Stg as IPropertySetStorage; +// if not Succeeded(PropSetStg.Open(FMTID_UserDefinedProperties, +// STGM_READ or STGM_SHARE_EXCLUSIVE, PropStg)) then +// begin +// TTgTrace.T('Fail .. PropSetStg.Open() .. Path=%s', [sPath], 1); +// exit; +// end; +// +// if not Succeeded(PropStg.Enum(PropEnum)) then +// begin +// TTgTrace.T('Fail .. PropStg.Enum() .. Path=%s', [sPath], 1); +// exit; +// end; +// +// nCnt := 0; +// HR := PropEnum.Next(1, PropStat, nil); +// while HR = S_OK do +// begin +// sSpecName := UpperCase(PropStat.lpwstrName); +// if sSpecName.StartsWith('MSIP_LABEL_') and sSpecName.EndsWith('_NAME') then +// begin +// SetLength(PropSpec, nCnt + 1); +// PropSpec[nCnt].ulKind := PRSPEC_PROPID; +// PropSpec[nCnt].propid := PropStat.propid; +// Inc(nCnt); +// break; +// end; +// HR := PropEnum.Next(1, PropStat, nil); +// end; +// +// if nCnt = 0 then +// begin +// TTgTrace.T('Fail .. Not found PropSpec .. Path=%s', [sPath], 1); +// exit; +// end; +// +// SetLength(PropVariant, nCnt); +// if PropStg.ReadMultiple(nCnt, @PropSpec[0], @PropVariant[0]) <> S_OK then +// begin +// TTgTrace.T('Fail .. PropStg.ReadMultiple() .. Path=%s', [sPath], 1); +// exit; +// end; +// +// if PropVariant[0].vt = VT_LPSTR then +// if Assigned(PropVariant[0].pszVal) then +// begin +// if IsUTF8(PropVariant[0].pszVal) then +// Result := UTF8String(PropVariant[0].pszVal) +// else +// Result := AnsiString(PropVariant[0].pszVal); +// end; +// except +// on E: Exception do +// ETgException.TraceException(E, 'Fail .. FileDetailToList()'); +// end; +//end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Files.pas b/Tocsg.Lib/VCL/Tocsg.Files.pas new file mode 100644 index 00000000..0d66a465 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Files.pas @@ -0,0 +1,1665 @@ +{*******************************************************} +{ } +{ Tocsg.Files } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Files; + +interface + +uses + Winapi.Windows, System.SysUtils, Tocsg.Obj, superobject, Tocsg.Thread, + System.SyncObjs, System.Classes, System.Generics.Collections, + System.Generics.Defaults; + +const +{$IF CompilerVersion <= 21} + FILE_LIST_DIRECTORY = $0001; +{$IFEND} + + DEFAULT_FILEWATCH_FILTER = FILE_NOTIFY_CHANGE_FILE_NAME or + FILE_NOTIFY_CHANGE_DIR_NAME or + FILE_NOTIFY_CHANGE_SIZE or + FILE_NOTIFY_CHANGE_LAST_WRITE; // FILE_NOTIFY_CHANGE_SIZE �����δ� ���� ����� �� ����� ijġ ���ؼ� �߰���. + + + STOP_WORK = $FFFFFFFF; + +type + PDirWatchInfo = ^TDirWatchInfo; + TDirWatchInfo = packed record + dwNextOffset, + dwAction, + dwLength: DWORD; + sPath: PChar; + end; + +// Action : 1 = Add, 2 = Delete, 3 = Modify, 4 = Rename, 5 = NewName + PDirWatchEnt = ^TDirWatchEnt; + TDirWatchEnt = record + sPath: String; + dwAction: DWORD; + end; + + TEvDirWatchNotification = procedure(Sender: TObject; pEnt: PDirWatchEnt) of object; + + TThdProcDirWatchEnt = class(TTgThread) + private + qDirWatchEntry_: TQueue<PDirWatchEnt>; + evDirWatchNotification_: TEvDirWatchNotification; + protected + procedure OnDirWatchNotify(Sender: TObject; const Item: PDirWatchEnt; + Action: TCollectionNotification); + procedure Execute; override; + public + Constructor Create(bSync: Boolean); + Destructor Destroy; override; + procedure Clear; + + function Count: Integer; + + procedure PushDirWatch(pEnt: PDirWatchEnt); virtual; + property OnProcessDirWatch: TEvDirWatchNotification write evDirWatchNotification_; + end; + + TThdDirWatchEnt = class(TTgThread) + private + Processor_: TThdProcDirWatchEnt; + sTgDir_: String; + hDir_, + hCompPort_: THandle; + dwFilter_: DWORD; + OverL_: TOverlapped; + pOVerL_: POverlapped; + pBuf_: array [0..4096] of Byte; + bSubDirWatch_, + bRemoveAbleDrive_: Boolean; + bCoInit_: Boolean; + protected + function GetFilter: DWORD; + procedure SetFilter(dwFilter: DWORD); + procedure Execute; override; + procedure DoTerminate; override; + public + Constructor Create(aProcessor: TThdProcDirWatchEnt; const sTgDir: String; + bSubDirWatch: Boolean; dwFilter: DWORD; bCoInit: Boolean = false); + Destructor Destroy; override; + + property Filter: DWORD read GetFilter write SetFilter; + end; + + TThdDirWatchEntList = class(TList<TThdDirWatchEnt>) + protected + procedure Notify(const Item: TThdDirWatchEnt; Action: TCollectionNotification); override; + public + function GetEntByTgDir(sTgDir: String): TThdDirWatchEnt; + end; + + TTgDirWatchBase = class(TTgObject) + private + CS_: TCriticalSection; + bSubDirWatch_: Boolean; + dwFilter_: DWORD; + DcDirWatch_: TDictionary<String,TThdDirWatchEnt>; + procedure OnDirWatchNotify(Sender: TObject; const Item: TThdDirWatchEnt; + Action: TCollectionNotification); + protected + Processor_: TThdProcDirWatchEnt; + protected + procedure Lock; + procedure Unlock; + procedure SetFilter(dwFilter: DWORD); + procedure ProcessDirWatchEnt(Sender: TObject; pInfo: PDirWatchEnt); virtual; abstract; + public + Constructor Create(bSubDir, bSync: Boolean); + Destructor Destroy; override; + + procedure AddDirWatch(sDir: String; bCoInit: Boolean = false); + function DelDirWatch(sDir: String): Boolean; + function ExistsDirWatch(sDir: String): Boolean; + procedure ClearDirWatch; + + procedure StartWatch; virtual; + procedure StopWatch; virtual; + + property Filter: DWORD read dwFilter_ write SetFilter; + property Processor: TThdProcDirWatchEnt read Processor_; + end; + + PFileInfo = ^TFileInfo; + TFileInfo = record + Path: String; + Size: LONGLONG; + CreateDT, + ModifyDT, + AccessDT: TDateTime; + IsDir: Boolean; + end; + + PModFile = ^TModFile; + TModFile = record + sDir, + sFName: String; + dtModify: TDateTime; + end; + TModFileList = class(TList<PModFile>) + protected + procedure Notify(const Item: PModFile; Action: TCollectionNotification); override; + end; + + TModeFileComparer = class(TComparer<PModFile>) + public + function Compare(const Left, Right: PModFile): Integer; override; + end; + +function GetFileSize_path(const sPath: String): LONGLONG; inline; +function GetFileSizeHiLow(dwHi, dwLow: DWORD): LONGLONG; inline; +function GetFilesSizeFromDir(sDir: String; bSubDir: Boolean; pnCnt: PInteger = nil; sIgrKwd: String = ''): LONGLONG; + +function MoveFile_wait(sSrcPath, sDecPath: String; nWaitSec: WORD = 10; bForce: Boolean = false): Boolean; +function DeleteFile_wait(sSrcPath: String; nWaitSec: Integer = 10): Boolean; + +function IsValidFilename(const sFName: String): Boolean; inline; +function GetValidFileName(sFName: String; sRepStr: String = ''): String; inline; + +procedure ExtrFilesFromDir(sDir: String; aList: TStrings; bSubDir: Boolean = false; sFileExts: String = ''); +procedure ExtrDirFromDir(sDir: String; aList: TStrings); +procedure ExtrFilesPathFromDir(sDir: String; aList: TStrings; bSubDir: Boolean = false; sFileExts: String = ''); +procedure ExtrModFilesFromDir(sDir: String; aList: TModFileList; bSubDir: Boolean = false; sFileExts: String = ''); +procedure DeleteDirSub(sDir: String; bIncludeSubDir: Boolean = true; + bForceDel: Boolean = false; aIgrList: TStringList = nil; bSafeDel: Boolean = false); +function DeleteDir(sDir: String; bIncludeSubDir: Boolean = true; + bForceDel: Boolean = false; aIgrList: TStringList = nil): Boolean; +function DeleteFileForce(sPath: String): Boolean; +function CopyDirSub(sSrcDir, sDestDir: String; bIncludeSubDir: Boolean = true): Boolean; +procedure GetDirInfo(sDir: String; var dwDirCnt: DWORD; var dwFileCnt: DWORD; var llTotalSize: LONGLONG; bSubDir: Boolean = false); +function CountFileExt(sDir: String; const arrExt: array of string; bIncSubDir: Boolean = false): Integer; + +function GetFileDateTime(const sPath: String; var ftCreate, ftModify, ftAccess: TFileTime): Boolean; overload; +function GetFileDateTime(const sPath: String; var dtCreate, dtModify, dtAccess: TDateTime): Boolean; overload; +function GetFileDateTime_Local(const sPath: String; var dtCreate, dtModify, dtAccess: TDateTime): Boolean; overload; +function GetFileDateTime_Local(const sPath: String; var ftCreate, ftModify, ftAccess: TFileTime): Boolean; overload; +function SetFileDateTime(const sPath: String; ftCreate, ftModify, ftAccess: TFileTime): Boolean; overload; +function SetFileDateTime(const sPath: String; dtCreate, dtModify, dtAccess: TDateTime): Boolean; overload; +function ConvFileAttrToStr(dwAttr: DWORD; bIncDir: Boolean = false): String; + +function GetSameFileNameInc(sPath: String): String; + +function StringListCompareFileCreateDate(List: TStringList; Index1, Index2: Integer): Integer; +function StringListCompareFileModifyDate(List: TStringList; Index1, Index2: Integer): Integer; + +function CheckSign(aStream: TStream; pBuf: Pointer; nLen: Integer): Boolean; overload; +function CheckSign(sPath: String; pBuf: Pointer; nLen: Integer): Boolean; overload; +function CheckSign(sPath: String; sSign: AnsiString): Boolean; overload; +function CheckSignFromList(sPath: String; BinStrList: TStrings): Boolean; + +function CopyFileAfOpenCheck(sSrcPath, sDestPath: String; nTOSec: Integer = 5): Boolean; +function GetLastOpenFileFromJumpListAuto(const sJmpAutoPath: String): String; + +// 사용하지 않음, 나중에 정리 25_1029 10:51:37 kku +//function FileExistsTO(sPath: String; nTOSec: Integer = 3): Boolean; + +implementation + +uses + System.IOUtils, Tocsg.Json, Tocsg.Exception, Tocsg.DateTime, Tocsg.Path, + Tocsg.Strings, System.DateUtils, System.StrUtils, Tocsg.Safe, Tocsg.Hex, Winapi.ActiveX, EM.GSStorage; + +{ TThdProcDirWatchEnt } + +Constructor TThdProcDirWatchEnt.Create(bSync: Boolean); +begin + Inherited Create; + + {$IFDEF TRACE1} _Trace('Process DirWatch Begin ...'); {$ENDIF} + qDirWatchEntry_ := TQueue<PDirWatchEnt>.Create; +end; + +Destructor TThdProcDirWatchEnt.Destroy; +begin + {$IFDEF TRACE1} _Trace('Process DirWatch End ...'); {$ENDIF} + Inherited; + qDirWatchEntry_.OnNotify := OnDirWatchNotify; + FreeAndNil(qDirWatchEntry_); +end; + +procedure TThdProcDirWatchEnt.OnDirWatchNotify(Sender: TObject; const Item: PDirWatchEnt; + Action: TCollectionNotification); +begin + if Action = cnRemoved then + Dispose(Item); +end; + +procedure TThdProcDirWatchEnt.Clear; +begin + Lock; + qDirWatchEntry_.OnNotify := OnDirWatchNotify; + try + qDirWatchEntry_.Clear; + finally + qDirWatchEntry_.OnNotify := nil; + Unlock; + end; +end; + +function TThdProcDirWatchEnt.Count: Integer; +begin + Lock; + try + Result := qDirWatchEntry_.Count; + finally + Unlock; + end; +end; + +procedure TThdProcDirWatchEnt.Execute; +var + pEnt: PDirWatchEnt; +begin + while not Terminated and not GetWorkStop do + begin + try + if qDirWatchEntry_.Count = 0 then + begin + Sleep(500); + continue; + end; + + Lock; + try + pEnt := qDirWatchEntry_.Dequeue + finally + Unlock; + end; + + if (pEnt <> nil) then + begin + if Assigned(evDirWatchNotification_) then + evDirWatchNotification_(Self, pEnt); + Dispose(pEnt); + end; + except + on E: Exception do + begin + ETgException.TraceException(Self, E, 'Fail .. Execute()'); + Sleep(1000); + end; + end; + end; +end; + +procedure TThdProcDirWatchEnt.PushDirWatch(pEnt: PDirWatchEnt); +begin + Lock; + try + qDirWatchEntry_.Enqueue(pEnt); + finally + Unlock; + end; +end; + +{ TThdFileWathchEntry } + +Constructor TThdDirWatchEnt.Create(aProcessor: TThdProcDirWatchEnt; + const sTgDir: String; bSubDirWatch: Boolean; dwFilter: DWORD; bCoInit: Boolean = false); +var + dwLen: DWORD; +begin + Inherited Create; + + hCompPort_ := 0; + Processor_ := aProcessor; + sTgDir_ := IncludeTrailingPathDelimiter(sTgDir); + bCoInit_ := bCoInit; + + {$IFDEF TRACE1} _Trace('DirWatch Begin ... Drive = %s', [sDrive_]); {$ENDIF} + + hDir_ := CreateFile(PChar(sTgDir_), + FILE_LIST_DIRECTORY, + FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE, + nil, + OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OVERLAPPED, + 0); + + if hDir_ = INVALID_HANDLE_VALUE then + begin + _Trace('CreateFile() - Fail!, Drive = %s, Error = %d', [sTgDir_, GetLastError]); + nLastError_ := 1; + hDir_ := 0; + exit; + end; + + dwFilter_ := dwFilter; + if dwFilter_ = 0 then + begin + _Trace('No Filter... - Fail!'); + nLastError_ := 2; + exit; + end; + + hCompPort_ := CreateIoCompletionPort(hDir_, 0, DWORD(Self), 0); + if hCompPort_ = 0 then + begin + _Trace('CreateIoCompletionPort() - Fail!, Drive = %s, Error = %d', [sTgDir_, GetLastError]); + nLastError_ := 3; + CloseHandle(hDir_); + hDir_ := 0; + exit; + end; + + ZeroMemory(@OverL_, SizeOf(OverL_)); + ZeroMemory(@pBuf_, SizeOf(pBuf_)); + pOVerL_ := @OverL_; + + dwLen := 0; + bSubDirWatch_ := bSubDirWatch; + if not ReadDirectoryChanges(hDir_, + @pBuf_, + SizeOf(pBuf_), + bSubDirWatch_, + dwFilter_, + @dwLen, + pOVerL_, + nil) then + begin + _Trace('ReadDirectoryChanges() - Fail!, Drive = %s, Error = %d', [sTgDir_, GetLastError]); + nLastError_ := 4; + CloseHandle(hCompPort_); + CloseHandle(hDir_); + hCompPort_ := 0; + hDir_ := 0; + exit; + end; + + if GetDriveType(PChar(sTgDir_)) = DRIVE_REMOVABLE then + bRemoveAbleDrive_ := true + else + bRemoveAbleDrive_ := false; + + StartThread; +end; + +Destructor TThdDirWatchEnt.Destroy; +begin + {$IFDEF TRACE1} _Trace('DirWatch End - Drive = %s', [sDrive_]); {$ENDIF} + + if hCompPort_ <> 0 then + begin + PostQueuedCompletionStatus(hCompPort_, 0, 0, Pointer(STOP_WORK)); + CloseHandle(hCompPort_); + hCompPort_ := 0; + end; + + if (hDir_ <> 0) and (hDir_ <> INVALID_HANDLE_VALUE) then + begin + CloseHandle(hDir_); + hDir_ := 0; + end; + + Inherited; +end; + +function TThdDirWatchEnt.GetFilter: DWORD; +begin + Lock; + try + Result := dwFilter_; + finally + Unlock; + end; +end; + +procedure TThdDirWatchEnt.SetFilter(dwFilter: DWORD); +begin + Lock; + try + dwFilter_ := dwFilter; + finally + Unlock; + end; +end; + +procedure TThdDirWatchEnt.DoTerminate; +begin + if hCompPort_ <> 0 then + PostQueuedCompletionStatus(hCompPort_, 0, 0, Pointer(STOP_WORK)); +end; + +procedure TThdDirWatchEnt.Execute; +var + dwTrans: DWORD; +{$IF CompilerVersion <= 21} + nCompKey: DWORD; +{$ELSE} + nCompKey: NativeUInt; +{$IFEND} + + procedure CloseWork; + begin + bWorkStop_ := false; +// if hCompPort_ <> 0 then +// begin +// CloseHandle(hCompPort_); +// hCompPort_ := 0; +// end; +// +// if hDir_ <> 0 then +// begin +// CloseHandle(hDir_); +// hDir_ := 0; +// end; + end; + + procedure ProcessResult; + var + pInfo: PDirWatchInfo; + nOffset: Integer; + pEnt: PDirWatchEnt; + begin + pInfo := PDirWatchInfo(@pBuf_[0]); + while True do + begin + if Terminated then + exit; + + New(pEnt); + {$IFDEF UNICODE} + pEnt.sPath := sTgDir_ + WideCharLenToString(@pInfo.sPath, pInfo.dwLength div 2); + {$ELSE} + pEnt.sPath := sDrive_ + WideCharLenToString(@pInfo.sPath, pInfo.dwLength); + {$ENDIF} + pEnt.dwAction := pInfo.dwAction; + + Processor_.PushDirWatch(pEnt); + + nOffset := pInfo.dwNextOffset; + if nOffset = 0 then + exit; + + PAnsiChar(pInfo) := PAnsiChar(pInfo) + nOffset; + end; + end; + +begin + if bCoInit_ then + CoInitialize(nil); + try + while not Terminated do + begin + try + if not bWorkStop_ and (hCompPort_ <> 0) then + begin + if GetQueuedCompletionStatus(hCompPort_, + dwTrans, + nCompKey, + pOVerL_, + INFINITE) then + begin + if DWORD(pOVerL_) = STOP_WORK then + begin + // _Trace('Stop work...., Drive = %s', [sDrive_]); + break; + end; + + if nCompKey = DWORD(Self) then + begin + ProcessResult; + + dwTrans := 0; + ZeroMemory(@pBuf_, SizeOf(pBuf_)); + + if not ReadDirectoryChanges(hDir_, + @pBuf_, + SizeOf(pBuf_), + bSubDirWatch_, + GetFilter, + @dwTrans, + pOVerL_, + nil) then + begin + nLastError_ := 7; + _Trace('>> ReadDirectoryChanges() - Fail! in Thread, Drive = %s, Error = %d', [sTgDir_, GetLastError]); + CloseWork; + end; + end else begin + nLastError_ := 6; + _Trace('Invlid completion key - Fail!, Drive = %s, Error = %d', [sTgDir_, GetLastError]); + CloseWork; + end; + end else begin + nLastError_ := 5; + _Trace('GetQueuedCompletionStatus() - Fail!, Drive = %s, Error = %d', [sTgDir_, GetLastError]); + CloseWork; + end; + end else Sleep(100); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. Execute()'); + end; + end; + finally + if bCoInit_ then + CoUninitialize; + end; +end; + +{ TThdDirWatchEntList } + +procedure TThdDirWatchEntList.Notify(const Item: TThdDirWatchEnt; Action: TCollectionNotification); +begin + if Action = cnRemoved then + Item.Free; +end; + +function TThdDirWatchEntList.GetEntByTgDir(sTgDir: String): TThdDirWatchEnt; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if CompareText(Items[i].sTgDir_, sTgDir) = 0 then + begin + Result := Items[i]; + exit; + end; +end; + +{ TTgDirWatchBase } + +Constructor TTgDirWatchBase.Create(bSubDir, bSync: Boolean); +begin + Inherited Create; + + CS_ := TCriticalSection.Create; + + dwFilter_ := DEFAULT_FILEWATCH_FILTER; + + bSubDirWatch_ := bSubDir; + Processor_ := TThdProcDirWatchEnt.Create(bSync); + Processor_.OnProcessDirWatch := ProcessDirWatchEnt; + DcDirWatch_ := TDictionary<String,TThdDirWatchEnt>.Create; + DcDirWatch_.OnValueNotify := OnDirWatchNotify; +end; + +Destructor TTgDirWatchBase.Destroy; +begin + StopWatch; + DcDirWatch_.Clear; + FreeAndNil(DcDirWatch_); + FreeAndNil(Processor_); + Inherited; + FreeAndNil(CS_); +end; + +procedure TTgDirWatchBase.Lock; +begin + CS_.Acquire; +end; + +procedure TTgDirWatchBase.Unlock; +begin + CS_.Release; +end; + +procedure TTgDirWatchBase.OnDirWatchNotify(Sender: TObject; const Item: TThdDirWatchEnt; + Action: TCollectionNotification); +begin + if Action = cnRemoved then + Item.Free; +end; + +procedure TTgDirWatchBase.SetFilter(dwFilter: DWORD); +var + enum: TEnumerator<TThdDirWatchEnt>; +begin + if dwFilter_ <> dwFilter then + begin + dwFilter_ := dwFilter; + Lock; + try + enum := DcDirWatch_.Values.GetEnumerator; + finally + Unlock; + end; + + while enum.MoveNext do + enum.Current.Filter := dwFilter_; + enum.Free; + end; +end; + +procedure TTgDirWatchBase.AddDirWatch(sDir: String; bCoInit: Boolean = false); +var + ThdDirWatch: TThdDirWatchEnt; +begin + if DirectoryExists(sDir) then + begin + sDir := IncludeTrailingPathDelimiter(sDir); + if not DcDirWatch_.ContainsKey(sDir) then + begin + ThdDirWatch := TThdDirWatchEnt.Create(Processor_, + sDir, + bSubDirWatch_, + dwFilter_, bCoInit); + if ThdDirWatch.LastError <> 0 then + begin + _Trace('Fail .. AddDirWatch() .. Error=%d', [ThdDirWatch.LastError], 1); + ThdDirWatch.Free; + exit; + end; + + Lock; + try + DcDirWatch_.Add(UpperCase(sDir), ThdDirWatch); + finally + Unlock; + end; + end; + end; +end; + +function TTgDirWatchBase.DelDirWatch(sDir: String): Boolean; +begin + Result := false; + sDir := UpperCase(IncludeTrailingPathDelimiter(sDir)); + Lock; + try + if DcDirWatch_.ContainsKey(sDir) then + begin + DcDirWatch_.Remove(sDir); + Result := true; + end; + finally + Unlock; + end; +end; + +function TTgDirWatchBase.ExistsDirWatch(sDir: String): Boolean; +begin + sDir := UpperCase(IncludeTrailingPathDelimiter(sDir)); + Lock; + try + Result := DcDirWatch_.ContainsKey(sDir); + finally + Unlock; + end; +end; + +procedure TTgDirWatchBase.ClearDirWatch; +begin + Lock; + try + DcDirWatch_.Clear; + finally + Unlock; + end; +end; + +procedure TTgDirWatchBase.StartWatch; +begin + Processor_.StartThread; +end; + +procedure TTgDirWatchBase.StopWatch; +begin + Processor_.Clear; + Processor_.PauseThread; + ClearDirWatch; +end; + +{ TModFileList } + +procedure TModFileList.Notify(const Item: PModFile; Action: TCollectionNotification); +begin + if Action = cnRemoved then + Dispose(Item); +end; + +{ TModeFileComparer } + +function TModeFileComparer.Compare(const Left, Right: PModFile): Integer; +begin +// Result := CompareDateTime(Left.dtModify, Right.dtModify); + Result := CompareDateTime(Right.dtModify, Left.dtModify); // �ֽż� +end; + +{ Function } + +function GetFileSize_path(const sPath: String): LONGLONG; +var + sr: TSearchRec; +begin + Result := -1; + try + if FindFirst(sPath, faAnyFile, sr) = 0 then + begin + Result := sr.Size; + FindClose(sr); + end; + except + // .. + end; +end; + +function GetFileSizeHiLow(dwHi, dwLow: DWORD): LONGLONG; +begin + Result := LONGLONG(LONGLONG(dwHi) * MAXDWORD) + dwLow; +end; + +function GetFilesSizeFromDir(sDir: String; bSubDir: Boolean; pnCnt: PInteger = nil; sIgrKwd: String = ''): LONGLONG; +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; +begin + Result := 0; + try + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + if sIgrKwd <> '' then + sIgrKwd := UpperCase(sIgrKwd); + + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if bSubDir then + Inc(Result, GetFilesSizeFromDir(sDir + wfd.cFileName, bSubDir, pnCnt, sIgrKwd)); + end else begin + if (sIgrKwd = '') or (Pos(sIgrKwd, UpperCase(wfd.cFileName)) = 0) then + begin + Inc(Result, GetFileSizeHiLow(wfd.nFileSizeHigh, wfd.nFileSizeLow)); + if pnCnt <> nil then + pnCnt^ := pnCnt^ + 1; + end; + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetFilesSizeFromDir()'); + end; +end; + +function MoveFile_wait(sSrcPath, sDecPath: String; nWaitSec: WORD = 10; bForce: Boolean = false): Boolean; +var + w: WORD; +begin + Result := false; + try + if FileExists(sSrcPath) and FileExists(sDecPath) then + begin + if bForce then + DeleteFile(sDecPath) + else exit; + end; + + if DirectoryExists(sSrcPath) and DirectoryExists(sDecPath) then + begin + if bForce then + DeleteDir(sDecPath) + else exit; + end; + + Result := true; + w := 0; + while not MoveFile(PChar(sSrcPath), PChar(sDecPath)) do + begin + Sleep(1000); + if w = nWaitSec then + begin + Result := false; + break; + end; + Inc(w); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. MoveFile_wait()'); + end; +end; + +function DeleteFile_wait(sSrcPath: String; nWaitSec: Integer = 10): Boolean; +var + n: Integer; +begin + Result := true; + n := 0; + while FileExists(sSrcPath) and + not DeleteFile(PChar(sSrcPath)) do + begin + Sleep(1000); + if n = nWaitSec then + begin + Result := false; + exit; + end; + Inc(n); + end; +end; + +function IsValidFilename(const sFName: String): Boolean; +begin +// \ / : * ? " < > | + Result := TPath.HasValidFileNameChars(sFName, false); +end; + +function GetValidFileName(sFName: String; sRepStr: String = ''): String; inline; +var + sNoFileChars: String; + i: Integer; +begin + Result := sFName; + sNoFileChars := '\/:*?"<>|'; + for i := 1 to Length(sNoFileChars) do + Result := ReplaceStr(Result, sNoFileChars[i], sRepStr); +end; + +procedure ExtrFilesFromDir(sDir: String; aList: TStrings; bSubDir: Boolean = false; sFileExts: String = ''); +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; +begin + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + if sFileExts <> '' then + sFileExts := UpperCase(sFileExts); + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if bSubDir then + ExtrFilesFromDir(sDir + wfd.cFileName, aList, bSubDir, sFileExts); + end else begin + if (sFileExts = '') or (Pos(GetFileExt(wfd.cFileName).ToUpper, sFileExts) <> 0) then + aList.Add(wfd.cFileName); + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +procedure ExtrDirFromDir(sDir: String; aList: TStrings); +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; +begin + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + aList.Add(wfd.cFileName); + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +procedure ExtrFilesPathFromDir(sDir: String; aList: TStrings; bSubDir: Boolean = false; sFileExts: String = ''); +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; +begin + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + if sFileExts <> '' then + sFileExts := UpperCase(sFileExts); + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if bSubDir then + ExtrFilesPathFromDir(sDir + wfd.cFileName, aList, bSubDir, sFileExts); + end else begin + if (sFileExts = '') or (Pos(GetFileExt(wfd.cFileName).ToUpper, sFileExts) <> 0) then + aList.Add(sDir + wfd.cFileName); + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +procedure ExtrModFilesFromDir(sDir: String; aList: TModFileList; bSubDir: Boolean = false; sFileExts: String = ''); +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; + pEnt: PModFile; +begin + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + if sFileExts <> '' then + sFileExts := UpperCase(sFileExts); + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if bSubDir then + ExtrModFilesFromDir(sDir + wfd.cFileName, aList, bSubDir, sFileExts); + end else begin + if (sFileExts = '') or (Pos(GetFileExt(wfd.cFileName).ToUpper, sFileExts) <> 0) then + begin + New(pEnt); + pEnt.sDir := sDir; + pEnt.sFName := wfd.cFileName; + pEnt.dtModify := ConvFileTimeToDateTime(wfd.ftLastWriteTime); + aList.Add(pEnt); + end; + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +procedure DeleteDirSub(sDir: String; bIncludeSubDir: Boolean = true; + bForceDel: Boolean = false; aIgrList: TStringList = nil; bSafeDel: Boolean = false); +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; + bOpen: Boolean; +begin + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + if aIgrList <> nil then + aIgrList.CaseSensitive := false; + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if (aIgrList = nil) or + ( (aIgrList.IndexOf(wfd.cFileName) = -1) and + (aIgrList.IndexOf(String(wfd.cFileName) + '\') = -1) ) then + DeleteDir(sDir + wfd.cFileName, bIncludeSubDir, bForceDel, aIgrList); + end else begin + if (aIgrList = nil) or (aIgrList.IndexOf(wfd.cFileName) = -1) then + begin + sPath := sDir + wfd.cFileName; + if bForceDel and + ((wfd.dwFileAttributes and FILE_ATTRIBUTE_READONLY) <> 0) then + begin + // 22_0510 10:28:28 kku + SetFileAttributes(PChar(sPath), FILE_ATTRIBUTE_NORMAL); + end; + + bOpen := false; + if bSafeDel then + begin + var fs: TFileStream := nil; + try + fs := TFileStream.Create(sPath, fmOpenReadWrite or fmShareExclusive); + fs.Free; + except + on E: EFOpenError do + bOpen := True; + on E: EInOutError do + bOpen := True; + end; + end; + + if not bOpen then + DeleteFile(PChar(sPath)); + end; + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +function DeleteDir(sDir: String; bIncludeSubDir: Boolean = true; + bForceDel: Boolean = false; aIgrList: TStringList = nil): Boolean; +begin + DeleteDirSub(sDir, bIncludeSubDir, bForceDel, aIgrList); + Result := RemoveDir(sDir); +end; + +function DeleteFileForce(sPath: String): Boolean; +begin + Result := DeleteFile(PChar(sPath)); + if not Result then + begin + SetFileAttributes(PChar(sPath), FILE_ATTRIBUTE_NORMAL); + Result := DeleteFile(PChar(sPath)); + end; +end; + +function CopyDirSub(sSrcDir, sDestDir: String; bIncludeSubDir: Boolean = true): Boolean; +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; +begin + Result := false; + + try + sSrcDir := IncludeTrailingPathDelimiter(sSrcDir); + sDestDir := IncludeTrailingPathDelimiter(sDestDir); + + sPath := sSrcDir + '*.*'; + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + if not ForceDirectories(sDestDir) then + exit; + + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if not CopyDirSub(sSrcDir + wfd.cFileName, sDestDir + wfd.cFileName, bIncludeSubDir) then + exit; + end else begin + if FileExists(sDestDir + wfd.cFileName) then + DeleteFile(sDestDir + wfd.cFileName); + + if not CopyFile(PChar(sSrcDir + wfd.cFileName), + PChar(sDestDir + wfd.cFileName), false) then + exit; + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; + Result := true; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. CopyDirSub()'); + end; +end; + +procedure GetDirInfo(sDir: String; var dwDirCnt: DWORD; var dwFileCnt: DWORD; var llTotalSize: LONGLONG; bSubDir: Boolean = false); +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; +begin + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + Inc(dwDirCnt); + if bSubDir then + GetDirInfo(sDir + wfd.cFileName, dwDirCnt, dwFileCnt, llTotalSize, bSubDir); + end else begin + Inc(dwFileCnt); + Inc(llTotalSize, GetFileSizeHiLow(wfd.nFileSizeHigh, wfd.nFileSizeLow)); + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +function CountFileExt(sDir: String; const arrExt: array of string; bIncSubDir: Boolean = false): Integer; +var + wfd: TWin32FindData; + hSc: THandle; + sPath: String; + i: Integer; +begin + Result := 0; + + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if bIncSubDir then + Inc(Result, CountFileExt(sDir + wfd.cFileName, arrExt, bIncSubDir)); + end else begin + for i := Low(arrExt) to High(arrExt) do + if CompareText(GetFileExt(wfd.cFileName), arrExt[i]) = 0 then + Inc(Result); + end; + Until not FindNextFile(hSc, wfd); + finally + WinApi.Windows.FindClose(hSc); + end; +end; + +function GetFileDateTime(const sPath: String; var ftCreate, ftModify, ftAccess: TFileTime): Boolean; +var + h: THandle; +begin + Result := false; + if FileExists(sPath) then + begin + h := FileOpen(sPath, fmOpenRead or fmShareDenyNone); + if h <> INVALID_HANDLE_VALUE then + begin + try + Result := GetFileTime(h, @ftCreate, @ftAccess, @ftModify); + finally + FileClose(h); + end; + end; + end; +end; + +function GetFileDateTime(const sPath: String; var dtCreate, dtModify, dtAccess: TDateTime): Boolean; +var + ftCreate, ftAccess, ftModify: TFileTime; +begin + try + dtCreate := 0; + dtModify := 0; + dtAccess := 0; + + Result := GetFileDateTime(sPath, ftCreate, ftModify, ftAccess); + if Result then + begin + dtCreate := ConvFileTimeToDateTime(ftCreate); + dtModify := ConvFileTimeToDateTime(ftModify); + dtAccess := ConvFileTimeToDateTime(ftAccess); + end; + except + on E: Exception do + begin + Result := false; + ETgException.TraceException(E, 'Fail .. GetFileDateTime()'); + end; + end; +end; + +function GetFileDateTime_Local(const sPath: String; var dtCreate, dtModify, dtAccess: TDateTime): Boolean; +var + ftCreate, ftAccess, ftModify: TFileTime; +begin + Result := GetFileDateTime(sPath, ftCreate, ftModify, ftAccess); + if Result then + begin + dtCreate := ConvFileTimeToDateTime_Local(ftCreate); + dtModify := ConvFileTimeToDateTime_Local(ftModify); + dtAccess := ConvFileTimeToDateTime_Local(ftAccess); + end; +end; + +function GetFileDateTime_Local(const sPath: String; var ftCreate, ftModify, ftAccess: TFileTime): Boolean; overload; +begin + Result := GetFileDateTime(sPath, ftCreate, ftModify, ftAccess); + if Result then + begin + WinApi.Windows.FileTimeToLocalFileTime(ftCreate, ftCreate); + WinApi.Windows.FileTimeToLocalFileTime(ftModify, ftModify); + WinApi.Windows.FileTimeToLocalFileTime(ftAccess, ftAccess); + end; +end; + +function SetFileDateTime(const sPath: String; ftCreate, ftModify, ftAccess: TFileTime): Boolean; +var + h: THandle; +begin + Result := false; + try + if FileExists(sPath) then + begin + h := FileOpen(sPath, fmOpenWrite); + try + Result := SetFileTime(h, @ftCreate, @ftAccess, @ftModify); + finally + FileClose(h); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. SetFileDateTime()'); + end; +end; + +function SetFileDateTime(const sPath: String; dtCreate, dtModify, dtAccess: TDateTime): Boolean; +begin + Result := SetFileDateTime(sPath, ConvDateTimeToFileTime(dtCreate), + ConvDateTimeToFileTime(dtModify), + ConvDateTimeToFileTime(dtAccess)); +end; + +function ConvFileAttrToStr(dwAttr: DWORD; bIncDir: Boolean = false): String; +begin + Result := ''; + + if (dwAttr and $01) <> 0 then + Result := 'R'; // �б� ���� (Read only) + if (dwAttr and $02) <> 0 then + Result := Result + 'H'; // ���� (Hidden) + if (dwAttr and $04) <> 0 then + Result := Result + 'S'; // �ý��� (System) + if (dwAttr and $08) <> 0 then + Result := Result + 'V'; // FAT ���� ���̺�. �ݵ�� ��Ʈ�� �ִ�. + if bIncDir and ((dwAttr and $10) <> 0) then // ���丮�� �ϴ� �����ϴ°ɷ� + Result := Result + 'D'; + if bIncDir and ((dwAttr and $10000000) <> 0) then + Result := Result + 'D'; + if (dwAttr and $20) <> 0 then + Result := Result + 'A'; // Archive + if (dwAttr and $40) <> 0 then + Result := Result + 'd'; // ��ġ (Device) + if (dwAttr and $80) <> 0 then + Result := Result + 'N'; // �˹� (Normal) + if (dwAttr and $100) <> 0 then + Result := Result + 'T'; // �ӽ����� (Temp) + if (dwAttr and $200) <> 0 then + Result := Result + 'S'; // Sparese ���� + if (dwAttr and $400) <> 0 then + Result := Result + 'P'; // Reparse Point + if (dwAttr and $800) <> 0 then + Result := Result + 'C'; // ����� + if (dwAttr and $1000) <> 0 then + Result := Result + 'F'; // �������� + if (dwAttr and $2000) <> 0 then + Result := Result + 'X'; // �ε����� ��� ������ �ƴ� (NTFS) + if (dwAttr and $4000) <> 0 then + Result := Result + 'E'; // ��ȣȭ�� + if (dwAttr and $20000000) <> 0 then + Result := Result + 'I'; // Index View +end; + +function GetSameFileNameInc(sPath: String): String; +var + sDir, sFName, sExt: String; + nCnt: Integer; +begin + if not FileExists(sPath) then + begin + Result := sPath; + exit; + end; + + sDir := ExtractFilePath(sPath); + if not DirectoryExists(sDir) then + begin + Result := sPath; + exit; + end; + + sExt := GetFileExt(sPath); + sFName := CutFileExt(ExtractFileName(sPath)); + nCnt := 1; + Result := sDir + Format('%s (%d).%s', [sFName, nCnt, sExt]); + while FileExists(Result) do + begin + Inc(nCnt); + Result := sDir + Format('%s (%d).%s', [sFName, nCnt, sExt]); + end; +end; + +//function StringListCompareFileSize(List: TStringList; Index1, Index2: Integer): Integer; +//var +// ullSize1, ullSize2: ULONGLONG; +//begin +// if (Index1 >= 0) and (Index1 < List.Count) and +// (Index2 >= 0) and (Index2 < List.Count) then +// begin +// ullSize1 := GetFileSize_path(List[Index1]); +// ullSize2 := GetFileSize_path(List[Index2]); +// Result := CompareValue(ullSize1, ullSize2); +// end else +// Result := 0; +//end; + +function StringListCompareFileCreateDate(List: TStringList; Index1, Index2: Integer): Integer; +var + ftCreate1, ftCreate2, ftModify, ftAccess: TFileTime; +begin + if (Index1 >= 0) and (Index1 < List.Count) and + (Index2 >= 0) and (Index2 < List.Count) then + begin + GetFileDateTime(List[Index1], ftCreate1, ftModify, ftAccess); + GetFileDateTime(List[Index2], ftCreate2, ftModify, ftAccess); + Result := CompareFileTime(ftCreate1, ftCreate2); + end else + Result := 0; +end; + +function StringListCompareFileModifyDate(List: TStringList; Index1, Index2: Integer): Integer; +var + ftCreate, ftModify1, ftModify2, ftAccess: TFileTime; +begin + if (Index1 >= 0) and (Index1 < List.Count) and + (Index2 >= 0) and (Index2 < List.Count) then + begin + GetFileDateTime(List[Index1], ftCreate, ftModify1, ftAccess); + GetFileDateTime(List[Index2], ftCreate, ftModify2, ftAccess); + Result := CompareFileTime(ftModify1, ftModify2); + end else + Result := 0; +end; + +function CheckSign(aStream: TStream; pBuf: Pointer; nLen: Integer): Boolean; +var + pData: TBytes; +begin + Result := false; + + try + SetLength(pData, nLen); + + aStream.Position := 0; + if aStream.Read(pData[0], nLen) <> nLen then + exit; + + Result := CompareMem(@pData[0], pBuf, nLen); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. CheckSign() .. 1'); + end; +end; + +function CheckSign(sPath: String; pBuf: Pointer; nLen: Integer): Boolean; +var + fs: TFileStream; +begin + Result := false; + try + Guard(fs, TFileStream.Create(sPath, fmOpenRead)); + Result := CheckSign(fs, pBuf, nLen); + except + {$IFDEF DEBUG} + // �ǻ���� �αװ� �ʹ� ���� ���� + on E: Exception do + ETgException.TraceException(E, 'Fail .. CheckSign() .. 2'); + {$ENDIF} + end; +end; + +function CheckSign(sPath: String; sSign: AnsiString): Boolean; +begin + Result := CheckSign(sPath, @sSign[1], Length(sSign)); +end; + +function CheckSignFromList(sPath: String; BinStrList: TStrings): Boolean; +var + arrBufs: array of TBytes; + i, nLen, nMaxLen: Integer; + pData: TBytes; + fs: TFileStream; +begin + Result := false; + try + if BinStrList.Count = 0 then + exit; + + nMaxLen := 0; + SetLength(arrBufs, BinStrList.Count); + for i := 0 to BinStrList.Count - 1 do + begin + nLen := ConvStrToBin(BinStrList[i], arrBufs[i]); + if nLen > nMaxLen then + nMaxLen := nLen; + end; + + if nMaxLen = 0 then + exit; + + SetLength(pData, nMaxLen); + Guard(fs, TFileStream.Create(sPath, fmOpenRead)); + nMaxLen := fs.Read(pData[0], nMaxLen); + + for i := 0 to High(arrBufs) do + begin + nLen := Length(arrBufs[i]); + if nLen > nMaxLen then + nLen := nMaxLen; + + if CompareMem(arrBufs[i], pData, nLen) then + begin + Result := true; + exit; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. CheckSignFromList() ..', 3); + end; +end; + +function CopyFileAfOpenCheck(sSrcPath, sDestPath: String; nTOSec: Integer = 5): Boolean; +var + fs: TFileStream; + dwTick: DWORD; + bFail: Boolean; +Label + LB_Retry; +begin + Result := false; + if CopyFile(PChar(sSrcPath), PChar(sDestPath), false) then + begin + nTOSec := nTOSec * 1000; + dwTick := GetTickCount; + bFail := false; + + LB_Retry : + try + Guard(fs, TFileStream.Create(sDestPath, fmOpenRead)); + except + bFail := true; + end; + + if bFail then + begin + if (GetTickCount - dwTick) < nTOSec then + begin + Sleep(200); + goto LB_Retry; + end else exit; + end; + + Result := true; + end; +end; + +type + TJmpDestInfo = packed record + dwVersion: DWORD; + arrUnknown: array [0..27] of Byte; + end; + + TJmpDestH = packed record + sCheckSum: array [0..7] of AnsiChar; // 가리키고 있는 Stream의 Check Sum 값이 저장되어 있다. + VolDroidId, // Volume Droid ID + FileDroidId, // File Droid ID + BrhVolDroidId, // Birth volume Droid ID + BrhFileDroidId: TGUID; // Birth file Droid ID + sHostName: array [0..15] of AnsiChar; // 해당 Stream이 생성 된 컴퓨터 이름이 저장 된다. + end; + + PJmpDestM78 = ^TJmpDestM78; // Windows 7, 8 용 중간 데이터 + TJmpDestM78 = packed record + llSeq: LONGLONG; // 가리키고 있는 Stream의 이름이 저장 된다. + fCount: Single; // Stream의 접근 횟수를 부동소수점으로 표현한 값을 저장하고 있다. + ftLastAccess: TFileTime; // Stream의 마지막 수정 시간을 저장하고 있다. + end; + + PJmpDestM10 = ^TJmpDestM10; // Windows 10 용 중간 데이터 + TJmpDestM10 = packed record + dwSeq: DWORD; + llUnDefined: LONGLONG; // In all test ‘0x00 0x00 0x00 0x00’ + ftLastAccess: TFileTime; // Stream의 마지막 수정 시간을 저장하고 있다. + end; + + TJmpDestT78 = packed record // Windows 7, 8 용 끝 데이터 + dwPin: DWORD; + wUniStrLen: WORD; + end; + + TJmpDestT10 = packed record // Windows 10 용 끝 데이터 + dwPin: DWORD; + dwUnDefined1: DWORD; // In all tests, ‘0xFF 0xFF 0xFF 0xFF’ + dwCount: DWORD; + llUnDefined2: LONGLONG; // In all test ‘0x00 0x00 0x00 0x00’ + wUniStrLen: WORD; + end; + +function GetLastOpenFileFromJumpListAuto(const sJmpAutoPath: String): String; +var + ms: TMemoryStream; + stg: TGSStorage; + stgRoot: TGSStorageCursor; + enum: TGSStorageEnum; + i: Integer; + + DestInfo: TJmpDestInfo; + DestH: TJmpDestH; + DestM: array [0..19] of Byte; + DestT78: TJmpDestT78; + DestT10: TJmpDestT10; + sTemp: array of Char; + wUniStrLen: WORD; +begin + Result := ''; + try + if FileExists(sJmpAutoPath) then + begin + if GetFileExt(sJmpAutoPath).ToUpper <> 'AUTOMATICDESTINATIONS-MS' then + exit; + + Guard(stg, TGSStorage.Create); + if stg.OpenFile(sJmpAutoPath, false, stgRoot) <> S_OK then + exit; + + if stgRoot.Enumerate(enum) <> S_OK then + exit; + + try + for i := 0 to enum.Count - 1 do + begin + if CompareText('DestList', enum.ElementEnum[i].pwcsName) <> 0 then + continue; + + Guard(ms, TMemoryStream.Create); + try + stgRoot.ReadStream(enum.ElementEnum[i].pwcsName, ms); + except + exit; + end; + + if ms.Read(DestInfo, SizeOf(DestInfo)) <> SizeOf(DestInfo) then + exit; + + while ms.Size > ms.Position do + begin + if ms.Read(DestH, SizeOf(DestH)) <> SizeOf(DestH) then + break; + + if ms.Read(DestM, 20) <> 20 then + break; + + if DestInfo.dwVersion >= 4 then // Windows 7은 1, 10은 4로 보이는데... + begin + // Windows 10 +// Header.llSeq := PJmpDestM10(@DestM[0]).dwSeq; +// Header.ftLastAccess := PJmpDestM10(@DestM[0]).ftLastAccess; + + if ms.Read(DestT10, SizeOf(DestT10)) <> SizeOf(DestT10) then + break; + +// Header.fCount := DestT10.dwCount; + wUniStrLen := DestT10.wUniStrLen; + end else begin + // Windows 7, 8 +// Header.llSeq := PJmpDestM78(@DestM[0]).llSeq; +// Header.fCount := PJmpDestM78(@DestM[0]).fCount; +// Header.ftLastAccess := PJmpDestM78(@DestM[0]).ftLastAccess; + + if ms.Read(DestT78, SizeOf(DestT78)) <> SizeOf(DestT78) then + break; + + // if DestT78.dwPin <> $FFFFFFFF then + // break; + + wUniStrLen := DestT78.wUniStrLen; + end; + + if (wUniStrLen > 0) and (wUniStrLen <> WORD(-1)) then + begin + SetLength(sTemp, wUniStrLen + 1); + ms.Read(sTemp[0], wUniStrLen * 2); + sTemp[wUniStrLen] := #0; + Result := PChar(@sTemp[0]); + + if DestInfo.dwVersion > 1 then + ms.Position := ms.Position + 4; + + exit; + end; + end; + end; + finally + stgRoot.FreeMemAfterEnum(enum); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetRecentOpenFileFromJumpListAuto()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Graphic.pas b/Tocsg.Lib/VCL/Tocsg.Graphic.pas new file mode 100644 index 00000000..6c8d8129 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Graphic.pas @@ -0,0 +1,814 @@ +{*******************************************************} +{ } +{ Tocsg.Graphic } +{ } +{ Copyright (C) 2023 kku } +{ } +{*******************************************************} + +unit Tocsg.Graphic; + +interface + +uses + Vcl.Graphics, System.SysUtils, Winapi.Windows, Vcl.Imaging.pngimage, + Winapi.GDIPAPI; + +type + PColorMatrix = ^TColorMatrix; + +function RotatePng(var aPng: TPNGImage; Angle: Extended): Boolean; + +function RotatePngFile(sSrcPath, sDestpath: String; Angle: Extended): Boolean; + +// RotateBitmap_STF() 이건 이미지 돌린 후 가로 넓이 AdjustSize 적용이 제대로 되지 않는다... 짤림 +procedure RotateBitmap_STF(Bmp: Vcl.Graphics.TBitmap; Rads: Single; AdjustSize: Boolean; + BkColor: TColor = clNone; nAddWidth: Integer = 0); +procedure RotateBitmap_PlgBlt(Bmp: Vcl.Graphics.TBitmap; Rads: Single; AdjustSize: Boolean; + BkColor: TColor = clNone); +function ScalePercentBmp(bitmp: Vcl.Graphics.TBitmap; iPercent: Integer{100이면 원본}): Boolean; + +function MakeColorMatrix(R, G, B, A: Single): TColorMatrix; +function MakeTransparentMatrix(A: Single): TColorMatrix; + +procedure InitializeGDIPlus; +procedure FinalizeGDIPlus; + +function DrawBitmapWaterEx(aDestDC: HDC; nX, nY: Integer; aSrcBmp: Vcl.Graphics.TBitmap; pCM: PColorMatrix = nil; nStretchW: Integer = 0; nStretchH: Integer = 0): Boolean; +function DrawBitmapWaterEx2(aDestDC: HDC; nX, nY: Integer; aSrcBmp: Vcl.Graphics.TBitmap; pCM: PColorMatrix = nil; nStretchW: Integer = 0; nStretchH: Integer = 0; fAngle: Single = 0): Boolean; +function DrawBitmapWaterEx3( + aDestDC: HDC; + nX, nY: Integer; + aSrcBmp: Vcl.Graphics.TBitmap; + pCM: PColorMatrix = nil; + nStretchW: Integer = 0; + nStretchH: Integer = 0; + fAngle: Single = 0 +): Boolean; + +implementation + +uses + Tocsg.Safe, Tocsg.Exception, System.Classes, Winapi.GDIPOBJ, Winapi.ActiveX, System.UIConsts, System.Math; + +// 이걸로 돌리면 아래에 검은선이 생긴다. 25_0401 10:07:20 kku +//function RotatePng(var aPng: TPNGImage; Angle: Extended): Boolean; +// +// {Supporting functions} +// function TrimInt(i, Min, Max: Integer): Integer; +// begin +// if i>Max then Result:=Max +// else if i<Min then Result:=Min +// else Result:=i; +// end; +// function IntToByte(i:Integer):Byte; +// begin +// if i>255 then Result:=255 +// else if i<0 then Result:=0 +// else Result:=i; +// end; +// function Min(A, B: Double): Double; +// begin +// if A < B then Result := A else Result := B; +// end; +// function Max(A, B: Double): Double; +// begin +// if A > B then Result := A else Result := B; +// end; +// function Ceil(A: Double): Integer; +// begin +// Result := Integer(Trunc(A)); +// if Frac(A) > 0 then +// Inc(Result); +// end; +// +// {Calculates the png new size} +// function newsize: tsize; +// var +// fRadians: Extended; +// fCosine, fSine: Double; +// fPoint1x, fPoint1y, fPoint2x, fPoint2y, fPoint3x, fPoint3y: Double; +// fMinx, fMiny, fMaxx, fMaxy: Double; +// begin +// {Convert degrees to radians} +// fRadians := (2 * PI * Angle) / 360; +// +// fCosine := abs(cos(fRadians)); +// fSine := abs(sin(fRadians)); +// +// fPoint1x := (-apng.Height * fSine); +// fPoint1y := (apng.Height * fCosine); +// fPoint2x := (apng.Width * fCosine - apng.Height * fSine); +// fPoint2y := (apng.Height * fCosine + apng.Width * fSine); +// fPoint3x := (apng.Width * fCosine); +// fPoint3y := (apng.Width * fSine); +// +// fMinx := min(0,min(fPoint1x,min(fPoint2x,fPoint3x))); +// fMiny := min(0,min(fPoint1y,min(fPoint2y,fPoint3y))); +// fMaxx := max(fPoint1x,max(fPoint2x,fPoint3x)); +// fMaxy := max(fPoint1y,max(fPoint2y,fPoint3y)); +// +// Result.cx := ceil(fMaxx-fMinx); +// Result.cy := ceil(fMaxy-fMiny); +// end; +//type +// TFColor = record b,g,r:Byte end; +//var +// Top, Bottom, Left, Right, eww,nsw, fx,fy, wx,wy: Extended; +// cAngle, sAngle: Double; +// xDiff, yDiff, ifx,ify, px,py, ix,iy, x,y, cx, cy: Integer; +// nw,ne, sw,se: TFColor; +// anw,ane, asw,ase: Byte; +// P1,P2,P3:Pbytearray; +// A1,A2,A3: pbytearray; +// dst: TPNGImage; +// IsAlpha: Boolean; +// new_colortype: Integer; +//begin +// Result := false; +// try +// {Only allows RGB and RGBALPHA images} +// if not (apng.Header.ColorType in [COLOR_RGBALPHA, COLOR_RGB]) then +// raise Exception.Create('Only COLOR_RGBALPHA and COLOR_RGB formats' + +// ' are supported'); +// IsAlpha := apng.Header.ColorType in [COLOR_RGBALPHA]; +// if IsAlpha then new_colortype := COLOR_RGBALPHA else +// new_colortype := COLOR_RGB; +// +// {Creates a copy} +// dst := tpngobject.Create; +// with newsize do +// dst.createblank(new_colortype, 8, cx, cy); +// cx := dst.width div 2; cy := dst.height div 2; +// +// {Gather some variables} +// Angle:=angle; +// Angle:=-Angle*Pi/180; +// sAngle:=Sin(Angle); +// cAngle:=Cos(Angle); +// xDiff:=(Dst.Width-apng.Width)div 2; +// yDiff:=(Dst.Height-apng.Height)div 2; +// +// {Iterates over each line} +// for y:=0 to Dst.Height-1 do +// begin +// P3:=Dst.scanline[y]; +// if IsAlpha then A3 := Dst.AlphaScanline[y]; +// py:=2*(y-cy)+1; +// {Iterates over each column} +// for x:=0 to Dst.Width-1 do +// begin +// px:=2*(x-cx)+1; +// fx:=(((px*cAngle-py*sAngle)-1)/ 2+cx)-xDiff; +// fy:=(((px*sAngle+py*cAngle)-1)/ 2+cy)-yDiff; +// ifx:=Round(fx); +// ify:=Round(fy); +// +// {Only continues if it does not exceed image boundaries} +// if(ifx>-1)and(ifx<apng.Width)and(ify>-1)and(ify<apng.Height)then +// begin +// {Obtains data to paint the new pixel} +// eww:=fx-ifx; +// nsw:=fy-ify; +// iy:=TrimInt(ify+1,0,apng.Height-1); +// ix:=TrimInt(ifx+1,0,apng.Width-1); +// P1:=apng.scanline[ify]; +// P2:=apng.scanline[iy]; +// if IsAlpha then A1 := apng.alphascanline[ify]; +// if IsAlpha then A2 := apng.alphascanline[iy]; +// nw.r:=P1[ifx*3]; +// nw.g:=P1[ifx*3+1]; +// nw.b:=P1[ifx*3+2]; +// if IsAlpha then anw:=A1[ifx]; +// ne.r:=P1[ix*3]; +// ne.g:=P1[ix*3+1]; +// ne.b:=P1[ix*3+2]; +// if IsAlpha then ane:=A1[ix]; +// sw.r:=P2[ifx*3]; +// sw.g:=P2[ifx*3+1]; +// sw.b:=P2[ifx*3+2]; +// if IsAlpha then asw:=A2[ifx]; +// se.r:=P2[ix*3]; +// se.g:=P2[ix*3+1]; +// se.b:=P2[ix*3+2]; +// if IsAlpha then ase:=A2[ix]; +// +// +// {Defines the new pixel} +// Top:=nw.b+eww*(ne.b-nw.b); +// Bottom:=sw.b+eww*(se.b-sw.b); +// P3[x*3+2]:=IntToByte(Round(Top+nsw*(Bottom-Top))); +// Top:=nw.g+eww*(ne.g-nw.g); +// Bottom:=sw.g+eww*(se.g-sw.g); +// P3[x*3+1]:=IntToByte(Round(Top+nsw*(Bottom-Top))); +// Top:=nw.r+eww*(ne.r-nw.r); +// Bottom:=sw.r+eww*(se.r-sw.r); +// P3[x*3]:=IntToByte(Round(Top+nsw*(Bottom-Top))); +// +// {Only for alpha} +// if IsAlpha then +// begin +// Top:=anw+eww*(ane-anw); +// Bottom:=asw+eww*(ase-asw); +// A3[x]:=IntToByte(Round(Top+nsw*(Bottom-Top))); +// end; +// +// end; +// end; +// end; +// +// apng.assign(dst); +// dst.free; +// Result := true; +// except +// on E: Exception do +// ETgException.TraceException(E, 'Fail .. RotatePng()'); +// end; +//end; + +function RotatePng(var aPng: TPNGImage; Angle: Extended): Boolean; + + function TrimInt(i, Min, Max: Integer): Integer; + begin + if i < Min then Result := Min + else if i > Max then Result := Max + else Result := i; + end; + + function IntToByte(i: Integer): Byte; + begin + if i < 0 then Result := 0 + else if i > 255 then Result := 255 + else Result := i; + end; + + function CeilEx(A: Double): Integer; + begin + Result := Trunc(A); + if Frac(A) > 0 then Inc(Result); + end; + + function GetRotatedSize: TSize; + var + Radian, CosA, SinA: Extended; + x1, y1, x2, y2, x3, y3, x4, y4: Extended; + MinX, MaxX, MinY, MaxY: Extended; + begin + Radian := Angle * PI / 180; + CosA := Abs(Cos(Radian)); + SinA := Abs(Sin(Radian)); + + // 원래 이미지 꼭짓점 회전 후 좌표 계산 + x1 := 0 * CosA - 0 * SinA; + y1 := 0 * SinA + 0 * CosA; + + x2 := 0 * CosA - aPng.Height * SinA; + y2 := 0 * SinA + aPng.Height * CosA; + + x3 := aPng.Width * CosA - 0 * SinA; + y3 := aPng.Width * SinA + 0 * CosA; + + x4 := aPng.Width * CosA - aPng.Height * SinA; + y4 := aPng.Width * SinA + aPng.Height * CosA; + + MinX := Min(Min(x1, x2), Min(x3, x4)); + MinY := Min(Min(y1, y2), Min(y3, y4)); + MaxX := Max(Max(x1, x2), Max(x3, x4)); + MaxY := Max(Max(y1, y2), Max(y3, y4)); + + Result.cx := CeilEx(MaxX - MinX); + Result.cy := CeilEx(MaxY - MinY); + end; + +type + TFColor = record r, g, b: Byte; end; + +var + dst, src: TPNGImage; + x, y, cx, cy, SrcW, SrcH, DstW, DstH: Integer; + fx, fy, px, py: Extended; + ifx, ify, ix, iy: Integer; + Radian, SinA, CosA: Extended; + eww, nsw: Extended; + IsAlpha: Boolean; + nw, ne, sw, se: TFColor; + anw, ane, asw, ase: Byte; + P1, P2, P3: PByteArray; + A1, A2, A3: PByteArray; + newColorType: Integer; +begin + Result := False; + + if not (aPng.Header.ColorType in [COLOR_RGB, COLOR_RGBALPHA]) then + Exit; + + IsAlpha := aPng.Header.ColorType = COLOR_RGBALPHA; + if IsAlpha then newColorType := COLOR_RGBALPHA else newColorType := COLOR_RGB; + + SrcW := aPng.Width; + SrcH := aPng.Height; + + Radian := -Angle * PI / 180; + SinA := Sin(Radian); + CosA := Cos(Radian); + + // 원본 백업 + src := TPNGImage.Create; + src.Assign(aPng); + + // 새 이미지 생성 + dst := TPNGImage.CreateBlank(newColorType, 8, GetRotatedSize.cx, GetRotatedSize.cy); + DstW := dst.Width; + DstH := dst.Height; + cx := DstW div 2; + cy := DstH div 2; + + for y := 0 to DstH - 1 do + begin + P3 := dst.ScanLine[y]; + if IsAlpha then A3 := dst.AlphaScanline[y]; + py := 2 * (y - cy) + 1; + + for x := 0 to DstW - 1 do + begin + px := 2 * (x - cx) + 1; + + fx := (((px * CosA - py * SinA) - 1) / 2 + SrcW / 2); + fy := (((px * SinA + py * CosA) - 1) / 2 + SrcH / 2); + + ifx := Floor(fx); + ify := Floor(fy); + + if (ifx >= 0) and (ifx < SrcW - 1) and (ify >= 0) and (ify < SrcH - 1) then + begin + eww := fx - ifx; + nsw := fy - ify; + + ix := ifx + 1; + iy := ify + 1; + + P1 := src.ScanLine[ify]; + P2 := src.ScanLine[iy]; + if IsAlpha then + begin + A1 := src.AlphaScanline[ify]; + A2 := src.AlphaScanline[iy]; + end; + + // 색상 복사 + nw.r := P1[ifx * 3]; nw.g := P1[ifx * 3 + 1]; nw.b := P1[ifx * 3 + 2]; + ne.r := P1[ix * 3]; ne.g := P1[ix * 3 + 1]; ne.b := P1[ix * 3 + 2]; + sw.r := P2[ifx * 3]; sw.g := P2[ifx * 3 + 1]; sw.b := P2[ifx * 3 + 2]; + se.r := P2[ix * 3]; se.g := P2[ix * 3 + 1]; se.b := P2[ix * 3 + 2]; + + if IsAlpha then + begin + anw := A1[ifx]; ane := A1[ix]; + asw := A2[ifx]; ase := A2[ix]; + end; + + // 보간 계산 + P3[x * 3 + 2] := IntToByte(Round(nw.b + eww * (ne.b - nw.b) + nsw * ((sw.b + eww * (se.b - sw.b)) - (nw.b + eww * (ne.b - nw.b))))); + P3[x * 3 + 1] := IntToByte(Round(nw.g + eww * (ne.g - nw.g) + nsw * ((sw.g + eww * (se.g - sw.g)) - (nw.g + eww * (ne.g - nw.g))))); + P3[x * 3 + 0] := IntToByte(Round(nw.r + eww * (ne.r - nw.r) + nsw * ((sw.r + eww * (se.r - sw.r)) - (nw.r + eww * (ne.r - nw.r))))); + + if IsAlpha then + A3[x] := IntToByte(Round(anw + eww * (ane - anw) + nsw * ((asw + eww * (ase - asw)) - (anw + eww * (ane - anw))))); + end + else + begin + // 경계 바깥은 흰색 또는 투명 처리 + P3[x * 3 + 0] := 255; + P3[x * 3 + 1] := 255; + P3[x * 3 + 2] := 255; + if IsAlpha then A3[x] := 0; + end; + end; + end; + + aPng.Assign(dst); + dst.Free; + src.Free; + Result := True; +end; + +function RotatePngFile(sSrcPath, sDestpath: String; Angle: Extended): Boolean; +var + png: TPngImage; +begin + Result := false; + try + Guard(png, TPngImage.Create); + png.LoadFromFile(sSrcPath); + if RotatePng(png, Angle) then + begin + png.SaveToFile(sDestpath); + Result := true; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. RotatePngFile()'); + end; +end; + +// SetWorldTransform +procedure RotateBitmap_STF(Bmp: Vcl.Graphics.TBitmap; Rads: Single; AdjustSize: Boolean; + BkColor: TColor = clNone; nAddWidth: Integer = 0); +var + C: Single; + S: Single; + XForm: tagXFORM; + Tmp: Vcl.Graphics.TBitmap; +begin + C := Cos(Rads); + S := Sin(Rads); + XForm.eM11 := C; + XForm.eM12 := S; + XForm.eM21 := -S; + XForm.eM22 := C; + Tmp := Vcl.Graphics.TBitmap.Create; + try + Tmp.TransparentColor := Bmp.TransparentColor; + Tmp.TransparentMode := Bmp.TransparentMode; + Tmp.Transparent := Bmp.Transparent; + Tmp.Canvas.Brush.Color := BkColor; + if AdjustSize then + begin + Tmp.Width := Round(Bmp.Width * Abs(C) + Bmp.Height * Abs(S)) + nAddWidth; + Tmp.Height := Round(Bmp.Width * Abs(S) + Bmp.Height * Abs(C)); + XForm.eDx := (Tmp.Width - Bmp.Width * C + Bmp.Height * S) / 2; + XForm.eDy := (Tmp.Height - Bmp.Width * S - Bmp.Height * C) / 2; + end else begin + Tmp.Width := Bmp.Width; + Tmp.Height := Bmp.Height; + XForm.eDx := (Bmp.Width - Bmp.Width * C + Bmp.Height * S) / 2; + XForm.eDy := (Bmp.Height - Bmp.Width * S - Bmp.Height * C) / 2; + end; + SetGraphicsMode(Tmp.Canvas.Handle, GM_ADVANCED); + SetWorldTransform(Tmp.Canvas.Handle, XForm); + BitBlt(Tmp.Canvas.Handle, 0, 0, Tmp.Width, Tmp.Height, Bmp.Canvas.Handle, + 0, 0, SRCCOPY); + Bmp.Assign(Tmp); + finally + Tmp.Free; + end; +end; + +// PlgBlt +procedure RotateBitmap_PlgBlt(Bmp: Vcl.Graphics.TBitmap; Rads: Single; AdjustSize: Boolean; + BkColor: TColor = clNone); +var + C: Single; + S: Single; + Tmp: Vcl.Graphics.TBitmap; + OffsetX: Single; + OffsetY: Single; + Points: array[0..2] of TPoint; +begin + try + C := Cos(Rads); + S := Sin(Rads); + Tmp := Vcl.Graphics.TBitmap.Create; + try + Tmp.TransparentColor := Bmp.TransparentColor; + Tmp.TransparentMode := Bmp.TransparentMode; + Tmp.Transparent := Bmp.Transparent; + Tmp.Canvas.Brush.Color := BkColor; + if AdjustSize then + begin + Tmp.Width := Round(Bmp.Width * Abs(C) + Bmp.Height * Abs(S)); + Tmp.Height := Round(Bmp.Width * Abs(S) + Bmp.Height * Abs(C)); + OffsetX := (Tmp.Width - Bmp.Width * C + Bmp.Height * S) / 2; + OffsetY := (Tmp.Height - Bmp.Width * S - Bmp.Height * C) / 2; + end + else + begin + Tmp.Width := Bmp.Width; + Tmp.Height := Bmp.Height; + OffsetX := (Bmp.Width - Bmp.Width * C + Bmp.Height * S) / 2; + OffsetY := (Bmp.Height - Bmp.Width * S - Bmp.Height * C) / 2; + end; + Points[0].X := Round(OffsetX); + Points[0].Y := Round(OffsetY); + Points[1].X := Round(OffsetX + Bmp.Width * C); + Points[1].Y := Round(OffsetY + Bmp.Width * S); + Points[2].X := Round(OffsetX - Bmp.Height * S); + Points[2].Y := Round(OffsetY + Bmp.Height * C); + PlgBlt(Tmp.Canvas.Handle, Points, Bmp.Canvas.Handle, 0, 0, Bmp.Width, + Bmp.Height, 0, 0, 0); + Bmp.Assign(Tmp); + finally + Tmp.Free; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. RotateBitmap_PlgBlt()'); + end; +end; + +function ScalePercentBmp(bitmp: Vcl.Graphics.TBitmap; iPercent: Integer{100이면 원본}): Boolean; +var + TmpBmp: Vcl.Graphics.TBitmap; + ARect: TRect; + h, w: Real; + hi, wi: Integer; +begin + Result := False; + try + TmpBmp := Vcl.Graphics.TBitmap.Create; + try +// h := bitmp.Height * (iPercent / 100); +// w := bitmp.Width * (iPercent / 100); +// hi := StrToInt(FormatFloat('#', h)) + bitmp.Height; +// wi := StrToInt(FormatFloat('#', w)) + bitmp.Width; + hi := Round((iPercent / 100) * bitmp.Height); + wi := Round((iPercent / 100) * bitmp.Width); + TmpBmp.Width := wi; + TmpBmp.Height := hi; + ARect := System.Classes.Rect(0, 0, wi, hi); + TmpBmp.Canvas.StretchDraw(ARect, Bitmp); + bitmp.Assign(TmpBmp); + finally + TmpBmp.Free; + end; + Result := True; + except + {$IFDEF DEBUG} + ASSERT(false); + {$ENDIF} + Result := False; + end; +end; + +function MakeColorMatrix(R, G, B, A: Single): TColorMatrix; +begin + Result[0, 0] := R; Result[0, 1] := 0; Result[0, 2] := 0; Result[0, 3] := 0; Result[0, 4] := 0; + Result[1, 0] := 0; Result[1, 1] := G; Result[1, 2] := 0; Result[1, 3] := 0; Result[1, 4] := 0; + Result[2, 0] := 0; Result[2, 1] := 0; Result[2, 2] := B; Result[2, 3] := 0; Result[2, 4] := 0; + Result[3, 0] := 0; Result[3, 1] := 0; Result[3, 2] := 0; Result[3, 3] := A; Result[3, 4] := 0; + Result[4, 0] := 0; Result[4, 1] := 0; Result[4, 2] := 0; Result[4, 3] := 0; Result[4, 4] := 1; +end; + +function MakeTransparentMatrix(A: Single): TColorMatrix; +begin + ZeroMemory(@Result, SizeOf(Result)); + Result[3, 3] := A; +end; + +procedure InitializeGDIPlus; +var + StartupInput: TGdiplusStartupInput; +begin + StartupInput.GdiplusVersion := 1; + StartupInput.DebugEventCallback := nil; + StartupInput.SuppressBackgroundThread := False; + StartupInput.SuppressExternalCodecs := False; + + if GdiplusStartup(GdiplusToken, @StartupInput, nil) <> Ok then + exit; +// raise Exception.Create('Failed to initialize GDI+'); +end; + +procedure FinalizeGDIPlus; +begin + GdiplusShutdown(GdiplusToken); +end; + +function MakePointF(X, Y: Single): TGPPointF; +begin + Result.X := X; + Result.Y := Y; +end; + +function DrawBitmapWaterEx(aDestDC: HDC; nX, nY: Integer; aSrcBmp: Vcl.Graphics.TBitmap; pCM: PColorMatrix = nil; nStretchW: Integer = 0; nStretchH: Integer = 0): Boolean; +var + GPGraphics: TGPGraphics; + ms: TMemoryStream; +// GPStream: IStream; + GPImg: TGPImage; + ImageAttributes: TGPImageAttributes; + GPRect: TGPRect; + nWW, nHH: Integer; + Matrix: TGPMatrix; +begin + Result := true; + try + // Guard() 쓰면 Invalid Pointer 예외뜸 24_0411 13:44:29 kku + ms := TMemoryStream.Create; // 얘는 (GPStream: IStream) 여기서 알아서 해제함 24_0411 13:51:35 kku + aSrcBmp.SaveToStream(ms); + ms.Position := 0; + + Guard(GPGraphics, TGPGraphics.Create(aDestDC)); + GPGraphics.SetPageScale(0.33); + + // IStream 메모리 해제를 위해 여기에 변수 선언해야 함 24_0125 10:58:12 kku + var GPStream: IStream := TStreamAdapter.Create(ms, soOwned) as IStream; + Guard(GPImg, TGPImage.Create(GPStream)); + Guard(ImageAttributes, TGPImageAttributes.Create); + + // 흰색 배경 투명처리 + ImageAttributes.SetColorKey(System.UIConsts.MakeColor(255, 255, 255), System.UIConsts.MakeColor(255, 255, 255)); + // 빨간색 배경 투명처리 +// ImageAttributes.SetColorKey(System.UIConsts.MakeColor(255, 0, 0), System.UIConsts.MakeColor(255, 0, 0)); + +// ImageAttributes.SetColorMatrix(MakeColorMatrix(0.1, 0.1, 0.5, 0.2)); // Gray, 하늘색 +// ImageAttributes.SetColorMatrix(MakeColorMatrix(0.1, 0.5, 0.5, 0.2)); // Gray, 녹색 +// ImageAttributes.SetColorMatrix(MakeColorMatrix(0.1, 1.1, 0.5, 0.2)); // Gray, 연두색 +// ImageAttributes.SetColorMatrix(MakeColorMatrix(0.2, 0.2, 0.2, 0.2)); // Gray, 실버 +// ImageAttributes.SetColorMatrix(MakeColorMatrix(0.2, 0.2, 0.2, 0.3)); // Gray, 회색 + if pCM <> nil then +// ImageAttributes.SetColorMatrix(pCM^, ColorMatrixFlagsDefault, ColorAdjustTypeBitmap) + ImageAttributes.SetColorMatrix(pCM^) + else + ImageAttributes.SetColorMatrix(MakeColorMatrix(0.2, 0.2, 0.2, 0.3)); // Gray, 회색 +// ImageAttributes.SetColorMatrix(MakeTransparentMatrix(0.4)); // 그 외 mode, type 옵션 의미 없음.. + + nWW := GPImg.GetWidth; + nHH := GPImg.GetHeight; + +// var GPUnit: TUnit := GPGraphics.GetPageUnit; + GPRect.X := nX; // nX div 2; // 이렇게 해야 위치가 맞음... 이유는 아직 모름 + GPRect.Y := nY; // nY div 2; // 이렇게 해야 위치가 맞음... 이유는 아직 모름 + GPRect.Width := nWW; + GPRect.Height := nHH; + + if nStretchW > 0 then + GPRect.Width := nStretchW; + if nStretchH > 0 then + GPRect.Height := nStretchH; + + GPGraphics.DrawImage(GPImg, GPRect, 0, 0, Round(nWW), Round(nHH), UnitPixel, ImageAttributes); + GPGraphics.Flush(FlushIntentionFlush); + except + Result := false; + end; +end; + +function DrawBitmapWaterEx2(aDestDC: HDC; nX, nY: Integer; aSrcBmp: Vcl.Graphics.TBitmap; pCM: PColorMatrix = nil; nStretchW: Integer = 0; nStretchH: Integer = 0; fAngle: Single = 0): Boolean; +var + GPGraphics: TGPGraphics; + ms: TMemoryStream; + GPImg: TGPImage; + ImageAttributes: TGPImageAttributes; + GPRect: TGPRect; + nWW, nHH: Integer; + offX, offY: Integer; + SavedDC: Integer; + Matrix: TGPMatrix; +begin + Result := true; + try + SavedDC := SaveDC(aDestDC); + try + ms := TMemoryStream.Create; + aSrcBmp.SaveToStream(ms); + ms.Position := 0; + + Guard(GPGraphics, TGPGraphics.Create(aDestDC)); + GPGraphics.SetInterpolationMode(InterpolationModeHighQualityBicubic); // 보간법: 고품질 + GPGraphics.SetSmoothingMode(SmoothingModeAntiAlias); // 안티앨리어싱 + GPGraphics.SetPixelOffsetMode(PixelOffsetModeHighQuality); // 픽셀 오프셋 품질 + + // ★ SetPageScale 는 제거하는 걸 추천 (좌표 꼬임 방지) + // GPGraphics.SetPageScale(0.33); +// GPGraphics.SetPageUnit(UnitPixel); + + var GPStream: IStream := TStreamAdapter.Create(ms, soOwned) as IStream; + Guard(GPImg, TGPImage.Create(GPStream)); + Guard(ImageAttributes, TGPImageAttributes.Create); + + ImageAttributes.SetColorKey( + System.UIConsts.MakeColor(255, 255, 255), + System.UIConsts.MakeColor(255, 255, 255) + ); + + if pCM <> nil then + ImageAttributes.SetColorMatrix(pCM^) + else + ImageAttributes.SetColorMatrix(MakeColorMatrix(0.2, 0.2, 0.2, 0.3)); + + nWW := GPImg.GetWidth; + nHH := GPImg.GetHeight; + + GPRect.X := nX; + GPRect.Y := nY; + + GPRect.Width := nWW; + GPRect.Height := nHH; + + if nStretchW > 0 then + GPRect.Width := nStretchW; + if nStretchH > 0 then + GPRect.Height := nStretchH; + + // 프린터 물리 offset 구하기 + offX := GetDeviceCaps(aDestDC, PHYSICALOFFSETX); + offY := GetDeviceCaps(aDestDC, PHYSICALOFFSETY); + GPGraphics.TranslateTransform(offX, offY); + + if fAngle <> 0 then + begin + Matrix := TGPMatrix.Create; + try + Matrix.RotateAt(fAngle, MakePointF(GPRect.X, GPRect.Y)); + GPGraphics.SetTransform(Matrix); + finally + Matrix.Free; + end; + end; + + GPGraphics.DrawImage(GPImg, GPRect, 0, 0, nWW, nHH, UnitPixel, ImageAttributes); + + GPGraphics.Flush(FlushIntentionFlush); + finally + RestoreDC(aDestDC, SavedDC); + end; + except + Result := false; + end; +end; +function DrawBitmapWaterEx3(aDestDC: HDC; nX, nY: Integer; aSrcBmp: Vcl.Graphics.TBitmap; pCM: PColorMatrix = nil; nStretchW: Integer = 0; nStretchH: Integer = 0; fAngle: Single = 0): Boolean; +var + GPGraphics: TGPGraphics; + ms: TMemoryStream; + GPImg: TGPImage; + ImageAttributes: TGPImageAttributes; + GPRect: TGPRect; + nWW, nHH: Integer; + offX, offY: Integer; + SavedDC: Integer; + Matrix: TGPMatrix; +begin + Result := true; + try + SavedDC := SaveDC(aDestDC); + try + ms := TMemoryStream.Create; + aSrcBmp.SaveToStream(ms); + ms.Position := 0; + + Guard(GPGraphics, TGPGraphics.Create(aDestDC)); + GPGraphics.SetInterpolationMode(InterpolationModeHighQualityBicubic); // 보간법: 고품질 + GPGraphics.SetSmoothingMode(SmoothingModeAntiAlias); // 안티앨리어싱 + GPGraphics.SetPixelOffsetMode(PixelOffsetModeHighQuality); // 픽셀 오프셋 품질 + + // ★ SetPageScale 는 제거하는 걸 추천 (좌표 꼬임 방지) + // GPGraphics.SetPageScale(0.33); + GPGraphics.SetPageUnit(UnitPixel); + + var GPStream: IStream := TStreamAdapter.Create(ms, soOwned) as IStream; + Guard(GPImg, TGPImage.Create(GPStream)); + Guard(ImageAttributes, TGPImageAttributes.Create); + + ImageAttributes.SetColorKey( + System.UIConsts.MakeColor(255, 255, 255), + System.UIConsts.MakeColor(255, 255, 255) + ); + + if pCM <> nil then + ImageAttributes.SetColorMatrix(pCM^) + else + ImageAttributes.SetColorMatrix(MakeColorMatrix(0.2, 0.2, 0.2, 0.3)); + + nWW := GPImg.GetWidth; + nHH := GPImg.GetHeight; + + GPRect.X := nX; + GPRect.Y := nY; + + GPRect.Width := nWW; + GPRect.Height := nHH; + + if nStretchW > 0 then + GPRect.Width := nStretchW; + if nStretchH > 0 then + GPRect.Height := nStretchH; + + // 프린터 물리 offset 구하기 + offX := GetDeviceCaps(aDestDC, PHYSICALOFFSETX); + offY := GetDeviceCaps(aDestDC, PHYSICALOFFSETY); + GPGraphics.TranslateTransform(offX, offY); + + if fAngle <> 0 then + begin + Matrix := TGPMatrix.Create; + try + Matrix.RotateAt(fAngle, MakePointF(GPRect.X, GPRect.Y)); + GPGraphics.SetTransform(Matrix); + finally + Matrix.Free; + end; + end; + + GPGraphics.DrawImage(GPImg, GPRect, 0, 0, nWW, nHH, UnitPixel, ImageAttributes); + + GPGraphics.Flush(FlushIntentionFlush); + finally + RestoreDC(aDestDC, SavedDC); + end; + except + Result := false; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Hash.pas b/Tocsg.Lib/VCL/Tocsg.Hash.pas new file mode 100644 index 00000000..6005d80e --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Hash.pas @@ -0,0 +1,611 @@ +{*******************************************************} +{ } +{ Tocsg.Hash } +{ } +{ Copyright (C) 2020 kku } +{ } +{*******************************************************} + +unit Tocsg.Hash; + +interface + +uses +// EM.SHA1, // 11.1 에서 제대로 동작 하지 않음 22_0419 08:29:50 kku + Windows, SysUtils, System.Classes, EM.MD5, EM.Tocsg.Sha1, + EM.Tocsg.hash, Tocsg.Obj; + +type + THashStreamBase = class(TTgObject) + protected + bInit_: Boolean; + public + Constructor Create(bInit: Boolean = true); + procedure WorkInit; virtual; abstract; + procedure SetBuffer(buf: Pointer; nCount: Integer); virtual; abstract; + + function WorkFinalToStr: String; virtual; abstract; + end; + + TSHA1Hash = class(THashStreamBase) + private + ctx_: TTgHashContext; // TSHA1Context; + public + procedure WorkInit; override; + procedure SetBuffer(buf: Pointer; nCount: Integer); override; + function WorkFinalToStr: String; override; + function WorkFinalToDigest(var SHA1Digest: TSHA1Digest): Boolean; + end; + + TSHA256Hash = class(THashStreamBase) + private + ctx_: TTgHashContext; // TSHA1Context; + public + procedure WorkInit; override; + procedure SetBuffer(buf: Pointer; nCount: Integer); override; + function WorkFinalToStr: String; override; + function WorkFinalToDigest(var SHA256Digest: TSHA256Digest): Boolean; + end; + + TMD5Hash = class(THashStreamBase) + private + ctx_: TMD5Context; + public + procedure WorkInit; override; + procedure SetBuffer(buf: Pointer; nCount: Integer); override; + function WorkFinalToStr: String; override; + end; + + TTgHashProgress = reference to function(s: TStream; nPercent: Integer): Boolean; + +function GetStreamToSha1Str(aStream: TStream; aProgress: TTgHashProgress = nil): String; +function GetFileToSha1Str(const sPath: String; aProgress: TTgHashProgress = nil): String; + +function GetStreamToHash(aStream: TStream; var sSHA1, sMD5, sSHA256: AnsiString; + aProgress: TTgHashProgress = nil; llUntilSize: LONGLONG = 0): Boolean; +function GetFileToHash(const sPath: String; var sSHA1, sMD5, sSHA256: AnsiString; + aProgress: TTgHashProgress = nil; llUntilSize: LONGLONG = 0): Boolean; overload; + +function GetStreamToSha256(aStream: TStream; aProgress: TTgHashProgress = nil; llUntilSize: LONGLONG = 0): AnsiString; +function GetFileToSha256(const sPath: String; aProgress: TTgHashProgress = nil; llUntilSize: LONGLONG = 0): AnsiString; + +function ConvStrToSha1A(str: AnsiString): String; +function ConvStrToSha1A_Bin(str: AnsiString): TBytes; +function ConvStrToSha1W(str: WideString): String; +function ConvStrToSha256A_Bin(str: AnsiString): TBytes; +function ConvStrToSha256A(str: AnsiString): String; +function ConvStrToSha256W(str: WideString): String; +function ConvStrToHash(str: String): DWORD; + +// By .. https://helloacm.com/simple-and-fast-hash-functions-in-delphi/ +type + HashFunction = function(aData: Pointer; aDataLength: Integer): DWORD; + +function Hash_djb2(aData: Pointer; aDataLength: Integer): NativeUInt; +function Hash_djb2a(aData: Pointer; aDataLength: Integer): NativeUInt; +function Hash_fnv(aData: Pointer; aDataLength: Integer): NativeUInt; +function Hash_fnv1a(aData: Pointer; aDataLength: Integer): NativeUInt; +function Hash_sdbm(aData: Pointer; aDataLength: Integer): NativeUInt; +function Hash_jenkis(aData: Pointer; aDataLength: Integer): NativeUInt; + +implementation + +uses + EM.CRC32, EM.Tocsg.sha256, Tocsg.Binary, Tocsg.Safe, Tocsg.Exception; + +const +// BUF_SIZE = 65536; // 이거 쓰면 Range 오류남 25_0911 17:38:13 kku + BUF_SIZE = 32768; + +function ConvStrToSha1A(str: AnsiString): String; +var + nRead : Integer; + ctx: TTgHashContext; //TSHA1Context; + sd: TSHA1Digest; +begin + try + SHA1Init(ctx); + nRead := Length(str); + SHA1Update(ctx, @str[1], nRead); + + SHA1Final(ctx, sd); + Result := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); + finally + + end; +end; + +function ConvStrToSha1A_Bin(str: AnsiString): TBytes; +var + nRead : Integer; + ctx: TTgHashContext; //TSHA1Context; + sd: TSHA1Digest; +begin + try + SHA1Init(ctx); + nRead := Length(str); + SHA1Update(ctx, @str[1], nRead); + + SHA1Final(ctx, sd); + SetLength(Result, Length(sd)); + CopyMemory(Result, @sd[0], SizeOf(sd)); + finally + + end; +end; + +function ConvStrToSha1W(str: WideString): String; +var + nRead: Integer; + ctx: TTgHashContext; //TSHA1Context; + sd: TSHA1Digest; +begin + try + if str = '' then + begin + Result := ''; + exit; + end; + + SHA1Init(ctx); + nRead := Length(str); + SHA1Update(ctx, @str[1], nRead*2); + + SHA1Final(ctx, sd); + Result := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ConvStrToSha1W()'); + end; +end; + +function ConvStrToSha256A_Bin(str: AnsiString): TBytes; +var + nRead : Integer; + ctx: TTgHashContext; + sd: TSHA256Digest; +begin + try + SHA256Init(ctx); + nRead := Length(str); + SHA256Update(ctx, @str[1], nRead); + + SHA256Final(ctx, sd); + SetLength(Result, Length(sd)); + CopyMemory(Result, @sd[0], SizeOf(sd)); + finally + + end; +end; + +function ConvStrToSha256A(str: AnsiString): String; +var + nRead: Integer; + ctx: TTgHashContext; + sd: TSHA256Digest; +begin + Result := ''; + try + if str = '' then + exit; + + SHA256Init(ctx); + nRead := Length(str); + SHA256Update(ctx, @str[1], nRead); + + SHA256Final(ctx, sd); + Result := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ConvStrToSha256A()'); + end; +end; + +function ConvStrToSha256W(str: WideString): String; +var + nRead: Integer; + ctx: TTgHashContext; + sd: TSHA256Digest; +begin + Result := ''; + try + if str = '' then + exit; + + SHA256Init(ctx); + nRead := Length(str); + SHA256Update(ctx, @str[1], nRead*2); + + SHA256Final(ctx, sd); + Result := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ConvStrToSha256W()'); + end; +end; + +function GetStreamToSha1Str(aStream: TStream; aProgress: TTgHashProgress = nil): String; +var + nRead: Integer; + pBuf: array [0..BUF_SIZE] of AnsiChar; + ctx: TTgHashContext; //TSHA1Context; + sd: TSHA1Digest; +begin + Result := ''; + + SHA1Init(ctx); + Repeat + nRead := aStream.Read(pBuf, BUF_SIZE); + SHA1Update(ctx, @pBuf, nRead); + + if Assigned(aProgress) then + if not aProgress(aStream, (aStream.Position * 100) div aStream.Size) then + exit; + Until nRead <> BUF_SIZE; + + SHA1Final(ctx, sd); + Result := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); +end; + +function GetFileToSha1Str(const sPath: String; aProgress: TTgHashProgress = nil): String; +var + fs: TFileStream; +begin + Result := ''; + try + if FileExists(sPath) then + begin + Guard(fs, TFileStream.Create(sPath, fmOpenRead or fmShareDenyNone)); + Result := GetStreamToSha1Str(fs, aProgress); + end; + except + exit; + end; +end; + +function GetFileToHash(const sPath: String; var sSHA1, sMD5, sSHA256: AnsiString; + aProgress: TTgHashProgress = nil; llUntilSize: LONGLONG = 0): Boolean; +var + fs: TFileStream; +begin + try + Guard(fs, TFileStream.Create(sPath, fmOpenRead or fmShareDenyNone)); + Result := GetStreamToHash(fs, sSHA1, sMD5, sSHA256, aProgress, llUntilSize); + except + Result := false; + exit; + end; +end; + +function GetStreamToHash(aStream: TStream; var sSHA1, sMD5, sSHA256: AnsiString; + aProgress: TTgHashProgress = nil; llUntilSize: LONGLONG = 0): Boolean; +var + nRead: Integer; + pBuf: array [0..BUF_SIZE-1] of AnsiChar; + SHA1Ctx: TTgHashContext; //TSHA1Context; + MD5Ctx: TMD5Context; + SHA256Ctx: TTgHashContext; + sd: TSHA1Digest; + md: EM.MD5.TMD5Digest; + s256d: TSHA256Digest; + llTotalRead: LONGLONG; +begin + Result := false; + + if aStream.Size > 0 then + begin + llTotalRead := 0; + sSHA1 := ''; + sMD5 := ''; + sSHA256 := ''; + + MD5Init(MD5Ctx); + SHA1Init(SHA1Ctx); + SHA256Init(SHA256Ctx); + Repeat + nRead := aStream.Read(pBuf, BUF_SIZE); + MD5Update(MD5Ctx, @pBuf, nRead); + SHA1Update(SHA1Ctx, @pBuf, nRead); + SHA256Update(SHA256Ctx, @pBuf, nRead); + + if Assigned(aProgress) then + if not aProgress(aStream, (aStream.Position * 100) div aStream.Size) then + exit; + + Inc(llTotalRead, nRead); + if (llUntilSize > 0) and (llUntilSize <= llTotalRead) then // 추가 15_0921 11:43:31 kku + break; + Until (nRead <> BUF_SIZE) or (aStream.Size <= llTotalRead); + + MD5Final(MD5Ctx, md); + SHA1Final(SHA1Ctx, sd); + SHA256Final(SHA256Ctx, s256d); + + sMD5 := ConvBytesToHexStr(PByte(@md), SizeOf(md)); + sSHA1 := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); + sSHA256 := ConvBytesToHexStr(PByte(@s256d), SizeOf(s256d)); + + Result := true; + end; +end; + +function GetStreamToSha256(aStream: TStream; aProgress: TTgHashProgress = nil; llUntilSize: LONGLONG = 0): AnsiString; +//const +// BUF_SIZE2 = 32768; // BUF_SIZE(65536) 사용하면 Range 오류난다 25_0728 18:20:37 kku +var + nRead: Integer; + pBuf: array [0..BUF_SIZE-1] of AnsiChar; + SHA256Ctx: TTgHashContext; + s256d: TSHA256Digest; + llTotalRead: LONGLONG; +begin + Result := ''; + + if aStream.Size > 0 then + begin + llTotalRead := 0; + + SHA256Init(SHA256Ctx); + Repeat + nRead := aStream.Read(pBuf, BUF_SIZE); + SHA256Update(SHA256Ctx, @pBuf, nRead); + + if Assigned(aProgress) then + if not aProgress(aStream, (aStream.Position * 100) div aStream.Size) then + exit; + + Inc(llTotalRead, nRead); + if (llUntilSize > 0) and (llUntilSize <= llTotalRead) then // 추가 15_0921 11:43:31 kku + break; + Until (nRead <> BUF_SIZE) or (aStream.Size <= llTotalRead); + + SHA256Final(SHA256Ctx, s256d); + + Result := ConvBytesToHexStr(PByte(@s256d), SizeOf(s256d)); + end; +end; + +function GetFileToSha256(const sPath: String; aProgress: TTgHashProgress = nil; llUntilSize: LONGLONG = 0): AnsiString; +var + fs: TFileStream; +begin + try + Guard(fs, TFileStream.Create(sPath, fmOpenRead or fmShareDenyNone)); + Result := GetStreamToSha256(fs, aProgress, llUntilSize); + except + Result := ''; + exit; + end; +end; + +// IniFiles.pas 에서 TStringHash.HashOf 가져옴 2010-11-04 kku +function ConvStrToHash(str: String): DWORD; +var + i: Integer; +begin + Result := 0; + for i := 1 to Length(str) do + Result := ((Result shl 2) or + (Result shr (SizeOf(Result) * 8 - 2))) xor + Ord(str[i]); +end; + +{ THashStreamBase } + +Constructor THashStreamBase.Create(bInit: Boolean = true); +begin + Inherited Create; + + bInit_ := false; + + if bInit then + WorkInit; +end; + +{ TSHA1Hash } + +procedure TSHA1Hash.WorkInit; +begin + SHA1Init(ctx_); + bInit_ := true; +end; + +procedure TSHA1Hash.SetBuffer(buf: Pointer; nCount: Integer); +begin + if bInit_ then + SHA1Update(ctx_, buf, nCount); +end; + +function TSHA1Hash.WorkFinalToStr: String; +var + sd : TSHA1Digest; +begin + Result := ''; + if bInit_ then + begin + SHA1Final(ctx_, sd); + Result := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); + bInit_ := false; + end; +end; + +function TSHA1Hash.WorkFinalToDigest(var SHA1Digest: TSHA1Digest): Boolean; +begin + Result := false; + ZeroMemory(@SHA1Digest, SizeOf(SHA1Digest)); + if bInit_ then + begin + SHA1Final(ctx_, SHA1Digest); + bInit_ := false; + Result := true; + end; +end; + +{ TSHA256Hash } + +procedure TSHA256Hash.WorkInit; +begin + SHA256Init(ctx_); + bInit_ := true; +end; + +procedure TSHA256Hash.SetBuffer(buf: Pointer; nCount: Integer); +begin + if bInit_ then + SHA256Update(ctx_, buf, nCount); +end; + +function TSHA256Hash.WorkFinalToStr: String; +var + sd : TSHA256Digest; +begin + Result := ''; + if bInit_ then + begin + SHA256Final(ctx_, sd); + Result := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); + bInit_ := false; + end; +end; + +function TSHA256Hash.WorkFinalToDigest(var SHA256Digest: TSHA256Digest): Boolean; +begin + Result := false; + ZeroMemory(@SHA256Digest, SizeOf(SHA256Digest)); + if bInit_ then + begin + SHA256Final(ctx_, SHA256Digest); + bInit_ := false; + Result := true; + end; +end; + +{ TMD5Hash } + +procedure TMD5Hash.SetBuffer(buf: Pointer; nCount: Integer); +begin + if bInit_ then + MD5Update(ctx_, buf, nCount); +end; + +function TMD5Hash.WorkFinalToStr: String; +var + sd : EM.MD5.TMD5Digest; +begin + Result := ''; + if bInit_ then + begin + MD5Final(ctx_, sd); + Result := ConvBytesToHexStr(PByte(@sd), SizeOf(sd)); + bInit_ := false; + end; +end; + +procedure TMD5Hash.WorkInit; +begin + MD5Init(ctx_); + bInit_ := true; +end; + +// By .. https://helloacm.com/simple-and-fast-hash-functions-in-delphi/ + +// HASH_DJB2 +function Hash_djb2(aData: Pointer; aDataLength: Integer): NativeUInt; +var + i: integer; +begin + Result := 5381; + for i := 1 to aDataLength do + begin + Result := ((Result shl 5) + Result) + PByte(aData)^; + aData := Pointer(NativeUInt(aData) + 1); + end; +end; + +// HASH_DJB2A +// A Slight variation of Hash_djb2 +function Hash_djb2a(aData: Pointer; aDataLength: Integer): NativeUInt; +var + i: integer; +begin + Result := 5381; + for i := 1 to aDataLength do + begin + Result := ((Result shl 5) xor Result) xor PByte(aData)^; + aData := Pointer(NativeUInt(aData) + 1); + end; +end; + +// HASH_FNV +function Hash_fnv(aData: Pointer; aDataLength: Integer): NativeUInt; +var + i: integer; +begin + Result := 2166136261; + for i := 1 to aDataLength do + begin + Result := (Result * 16777619) xor PByte(aData)^; + aData := Pointer(NativeUInt(aData) + 1); + end; +end; + +// HASH_FNV1A +// Slight variation of Hash_fnv. +function Hash_fnv1a(aData: Pointer; aDataLength: Integer): NativeUInt; +var + i: integer; +begin + Result := 2166136261; + for i := 1 to aDataLength do + begin + Result := (Result xor PByte(aData)^) * 16777619; + aData := Pointer(NativeUInt(aData) + 1); + end; +end; + +// HASH_SDBM +function Hash_sdbm(aData: Pointer; aDataLength: Integer): NativeUInt; +var + i: integer; +begin + Result := 0; + for i := 1 to aDataLength do + begin + Result := PByte(aData)^ + (Result shl 6) + (Result shl 16) - Result; + aData := Pointer(NativeUInt(aData) + 1); + end; +end; + +// HASH_JENKIS +function Hash_jenkis(aData: Pointer; aDataLength: Integer): NativeUInt; +var + i: integer; +begin + Result := 0; + for i := 1 to aDataLength do + begin + Inc(Result, PByte(aData)^); + Inc(Result, Result shl 10); + Result := Result xor (Result shr 6); + aData := Pointer(NativeUInt(aData) + 1); + end; + Inc(Result, Result shl 3); + Result := Result xor (Result shr 11); + Inc(Result, Result shl 15); +end; + +function StrToHash_FNV1A(sSrc: String): NativeUInt; +var + nLen: Integer; +begin + nLen := Length(sSrc); + if nLen = 0 then + begin + Result := 0; + exit; + end; + + Result := Hash_fnv1a(@sSrc[1], nLen); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Hex.pas b/Tocsg.Lib/VCL/Tocsg.Hex.pas new file mode 100644 index 00000000..b3064a2a --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Hex.pas @@ -0,0 +1,270 @@ +{*******************************************************} +{ } +{ Tocsg.Hex } +{ } +{ Copyright (C) 2022 Sunk } +{ } +{*******************************************************} + +unit Tocsg.Hex; + +interface + +uses + System.Classes, System.SysUtils, Winapi.Windows; + +function ConvBinToStr(pBuf: PAnsiChar; dwSize: DWORD): AnsiString; +function ConvBinToDelphiStr(pBuf: PAnsiChar; dwSize: DWORD): AnsiString; +function ConvStrToBin(str: String; var pBuf: TBytes): Integer; +function ConvStrToBinStream(const sBinStr: String; aStream: TStream): Boolean; +function ConvStrToBinStreamForce(sBinStr: String; aStream: TStream): Boolean; + +procedure hexDump_to_list(pBuf: PBYTE; dwLen: DWORD; var lstDump: TStringList); + +function PosBin(const pFind, pDestBuf: TBytes; nBeginOffset: Integer = 0): Integer; + +implementation + +uses + Tocsg.Safe, Tocsg.Strings; + +function ConvBinToStr(pBuf: PAnsiChar; dwSize: DWORD): AnsiString; +var + i: Integer; +begin + Result := ''; + for i := 0 to dwSize - 1 do + Result := Result + Format('%.2x', [Integer(pBuf[i])]); +end; + +function ConvBinToDelphiStr(pBuf: PAnsiChar; dwSize: DWORD): AnsiString; +var + i: Integer; +begin + Result := ''; + for i := 0 to dwSize - 1 do + Result := Result + Format('$%.2x', [Integer(pBuf[i])]); +end; + +// $뒤에 2자리까지 짤라서 리스트에 넣어준다. +function SplitHexToStringList(sText: String; var lstString: TStringList; bDelphiHex: Boolean): Integer; +var + nPos : Integer; + sTemp : String; +begin + lstString.Clear; + + Result := 0; + + if bDelphiHex then + begin + while sText <> '' do + if sText[1] = '$' then + begin + sTemp := Copy(sText, 1, 3); + lstString.Add(sTemp); + Delete(sText, 1, 3); + Inc(Result); + end else begin + nPos := Pos('$', sText); + if nPos <> 0 then + begin + sTemp := Copy(sText, 1, nPos-1); + lstString.Add(sTemp); + Delete(sText, 1, Length(sTemp)); + Inc(Result, Length(sTemp)); + end else begin + lstString.Add(sText); + Inc(Result, Length(sText)); + break; + end; + end; + end else begin + while sText <> '' do + begin + sTemp := Copy(sText, 1, 2); + lstString.Add(sTemp); + Delete(sText, 1, 2); + Inc(Result); + end; + end; +end; + +function ConvStrToBin(str: String; var pBuf: TBytes): Integer; +var + lstStr: TStringList; + i: Integer; +begin +// c 스타일의 16진수 표시 문자 바꾸기 +// str := StringReplace(str, '\x', '$', [rfReplaceAll]); + +// 길이가 짝수가 아니라면 맨앞에 0을 붙혀준다 14_1222 14:25:10 sunk + if (Length(str) mod 2) <> 0 then + str := '0' + str; + + Guard(lstStr, TStringList.Create); + Result := SplitHexToStringList(str, lstStr, false); + + if Result <= 0 then + exit; + +// pBuf := AllocMem(Result); + SetLength(pBuf, Result); + + for i := 0 to lstStr.Count - 1 do + pBuf[i] := StrToIntDef('$'+lstStr[i], 0); +end; + +function ConvStrToBinStream(const sBinStr: String; aStream: TStream): Boolean; +var + lstTemp: TStringList; + i: Integer; + arrBin: array of Byte; +begin + Result := false; + + aStream.Size := 0; + aStream.Position := 0; + + Guard(lstTemp, TStringList.Create); + lstTemp.CommaText := sBinStr; + SetLength(arrBin, lstTemp.Count); + + for i := 0 to lstTemp.Count - 1 do + try + arrBin[i] := StrToInt('$'+lstTemp[i]); + except + exit; + end; + + aStream.Write(arrBin[0], Length(arrBin)); + + Result := true; +end; + +function ConvStrToBinStreamForce(sBinStr: String; aStream: TStream): Boolean; +var + lstTemp: TStringList; + i: Integer; + pBuf: TBytes; +begin + aStream.Size := 0; + aStream.Position := 0; + + sBinStr := StringReplace(sBinStr, ' ', '', [rfReplaceAll]); + sBinStr := InsertPointString(',', sBinStr, 2); + + Guard(lstTemp, TStringList.Create); + lstTemp.CommaText := sBinStr; + SetLength(pBuf, lstTemp.Count); + + for i := 0 to lstTemp.Count - 1 do + pBuf[i] := StrToIntDef('$'+lstTemp[i], 0); + + aStream.Write(pBuf[0], Length(pBuf)); + + Result := true; +end; + +procedure hexDump_to_list(pBuf: PBYTE; dwLen: DWORD; var lstDump: TStringList); +var + pStart, + pEnd : PBYTE; + i, dwRemainder : DWORD; + sLine : String; + b : BYTE; +begin +// 시작과 끝을 잡아주고.. + pStart := pBuf; + pEnd := PBYTE(LongInt(pBuf)+dwLen); + + dwRemainder := dwLen mod 16; + +// 16Byte씩 보여주기 + while LongInt(pStart)+16 <= LongInt(pEnd) do + begin + // offset 출력 + sLine := Format('0x%.8x ', [LongInt(pStart)-LongInt(pBuf)]); + + // 16Byte 단위로 내용출력 + for i := 0 to 15 do + begin + CopyMemory(@b, PBYTE(LongInt(pStart)+i), SizeOf(BYTE)); + sLine := sLine + Format('%.2x ', [Integer(b)]); + end; + + sLine := sLine + ' '; + + for i := 0 to 15 do + begin + CopyMemory(@b, PBYTE(LongInt(pStart)+i), SizeOf(BYTE)); + if (Integer(b) >= 32) and (Integer(b) <= 125 )then + sLine := sLine + Format('%s', [Char(b)]) + else + sLine := sLine + '.'; + end; + + pStart := PBYTE(LongInt(pStart)+16); + lstDump.Add(sLine); + end; + +// 나머지 + if dwRemainder > 0 then + begin + // offset 출력 + sLine := Format('0x%.8x ', [LongInt(pStart)-LongInt(pBuf)]); + + // 16Byte 단위로 출력하고 남은 것 출력 + for i := 0 to 15 do + begin + CopyMemory(@b, PBYTE(LongInt(pStart)+i), SizeOf(BYTE)); + sLine := sLine + Format('%.2x ', [LongInt(pStart)+i]); + end; + + for i := 0 to 155 - dwRemainder do + sLine := sLine + ' '; + + sLine := sLine + ' '; + for i := 0 to 15 do + begin + CopyMemory(@b, PBYTE(LongInt(pStart)+i), SizeOf(BYTE)); + if (Integer(b) >= 32) and (Integer(b) <= 125 )then + sLine := sLine + Format('%s', [Char(b)]) + else + sLine := sLine + '.'; + end; + + for i := 0 to 15 - dwRemainder do + sLine := sLine + ' '; + + lstDump.Add(sLine) + end; +end; + +function PosBin(const pFind, pDestBuf: TBytes; nBeginOffset: Integer = 0): Integer; +var + i, j, lp, ld: integer; +begin + lp := Length(pFind); + ld := Length(pDestBuf); + Result := -1; + if (lp > ld) or (nBeginOffset >= ld) then + Exit; + + for i := nBeginOffset to ld-lp-1 do + begin + for j := 0 to lp -1 do + begin + if pFind[j] <> pDestBuf[i + j] then + Break; + + if j = lp-1 then + Result := i; + end; + + if Result <> -1 then + Break; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Html.pas b/Tocsg.Lib/VCL/Tocsg.Html.pas new file mode 100644 index 00000000..5e87c912 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Html.pas @@ -0,0 +1,503 @@ +{*******************************************************} +{ } +{ Tocsg.Html } +{ } +{ Copyright (C) 2020 kku } +{ } +{*******************************************************} + +unit Tocsg.Html; + +interface + +uses + Tocsg.Obj, System.SysUtils, System.Classes; + +type + TTgHtmlParser = class(TTgObject) + private + sHtml_: String; + procedure SetHtmlStr(const sHtml: String); + function GetTagData(sTagPath: String): String; + function GetTagText(sTagPath: String): String; + public + Constructor Create; + + property Html: String read sHtml_ write SetHtmlStr; + property Text[sTagpath: String]: String read GetTagText; default; + end; + +function ExtractElementToStrings(sTag, sHtml: String; EltList: TStrings): Integer; +function ExtractElement(sTag, sHtml: String): String; +function ExtractElementOnce(sTag, sHtml: String): String; +function ClearElement(sTag, sHtml: String): String; overload; +function ClearElement(sBTag, sETag, sHtml: String): String; overload; + +function ExtractAttrToStrings(sHtml: String; AttrList: TStrings): Integer; + +// 셋중에 하나로 정리 하자.... 19_1205 kku +function HtmlDecode(const AStr: String): String; +function StripHTMLTags(const strHTML: string): string; +function ConvHtmlEntities(sText: String): String; + +implementation + +uses + EM.DomParser, Tocsg.Strings, Tocsg.Safe; + +function ExtractElementToStrings(sTag, sHtml: String; EltList: TStrings): Integer; +var + nPosB, nPosE, nPosE_Ck: Integer; + nBEltC, nEEltC: Integer; + sBTag, sETag, sCheckHtml: String; +begin + EltList.Clear; + + sBTag := '<' + sTag; + sETag := '</' + sTag + '>'; + + Result := 0; + nBEltC := Length(sBTag); + while Length(sHtml) > 0 do + begin + nEEltC := Length(sETag); + nPosB := Pos(sBTag, sHtml); + if nPosB = 0 then + break; + + Delete(sHtml, 1, nPosB - 1); + if (sHtml[nBEltC+1] <> ' ') and (sHtml[nBEltC+1] <> '>') then + begin + Delete(sHtml, 1, nBEltC); + continue; + end; + +// nPosB := Pos(sBTag, PChar(@sHtml[nBEltC + 1])); + sCheckHtml := Copy(sHtml, nBEltC + 1, Length(sHtml) - nBEltC + 1); + nPosB := Pos(sBTag, sCheckHtml); + nPosE := Pos(sETag, sHtml); +// nPosE_Ck := Pos('<', sCheckHtml, nPosB + 1); + +// if nPosE > nPosE_Ck then +// begin +// nPosE := nPosE_Ck; +// nEEltc := 0; +// end else + if (nPosE = 0) or ((nPosB > 0) and (nPosB < nPosE)) then + begin + // /> 이렇게 끝날수도 있다. + nPosE_Ck := Pos('/>', sHtml); + if nPosE > nPosE_Ck then + begin + nPosE := nPosE_Ck; + nEEltC := 2; + end; + end; + + if nPosE <> 0 then + begin + EltList.Add(Copy(sHtml, 1, nPosE + nEEltC - 1)); + Delete(sHtml, 1, nPosE + nEEltC - 1); + end else break; + end; + + Result := EltList.Count; +end; + +function ExtractElement(sTag, sHtml: String): String; +var + nPosB, nPosE: Integer; + nBEltC, nEEltC: Integer; + sBTag, sETag: String; +begin + Result := ''; + + sBTag := '<' + sTag; + sETag := '</' + sTag + '>'; + + nBEltC := Length(sBTag); + while Length(sHtml) > 0 do + begin + nEEltC := Length(sETag); + nPosB := Pos(sBTag, sHtml); + if nPosB = 0 then + break; + + Delete(sHtml, 1, nPosB - 1); + +// nPosB := Pos(sBTag, PChar(@sHtml[nBEltC + 1])); + nPosB := Pos(sBTag, Copy(sHtml, nBEltC + 1, Length(sHtml) - nBEltC + 1)); + nPosE := Pos(sETag, sHtml); + + if (nPosE = 0) or ((nPosB > 0) and (nPosB < nPosE)) then + begin + // /> 이렇게 끝날수도 있다. + nPosE := Pos('/>', sHtml); + nEEltC := 2; + end; + + if nPosE <> 0 then + begin + Result := Result + Copy(sHtml, 1, nPosE + nEEltC - 1); + Delete(sHtml, 1, nPosE + nEEltC - 1); + end else break; + end; +end; + +function ClearElement(sTag, sHtml: String): String; +var + nPosB, nPosE: Integer; + nBEltC, nEEltC: Integer; + sBTag, sETag: String; +begin + Result := ''; + + sBTag := '<' + sTag; + sETag := '</' + sTag + '>'; + + nBEltC := Length(sBTag); + while Length(sHtml) > 0 do + begin + nEEltC := Length(sETag); + nPosB := Pos(sBTag, sHtml); + if nPosB = 0 then + break; + + Result := Result + Copy(sHtml, 1, nPosB - 1); + Delete(sHtml, 1, nPosB + nBEltC - 1); + +// nPosB := Pos(sBTag, PChar(@sHtml[nBEltC + 1])); + nPosB := Pos(sBTag, Copy(sHtml, nBEltC + 1, Length(sHtml) - nBEltC + 1)); + nPosE := Pos(sETag, sHtml); + + if (nPosE = 0) or ((nPosB > 0) and (nPosB < nPosE)) then + begin + // /> 이렇게 끝날수도 있다. + nPosE := Pos('/>', sHtml); + nEEltC := 2; + end; + + if nPosE = 0 then + break + else + Delete(sHtml, 1, nPosE + nEEltC - 1); + end; + Result := Result + sHtml; +end; + +function ClearElement(sBTag, sETag, sHtml: String): String; +var + nPosB, nPosE: Integer; + nBEltC, nEEltC: Integer; +begin + Result := ''; + + nBEltC := Length(sBTag); + while Length(sHtml) > 0 do + begin + nEEltC := Length(sETag); + nPosB := Pos(sBTag, sHtml); + if nPosB = 0 then + break; + + Result := Result + Copy(sHtml, 1, nPosB - 1); + Delete(sHtml, 1, nPosB + nBEltC - 1); + +// nPosB := Pos(sBTag, PChar(@sHtml[nBEltC + 1])); + nPosB := Pos(sBTag, Copy(sHtml, nBEltC + 1, Length(sHtml) - nBEltC + 1)); + nPosE := Pos(sETag, sHtml); + + if (nPosE = 0) or ((nPosB > 0) and (nPosB < nPosE)) then + begin + // /> 이렇게 끝날수도 있다. + nPosE := Pos('/>', sHtml); + nEEltC := 2; + end; + + if nPosE = 0 then + break + else + Delete(sHtml, 1, nPosE + nEEltC - 1); + end; + Result := Result + sHtml; +end; + +function ExtractElementOnce(sTag, sHtml: String): String; +var + nPosB, nPosE: Integer; + nBEltC, nEEltC: Integer; + sBTag, sETag: String; +begin + Result := ''; + + sBTag := '<' + sTag; + sETag := '</' + sTag + '>'; + + nBEltC := Length(sBTag); + while Length(sHtml) > 0 do + begin + nEEltC := Length(sETag); + nPosB := Pos(sBTag, sHtml); + if nPosB = 0 then + break; + + Delete(sHtml, 1, nPosB - 1); + +// nPosB := Pos(sBTag, PChar(@sHtml[nBEltC + 1])); + nPosB := Pos(sBTag, Copy(sHtml, nBEltC + 1, Length(sHtml) - nBEltC + 1)); + nPosE := Pos(sETag, sHtml); + + if (nPosE = 0) or ((nPosB > 0) and (nPosB < nPosE)) then + begin + // /> 이렇게 끝날수도 있다. + nPosE := Pos('/>', sHtml); + nEEltC := 2; + end; + + if nPosE <> 0 then + begin + Result := Result + Copy(sHtml, 1, nPosE + nEEltC - 1); + exit; +// Delete(sHtml, 1, nPosE + nEEltC - 1); + end else break; + end; +end; + +function ExtractAttrToStrings(sHtml: String; AttrList: TStrings): Integer; +var + sBTag: String; + i, nPos, nLen: Integer; +begin + Result := 0; + AttrList.Clear; + + nPos := Pos('<', sHtml); + if nPos > 0 then + begin + Delete(sHtml, 1, nPos); + nPos := Pos('>', sHtml); + if nPos > 0 then + begin + SetLength(sHtml, nPos - 1); +// Delete(sHtml, nPos, Length(sHtml) - nPos); + nLen := Length(sHtml); + if sHtml[nLen] = '/' then + SetLength(sHtml, nLen - 1); + + SplitString(sHtml, ' ', AttrList); + + for i := AttrList.Count - 1 downto 0 do + if Pos('=', AttrList[i]) = 0 then + AttrList.Delete(i); + + AttrList.Text := StringReplace(AttrList.Text, '"', '', [rfReplaceAll]); + AttrList.Text := StringReplace(AttrList.Text, '''', '', [rfReplaceAll]); + Result := AttrList.Count; + end; + end; +end; + +{ TTgHtmlParser } + +Constructor TTgHtmlParser.Create; +begin + Inherited Create; + sHtml_ := ''; +end; + +procedure TTgHtmlParser.SetHtmlStr(const sHtml: String); +begin + if sHtml_ <> sHtml then + sHtml_ := sHtml; +end; + +function TTgHtmlParser.GetTagData(sTagPath: String): String; +var + TagPaths: TStringList; + i, b, e: Integer; + sHtml: String; +begin + Result := ''; + sHtml := sHtml_; + Guard(TagPaths, TStringList.Create); + SplitString(sTagpath, '/', TagPaths); + for i := 0 to TagPaths.Count - 1 do + sHtml := ExtractElementOnce(TagPaths[i], sHtml); + + Result := sHtml; +end; + +function TTgHtmlParser.GetTagText(sTagPath: String): String; +var + b, e: Integer; + sAttr: String; + AttrList: TStringList; + i: Integer; +begin + Result := ''; + try + b := LastDelimiter(':', sTagPath); + if b > 0 then + begin + e := Length(sTagPath); + sAttr := Copy(sTagPath, b + 1, e - b); + Delete(sTagPath, b, e - b + 1); + end; + + Result := GetTagData(sTagpath); + if Result <> '' then + begin + b := Pos('>', Result); + e := LastDelimiter('<', Result); + if b < e then + begin + if sAttr <> '' then + begin + Guard(AttrList, TStringList.Create); + if ExtractAttrToStrings(Result, AttrList) > 0 then + begin + Result := ''; + for i := 0 to AttrList.Count - 1 do + if Pos(sAttr + '=', AttrList[i]) = 1 then + begin + Result := Copy(AttrList[i], Length(sAttr) + 2, Length(AttrList[i]) - Length(sAttr) + 1); + exit; + end; + end else Result := ''; + end else begin + Result := Copy(Result, b + 1, e - b - 1); + Result := ClearElement('<', '>', Result) + end; + + end else Result := ''; + end; + finally + if Result <> '' then + begin + Result := StringReplace(Result, #13, ' ', [rfReplaceAll]); + Result := StringReplace(Result, #10, '', [rfReplaceAll]); + Result := Trim(Result); + end; + end; +end; + +// By - https://stackoverflow.com/questions/1657105/delphi-html-decode +function HtmlDecode(const AStr: String): String; +var + Sp, Rp, Cp, Tp: PChar; + S: String; + I, Code: Integer; +begin + SetLength(Result, Length(AStr)); + Sp := PChar(AStr); + Rp := PChar(Result); + Cp := Sp; + try + while Sp^ <> #0 do + begin + case Sp^ of + '&': begin + Cp := Sp; + Inc(Sp); + case Sp^ of + 'a': if AnsiStrPos(Sp, 'amp;') = Sp then { do not localize } + begin + Inc(Sp, 3); + Rp^ := '&'; + end; + 'l', + 'g': if (AnsiStrPos(Sp, 'lt;') = Sp) or (AnsiStrPos(Sp, 'gt;') = Sp) then { do not localize } + begin + Cp := Sp; + Inc(Sp, 2); + while (Sp^ <> ';') and (Sp^ <> #0) do + Inc(Sp); + if Cp^ = 'l' then + Rp^ := '<' + else + Rp^ := '>'; + end; + 'n': if AnsiStrPos(Sp, 'nbsp;') = Sp then { do not localize } + begin + Inc(Sp, 4); + Rp^ := ' '; + end; + 'q': if AnsiStrPos(Sp, 'quot;') = Sp then { do not localize } + begin + Inc(Sp,4); + Rp^ := '"'; + end; + '#': begin + Tp := Sp; + Inc(Tp); + while (Sp^ <> ';') and (Sp^ <> #0) do + Inc(Sp); + SetString(S, Tp, Sp - Tp); + Val(S, I, Code); + Rp^ := Chr((I)); + end; + else + Exit; + end; + end + else + Rp^ := Sp^; + end; + Inc(Rp); + Inc(Sp); + end; + except + end; + SetLength(Result, Rp - PChar(Result)); +end; + +// By - https://stackoverflow.com/questions/3001443/get-the-rendered-text-from-html-delphi +function StripHTMLTags(const strHTML: string): string; +var + P: PChar; + InTag: Boolean; + i, intResultLength: Integer; +begin + P := PChar(strHTML); + Result := ''; + + InTag := False; + repeat + case P^ of + '<': InTag := True; + '>': InTag := False; + #13, #10: ; {do nothing} + else + if not InTag then + begin + if (P^ in [#9, #32]) and ((P+1)^ in [#10, #13, #32, #9, '<']) then + else + Result := Result + P^; + end; + end; + Inc(P); + until (P^ = #0); + + {convert system characters} + Result := StringReplace(Result, '&quot;', '"', [rfReplaceAll]); + Result := StringReplace(Result, '&apos;', '''', [rfReplaceAll]); + Result := StringReplace(Result, '&gt;', '>', [rfReplaceAll]); + Result := StringReplace(Result, '&lt;', '<', [rfReplaceAll]); + Result := StringReplace(Result, '&amp;', '&', [rfReplaceAll]); + Result := StringReplace(Result, '&nbsp;', ' ', [rfReplaceAll]); + {here you may add another symbols from RFC if you need} +end; + +function ConvHtmlEntities(sText: String): String; +begin + Result := StringReplace(sText, #9, '', [rfReplaceAll]); + Result := StringReplace(Result, '&lt;', '<', [rfReplaceAll]); + Result := StringReplace(Result, '&gt;', '>', [rfReplaceAll]); + Result := StringReplace(Result, '&amp;', '&', [rfReplaceAll]); + Result := StringReplace(Result, '&quot;', '"', [rfReplaceAll]); + Result := StringReplace(Result, '&nbsp;', ' ', [rfReplaceAll]); + Result := StringReplace(Result, '&#039;', '''', [rfReplaceAll]); + Result := StringReplace(Result, '&middot;', '·', [rfReplaceAll]); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Json.pas b/Tocsg.Lib/VCL/Tocsg.Json.pas new file mode 100644 index 00000000..0649d998 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Json.pas @@ -0,0 +1,112 @@ +{*******************************************************} +{ } +{ Tocsg.Json } +{ } +{ Copyright (C) 2020 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Json; + +interface + +uses + Tocsg.Obj, SysUtils, WinApi.Windows, Rtti, TypInfo, + superobject; // http://www.progdigy.com/?page_id=6, http://superobject.googlecode.com/svn/trunk/ + +type + TValueArray = array of TValue; + + TTgJson = class(TTgObject) + public + class function GetDataAsType<T>(O: ISuperObject; const sPath: String = ''): T; + + class function ValueToJsonObject<T>(aValue: T): ISuperObject; + class function ValueToJsonAsString<T>(aValue: T): String; + {$IF CompilerVersion > 21} + class function ArrayToJsonObject<T>(aValues: TArray<T>): ISuperObject; + class function ArrayToJsonAsString<T>(aValues: TArray<T>): String; + {$IFEND} + end; + +implementation + +uses + Tocsg.Safe; + +{ TTgJson } + +class function TTgJson.GetDataAsType<T>(O: ISuperObject; const sPath: String = ''): T; +var + ctx: TSuperRttiContext; +begin + Guard(ctx, TSuperRttiContext.Create); + try + if sPath = '' then + Result := ctx.AsType<T>(O) + else + Result := ctx.AsType<T>(O[sPath]); + except + // + end; +end; + +class function TTgJson.ValueToJsonObject<T>(aValue: T): ISuperObject; +var + v: TValue; + ctx: TSuperRttiContext; +begin + v := TValue.From<T>(aValue); + ctx := TSuperRttiContext.Create; + try + Result := ctx.ToJson(v, SO); + finally + FreeAndNil(ctx); + end; +end; + +class function TTgJson.ValueToJsonAsString<T>(aValue: T): String; +var + O: ISuperObject; +begin + O := ValueToJsonObject<T>(aValue); +// Result := O.AsString; + Result := O.AsJson; +end; + +{$IF CompilerVersion > 21} +class function TTgJson.ArrayToJsonObject<T>(aValues: TArray<T>): ISuperObject; +var + v: TValue; + i, nCnt: Integer; + ValueArray: TValueArray; + ctx: TSuperRttiContext; + rctx: TRttiContext; + rtype: TRttiType; +begin + nCnt := Length(aValues); + SetLength(ValueArray, nCnt); + rctx := TRttiContext.Create; + try + for i := 0 to nCnt - 1 do + ValueArray[i] := TValue.From<T>(aValues[i]); + rtype := rctx.GetType(TypeInfo(TArray<T>)); + v := TValue.FromArray(rtype.Handle, ValueArray); + Guard(ctx, TSuperRttiContext.Create); + Result := ctx.ToJson(v, SO); + finally + rctx.Free; + SetLength(ValueArray, 0); + end; +end; + +class function TTgJson.ArrayToJsonAsString<T>(aValues: TArray<T>): String; +var + O: ISuperObject; +begin + O := ArrayToJsonObject<T>(aValues); + Result := O.AsString; +end; +{$IFEND} + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Kernel32.pas b/Tocsg.Lib/VCL/Tocsg.Kernel32.pas new file mode 100644 index 00000000..0c276642 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Kernel32.pas @@ -0,0 +1,137 @@ +{*******************************************************} +{ } +{ Tocsg.Kernel32 } +{ } +{ Copyright (C) 2021 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Kernel32; + +interface + +uses + WinApi.Windows; + +const + PROCESS_QUERY_LIMITED_INFORMATION = $1000; + + GET_MODULE_HANDLE_EX_FLAG_PIN = $00000001; + GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS = $00000004; + GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT = $00000002; + + ATTACH_PARENT_PROCESS = DWORD(-1); // for AttachConsole() API + +type + PHMODULE = ^HMODULE; + + TQueryFullProcessImageName = function(hProcess: THandle; dwFlags: DWORD; pBuffer: PChar; var dwSize: DWORD): DWORD; stdcall; + TGetModuleHandleEx = function(dwFlags: DWORD; lbModuleName: PChar; phModule: PHMODULE): BOOL; stdcall; + TProcessIdToSessionId = function(dwProcessId: DWORD; var dwSessionId: DWORD): BOOL; stdcall; + +// 64 환경에서 32 응용 프로그램으로 system32에 접근 할때 자동을 syswow64로 변경되지 않도록 함 + TWow64DisableWow64FsRedirection = function(var pOldVal: Pointer): BOOL; stdcall; + TWow64RevertWow64FsRedirection = function(pOldVal: Pointer): BOOL; stdcall; + + TAttachConsole = function(dwProcessID: DWORD): BOOL; stdcall; + TFreeConsole = function: BOOL; stdcall; + + +function QueryFullProcessImageName(hProcess: THandle; dwFlags: DWORD; pBuffer: PChar; var dwSize: DWORD): DWORD; +function GetModuleHandleEx(dwFlags: DWORD; lpModuleName: PChar; phModule: PHMODULE): BOOL; +function ProcessIdToSessionId(dwProcessId: DWORD; var dwSessionId: DWORD): BOOL; + +function Wow64DisableWow64FsRedirection(var pOldVal: Pointer): BOOL; +function Wow64RevertWow64FsRedirection(pOldVal: Pointer): BOOL; + +function AttachConsole(dwProcessId: DWORD): BOOL; +function FreeConsole: BOOL; + +implementation + +var + _hKernel32: THandle = 0; + _fnQueryFullProcessImageName: TQueryFullProcessImageName = nil; + _fnGetModuleHandleEx: TGetModuleHandleEx = nil; + _fnProcessIdToSessionId: TProcessIdToSessionId = nil; + _fnWow64DisableWow64FsRedirection: TWow64DisableWow64FsRedirection = nil; + _fnWow64RevertWow64FsRedirection: TWow64RevertWow64FsRedirection = nil; + _fnAttachConsole: TAttachConsole = nil; + _fnFreeConsole: TFreeConsole = nil; + +function InitKernel32Procedure: Boolean; +begin + if _hKernel32 = 0 then + begin + _hKernel32 := GetModuleHandle(kernel32); + if _hKernel32 <> 0 then + begin +{$IFDEF UNICODE} + @_fnQueryFullProcessImageName := GetProcAddress(_hKernel32, 'QueryFullProcessImageNameW'); // vista 이상 + @_fnGetModuleHandleEx := GetProcAddress(_hKernel32, 'GetModuleHandleExW'); // xp 이상 +{$ELSE} + @_fnQueryFullProcessImageName := GetProcAddress(_hKernel32, 'QueryFullProcessImageNameA'); + @_fnGetModuleHandleEx := GetProcAddress(_hKernel32, 'GetModuleHandleExA'); +{$ENDIF} + @_fnProcessIdToSessionId := GetProcAddress(_hKernel32, 'ProcessIdToSessionId'); + @_fnWow64DisableWow64FsRedirection := GetProcAddress(_hKernel32, 'Wow64DisableWow64FsRedirection'); + @_fnWow64RevertWow64FsRedirection := GetProcAddress(_hKernel32, 'Wow64RevertWow64FsRedirection'); + @_fnAttachConsole := GetProcAddress(_hKernel32, 'AttachConsole'); + @_fnFreeConsole := GetProcAddress(_hKernel32, 'FreeConsole'); + end; + end; + Result := _hKernel32 <> 0; +end; + +function QueryFullProcessImageName(hProcess: THandle; dwFlags: DWORD; pBuffer: PChar; var dwSize: DWORD): DWORD; +begin + if InitKernel32Procedure and Assigned(_fnQueryFullProcessImageName) then + Result := _fnQueryFullProcessImageName(hProcess, dwFlags, pBuffer, dwSize) + else Result := 0; +end; + +function GetModuleHandleEx(dwFlags: DWORD; lpModuleName: PChar; phModule: PHMODULE): BOOL; +begin + if InitKernel32Procedure and Assigned(_fnGetModuleHandleEx) then + Result := _fnGetModuleHandleEx(dwFlags, lpModuleName, phModule) + else Result := FALSE; +end; + +function ProcessIdToSessionId(dwProcessId: DWORD; var dwSessionId: DWORD): BOOL; +begin + if InitKernel32Procedure and Assigned(_fnProcessIdToSessionId) then + Result := _fnProcessIdToSessionId(dwProcessId, dwSessionId) + else Result := FALSE; +end; + +// 사용 = Wow64DisableWow64FsRedirection(nil) +function Wow64DisableWow64FsRedirection(var pOldVal: Pointer): BOOL; +begin + if InitKernel32Procedure and Assigned(_fnWow64DisableWow64FsRedirection) then + Result := _fnWow64DisableWow64FsRedirection(pOldVal) + else Result := FALSE; +end; + +// 사용 = Wow64RevertWow64FsRedirection(nil) +function Wow64RevertWow64FsRedirection(pOldVal: Pointer): BOOL; +begin + if InitKernel32Procedure and Assigned(_fnWow64RevertWow64FsRedirection) then + Result := _fnWow64RevertWow64FsRedirection(pOldVal) + else Result := FALSE; +end; + +function AttachConsole(dwProcessId: DWORD): BOOL; +begin + if InitKernel32Procedure and Assigned(_fnAttachConsole) then + Result := _fnAttachConsole(dwProcessId) + else Result := FALSE; +end; + +function FreeConsole: BOOL; +begin + if InitKernel32Procedure and Assigned(_fnFreeConsole) then + Result := _fnFreeConsole + else Result := FALSE; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Keyboard.pas b/Tocsg.Lib/VCL/Tocsg.Keyboard.pas new file mode 100644 index 00000000..1e43f9f5 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Keyboard.pas @@ -0,0 +1,732 @@ +{*******************************************************} +{ } +{ Tocsg.Keyboard } +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.Keyboard; + +interface + +uses + Winapi.Windows, System.Classes, System.SysUtils; + +function IsCapsLockOn: Boolean; +function IsNumLockOn: Boolean; +function IsScrollLockOn: Boolean; +function GetInputKeyToStr(nInput: Integer): String; inline; + +function EngCharToHanChar(const cEng: Char): Char; +function EngStrToHanStr(const sEng: String; bIgnoreSPKey: Boolean = false): String; + +procedure DeleteSPKey(var sContexts: String); + +function ConvHotkeyToStr(dwHotkey: DWORD): String; + +procedure PressKeys(const sPress: String; bCtrl: Boolean = false); +procedure PressKey(const dwCode: DWORD); + +function IsWinKeyDown: Boolean; + +implementation + +uses + Vcl.Forms; + +const + ChoSung : WideString = 'ㄱㄲㄴㄷㄸㄹㅁㅂㅃㅅㅆㅇㅈㅉㅊㅋㅌㅍㅎ'; + JungSung : WideString = 'ㅏㅐㅑㅒㅓㅔㅕㅖㅗㅘㅙㅚㅛㅜㅝㅞㅟㅠㅡㅢㅣ'; + JongSung : WideString = ' ㄱㄲㄳㄴㄵㄶㄷㄹㄺㄻㄼㄽㄾㄿㅀㅁㅂㅄㅅㅆㅇㅈㅊㅋㅌㅍㅎ'; + +function IsCapsLockOn: Boolean; +begin + Result := GetKeyState(VK_CAPITAL) = 1; +end; + +function IsNumLockOn: Boolean; +begin + Result := GetKeyState(VK_NUMLOCK) = 1; +end; + +function IsScrollLockOn: Boolean; +begin + Result := GetKeyState(VK_SCROLL) = 1; +end; + +function GetInputKeyToStr(nInput: Integer): String; +var + ShiftState: TShiftState; +begin + ShiftState := KeyDataToShiftState(0); + if GetKeyState(VK_LMENU) < 0 then + Include(ShiftState, ssAlt); + +// 단순 캐스팅으로 뭘 쳤는지 알수 없는 것들은 아래처럼 처리한다. + case nInput of + 8 : Result := '[Back Space]'; + 9 : Result := '[Tab]'; + 13 : Result := '[Enter]'; + 19 : Result := '[Pause]'; + 21 : Result := '[HanYoung]'; + 22 : Result := '[Hangul]'; + 23, + 25 : Result := '[Hanja]'; + 27 : Result := '[Esc]'; + 32 : Result := ' '; + 33 : Result := '[Page Up]'; + 34 : Result := '[Page Down]'; + 35 : Result := '[End]'; + 36 : Result := '[Home]'; + 37 : Result := '[Left]'; + 38 : Result := '[Up]'; + 39 : Result := '[Right]'; + 40 : Result := '[Down]'; + 44 : Result := '[Print Screen]'; + 45 : Result := '[Insert]'; + 46 : Result := '[Delete]'; + 91 : Result := '[Win Right]'; + 92 : Result := '[Win Left]'; + 93 : Result := '[Win Menu]'; + 96 : Result := '[Num 0]'; + 97 : Result := '[Num 1]'; + 98 : Result := '[Num 2]'; + 99 : Result := '[Num 3]'; + 100 : Result := '[Num 4]'; + 101 : Result := '[Num 5]'; + 102 : Result := '[Num 6]'; + 103 : Result := '[Num 7]'; + 104 : Result := '[Num 8]'; + 105 : Result := '[Num 9]'; + 106 : Result := '*'; + 107 : Result := '+'; + 109 : Result := '-'; + 110 : Result := '[. Del]'; + 111 : Result := '/'; + 112 : Result := '[F1]'; + 113 : Result := '[F2]'; + 114 : Result := '[F3]'; + 115 : Result := '[F4]'; + 116 : Result := '[F5]'; + 117 : Result := '[F6]'; + 118 : Result := '[F7]'; + 119 : Result := '[F8]'; + 120 : Result := '[F9]'; + 121 : Result := '[F10]'; + 122 : Result := '[F11]'; + 123 : Result := '[F12]'; + 144 : Result := '[Num Lock]'; + 145 : Result := '[Scroll Lock]'; + 186 : + if ssShift in ShiftState then + Result := ':' + else + Result := ';'; + 187 : + if ssShift in ShiftState then + Result := '+' + else + Result := '='; + 188 : + if ssShift in ShiftState then + Result := '<' + else + Result := ','; + 189 : + if ssShift in ShiftState then + Result := '_' + else + Result := '-'; + 190 : + if ssShift in ShiftState then + Result := '>' + else + Result := '.'; + 191 : + if ssShift in ShiftState then + Result := '?' + else + Result := '/'; + 192 : + if ssShift in ShiftState then + Result := '~' + else + Result := '`'; + 219 : + if ssShift in ShiftState then + Result := '{' + else + Result := '"["'; + 220 : + if ssShift in ShiftState then + Result := '|' + else + Result := '\'; + 221 : + if ssShift in ShiftState then + Result := '}' + else + Result := '"]"'; + 222 : + if ssShift in ShiftState then + Result := '"' + else + Result := ''''; + 48..57 : + if ssShift in ShiftState then + begin + case nInput of + 48 : Result := ')'; + 49 : Result := '!'; + 50 : Result := '@'; + 51 : Result := '#'; + 52 : Result := '$'; + 53 : Result := '%'; + 54 : Result := '^'; + 55 : Result := '&'; + 56 : Result := '*'; + 57 : Result := '('; + end; + end else + Result := IntToStr(nInput - 48); // 숫자 0 ~ 9 + 65..90 : + begin + if GetKeyState(VK_CAPITAL) = 0 then + begin + if ssShift in ShiftState then + Result := Char(nInput) + else + Result := Char(nInput + 32); + end else + if ssShift in ShiftState then + Result := Char(nInput + 32) + else + Result := Char(nInput); + end; + end; + + if ssAlt in ShiftState then + Result := '[Alt]+' + Result; + + if ssCtrl in ShiftState then + Result := '[Ctrl]+' + Result; + + if ssShift in ShiftState then + Result := '[Shift]+' + Result; +end; + +function GetChoSungIdx(const cJaso: Char): WORD; +begin + Result := Pos(cJaso, ChoSung); +end; + +function GetJungSungIdx(const cJaso: Char): WORD; +begin + Result := Pos(cJaso, JungSung); +end; + +function GetJongSungIdx(const cJaso: Char): WORD; +begin + Result := Pos(cJaso, JongSung); +end; + +function EngCharToHanChar(const cEng: Char): Char; +begin + Result := cEng; + case cEng of + 'A', + 'a' : Result := 'ㅁ'; + 'B', + 'b' : Result := 'ㅠ'; + 'C', + 'c' : Result := 'ㅊ'; + 'D', + 'd' : Result := 'ㅇ'; + 'e' : Result := 'ㄷ'; + 'F', + 'f' : Result := 'ㄹ'; + 'G', + 'g' : Result := 'ㅎ'; + 'H', + 'h' : Result := 'ㅗ'; + 'I', + 'i' : Result := 'ㅑ'; + 'J', + 'j' : Result := 'ㅓ'; + 'K', + 'k' : Result := 'ㅏ'; + 'L', + 'l' : Result := 'ㅣ'; + 'M', + 'm' : Result := 'ㅡ'; + 'N', + 'n' : Result := 'ㅜ'; + 'o' : Result := 'ㅐ'; + 'p' : Result := 'ㅔ'; + 'q' : Result := 'ㅂ'; + 'r' : Result := 'ㄱ'; + 'S', + 's' : Result := 'ㄴ'; + 't' : Result := 'ㅅ'; + 'U', + 'u' : Result := 'ㅕ'; + 'V', + 'v' : Result := 'ㅍ'; + 'w' : Result := 'ㅈ'; + 'X', + 'x' : Result := 'ㅌ'; + 'Y', + 'y' : Result := 'ㅛ'; + 'Z', + 'z' : Result := 'ㅋ'; + + 'R' : Result := 'ㄲ'; + 'E' : Result := 'ㄸ'; + 'Q' : Result := 'ㅃ'; + 'T' : Result := 'ㅆ'; + 'W' : Result := 'ㅉ'; + + 'O' : Result := 'ㅒ'; + 'P' : Result := 'ㅖ'; + end; +end; + +function EngStrToHanStr(const sEng: String; bIgnoreSPKey: Boolean = false): String; +const + STEP_CHOSUNG = 0; + STEP_JUNGSUNG = 1; + STEP_JUNGSUNG2 = 2; + STEP_JONGSUNG = 3; + STEP_JONGSUNG2 = 4; + + RESULT_SUCCESS = 0; + RESULT_FAIL = 1; + RESULT_RETRY = 2; + RESULT_ADD_RETRY = 3; + +var + i, nLen, + nStep: Integer; + wCombine, + wJasoTemp, + wCombineTemp: WORD; + cJaso, + cNextJaso: Char; + bFilterSP: Boolean; + + function ProcessCombine: Integer; + var + wTemp: WORD; + Label LB_EXIT_STEP_JUNGSUNG2; + Label LB_EXIT_STEP_JONGSUNG2; + begin + Result := RESULT_FAIL; + + case nStep of + STEP_CHOSUNG : + begin + wTemp := GetChoSungIdx(cJaso); + if wTemp > 0 then + begin + Result := RESULT_SUCCESS; + wCombineTemp := wTemp; + nStep := STEP_JUNGSUNG; + end; + end; + STEP_JUNGSUNG : + begin + wTemp := GetJungSungIdx(cJaso); + if wTemp > 0 then + begin + wCombine := ((wCombineTemp - 1) * 21 * 28) + $AC00; + Result := RESULT_SUCCESS; + case wTemp of + 9, // ㅗ + 14, // ㅜ + 19 : // ㅡ + begin + wCombineTemp := wTemp; + nStep := STEP_JUNGSUNG2; + end; + else begin + Inc(wCombine, (wTemp-1) * 28); + nStep := STEP_JONGSUNG; + end; + end; + end; + end; + STEP_JUNGSUNG2 : + begin + nStep := STEP_JONGSUNG; + // ㅘ, ㅚ, ㅙ, ㅞ,ㅟ... 등등을 처리해 준다 13_1216 16:37:29 sunk + wJasoTemp := GetJungSungIdx(cJaso); + case wJasoTemp of + 1 : // ㅏ + case wCombineTemp of + 9 : Inc(wCombine, (10-1) * 28); // ㅘ + 14 : Goto LB_EXIT_STEP_JUNGSUNG2; + 19 : Goto LB_EXIT_STEP_JUNGSUNG2; + end; + 2 : // ㅐ + case wCombineTemp of + 9 : Inc(wCombine, (11-1) * 28); // ㅙ + 14 : Goto LB_EXIT_STEP_JUNGSUNG2; + 19 : Goto LB_EXIT_STEP_JUNGSUNG2; + end; + 5 : + case wCombineTemp of + 9 : Goto LB_EXIT_STEP_JUNGSUNG2; + 14 : Inc(wCombine, (15-1) * 28); // ㅝ + 19 : Goto LB_EXIT_STEP_JUNGSUNG2; + end; + 6 : // ㅔ + case wCombineTemp of + 9 : Goto LB_EXIT_STEP_JUNGSUNG2; + 14 : Inc(wCombine, (16-1) * 28); // ㅞ + 19 : Goto LB_EXIT_STEP_JUNGSUNG2; + end; + 21 : // ㅣ + case wCombineTemp of + 9 : Inc(wCombine, (12-1) * 28); // ㅚ + 14 : Inc(wCombine, (17-1) * 28); // ㅟ + 19 : Inc(wCombine, (20-1) * 28); // ㅢ + end; + else Goto LB_EXIT_STEP_JUNGSUNG2; + end; + Result := RESULT_SUCCESS; + exit; + + LB_EXIT_STEP_JUNGSUNG2 : + Inc(wCombine, (wCombineTemp-1) * 28); + Result := RESULT_RETRY; + end; + STEP_JONGSUNG : + begin + if cJaso = ' ' then + exit; + + if (cNextJaso <> #0) and + (GetJungSungIdx(EngCharToHanChar(cNextJaso)) > 0) then + begin + // 종성처리 부분이지만 다음 부분이 중성이면 + // 종성처리 하지 않고 초성처리부터 조합하도록 넘긴다 13_1216 16:38:03 sunk + nStep := STEP_CHOSUNG; + Result := RESULT_ADD_RETRY; + exit; + end; + + wTemp := GetJongSungIdx(cJaso); + if wTemp > 0 then + begin + Result := RESULT_SUCCESS; + case wTemp of + 2, // ㄱ + 5, // ㄴ + 9, // ㄹ + 18 : // ㅂ + begin + wCombineTemp := wTemp; + nStep := STEP_JONGSUNG2; + end; + else begin + Inc(wCombine, wTemp-1); + nStep := STEP_CHOSUNG; + end; + end; + end; + end; + STEP_JONGSUNG2 : + if ((cNextJaso <> #0) and + (GetJungSungIdx(EngCharToHanChar(cNextJaso)) > 0)) or + (GetJungSungIdx(cJaso) > 0) then + begin + Inc(wCombine, wCombineTemp-1); + nStep := STEP_CHOSUNG; + Result := RESULT_ADD_RETRY; + end else begin + // 종성처리 - ㄳ ㄵ ㄶ ㄺ... 등등을 처리해준다. + nStep := STEP_CHOSUNG; + wJasoTemp := GetJongSungIdx(cJaso); + case wJasoTemp of + 2 : // ㄱ + case wCombineTemp of + 2 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄱㄱ + 5 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄴㄱ + 9 : Inc(wCombine, 10-1); // ㄹㄱ + 18 : Goto LB_EXIT_STEP_JONGSUNG2; // ㅂㄱ + end; + 17 : // ㅁ + case wCombineTemp of + 2 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄱㅁ + 5 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄴㅁ + 9 : Inc(wCombine, 11-1); // ㄹㅁ + 18 : Goto LB_EXIT_STEP_JONGSUNG2; // ㅂㅁ + end; + 18 : // ㅂ + case wCombineTemp of + 2 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄱㅂ + 5 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄴㅂ + 9 : Inc(wCombine, 12-1); // ㄹㅂ + 18 : Goto LB_EXIT_STEP_JONGSUNG2; // ㅂㅂ + end; + 20 : // ㅅ + case wCombineTemp of + 2 : Inc(wCombine, 4-1); // ㄱㅅ + 5 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄴㅅ + 9 : Inc(wCombine, 13-1); // ㄹㅅ + 18 : Inc(wCombine, 19-1); // ㅂㅅ + end; + 23 : // ㅈ + case wCombineTemp of + 2 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄱㅈ + 5 : Inc(wCombine, 6-1); // ㄴㅈ + 9 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄹㅈ + 18 : Goto LB_EXIT_STEP_JONGSUNG2; // ㅂㅈ + end; + 26 : // ㅌ + case wCombineTemp of + 2 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄱㅌ + 5 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄴㅌ + 9 : Inc(wCombine, 14-1); // ㄹㅌ + 18 : Goto LB_EXIT_STEP_JONGSUNG2; // ㅂㅌ + end; + 27 : // ㅍ + case wCombineTemp of + 2 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄱㅍ + 5 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄴㅍ + 9 : Inc(wCombine, 15-1); // ㄹㅍ + 18 : Goto LB_EXIT_STEP_JONGSUNG2; // ㅂㅍ + end; + 28 : // ㅎ + case wCombineTemp of + 2 : Goto LB_EXIT_STEP_JONGSUNG2; // ㄱㅎ + 5 : Inc(wCombine, 7-1); // ㄴㅎ + 9 : Inc(wCombine, 16-1); // ㄹㅎ + 18 : Goto LB_EXIT_STEP_JONGSUNG2; // ㅂㅎ + end; + else Goto LB_EXIT_STEP_JONGSUNG2; + end; + Result := RESULT_SUCCESS; + exit; + + LB_EXIT_STEP_JONGSUNG2 : + Inc(wCombine, wCombineTemp-1); + Result := RESULT_ADD_RETRY; + end; + else ASSERT(false); + end; + end; + + procedure ProcessAfterCombine; + begin + // 특수키 제외 시키는 부분에서도 필요해서 따로 뺌 13_1217 16:25:27 sunk + case nStep of + STEP_JUNGSUNG : Result := Result + ChoSung[wCombineTemp]; // 중성 조합시기에 끝났다면 초성찍고 마무리 13_1217 13:42:40 sunk + STEP_JUNGSUNG2 : + begin + Inc(wCombine, (wCombineTemp-1) * 28); + Result := Result + Char(wCombine); + end; + STEP_JONGSUNG2 : + begin + Inc(wCombine, wCombineTemp-1); + Result := Result + Char(wCombine); + end; + else + if wCombine <> 0 then + Result := Result + Char(wCombine); // 조합중인거 있다면 포함시켜서 마무리 13_1217 13:43:31 sunk + end; + wCombine := 0; + nStep := STEP_CHOSUNG; + end; + +begin + Result := ''; + bFilterSP := false; + nStep := 0; + nLen := Length(sEng); + wCombine := 0; + i := 1; + + while i <= nLen do + begin + cJaso := EngCharToHanChar(sEng[i]); + if (i+1) <= nLen then + cNextJaso := EngCharToHanChar(sEng[i+1]) + else + cNextJaso := #0; + + if bIgnoreSPKey and not bFilterSP and (cJaso = '[') and (cNextJaso <> '"') then + begin + ProcessAfterCombine; + + bFilterSP := true; + Result := Result + sEng[i]; + Inc(i); + continue; + end else + if bIgnoreSPKey and bFilterSP and (cJaso <> '"') and (cNextJaso = ']') then + begin + bFilterSP := false; + Result := Result + sEng[i] + sEng[i+1]; + Inc(i, 2); + continue; + end else + if bFilterSP then + begin + Result := Result + sEng[i]; + Inc(i); + continue; + end; + + case ProcessCombine of + RESULT_SUCCESS : + case nStep of + STEP_CHOSUNG : + begin + Result := Result + Char(wCombine); + wCombine := 0; + end; + end; + RESULT_FAIL : + if nStep <> STEP_CHOSUNG then + begin + if nStep = STEP_JUNGSUNG then + begin + Result := Result + ChoSung[wCombineTemp]; + nStep := STEP_CHOSUNG; + continue; + end else + if wCombine <> 0 then + begin + Result := Result + Char(wCombine) + cJaso; + end else + Result := Result + cJaso; + wCombine := 0; + nStep := STEP_CHOSUNG; + end else + Result := Result + cJaso; + RESULT_RETRY : continue; + RESULT_ADD_RETRY : + begin + Result := Result + Char(wCombine); + wCombine := 0; + continue; + end; + end; + Inc(i); + end; + +// 조합 도중 끝났을때 마무리 + ProcessAfterCombine; +end; + +// [Shift], [Ctrl] ... 이렇게 [ ]에 감싼건 다 없애준다. 13_1217 15:19:14 sunk +procedure DeleteSPKey(var sContexts: String); +var + i, nDelBegin: Integer; + cOne, cTwo: Char; +begin + sContexts := StringReplace(sContexts, ']+', ']', [rfReplaceAll]); + i := Length(sContexts); + nDelBegin := 0; + while i > 0 do + begin + cOne := sContexts[i]; + if (i-1) > 0 then + cTwo := sContexts[i-1] + else + cTwo := #0; + + if (nDelBegin = 0) and (cOne = ']') and (cTwo <> '"') then + begin + nDelBegin := i; + end else + if (nDelBegin > 0) and (cTwo = '[') and (cOne <> '"') then + begin + Delete(sContexts, i-1, nDelBegin - i + 2); + Dec(i); + nDelBegin := 0; + end; + + Dec(i); + end; +end; + +function ConvHotkeyToStr(dwHotkey: DWORD): String; +var + nHk: Integer; + arrChar: array [0..1] of Char; +begin + Result := ''; + ZeroMemory(@arrChar, SizeOf(arrChar)); + try + if dwHotkey = 0 then + exit; + + if (dwHotkey and $FF) >= $70 then // F1 - F24 + begin + if ((dwHotkey and $FF) >= $90) then + begin + case dwHotKey and $FF of + $90 : Result := 'Num Lock'; + $91 : Result := 'Scroll Lock'; + end; + end else begin + nHk := ((dwHotkey and $FF) - $70) + 1; + Result := 'F' + IntToStr(nHk); + end; + end else begin + Result := GetInputKeyToStr(dwHotKey and $FF); + end; + +// if (Result <> '') and ((dwHotKey and $700) > 0) then +// Result := ' + ' + Result; + + // 아래 순서는 일부러 이렇게 함 17_1011 15:29:21 sunk + if ((dwHotKey and $400) > 0) then + Result := 'Alt + ' + Result; + if ((dwHotKey and $100) > 0) then + Result := 'Shift + ' + Result; + if ((dwHotKey and $200) > 0) then + Result := 'Ctrl + ' + Result; + finally + if Result = '' then + Result := 'None'; + end; +end; + +procedure PressKeys(const sPress: String; bCtrl: Boolean = false); +var + i: Integer; + u: Byte; +begin + if bCtrl then + keybd_event(VK_CONTROL, 0, 0, 0); + try + for i := 1 to Length(sPress) do + begin + u := Byte(sPress[i]); + + keybd_event(u, MapVirtualKey(u, 0),0, 0); + keybd_event(u, MapVirtualKey(u, 0), KEYEVENTF_KEYUP, 0); + end; + finally + if bCtrl then + keybd_event(VK_CONTROL, 0, KEYEVENTF_KEYUP, 0); + end; +end; + +procedure PressKey(const dwCode: DWORD); +begin + keybd_event(dwCode, 0, 0, 0); + keybd_event(dwCode, 0, KEYEVENTF_KEYUP, 0); +end; + +function IsWinKeyDown: Boolean; +begin + Result := (GetKeyState(VK_LWIN) and $8000 <> 0) or (GetKeyState(VK_RWIN) and $8000 <> 0); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.MSAA.pas b/Tocsg.Lib/VCL/Tocsg.MSAA.pas new file mode 100644 index 00000000..de151db0 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.MSAA.pas @@ -0,0 +1,681 @@ +{*******************************************************} +{ } +{ Tocsg.MSAA } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} +unit Tocsg.MSAA; +interface +uses + Winapi.Windows, Winapi.oleacc, System.Classes, System.SysUtils; + +const + IID_IServiceProvider: TGUID = '{6D5140C1-7436-11CE-8034-00AA006009FA}'; + IID_ISimpleDOMNode: TGUID = '{1814ceeb-49e2-407f-af99-fa755a7d2607}';//'{0C539790-12E4-11CF-B661-00AA004CD6D8}'; + IID_ISimpleDOMDocument: TGUID = '{0D68D6D0-D93D-4d08-A30D-F00DD1F45B24}'; + IID_IEnumVARIANT: TGUID ='{00020404-0000-0000-C000-000000000046}'; + +type + IServiceProvider = interface(IUnknown) + [IID_IServiceProvider] + function QueryService(const rsid, IID: TGuid; out Obj): HResult; stdcall; + end; + + ISimpleDOMNode = interface(IUnknown) + [IID_ISimpleDOMNode] + function QueryService(const rsid, IID: TGuid; out Obj): HResult; stdcall; + end; + + ISimpleDOMDocument = interface(IUnknown) + [IID_ISimpleDOMDocument] + function QueryService(const rsid, IID: TGuid; out Obj): HResult; stdcall; + end; + + TProcessEnumAccessible = reference to procedure(aParentAccObj, aAccObj: IAccessible; varChild: OleVariant; h: HWND; nLevel: Integer; var bContinue: Boolean); + + function GetObjectState(aAccObj: IAccessible; var aVarChild: OleVariant; var nState: Integer): Boolean; + function GetObjectRole(aAccObj: IAccessible; var aVarChild: OleVariant; var nRole: Integer): Boolean; + function GetObjectRoleString(aAccObj: IAccessible; var aVarChild: OleVariant; sData: PChar): Boolean; + function GetObjectName(aAccObj: IAccessible; var aVarChild: OleVariant): String; + function GetObjectValue(aAccObj: IAccessible; var aVarChild: OleVariant): String; + function EnumAccessible(h: HWND; ProcEnumAccessible: TProcessEnumAccessible; bIncludeInvisible: Boolean = false): Boolean; + function FindChildAccessible(aAccParent: IAccessible; ProcEnumAccessible: TProcessEnumAccessible; bFirst, bIncludeInvisible: Boolean): Boolean; + + function WindowFromAccessibleObject(aAccObj: IAccessible; var h: HWND): HRESULT; stdcall; external 'oleacc.dll'; + function AccessibleChildren(paccContainer : Pointer; iChildStart : LONGINT; cChildren : LONGINT; + out rgvarChildren : OleVariant; out pcObtained : LONGINT) : HRESULT; stdcall; external 'oleacc.dll'; + function GetRoleTextA(dwRole: DWORD; sRole: PAnsiChar; cRoleMax: byte):HRESULT; stdcall; external 'oleacc.dll'; + function GetRoleTextW(dwRole: DWORD; sRole: PWideChar; cRoleMax: byte):HRESULT; stdcall; external 'oleacc.dll'; + function GetRoleText(dwRole: DWORD; sRole: pchar; cRoleMax: byte):HRESULT; stdcall; external 'oleacc.dll' name 'GetRoleTextW'; + +implementation + +uses + Winapi.ActiveX, System.Variants, Tocsg.Exception, + Tocsg.Trace; + +var + gnLevel: Integer = 0; + +function GetObjectState(aAccObj: IAccessible; var aVarChild: OleVariant; var nState: Integer): Boolean; +var + varState: OleVariant; +begin + Result := false; + try + if (aAccObj <> nil) and not VarIsNull(aVarChild) then + begin + VariantInit(varState); + try + if SUCCEEDED(aAccObj.Get_accState(aVarChild, varState)) and (TVarData(varState).VType = VT_I4) then + begin + nState := TVarData(varState).VInteger; + Result := true; + end; + finally + VariantClear(varState); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetObjectState()'); + end; +end; + +function GetObjectRole(aAccObj: IAccessible; var aVarChild: OleVariant; var nRole: Integer): Boolean; +var + varRole: OleVariant; +begin + Result := false; + try + if (aAccObj <> nil) and not VarIsNull(aVarChild) then + begin + VariantInit(varRole); + try + if SUCCEEDED(aAccObj.Get_accRole(aVarChild, varRole)) and (TVarData(varRole).VType = VT_I4) then + begin + nRole := TVarData(varRole).VInteger; + Result := true; + end; + finally + VariantClear(varRole); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetObjectRole()'); + end; +end; + +//function GetObjectRoleString(aAccObj: IAccessible; var aVarChild: OleVariant): String; +function GetObjectRoleString(aAccObj: IAccessible; var aVarChild: OleVariant; sData: PChar): Boolean; +var + varRole: OleVariant; + nLen, + nRole: Integer; +// 여기 안에서 메모리 생성하면 안되는듯.. 계속 크러쉬 난다 22_0623 14:12:59 kku +// arrBuf 선언하면 프로그램이 크러쉬 나고, pBuf로 동적으로 메모리 셋팅 하면 윈도우가 크러쉬 난다. +// 32bit 환경에서는 괜찮았던거 같은데... +// pBuf: TBytes; +// arrBuf: array [0..199] of WideChar; // 100에서 200으로 올림 22_0620 14:41:59 kku +begin + Result := false; + try + if (aAccObj <> nil) and not VarIsNull(aVarChild) then + begin + VariantInit(varRole); + try + if SUCCEEDED(aAccObj.Get_accRole(aVarChild, varRole)) then // and +// (TVarData(varRole).VType = VT_I4) then + begin + case TVarData(varRole).VType of + VT_I4 : + begin + nRole := TVarData(varRole).VInteger; +// nLen := GetRoleText(nRole, nil, 0); +// if (nLen <= 0) or (nLen > 100) then +// exit; +// SetLength(pBuf, nLen * 2); +// GetRoleText(nRole, @pBuf[0], nLen * 2); + +// ZeroMemory(@arrBuf, SizeOf(arrBuf)); +// nLen := GetRoleText(nRole, nil, 0); +// if (nLen <= 0) or (nLen > 100) then +// exit; +// GetRoleText(nRole, @arrBuf, nLen * 2); +// +// Result := arrBuf; // String(PChar(@pBuf[0])); + + nLen := GetRoleText(nRole, nil, 0); + if (nLen <= 0) or (nLen > 100) then + begin + {$IFDEF DEBUG} ASSERT(false); {$ENDIF} + exit; + end; + Result := GetRoleText(nRole, sData, nLen * 2) > 0; + end; +// VT_BSTR : +// begin +// Result := String(TVarData(varRole).VString); +// end; + end; + end; + finally + VariantClear(varRole); + end; + end; + except + on E: Exception do + begin + ETgException.TraceException(E, 'Fail .. GetObjectRoleString()'); + end; + end; +end; + +function GetObjectName(aAccObj: IAccessible; var aVarChild: OleVariant): String; +var + sVal: WideString; +begin + try + sVal := ''; + Result := ''; + if (aAccObj <> nil) and not VarIsNull(aVarChild) then + if SUCCEEDED(aAccObj.Get_accName(aVarChild, sVal)) then + begin + Result := sVal; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetObjectName()'); + end; +end; + +function GetObjectValue(aAccObj: IAccessible; var aVarChild: OleVariant): String; +var + sVal: WideString; +begin + try + sVal := ''; + Result := ''; + if (aAccObj <> nil) and not VarIsNull(aVarChild) then + if SUCCEEDED(aAccObj.Get_accValue(aVarChild, sVal)) then + begin + Result := sVal; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetObjectValue()'); + end; +end; + +function EnumAccessible(h: HWND; ProcEnumAccessible: TProcessEnumAccessible; bIncludeInvisible: Boolean = false): Boolean; +var + AccObj: IAccessible; +begin + Result := false; + try + if IsWindow(h) and (@ProcEnumAccessible <> nil) then + begin + AccObj := nil; + if SUCCEEDED(AccessibleObjectFromWindow(h, OBJID_WINDOW, IID_IAccessible, AccObj)) and (AccObj <> nil) then + FindChildAccessible(AccObj, ProcEnumAccessible, true, bIncludeInvisible); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. EnumAccessible()'); + end; +end; + +//function FindChildAccessible(aAccParent: IAccessible; ProcEnumAccessible: TProcessEnumAccessible; bFirst, bIncludeInvisible: Boolean): Boolean; +//var +// enumVar: IEnumVARIANT; +// varChild: OleVariant; +// AccChild: IAccessible; +// bContinue: Boolean; +// i, nChildCnt, nCnt, +// nState, nRole: Integer; +// dwFetched: DWORD; +// Dispatch: IDispatch; +// hChild: HWND; +// arrChild: array of OleVariant; +//begin +// Result := false; +// try +// bContinue := true; +// enumVar := nil; +// +// if bFirst then +// begin +// gnLevel := 0; +// VariantInit(varChild); +// TVarData(varChild).VType := VT_I4; +// TVarData(varChild).VInteger := CHILDID_SELF; +// ProcEnumAccessible(aAccParent, varChild, 0, gnLevel, bContinue); +// end; +// Inc(gnLevel); +// +//// aAccParent.QueryInterface(IID_IEnumVARIANT, enumVar); +//// if enumVar <> nil then +//// enumVar.Reset; +// +// nChildCnt := 0; +// aAccParent.Get_accChildCount(nChildCnt); +// +// if nChildCnt = 0 then +// exit; +// +// nCnt := 0; +// if AccessibleChildren(aAccParent, 0, nChildCnt, arrChild[0], nCnt) <> S_OK then +// exit; +// +// SetLength(arrChild, nChildCnt); +// for i := 0 to nCnt - 1 do +// begin +// if not bContinue then +// break; +// +//// VariantClear(varChild); +// varChild := arrChild[i]; +// +// AccChild := nil; +//// if enumVar <> nil then +//// begin +//// dwFetched := 0; +//// if not SUCCEEDED(enumVar.Next(1, varChild, dwFetched)) then +//// begin +//// Result := false; +//// exit; +//// end; +//// +//// // 위에서 성공해도 varChild가 "Unassigned" 상태일 수 있다. +//// // 이럴땐 기본값 강제로 넣어주도록 보완 18_0718 17:17:00 kku +//// if VarIsEmpty(varChild) then +//// begin +//// TVarData(varChild).VType := VT_I4; +//// TVarData(varChild).VInteger := i; +//// end; +//// end else begin +//// TVarData(varChild).VType := VT_I4; +//// TVarData(varChild).VInteger := i; +//// end; +// +// Dispatch := nil; +// case TVarData(varChild).VType of +// VT_I4 : aAccParent.Get_accChild(varChild, Dispatch); +// VT_DISPATCH : Dispatch := IDispatch(TVarData(varChild).VDispatch); +// end; +// +// if Dispatch <> nil then +// begin +// Dispatch.QueryInterface(IID_IAccessible, AccChild); +// +// if AccChild <> nil then +// begin +// VariantInit(varChild); +// TVarData(varChild).VType := VT_I4; +// TVarData(varChild).VInteger := CHILDID_SELF; +// end; +// end; +// +// nState := 0; +// hChild := 0; +// if AccChild <> nil then +// begin +// // nRole := 0; +// // GetObjectRole(AccChild, varChild, nRole); +// +// GetObjectState(AccChild, varChild, nState); +// if not bIncludeInvisible and ((nState and STATE_SYSTEM_INVISIBLE) <> 0) then +// continue; +// +// WindowFromAccessibleObject(AccChild, hChild); +//// {$IFDEF DEBUG} +//// if gnLevel = 5 then +//// gnLevel := gnLevel + 0; +//// {$ENDIF} +// ProcEnumAccessible(AccChild, varChild, hChild, gnLevel, bContinue); +// +// if bContinue then +// bContinue := FindChildAccessible(AccChild, ProcEnumAccessible, false, bIncludeInvisible); +// end else begin +// GetObjectState(aAccParent, varChild, nState); +// if not bIncludeInvisible and ((nState and STATE_SYSTEM_INVISIBLE) <> 0) then +// continue; +// +// WindowFromAccessibleObject(aAccParent, hChild); +// ProcEnumAccessible(aAccParent, varChild, hChild, gnLevel, bContinue); +// end; +// end; +// VariantClear(varChild); +// Dec(gnLevel); +// Result := bContinue; +// except +// on E: Exception do +// ETgException.TraceException(E, 'Fail .. FindChildAccessible()'); +// end; +//end; + +function FindChildAccessible(aAccParent: IAccessible; ProcEnumAccessible: TProcessEnumAccessible; bFirst, bIncludeInvisible: Boolean): Boolean; +var + enumVar: IEnumVARIANT; + varChild: OleVariant; + AccChild: IAccessible; + bContinue: Boolean; + i, nChildCnt, + nState, nRole: Integer; + dwFetched: DWORD; + Dispatch: IDispatch; + hChild: HWND; + arrChild: array of OleVariant; +begin + Result := false; + try + bContinue := true; + enumVar := nil; + + if bFirst then + begin + gnLevel := 0; + VariantInit(varChild); + TVarData(varChild).VType := VT_I4; + TVarData(varChild).VInteger := CHILDID_SELF; + ProcEnumAccessible(nil, aAccParent, varChild, 0, gnLevel, bContinue); + end; + Inc(gnLevel); + + aAccParent.QueryInterface(IID_IEnumVARIANT, enumVar); + if enumVar <> nil then + enumVar.Reset; + + nChildCnt := 0; + aAccParent.Get_accChildCount(nChildCnt); + for i := 1 {0=self} to nChildCnt do + begin + if not bContinue then + break; + + VariantClear(varChild); + + AccChild := nil; + if enumVar <> nil then + begin + dwFetched := 0; + if not SUCCEEDED(enumVar.Next(1, varChild, dwFetched)) then + begin + Result := false; + exit; + end; + + // 위에서 성공해도 varChild가 "Unassigned" 상태일 수 있다. + // 이럴땐 기본값 강제로 넣어주도록 보완 18_0718 17:17:00 kku + if VarIsEmpty(varChild) then + begin + TVarData(varChild).VType := VT_I4; + TVarData(varChild).VInteger := i; + end; + end else begin + TVarData(varChild).VType := VT_I4; + TVarData(varChild).VInteger := i; + end; + + Dispatch := nil; + case TVarData(varChild).VType of + VT_I4 : aAccParent.Get_accChild(varChild, Dispatch); + VT_DISPATCH : Dispatch := IDispatch(TVarData(varChild).VDispatch); + end; + + if Dispatch <> nil then + begin + Dispatch.QueryInterface(IID_IAccessible, AccChild); + + if AccChild <> nil then + begin + VariantInit(varChild); + TVarData(varChild).VType := VT_I4; + TVarData(varChild).VInteger := CHILDID_SELF; + end; + end; + + nState := 0; + hChild := 0; + if AccChild <> nil then + begin + // nRole := 0; + // GetObjectRole(AccChild, varChild, nRole); + + GetObjectState(AccChild, varChild, nState); + if not bIncludeInvisible and ((nState and STATE_SYSTEM_INVISIBLE) <> 0) then + continue; + + WindowFromAccessibleObject(AccChild, hChild); +// {$IFDEF DEBUG} +// if gnLevel = 5 then +// gnLevel := gnLevel + 0; +// {$ENDIF} + ProcEnumAccessible(aAccParent, AccChild, varChild, hChild, gnLevel, bContinue); + + if bContinue then + bContinue := FindChildAccessible(AccChild, ProcEnumAccessible, false, bIncludeInvisible); + end else begin + GetObjectState(aAccParent, varChild, nState); + if not bIncludeInvisible and ((nState and STATE_SYSTEM_INVISIBLE) <> 0) then + continue; + + WindowFromAccessibleObject(aAccParent, hChild); + ProcEnumAccessible(nil, aAccParent, varChild, hChild, gnLevel, bContinue); + end; + end; + VariantClear(varChild); + Dec(gnLevel); + Result := bContinue; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. FindChildAccessible()'); + end; +end; + +(* +// 나중에 필요하면 포팅해서 쓰자 14_1112 14:40:03 kku +//============================================================================= +BOOL CXMSAALib::GetObjectDescription(IAccessible *pAcc, + VARIANT *pvarChild, + LPTSTR lpszDescription, + UINT cchDescription) +//============================================================================= +{ + BOOL bRet = FALSE; + _ASSERTE(pAcc); + _ASSERTE(pvarChild); + _ASSERTE(lpszDescription); + if (pAcc && pvarChild && lpszDescription) + { + lpszDescription[0] = 0; + BSTR bstrDescription = NULL; + HRESULT hr = pAcc->get_accDescription(*pvarChild, &bstrDescription); + if (SUCCEEDED(hr) && bstrDescription) + { + _bstr_t btemp(bstrDescription, false); + if ((LPCTSTR)btemp) + _tcsncpy(lpszDescription, btemp, cchDescription); + bRet = TRUE; + } + } + return bRet; +} +//============================================================================= +BOOL CXMSAALib::GetObjectLocation(IAccessible *pAcc, + VARIANT *pvarChild, + RECT& rect) +//============================================================================= +{ + BOOL bRet = FALSE; + _ASSERTE(pAcc); + _ASSERTE(pvarChild); + if (pAcc && pvarChild) + { + HRESULT hr = pAcc->accLocation(&rect.left, &rect.top, + &rect.right, &rect.bottom, *pvarChild); + if (SUCCEEDED(hr)) + { + // accLocation returns width and height + rect.right += rect.left; + rect.bottom += rect.top; + bRet = TRUE; + } + } + return bRet; +} +BOOL CXMSAALib::GetObjectChildCount(IAccessible *pAcc, + long& nCount) +//============================================================================= +{ + BOOL bRet = FALSE; + _ASSERTE(pAcc); + if (pAcc) + { + HRESULT hr = pAcc->get_accChildCount(&nCount); + if (SUCCEEDED(hr)) + { + bRet = TRUE; + } + } + return bRet; +} +BOOL CXMSAALib::GetObjectStateString(IAccessible *pAcc, + VARIANT *pvarChild, + LPTSTR lpszBuf, + UINT cchBuf) +//============================================================================= +{ + BOOL bRet = FALSE; + _ASSERTE(pAcc); + _ASSERTE(pvarChild); + _ASSERTE(lpszBuf); + if (pAcc && pvarChild && lpszBuf) + { + lpszBuf[0] = 0; + UINT nState = 0; + if (GetObjectState(pAcc, pvarChild, nState)) + { + if ((nState & STATE_SYSTEM_INVISIBLE) == 0) + { + if (cchBuf > _tcslen(_T("visible"))) + _tcscpy(lpszBuf, _T("visible")); + } + TCHAR szState[200]; + szState[0] = 0; + UINT nChars = 0; + // convert state flags to comma separated list + for (DWORD dwStateBit = STATE_SYSTEM_UNAVAILABLE; + (dwStateBit < STATE_SYSTEM_HASPOPUP) && (nChars < cchBuf); + dwStateBit <<= 1) + { + if (nState & dwStateBit) + { + szState[0] = 0; + nChars += GetStateText(dwStateBit, szState, sizeof(szState)/sizeof(TCHAR)-1); + if ((nChars < (cchBuf-3)) && (szState[0] != 0)) + { + if (lpszBuf[0] != 0) + _tcscat(lpszBuf, _T(",")); + _tcscat(lpszBuf, szState); + nChars = (UINT)_tcslen(lpszBuf); + } + } + } + bRet = TRUE; + } + } + return bRet; +} +typedef void (CALLBACK *XWINEVENTURLPROC)(IAccessible *pAccChild, + VARIANT *pvarChild, + DWORD event, + HWND hwnd); +typedef BOOL (CALLBACK *XENUMACCESSIBLEPROC)(IAccessible *pAccChild, + VARIANT *pvarChild, + HWND hwndChild, + int nLevel, + LPARAM lParam); +static XWINEVENTURLPROC g_lpfnXWinEventUrlProc = 0; +//============================================================================= +static void CALLBACK CXMSAALib_WinEventProc(HWINEVENTHOOK /*hook*/, + DWORD event, + HWND hwnd, + LONG idObject, + LONG idChild, + DWORD /*dwEventThread*/, + DWORD /*dwmsEventTime*/) +//============================================================================= +{ + switch (event) + { + case EVENT_OBJECT_FOCUS: + { + TRACE(_T("event=0x%X\n"), event); + IAccessible *pIAcc = 0; + VARIANT varChild; + VariantInit(&varChild); + HRESULT hr = AccessibleObjectFromEvent(hwnd, idObject, idChild, + &pIAcc, &varChild); + if ((hr == S_OK) && (pIAcc != NULL)) + { + if (IsWindow(hwnd)) + { + TRACE(_T("hwnd=0x%X\n"), hwnd); + TCHAR szClassname[256]; + ::GetClassName(hwnd, szClassname, sizeof(szClassname)/sizeof(TCHAR)-1); + szClassname[sizeof(szClassname)/sizeof(TCHAR)-1] = 0; + TRACE(_T("class %s\n"), szClassname); + } + if (g_lpfnXWinEventUrlProc) + { + g_lpfnXWinEventUrlProc(pIAcc, &varChild, event, hwnd); + TRACE(_T("after event proc\n")); + } + SAFE_RELEASE(pIAcc); + } + break; + } + default: + break; + } +} +//============================================================================= +BOOL CXMSAALib::StartGetObjectFromEvent(XWINEVENTURLPROC lpfnXWinEventUrlProc) +//============================================================================= +{ + TRACE(_T("in CXMSAALib::StartGetObjectFromEvent\n")); + g_lpfnXWinEventUrlProc = 0; + if (lpfnXWinEventUrlProc) + { + g_lpfnXWinEventUrlProc = lpfnXWinEventUrlProc; + } + _ASSERTE(g_lpfnXWinEventUrlProc); + if (g_lpfnXWinEventUrlProc == 0) + { + StopGetObjectFromEvent(); + } + else if (g_lpfnXWinEventUrlProc) + { + if (!m_eHook) + { + m_eHook = ::SetWinEventHook(EVENT_OBJECT_FOCUS, EVENT_OBJECT_VALUECHANGE, 0, + CXMSAALib_WinEventProc, 0, 0, WINEVENT_OUTOFCONTEXT | WINEVENT_SKIPOWNPROCESS); + } + } + TRACE(_T("exiting CXMSAALib::StartGetObjectFromEvent\n")); + return m_eHook != 0; +} +//============================================================================= +void CXMSAALib::StopGetObjectFromEvent() +//============================================================================= +{ + if (m_eHook) + ::UnhookWinEvent(m_eHook); + m_eHook = 0; + g_lpfnXWinEventUrlProc = 0; +} +*) +end. diff --git a/Tocsg.Lib/VCL/Tocsg.MTP.pas b/Tocsg.Lib/VCL/Tocsg.MTP.pas new file mode 100644 index 00000000..74c927f2 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.MTP.pas @@ -0,0 +1,188 @@ +{*******************************************************} +{ } +{ Tocsg.MTP } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.MTP; + +interface + +uses + System.SysUtils, System.Classes, Tocsg.Obj, Winapi.Windows, + System.Generics.Collections; + +type + PMtpEnt = ^TMtpEnt; + TMtpEnt = record + sName, + sDesc, + sMfg, + sDevId: String; + end; + TMtpEntList = TList<PMtpEnt>; + + TManagerMtpDev = class(TTgObject) + private + MtpEntList_: TMtpEntList; + procedure OnMptEntNotify(Sender: TObject; const Item: PMtpEnt; Action: TCollectionNotification); + public + Constructor Create; + Destructor Destroy; override; + + procedure RefreshMptDev; + function GetMtpEntByDevId(sDevId: String): PMtpEnt; + + property MtpEntList: TMtpEntList read MtpEntList_; + end; + +implementation + +uses + Tocsg.Driver, Tocsg.Exception, Tocsg.Safe; + +Constructor TManagerMtpDev.Create; +begin + Inherited Create; + MtpEntList_ := TMtpEntList.Create; + MtpEntList_.OnNotify := OnMptEntNotify; +end; + +Destructor TManagerMtpDev.Destroy; +begin + FreeAndNil(MtpEntList_); + Inherited; +end; + +procedure TManagerMtpDev.OnMptEntNotify(Sender: TObject; const Item: PMtpEnt; Action: TCollectionNotification); +begin + if Action = cnRemoved then + Dispose(Item); +end; + +procedure TManagerMtpDev.RefreshMptDev; +var + hDev: HDEVINFO; + sdd: TSPDevInfoData; + i, c: Integer; + dwBufSize, + dwStatus, dwProblem, + dwPropertyRegDataType: DWORD; + pBuf: Pointer; + sInfo1, sInfo2: String; + InfoList: TStringList; + pEnt: PMtpEnt; + + function GetPropStr(dwProp: DWORD): String; + begin + Result := ''; + + dwBufSize := 0; + if pBuf <> nil then + begin + FreeMem(pBuf); + pBuf := nil; + end; + + while not SetupDiGetDeviceRegistryProperty(hDev, sdd, + dwProp, dwPropertyRegDataType, pBuf, dwBufSize, dwBufSize) do + begin + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + if pBuf <> nil then + FreeMem(pBuf); + pBuf := AllocMem(dwBufSize); + end else break; + end; + + if pBuf <> nil then + Result := PChar(pBuf); // 값 여러줄 있는거 무시하고 첫번째만 가져옴 + end; + +begin + try + hDev := SetupDiGetClassDevs(@GUID_DEVCLASS_WPD, nil, 0, DIGCF_PRESENT); + if hDev = INVALID_HANDLE_VALUE then + exit; + + pBuf := nil; + try + ZeroMemory(@sdd, SizeOf(sdd)); + sdd.cbSize := SizeOf(sdd); + + Guard(InfoList, TStringList.Create); + + i := 0; + while SetupDiEnumDeviceInfo(hDev, i, sdd) do + begin + sInfo1 := UpperCase(Trim(GetPropStr(SPDRP_COMPATIBLEIDS))); + sInfo2 := UpperCase(Trim(GetPropStr(SPDRP_SERVICE))); + +// if GetPropStr(SPDRP_DEVTYPE) = 'MTP' then // todo : "버스에서 보고된 장치 설명" 값을 가져오는 방법을 모름.. 22_0630 15:18:12 kku + if (sInfo1 = 'USB\MS_COMP_MTP') or (sInfo2 = 'WUDFWPDMTP') then + begin + New(pEnt); +// _Trace(GetPropStr(SPDRP_COMPATIBLEIDS)); // USB\MS_COMP_MTP +// _Trace(GetPropStr(SPDRP_SERVICE)); // WUDFWpdMtp +// _Trace(GetPropStr(SPDRP_CLASS)); +// _Trace(GetPropStr(SPDRP_CLASSGUID)); +// _Trace(GetPropStr(SPDRP_DRIVER)); +// _Trace(GetPropStr(SPDRP_CONFIGFLAGS)); +// _Trace(GetPropStr(SPDRP_LOCATION_INFORMATION)); +// _Trace(GetPropStr(SPDRP_PHYSICAL_DEVICE_OBJECT_NAME)); +// _Trace(GetPropStr(SPDRP_CAPABILITIES)); +// _Trace(GetPropStr(SPDRP_UI_NUMBER)); +// _Trace(GetPropStr(SPDRP_UPPERFILTERS)); +// _Trace(GetPropStr(SPDRP_LOWERFILTERS)); +// _Trace(GetPropStr(SPDRP_BUSTYPEGUID)); +// _Trace(GetPropStr(SPDRP_LEGACYBUSTYPE)); +// _Trace(GetPropStr(SPDRP_BUSNUMBER)); +// _Trace(GetPropStr(SPDRP_UI_NUMBER)); +// _Trace(GetPropStr(SPDRP_ENUMERATOR_NAME)); +// _Trace(GetPropStr(SPDRP_SECURITY)); +// _Trace(GetPropStr(SPDRP_SECURITY_SDS)); +// _Trace(GetPropStr(SPDRP_DEVTYPE)); +// _Trace(GetPropStr(SPDRP_EXCLUSIVE)); +// _Trace(GetPropStr(SPDRP_CHARACTERISTICS)); +// _Trace(GetPropStr(SPDRP_ADDRESS)); +// _Trace(GetPropStr(SPDRP_UI_NUMBER_DESC_FORMAT)); +// _Trace(GetPropStr(SPDRP_DEVICE_POWER_DATA)); +// _Trace(GetPropStr(SPDRP_REMOVAL_POLICY)); +// _Trace(GetPropStr(SPDRP_LOCATION_PATHS)); + + pEnt.sName := GetPropStr(SPDRP_FRIENDLYNAME); + pEnt.sDesc := GetPropStr(SPDRP_DEVICEDESC); + pEnt.sMfg := GetPropStr(SPDRP_MFG); + pEnt.sDevId := GetPropStr(SPDRP_HARDWAREID); + MtpEntList_.Add(pEnt); + end; + Inc(i); + end; + + finally + SetupDiDestroyDeviceInfoList(hDev); + if pBuf <> nil then + FreeMem(pBuf); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. RefreshMptDev()'); + end; +end; + +function TManagerMtpDev.GetMtpEntByDevId(sDevId: String): PMtpEnt; +var + i: Integer; +begin + Result := nil; + for i := 0 to MtpEntList_.Count - 1 do + if MtpEntList_[i].sDevId = sDevId then + begin + Result := MtpEntList_[i]; + exit; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.NTDLL.Decompress.pas b/Tocsg.Lib/VCL/Tocsg.NTDLL.Decompress.pas new file mode 100644 index 00000000..8b9ebd4c --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.NTDLL.Decompress.pas @@ -0,0 +1,153 @@ +{*******************************************************} +{ } +{ Tocsg.NTDLL.Decompress } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.NTDLL.Decompress; + +interface + +uses + SysUtils, Winapi.Windows; + +const + COMPRESSION_FORMAT_NONE = 0; + COMPRESSION_FORMAT_DEFAULT = 1; + COMPRESSION_FORMAT_LZNT1 = 2; + COMPRESSION_FORMAT_XPRESS = 3; + COMPRESSION_FORMAT_XPRESS_HUFF = 4; + + STATUS_SUCCESS = 0; + STATUS_ACCESS_DENIED = $C0000022; + +type + TRtlHeader = record + arrSig: array[0..3] of AnsiChar; + dwSize: DWORD; + end; + + NTSTATUS = DWORD; + ULONG = DWORD; + PULONG = ^ULONG; + PVOID = Pointer; + USHORT = WORD; + UCHAR = Byte; + PUCHAR = ^UCHAR; + PWSTR = PWideChar; + +TRtlGetCompressionWorkSpaceSize = function(CompressionFormatAndEngine: USHORT; + CompressBufferWorkSpaceSize: PULONG; + CompressFragmentWorkSpaceSize: PULONG): NTSTATUS; stdcall; + +TRtlDecompressBufferEx = function(CompressionFormat: USHORT; + UncompressedBuffer: PUCHAR; + UncompressedBufferSize: ULONG; + CompressedBuffer: PUCHAR; + CompressedBufferSize: ULONG; + FinalUncompressedSize: PULONG; + WorkSpace: PVOID): NTSTATUS; stdcall; + +function RtlGetCompressionWorkSpaceSize(CompressionFormatAndEngine: USHORT; + CompressBufferWorkSpaceSize: PULONG; + CompressFragmentWorkSpaceSize: PULONG): NTSTATUS; // stdcall external 'ntdll.dll'; + +function RtlDecompressBufferEx(CompressionFormat: USHORT; + UncompressedBuffer: PUCHAR; + UncompressedBufferSize: ULONG; + CompressedBuffer: PUCHAR; + CompressedBufferSize: ULONG; + FinalUncompressedSize: PULONG; + WorkSpace: PVOID): NTSTATUS; // stdcall external 'ntdll.dll'; + + +function RtlDecompress(pSrc, pDest: Pointer; dwSrcSize, dwDecompSize, dwCompFormat: DWORD): DWORD; + +implementation + +var + _hNtdll: THandle = 0; + _fnRtlGetCompressionWorkSpaceSize: TRtlGetCompressionWorkSpaceSize = nil; + _fnRtlDecompressBufferEx: TRtlDecompressBufferEx = nil; + +function InitNtdllDecompProcedure: Boolean; +begin + if _hNtdll = 0 then + begin + _hNtdll := GetModuleHandle('ntdll.dll'); + if _hNtdll <> 0 then + begin + @_fnRtlGetCompressionWorkSpaceSize := GetProcAddress(_hNtdll, 'RtlGetCompressionWorkSpaceSize'); + @_fnRtlDecompressBufferEx := GetProcAddress(_hNtdll, 'RtlDecompressBufferEx'); + end; + end; + Result := _hNtdll <> 0; +end; + +function RtlGetCompressionWorkSpaceSize(CompressionFormatAndEngine: USHORT; + CompressBufferWorkSpaceSize: PULONG; + CompressFragmentWorkSpaceSize: PULONG): NTSTATUS; +begin + if InitNtdllDecompProcedure and Assigned(_fnRtlGetCompressionWorkSpaceSize) then + Result := _fnRtlGetCompressionWorkSpaceSize(CompressionFormatAndEngine, + CompressBufferWorkSpaceSize, + CompressFragmentWorkSpaceSize) + else + Result := STATUS_ACCESS_DENIED; + +end; + +function RtlDecompressBufferEx(CompressionFormat: USHORT; + UncompressedBuffer: PUCHAR; + UncompressedBufferSize: ULONG; + CompressedBuffer: PUCHAR; + CompressedBufferSize: ULONG; + FinalUncompressedSize: PULONG; + WorkSpace: PVOID): NTSTATUS; +begin + if InitNtdllDecompProcedure and Assigned(_fnRtlDecompressBufferEx) then + Result := _fnRtlDecompressBufferEx(CompressionFormat, + UncompressedBuffer, + UncompressedBufferSize, + CompressedBuffer, + CompressedBufferSize, + FinalUncompressedSize, + WorkSpace) + else + Result := STATUS_ACCESS_DENIED; + +end; + + +function RtlDecompress(pSrc, pDest: Pointer; dwSrcSize, dwDecompSize, dwCompFormat: DWORD): DWORD; +var + dwOutSize, + dwResult, + dwCompBufWorkSpaceSize, + dwCompFragWorkSpaceSize: DWORD; + pWorkSpace: array of AnsiChar; +begin + Result := 0; + dwResult := RtlGetCompressionWorkSpaceSize(dwCompFormat, + @dwCompBufWorkSpaceSize, + @dwCompFragWorkSpaceSize); + if dwResult <> STATUS_SUCCESS then + exit; + + dwOutSize := 0; + SetLength(pWorkSpace, dwCompBufWorkSpaceSize); + dwResult := RtlDecompressBufferEx(dwCompFormat, + pDest, + dwDecompSize, + pSrc, + dwSrcSize, + @dwOutSize, + pWorkSpace); + if dwResult = STATUS_SUCCESS then + Result := dwOutSize; +end; + + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Network.pas b/Tocsg.Lib/VCL/Tocsg.Network.pas new file mode 100644 index 00000000..810705be --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Network.pas @@ -0,0 +1,2656 @@ +{*******************************************************} +{ } +{ Tocsg.Network +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.Network; + +interface + +uses + Winapi.Windows, System.Classes, System.SysUtils, Winapi.WinSock, + Tocsg.Obj, System.Generics.Collections, Winapi.IpTypes; + +//------------- headers from Microsoft IPTYPES.H-------------------------------- + +const + REG_KEY_NAME_CUR = 'SYSTEM\CurrentControlSet\Control\Network\{4D36E972-E325-11CE-BFC1-08002BE10318}\%s\Connection'; + REG_KEY_NAME_001 = 'SYSTEM\ControlSet001\Control\Network\{4D36E972-E325-11CE-BFC1-08002BE10318}\%s\Connection'; + REG_KEY_NAME_002 = 'SYSTEM\ControlSet002\Control\Network\{4D36E972-E325-11CE-BFC1-08002BE10318}\%s\Connection'; + REG_KEY_DNS = 'SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\%s'; + + IP_NULL = '0.0.0.0'; + MAC_NULL = '000000000000'; + + ANY_SIZE = 1; + MAX_ADAPTER_DESCRIPTION_LENGTH = 128; // arb. + MAX_ADAPTER_NAME_LENGTH = 256; // arb. + MAX_ADAPTER_ADDRESS_LENGTH = 8; // arb. + DEFAULT_MINIMUM_ENTITIES = 32; // arb. + MAX_HOSTNAME_LEN = 128; // arb. + MAX_DOMAIN_NAME_LEN = 128; // arb. + MAX_SCOPE_ID_LEN = 256; // arb. + + // Node Types ( NETBIOS) + BROADCAST_NODETYPE = 1; + PEER_TO_PEER_NODETYPE = 2; + MIXED_NODETYPE = 4; + HYBRID_NODETYPE = 8; + + NETBIOSTypes : array[0..8] of string[20] = + ( 'UNKNOWN', 'BROADCAST', 'PEER_TO_PEER', '', 'MIXED', '', '', '', 'HYBRID' + ); + + // Adapter Types + IF_OTHER_ADAPTERTYPE = 0; + IF_ETHERNET_ADAPTERTYPE = 1; + IF_TOKEN_RING_ADAPTERTYPE = 2; + IF_FDDI_ADAPTERTYPE = 3; + IF_PPP_ADAPTERTYPE = 4; + IF_LOOPBACK_ADAPTERTYPE = 5; + IF_SLIP_ADAPTERTYPE = 6; + // + AdaptTypes : array[0..6] of string[10] = + ( 'other', 'ethernet', 'tokenring', 'FDDI', 'PPP', 'loopback', 'SLIP' ); + + DLL_IPHLPAPI = 'iphlpapi.dll'; + DLL_NETAPI32 = 'NetAPI32.dll'; + + TCP_TABLE_BASIC_LISTENER = 0; + TCP_TABLE_BASIC_CONNECTIONS = 1; + TCP_TABLE_BASIC_ALL = 2; + TCP_TABLE_OWNER_PID_LISTENER = 3; + TCP_TABLE_OWNER_PID_CONNECTIONS = 4; + TCP_TABLE_OWNER_PID_ALL = 5; + TCP_TABLE_OWNER_MODULE_LISTENER = 6; + TCP_TABLE_OWNER_MODULE_CONNECTIONS = 7; + TCP_TABLE_OWNER_MODULE_ALL = 8; + + UDP_TABLE_BASIC = 0; + UDP_TABLE_OWNER_PID = 1; + UDP_TABLE_OWNER_MODULE = 2; + + TCP_STATE_UNKNOWN = 0; + TCP_STATE_CLOSED = 1; + TCP_STATE_LISTEN = 2; + TCP_STATE_SENT = 3; + TCP_STATE_SYN_RECEIVED = 4; + TCP_STATE_ESTABLISHED = 5; + TCP_STATE_FIN_WAIT_1 = 6; + TCP_STATE_FIN_WAIT_2 = 7; + TCP_STATE_CLOSE_WAIT = 8; + TCP_STATE_CLOSING = 9; + TCP_STATE_LAST_ACK = 10; + TCP_STATE_TIME_WAIT = 11; + TCP_STATE_delete_TCB = 12; + + STYPE_DISKTREE = 0; + STYPE_PRINTQ = 1; + STYPE_DEVICE = 2; + STYPE_IPC = 3; + STYPE_TEMPORARY = $40000000; + STYPE_SPECIAL = $80000000; + + MIB_TCP_STATE: array[TCP_STATE_UNKNOWN..TCP_STATE_delete_TCB] of string = + ('Unknown', 'CLOSED', 'LISTEN', 'SYN-SENT ','SYN-RECEIVED', 'ESTABLISHED', 'FIN-WAIT-1', + 'FIN-WAIT-2', 'CLOSE-WAIT', 'CLOSING','LAST-ACK', 'TIME-WAIT', 'delete TCB'); + +//-------------from other MS header files--------------------------------------- + + MAX_INTERFACE_NAME_LEN = 256; { mrapi.h } + MAXLEN_PHYSADDR = 8; { iprtrmib.h } + MAXLEN_IFDESCR = 256; { --"--- } + +//------IP address structures--------------------------------------------------- + + MIB_IF_TYPE_OTHER = 1; // Some other type of network interface. 기타 등등 + MIB_IF_TYPE_ETHERNET = 6; // An Ethernet network interface. 이더넷(무선 포함) + IF_TYPE_ISO88025_TOKENRING = 9; // MIB_IF_TYPE_TOKENRING 토큰링 + MIB_IF_TYPE_FDDI = 15; // 광 + MIB_IF_TYPE_PPP = 23; // A PPP network interface. PPP + MIB_IF_TYPE_LOOPBACK = 24; // A software loopback network interface. 루프백 (localloop) + MIB_IF_TYPE_SLIP = 28; // An ATM network interface. SLIP + IF_TYPE_IEEE80211 = 71; // An IEEE 802.11 wireless network interface. + +type +// 추가 17_1206 14:17:45 sunk + TCP_TABLE_CLASS = Integer; + UDP_TABLE_CLASS = Integer; + + PMibTcpRowOwnerPid = ^TMibTcpRowOwnerPid; + TMibTcpRowOwnerPid = packed record + dwState, + dwLocalAddr, + dwLocalPort, + dwRemoteAddr, + dwRemotePort, + dwOwningPid: DWORD; + end; + + PMIB_TCPTABLE_OWNER_PID = ^MIB_TCPTABLE_OWNER_PID; + MIB_TCPTABLE_OWNER_PID = packed record + dwNumEntries: DWORD; + table: array of TMibTcpRowOwnerPid; +// table: Array [0..ANY_SIZE - 1] of TMibTcpRowOwnerPid; + end; + + PMibUdpRowOwnerPid = ^TMibUdpRowOwnerPid; + TMibUdpRowOwnerPid = packed record + dwLocalAddr, + dwLocalPort, + dwOwningPid: DWORD; + end; + + PMIB_UDPTABLE_OWNER_PID = ^MIB_UDPTABLE_OWNER_PID; + MIB_UDPTABLE_OWNER_PID = packed record + dwNumEntries: DWORD; + table: Array [0..ANY_SIZE - 1] of TMibUdpRowOwnerPid; + end; + +type + TMacAddress = array[1..MAX_ADAPTER_ADDRESS_LENGTH] of byte; + +type + PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; + TIP_ADDRESS_STRING = array [0..15] of AnsiChar; // IP as xxx.xxx.xxx.xxx string + // + PTIP_ADDR_STRING = ^TIP_ADDR_STRING; + TIP_ADDR_STRING = packed record // for use in linked lists + Next : PTIP_ADDR_STRING; + IpAddress : TIP_ADDRESS_STRING; + IpMask : TIP_ADDRESS_STRING; + Context : DWORD; + end; + + PTMibIPNetRow = ^TMibIPNetRow; + TMibIPNetRow = packed record + dwIndex : DWord; + dwPhysAddrLen : DWord; + bPhysAddr : TMACAddress; + dwAddr : DWord; + dwType : DWord; + end; + + PTMibIPAddrRow = ^TMibIPAddrRow; + TMibIPAddrRow = packed record + dwAddr : DWORD; + dwIndex : DWORD; + dwMask : DWORD; + dwBCastAddr : DWORD; + dwReasmSize : DWORD; + Unused1, + Unused2 : WORD; + end; + + TMibIPAddrArray = array of TMIBIPAddrRow; + + PTMibIPAddrTable = ^TMibIPAddrTable; + TMibIPAddrTable = packed record + dwNumEntries : DWORD; + Table : array[0..ANY_SIZE - 1] of TMibIPAddrRow; + end; + + PTMibIPNetTable = ^TMibIPNetTable; + TMibIPNetTable = packed record + dwNumEntries : DWORD; + Table : array[0..ANY_SIZE - 1] of TMibIPNetRow; + end; + + PTMibIPStats = ^TMibIPStats; + TMibIPStats = packed record + dwForwarding : DWORD; + dwDefaultTTL : DWORD; + dwInReceives : DWORD; + dwInHdrErrors : DWORD; + dwInAddrErrors : DWORD; + dwForwDatagrams : DWORD; + dwInUnknownProtos : DWORD; + dwInDiscards : DWORD; + dwInDelivers : DWORD; + dwOutRequests : DWORD; + dwRoutingDiscards : DWORD; + dwOutDiscards : DWORD; + dwOutNoRoutes : DWORD; + dwReasmTimeOut : DWORD; + dwReasmReqds : DWORD; + dwReasmOKs : DWORD; + dwReasmFails : DWORD; + dwFragOKs : DWORD; + dwFragFails : DWORD; + dwFragCreates : DWORD; + dwNumIf : DWORD; + dwNumAddr : DWORD; + dwNumRoutes : DWORD; + end; + + PTMibIPForwardRow = ^TMibIPForwardRow; + TMibIPForwardRow = packed record + dwForwardDest : DWORD; + dwForwardMask : DWORD; + dwForwardPolicy : DWORD; + dwForwardNextHop : DWORD; + dwForwardIFIndex : DWORD; + dwForwardType : DWORD; + dwForwardProto : DWORD; + dwForwardAge : DWORD; + dwForwardNextHopAS : DWORD; + dwForwardMetric1 : DWORD; + dwForwardMetric2 : DWORD; + dwForwardMetric3 : DWORD; + dwForwardMetric4 : DWORD; + dwForwardMetric5 : DWORD; + end; + + PTMibIPForwardTable = ^TMibIPForwardTable; + TMibIPForwardTable = packed record + dwNumEntries : DWORD; + Table : array[0..ANY_SIZE - 1] of TMibIPForwardRow; + end; + +//----------------TCP STRUCTURES------------------------------------------------ + + PTMibTCPRow = ^TMibTCPRow; + TMibTCPRow = packed record + dwState : DWORD; + dwLocalAddr : DWORD; + dwLocalPort : DWORD; + dwRemoteAddr : DWORD; + dwRemotePort : DWORD; + end; + // + PTMibTCPTable = ^TMibTCPTable; + TMibTCPTable = packed record + dwNumEntries : DWORD; + Table : array[0..0] of TMibTCPRow; + end; + // + PTMibTCPStats = ^TMibTCPStats; + TMibTCPStats = packed record + dwRTOAlgorithm : DWORD; + dwRTOMin : DWORD; + dwRTOMax : DWORD; + dwMaxConn : DWORD; + dwActiveOpens : DWORD; + dwPassiveOpens : DWORD; + dwAttemptFails : DWORD; + dwEstabResets : DWORD; + dwCurrEstab : DWORD; + dwInSegs : DWORD; + dwOutSegs : DWORD; + dwRetransSegs : DWORD; + dwInErrs : DWORD; + dwOutRsts : DWORD; + dwNumConns : DWORD; + end; + +//---------UDP STRUCTURES------------------------------------------------------- + + PTMibUDPRow = ^TMibUDPRow; + TMibUDPRow = packed record + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + end; + // + PTMibUDPTable = ^TMIBUDPTable; + TMIBUDPTable = packed record + dwNumEntries : DWORD; + UDPTable : array[0..ANY_SIZE - 1] of TMibUDPRow; + end; + // + PTMibUdpStats = ^TMIBUdpStats; + TMIBUdpStats = packed record + dwInDatagrams : DWORD; + dwNoPorts : DWORD; + dwInErrors : DWORD; + dwOutDatagrams : DWORD; + dwNumAddrs : DWORD; + end; + +//------ADAPTER INFO STRUCTURES------------------------------------------------- +type +// Winapi.IpTypes.pas에서 PIP_ADAPTER_INFO 로 대체 20_1016 12:3843 sunk +// 기존에 사용하던 아래 구조체는 64비트 환경에서 포인터 밀린다. + PTIP_ADAPTER_INFO = PIP_ADAPTER_INFO; + TIP_ADAPTER_INFO = IP_ADAPTER_INFO; + +// TTIME_T = array[1..325] of byte; // hack! MS time.h missing! + +// PTIP_ADAPTER_INFO = ^TIP_ADAPTER_INFO; +// TIP_ADAPTER_INFO = packed record +// Next : PTIP_ADAPTER_INFO; +// ComboIndex : DWORD; +// AdapterName : array[1..MAX_ADAPTER_NAME_LENGTH + 4] of AnsiChar; +// Description : array[1..MAX_ADAPTER_DESCRIPTION_LENGTH + 4] of AnsiChar; +// AddressLength : UINT; +// Address : array[1..MAX_ADAPTER_ADDRESS_LENGTH] of byte; +// Index : DWORD; +// aType : UINT; +// DHCPEnabled : UINT; +// CurrentIPAddress : PTIP_ADDR_STRING; +// IPAddressList : TIP_ADDR_STRING; +// GatewayList : TIP_ADDR_STRING; +// DHCPServer : TIP_ADDR_STRING; +// HaveWINS : BOOL; +// PrimaryWINSServer : TIP_ADDR_STRING; +// SecondaryWINSServer : TIP_ADDR_STRING; +// LeaseObtained : TTIME_T; //?? +// LeaseExpires : TTIME_T; //?? +// end; + +//----------Fixed Info STRUCTURES--------------------------------------------- + + PTFixedInfo = ^TFixedInfo; + TFixedInfo = packed record + HostName : array[0..MAX_HOSTNAME_LEN + 4] of char; + DomainName : array[0..MAX_DOMAIN_NAME_LEN + 4] of char; + CurrentDNSServer : PTIP_ADDR_STRING; + DNSServerList : TIP_ADDR_STRING; + NodeType : UINT; + ScopeID : array[0..MAX_SCOPE_ID_LEN + 4] of char; + EnableRouting : UINT; + EnableProxy : UINT; + EnableDNS : UINT; + end; + +//--------ICMP-STRUCTURES------------------------------------------------------ + + PTMibICMPStats = ^TMibICMPStats; + TMibICMPStats = packed record + dwMsgs : DWORD; + dwErrors : DWORD; + dwDestUnreachs : DWORD; + dwTimeEcxcds : DWORD; + dwParmProbs : DWORD; + dwSrcQuenchs : DWORD; + dwRedirects : DWORD; + dwEchos : DWORD; + dwEchoReps : DWORD; + dwTimeStamps : DWORD; + dwTimeStampReps : DWORD; + dwAddrMasks : DWORD; + dwAddrReps : DWORD; + end; + + PTMibICMPInfo = ^TMibICMPInfo; + TMibICMPInfo = packed record + InStats : TMibICMPStats; + OutStats : TMibICMPStats; + end; + + IPINFO = Record + Ttl : Char; // Time To Live + Tos : Char; // Type Of Service + IPFlags : Char; // IP flags + OptSize : Char; // Size of options data + Options : pChar; // Options data buffer + end; + + ICMPECHO = Record + Source : ULONG; // Source address + Status : ULONG; // IP status + RTTime : ULONG; // Round trip time in milliseconds + DataSize : SHORT ; // Reply data size + Reserved : SHORT ; // Unknown + pData : Pchar; // Reply data buffer + ipInfo : IPINFO; // Reply options + end; + +//----------INTERFACE STRUCTURES------------------------------------------------- + + + PTMibIfRow = ^TMibIfRow; + TMibIfRow = packed record + wszName : array[1..MAX_INTERFACE_NAME_LEN] of WCHAR; + dwIndex : DWORD; + dwType : DWORD; + dwMTU : DWORD; + dwSpeed : DWORD; + dwPhysAddrLen : DWORD; + bPhysAddr : array[1..MAXLEN_PHYSADDR] of byte; + dwAdminStatus : DWORD; + dwOperStatus : DWORD; + dwLastChange : DWORD; + dwInOctets : DWORD; + dwInUcastPkts : DWORD; + dwInNUCastPkts : DWORD; + dwInDiscards : DWORD; + dwInErrors : DWORD; + dwInUnknownProtos : DWORD; + dwOutOctets : DWORD; + dwOutUCastPkts : DWORD; + dwOutNUCastPkts : DWORD; + dwOutDiscards : DWORD; + dwOutErrors : DWORD; + dwOutQLen : DWORD; + dwDescrLen : DWORD; + bDescr : array[1..MAXLEN_IFDESCR] of char; //byte; + end; + + TMIBIfArray = array of TMIBIFRow; + + + // + PTMibIfTable = ^TMIBIfTable; + TMibIfTable = packed record + dwNumEntries : DWORD; + Table : array[0..ANY_SIZE - 1] of TMibIfRow; + end; + +//------------------imports from IPHLPAPI.DLL----------------------------------- + + PRouteEnt = ^TRouteEnt; + TRouteEnt = record + sDestIp: String; + Info: TMibIPForwardRow; + end; + TRouteEntList = class(TList<PRouteEnt>) + protected + procedure Notify(const Item: PRouteEnt; Action: TCollectionNotification); override; + public + function GetEntByDestIp(sDestIp: String): PRouteEnt; + end; + + SHARE_INFO_1 = record + shi1_netname : PWideChar; + shi1_type : DWORD; + shi1_remark : PWideChar; + end; + PSHARE_INFO_1 = ^SHARE_INFO_1; + + SHARE_INFO_2 = record + shi2_netname : PWideChar; + shi2_type : DWORD; + shi2_remark : PWideChar; + shi2_permissions : DWORD; + shi2_max_uses : DWORD; + shi2_current_uses: DWORD; + shi2_path : PWideChar; + shi2_passwd : PWideChar; + end; + PSHARE_INFO_2 = ^SHARE_INFO_2; + + NET_API_STATUS = DWORD; + + TGetAdaptersInfo = function(pAdapterInfo: PTIP_ADAPTER_INFO; pOutBufLen: PULONG): DWORD; stdcall; + TGetExtendedTcpTable = function(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; + lAf: ULONG; TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWORD; stdcall; + TGetExtendedUdpTable = function(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; + lAf: ULONG; TableClass: UDP_TABLE_CLASS; Reserved: ULONG): DWORD; stdcall; + TGetIpForwardTable = function(pIPForwardTable: PTMibIPForwardTable; pdwSize: PULONG; bOrder: BOOL): DWORD; stdCall; + TDeleteIpForwardEntry = function(pEnt: PTMibIPForwardRow): DWORD; stdCall; + + TNetShareEnum = function(ServerName: PWideChar; Level: DWORD; var BufPtr: Pointer; + PrefMaxLen: DWORD; var EntriesRead: DWORD; var TotalEntries: DWORD; + var ResumeHandle : DWORD): NET_API_STATUS; stdcall; + TNetApiBufferFree = function(Buffer : Pointer): NET_API_STATUS; stdcall; + +function GetAdaptersInfo(pAdapterInfo: PTIP_ADAPTER_INFO; pOutBufLen: PULONG): DWORD; +function GetExtendedTcpTable(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; + lAf: ULONG; TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWORD; +function GetExtendedUdpTable(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; + lAf: ULONG; TableClass: UDP_TABLE_CLASS; Reserved: ULONG): DWORD; +//function GetNetworkParams(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; external 'IPHLPAPI.DLL'; +//function GetTcpTable(pTCPTable: PTMibTCPTable; pDWSize: PDWORD; bOrder: BOOL): DWORD; stdcall; external 'IPHLPAPI.DLL'; +//function GetTcpStatistics(pStats: PTMibTCPStats): DWORD; stdcall; external 'IPHLPAPI.DLL'; +//function GetUdpTable(pUdpTable: PTMibUDPTable; pDWSize: PDWORD; bOrder: BOOL): DWORD; stdcall; external 'IPHLPAPI.DLL'; +//function GetUdpStatistics(pStats: PTMibUdpStats): DWORD; stdcall; external 'IPHLPAPI.DLL'; +//function GetIpStatistics(pStats: PTMibIPStats): DWORD; stdcall; external 'IPHLPAPI.DLL'; +//function GetIpNetTable(pIpNetTable: PTMibIPNetTable; pdwSize: PULONG; bOrder: BOOL): DWORD; stdcall; external 'IPHLPAPI.DLL'; +//function GetIpAddrTable(pIpAddrTable: PTMibIPAddrTable; pdwSize: PULONG; bOrder: BOOL): DWORD; stdcall; external 'IPHLPAPI.DLL'; +function GetIpForwardTable(pIPForwardTable: PTMibIPForwardTable; pdwSize: PULONG; bOrder: BOOL): DWORD; +function DeleteIpForwardEntry(pEnt: PTMibIPForwardRow): DWORD; +//function GetIcmpStatistics(pStats: PTMibICMPInfo): DWORD; stdCall; external 'IPHLPAPI.DLL'; +//function GetRTTAndHopCount(DestIPAddress: DWORD; HopCount: PULONG; MaxHops: ULONG; RTT: PULONG): BOOL; stdCall; external 'IPHLPAPI.DLL'; +//function GetIfTable(pIfTable: PTMibIfTable; pdwSize: PULONG; bOrder: boolean): DWORD; stdCall; external 'IPHLPAPI.DLL'; +//function GetIfEntry(pIfRow: PTMibIfRow): DWORD; stdCall; external 'IPHLPAPI.DLL'; +//function GetBestInterface(pIfRow: in_addr; pnBestIndex: PDWORD): DWORD; stdCall; external 'IPHLPAPI.DLL'; + +function NetShareEnum(ServerName: PWideChar; Level: DWORD; var BufPtr: Pointer; + PrefMaxLen: DWORD; var EntriesRead: DWORD; var TotalEntries: DWORD; + var ResumeHandle : DWORD): NET_API_STATUS; +function NetApiBufferFree(Buffer : Pointer): NET_API_STATUS; + +//function IcmpCreateFile: THandle; stdcall; external 'icmp.dll'; +//function IcmpCloseHandle(icmpHandle: THandle): boolean; stdcall; external 'icmp.dll'; +//function IcmpSendEcho(IcmpHandle: THandle; DestinationAddress: LongInt; +// RequestData: Pointer; RequestSize: Smallint; +// RequestOptions: pointer; ReplyBuffer: Pointer; +// ReplySize: DWORD; Timeout: DWORD): DWORD; +// stdcall; external 'icmp.dll'; + + +function GetCurrentHostName: String; + +function IPToDWORD(sIp: String) : Dword; +function DWORDToIP(IPDWord: DWORD; bBig: Boolean = true) : String; +function IncIP(sIp: String; nInc: Integer = 1): String; +function IsValidIP(const sIp: String; bIgrIpNull: Boolean = true; bIncIPv6: Boolean = false): Boolean; +function IsValidIPEx(const sIp: String): Boolean; +function IsValidIpRange(sIpRange: String): Boolean; +function IsIncludeIP(const sIpEx, sIp: String): Boolean; + +function GetHostIP: String; +function GetHostIPsFromDomain(sDomain: AnsiString; sDm: AnsiString = ','): AnsiString; +function GetIPAddrsToList(lstIP: TStrings): Integer; +function GetIPAddrsToListEx(lstIP: TStrings): Integer; +function GetIPAddrsToCommaStr: String; +function GetIPAddrsToCommaStrEx: String; +function GetMACAddrToList(aMacList: TStrings): Boolean; +function GetMACAddrToCommaStr: String; +function GetMACAddr: String; +function GetMACAddrUsing: String; + +function ExtractIPPort(sSrcIPort: String; var sIp: String; var nPort: Integer): Boolean; + +function GetNetDrives(aDrives: TStrings): Integer; +function NetDriveToRemoteAddr(sNDrv: String): String; +function IsNetDrive(cLetter: Char): Boolean; + +function GetNicEnable(sDesc: String): Boolean; +function SetNicEnable(sDesc: String; bVal: Boolean): Integer; +function SetNicEnableByIndex(nIdx: Integer; bVal: Boolean): Boolean; +function GetNetAdapterTypeToStr(dwType: DWORD): String; +function IsConnectedWIFI(aInterfaceGuid: TGUID): Boolean; +function DisconnectWIFI(aInterfaceGuid: TGUID): Boolean; + +function GetRouteTables(aList: TRouteEntList): Integer; +function GetPublicIP: string; +function RemoveEveryoneFromShare(const sShareName: string): Boolean; + +type +// dwType +// 1 = MIB_IF_TYPE_OTHER (다른 유형의 네트워크 인터페이스. Some other type of network interface.) +// 6 = MIB_IF_TYPE_ETHERNET (이더넷 네트워크 인터페이스. An Ethernet network interface.) +// 9 = IF_TYPE_ISO88025_TOKENRING (MIB_IF_TYPE_TOKENRING) +// 23 = MIB_IF_TYPE_PPP (PPP 네트워크 인터페이스. A PPP network interface.) +// 24 = B_IF_TYPE_LOOPBACK (소프트웨어 루프백 네트워크 인터페이스. A software loopback network interface.) +// 28 = MIB_IF_TYPE_SLIP (ATM 네트워크 인터페이스. An ATM network interface.) +// 71 = IF_TYPE_IEEE80211 (IEEE 802.11 무선 네트워크 인터페이스. An IEEE 802.11 wireless network interface.) + PNetAdapterEnt = ^TNetAdapterEnt; + TNetAdapterEnt = record + sName, + sDesc, + sMacAddr, + sIpAddrs, +// sCurIpAddr, + sGatewayIps, + sDHCPServer, + sPriWINSServer, + sSecWINSServer: AnsiString; + bDHCP, + bHaveWINS: Boolean; + dwComboIdx, + dwIndex, + dwType: DWORD; + end; + TNetAdapterEntList = TList<PNetAdapterEnt>; + + TNetAdapterInfo = class(TTgObject) + private + AdapterList_: TNetAdapterEntList; + procedure OnAdapterNotify(Sender: TObject; const Item: PNetAdapterEnt; + Action: TCollectionNotification); + function GetByIndex(nIndex: Integer): PNetAdapterEnt; + public + Constructor Create; + Destructor Destroy; override; + + procedure UpdateNetAdapterInfo; + function Count: Integer; + + property Items[nIndex: Integer]: PNetAdapterEnt read GetByIndex; default; + end; + + PWLanEnt = ^TWLanEnt; + TWLanEnt = record + sName, + sBssid, + sProfile: String; + nQuality: Integer; + dwAlgo1, + dwAlgo2: DWORD; + bSecurety: Boolean; + InterfaceGuid: TGUID; + end; + TWLanEntList = TList<PWLanEnt>; + TWlanInfo = class(TTgObject) + private + WLanEntList_: TWLanEntList; + procedure OnWlanEntNotify(Sender: TObject; const Item: PWLanEnt; + Action: TCollectionNotification); + function GetByIndex(nIndex: Integer): PWLanEnt; + public + Constructor Create; + Destructor Destroy; override; + + procedure UpdateWlanInfo; + function Count: Integer; + function GetWlanEntByName(sName: String): PWLanEnt; + + property Items[nIndex: Integer]: PWLanEnt read GetByIndex; default; + end; + + PTcpInfoEnt = ^TTcpInfoEnt; + TTcpInfoEnt = record + sLocalIpAddr, + sRemoteIpAddr: String; + nLocalPort, + nRemotePort: Integer; + dwPid, + dwStatus: DWORD; + end; + TTcpInfoEntList = TList<PTcpInfoEnt>; + + TTcpTableInfo = class(TTgObject) + private + TcpEnts_: TTcpInfoEntList; + procedure OnTcpInfoEntNotify(Sender: TObject; const Item: PTcpInfoEnt; + Action: TCollectionNotification); + function GetByIndex(nIndex: Integer): PTcpInfoEnt; + public + Constructor Create; + Destructor Destroy; override; + + procedure UpdateTcpTableInfo; + function Count: Integer; + procedure Delete(nIndex: Integer); + + property Items[nIndex: Integer]: PTcpInfoEnt read GetByIndex; default; + end; + + PUdpInfoEnt = ^TUdpInfoEnt; + TUdpInfoEnt = record + sLocalIpAddr: String; + nLocalPort: Integer; + dwPid: DWORD; + end; + TUdpInfoEntList = TList<PUdpInfoEnt>; + + TUdpTableInfo = class(TTgObject) + private + UdpEnts_: TUdpInfoEntList; + procedure OnUdpInfoEntNotify(Sender: TObject; const Item: PUdpInfoEnt; + Action: TCollectionNotification); + function GetByIndex(nIndex: Integer): PUdpInfoEnt; + public + Constructor Create; + Destructor Destroy; override; + + procedure UpdateUdpTableInfo; + function Count: Integer; + procedure Delete(nIndex: Integer); + + property Items[nIndex: Integer]: PUdpInfoEnt read GetByIndex; default; + end; + + PShdFldEnt = ^TShdFldEnt; + TShdFldEnt = record + sName, + sPath: String; + end; + TSharedFolder = class(TList<PShdFldEnt>) + protected + sSvrName_: String; + procedure Notify(const Item: PShdFldEnt; Action: TCollectionNotification); override; + public + Constructor Create(bUpdate: Boolean = false; sServerName: String = ''; bIgrSpecial: Boolean = false); + + procedure UpdateShdFldList(bIgrSpecial: Boolean = false); + function ExistsSharedFolder(sPath: String): Boolean; + end; + +implementation + +uses + Tocsg.Safe, Tocsg.Strings, Tocsg.Path, Tocsg.Exception, Tocsg.Driver, + Tocsg.Convert, EM.nduWlanAPI, Tocsg.Trace, Tocsg.WMI, Tocsg.WinInfo, + System.Net.HttpClient, EM.nduWlanTypes, Winapi.AclAPI, Winapi.AccCtrl; + +resourcestring + RS_NetOther = '기타'; + RS_NetEthernet = '이더넷'; + RS_NetTokenring = '토큰링'; + RS_NetFDDI = '광'; + RS_NetLoop = '루프백 (localloop)'; + +var + _hIpHlpApi: THandle = 0; + _fnGetAdaptersInfo: TGetAdaptersInfo = nil; + _fnGetExtendedTcpTable: TGetExtendedTcpTable = nil; + _fnGetExtendedUdpTable: TGetExtendedUdpTable = nil; + _fnGetIpForwardTable: TGetIpForwardTable = nil; + _fnDeleteIpForwardEntry: TDeleteIpForwardEntry = nil; + + _hNetApi32: THandle = 0; + _fnNetShareEnum: TNetShareEnum = nil; + _fnNetApiBufferFree: TNetApiBufferFree = nil; + +function InitIpHlpApiModule: Boolean; +begin + if _hIpHlpApi = 0 then + begin + _hIpHlpApi := GetModuleHandle(DLL_IPHLPAPI); + + // 추가 22_0107 10:45:42 sunk + if _hIpHlpApi = 0 then + _hIpHlpApi := LoadLibrary(DLL_IPHLPAPI); + + if _hIpHlpApi <> 0 then + begin + @_fnGetAdaptersInfo := GetProcAddress(_hIpHlpApi, 'GetAdaptersInfo'); + @_fnGetExtendedTcpTable := GetProcAddress(_hIpHlpApi, 'GetExtendedTcpTable'); + @_fnGetExtendedUdpTable := GetProcAddress(_hIpHlpApi, 'GetExtendedUdpTable'); + + @_fnGetIpForwardTable := GetProcAddress(_hIpHlpApi, 'GetIpForwardTable'); + @_fnDeleteIpForwardEntry := GetProcAddress(_hIpHlpApi, 'DeleteIpForwardEntry'); + end; + end; + Result := _hIpHlpApi <> 0; +end; + +function InitNetApi32Module: Boolean; +begin + if _hNetApi32 = 0 then + begin + _hNetApi32 := GetModuleHandle(DLL_NETAPI32); + + if _hNetApi32 = 0 then + _hNetApi32 := LoadLibrary(DLL_NETAPI32); + + if _hNetApi32 <> 0 then + begin + @_fnNetShareEnum := GetProcAddress(_hNetApi32, 'NetShareEnum'); + @_fnNetApiBufferFree := GetProcAddress(_hNetApi32, 'NetApiBufferFree'); + end; + end; + Result := _hNetApi32 <> 0; +end; + +function GetAdaptersInfo(pAdapterInfo: PTIP_ADAPTER_INFO; pOutBufLen: PULONG): DWORD; +begin + if InitIpHlpApiModule and Assigned(_fnGetAdaptersInfo) then + Result := _fnGetAdaptersInfo(pAdapterInfo, pOutBufLen) + else + Result := ERROR_INVALID_FUNCTION; +end; + +function GetExtendedTcpTable(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; + lAf: ULONG; TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWORD; +begin + if InitIpHlpApiModule and Assigned(_fnGetExtendedTcpTable) then + Result := _fnGetExtendedTcpTable(pTcpTable, dwSize, bOrder, lAf, TableClass, Reserved) + else + Result := ERROR_INVALID_FUNCTION; +end; + +function GetExtendedUdpTable(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; + lAf: ULONG; TableClass: UDP_TABLE_CLASS; Reserved: ULONG): DWORD; +begin + if InitIpHlpApiModule and Assigned(_fnGetExtendedUdpTable) then + Result := _fnGetExtendedUdpTable(pTcpTable, dwSize, bOrder, lAf, TableClass, Reserved) + else + Result := ERROR_INVALID_FUNCTION; +end; + +function GetIpForwardTable(pIPForwardTable: PTMibIPForwardTable; pdwSize: PULONG; bOrder: BOOL): DWORD; +begin + if InitIpHlpApiModule and Assigned(_fnGetIpForwardTable) then + Result := _fnGetIpForwardTable(pIPForwardTable, pdwSize, bOrder) + else + Result := ERROR_INVALID_FUNCTION; +end; + +function DeleteIpForwardEntry(pEnt: PTMibIPForwardRow): DWORD; +begin + if InitIpHlpApiModule and Assigned(_fnDeleteIpForwardEntry) then + Result := _fnDeleteIpForwardEntry(pEnt) + else + Result := ERROR_INVALID_FUNCTION; +end; + +function NetShareEnum(ServerName: PWideChar; Level: DWORD; var BufPtr: Pointer; + PrefMaxLen: DWORD; var EntriesRead: DWORD; var TotalEntries: DWORD; + var ResumeHandle : DWORD): NET_API_STATUS; +begin + if InitNetApi32Module and Assigned(_fnNetShareEnum) then + Result := _fnNetShareEnum(ServerName, Level, BufPtr, PrefMaxLen, EntriesRead, + TotalEntries, ResumeHandle) + else + Result := ERROR_INVALID_FUNCTION; +end; + +function NetApiBufferFree(Buffer : Pointer): NET_API_STATUS; +begin + if InitNetApi32Module and Assigned(_fnNetApiBufferFree) then + Result := _fnNetApiBufferFree(Buffer) + else + Result := ERROR_INVALID_FUNCTION; +end; + +function GetCurrentHostName: String; +var + wVersionRequested : WORD; + wsaData: TWSAData; + sHostName: array[0..128] of AnsiChar; +begin + ZeroMemory(@sHostName, SizeOf(sHostName)); + wVersionRequested := MAKEWORD(1, 1); + WSAStartup(wVersionRequested, wsaData); + + GetHostName(@sHostName, 128); + Result := sHostName; + + WSACleanup; +end; + +function IPToDWORD(sIp: String) : Dword; +var + SL : TStringList; + i : integer; +begin + Result := 0; + try + SL := TStringList.Create; + {replace points with commas} + for i := 1 to Length(sIp) do + if sIp[i] = '.' then + sIp[i] := ','; + {put in stringlist to split into separate strings} + SL.CommaText := sIp; + Result := 0; + {make a value from the individual parts} + with SL do + for i := 0 to Count - 1 do + Result := (Result * $100) + StrToInt(Strings[i]); + except + on E: Exception do + begin + ETgException.TraceException(E, 'Fail .. IPToDWORD()'); + Result := 0; + end; + end; +end; + +function DWORDToIP(IPDWord: DWORD; bBig: Boolean = true) : String; +begin + if bBig then + begin + Result := Format('%d.%d.%d.%d', [(IPDWord div $1000000), + (IPDWord div $10000) mod $100, + (IPDWord div $100) mod $100, + IPDWord mod $100]); + end else begin + Result := Format('%d.%d.%d.%d', [IPDWord mod $100, + (IPDWord div $100) mod $100, + (IPDWord div $10000) mod $100, + (IPDWord div $1000000)]); + end; +end; + +function IncIP(sIp: String; nInc: Integer = 1): String; +begin + Result := DWORDToIP(IPToDWord(sIp) + nInc) +end; + +function IsValidIP(const sIp: String; bIgrIpNull: Boolean = true; bIncIPv6: Boolean = false): Boolean; +var + StrList: TStringList; + str: String; + nNum: Integer; +begin + Result := false; + if (sIp = '') or (bIgrIpNull and (sIp = IP_NULL)) then + exit; + + if Pos('.', sIp) > 0 then + begin + // ipv4 + Guard(StrList, TStringList.Create); + SplitString(sIp, '.', StrList); + + if StrList.Count <> 4 then + exit; + + for str in StrList do + begin + nNum := StrToIntDef(str, -1); + if (nNum < 0) or (nNum > 255) then + exit; + end; + end else begin + if not bIncIPv6 then + exit; + // ipv6 + Guard(StrList, TStringList.Create); + SplitString(sIp, ':', StrList); + + if StrList.Count <> 8 then + exit; + + // todo : 자세히 체크 + end; + Result := true; +end; + +function IsValidIPEx(const sIp: String): Boolean; +var + lstStr: TStringList; + str: AnsiString; + nNum: Integer; +begin + Result := false; + + if sIp = '*' then + begin + Result := true; + exit; + end; + + Guard(lstStr, TStringList.Create); + lstStr.CommaText := StringReplace(sIp, '.', ',', [rfReplaceAll]); + + if lstStr.Count > 4 then + exit; + + if (lstStr.Count = 1) and (lstStr[0] <> '*') then + exit; + + if (lstStr.Count < 4) and (lstStr[lstStr.Count-1] <> '*') then + exit; + + for str in lstStr do + begin + if str = '*' then + continue; + + nNum := StrToIntDef(str, -1); + if (nNum < 0) or (nNum > 255) then + exit; + end; + Result := true; +end; + +// 아이피 범위 문법인지 확인 22_1011 14:00:30 kku +// 10.0.0.1-127.0.0.1 +function IsValidIpRange(sIpRange: String): Boolean; +var + n: Integer; + sEnd: String; +begin + Result := false; + n := Pos('-', sIpRange); + if n > 0 then + begin + sEnd := Copy(sIpRange, n + 1, Length(sIpRange) - n); + Delete(sIpRange, n, Length(sIpRange) - n + 1); + Result := IsValidIP(sIpRange, false) and IsValidIP(sEnd) and + (IPToDWORD(sIpRange) < IPToDWORD(sEnd)); + end; +end; + +function IsIncludeIP(const sIpEx, sIp: String): Boolean; +var + lstSrcStr, + lstDecStr: TStringList; + i, nCheckCnt: Integer; +begin + Result := false; + + if (sIpEx = '*') or (sIp = '*') then + begin + Result := true; + exit; + end; + + Guard(lstSrcStr, TStringList.Create); + lstSrcStr.CommaText := StringReplace(sIpEx, '.', ',', [rfReplaceAll]); + Guard(lstDecStr, TStringList.Create); + lstDecStr.CommaText := StringReplace(sIp, '.', ',', [rfReplaceAll]); + + if lstSrcStr.Count < lstDecStr.Count then + nCheckCnt := lstSrcStr.Count + else + nCheckCnt := lstDecStr.Count; + + if (nCheckCnt > 0) and (nCheckCnt < 5) then + begin + for i := 0 to nCheckCnt - 1 do + begin + if (lstSrcStr[i] = '*') or (lstDecStr[i] = '*') then + continue; + + if lstSrcStr[i] <> lstDecStr[i] then + exit; + end; + Result := true; + end; +end; + +function ConvSsidToStr(aSrc: array of Byte; nSize: Integer): String; +var + i: Integer; +begin + if nSize = 0 then + begin + Result := '000000000000'; + exit; + end else + Result := ''; + + for i := 0 to nSize - 1 do + Result := Result + IntToHex(aSrc[i], 2); +end; + +function ConvMACAddrToStr(MacAddress: TMacAddress; nSize: Integer): String; +var + i: Integer; +begin + if nSize = 0 then + begin + Result := '000000000000'; + exit; + end else + Result := ''; + + for i := 1 to nSize do + Result := Result + IntToHex(MacAddress[i], 2); +end; + +function GetHostIP: String; +var + wVersionRequested : WORD; + wsaData: TWSAData; + sHostName: array[0..127] of AnsiChar; + pHEnt: PHostEnt; + p: PAnsiChar; + + sIp, + sPath: String; + ss: TStringStream; + IPList: TStringList; + i: Integer; +begin + try + Result := ''; + ZeroMemory(@sHostName, SizeOf(sHostName)); + wVersionRequested := MAKEWORD(1, 1); + WSAStartup(wVersionRequested, wsaData); + + try + GetHostName(@sHostName, 128); + pHEnt := GetHostByName(@sHostName); + + if pHEnt <> nil then + begin + p := inet_ntoa(PInAddr(pHEnt^.h_addr_list^)^); + Result := AnsiString(p); + end; + finally + WSACleanup; + end; + + // 가끔 127.0.0.1 로 잡히는 알수없는 상황이 발생한다... + // 그래서 아래처럼 보완 + if Result = '127.0.0.1' then + begin + Guard(IPList, TStringList.Create); + if GetIPAddrsToList(IPList) > 0 then + begin + for i := 0 to IPList.Count - 1 do + begin + if IPList[i] <> Result then + begin + Result := IPList[i]; + exit; + end; + end; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetHostIP()'); + end; +end; + +function GetHostIPsFromDomain(sDomain: AnsiString; sDm: AnsiString = ','): AnsiString; +var + wVersionRequested : WORD; + wsaData: TWSAData; + pHEnt: PHostEnt; + pNext: PPAnsiChar; + sIp: PAnsiChar; +begin + try + Result := ''; + wVersionRequested := MAKEWORD(1, 1); +// wVersionRequested := MAKEWORD(2, 2); + WSAStartup(wVersionRequested, wsaData); + + try + pHEnt := GetHostByName(PAnsiChar(sDomain)); + + if pHEnt <> nil then + begin + pNext := PPAnsiChar(pHEnt^.h_addr_list); + while pNext^ <> nil do + begin + sIp := inet_ntoa(PInAddr(pNext^)^); + SumStringA(Result, sIp, sDm); + Inc(pNext); + end; + end; + finally + WSACleanup; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetHostIPsFromDomain()'); + end; +end; + +function GetIPAddrsToList(lstIP: TStrings): Integer; +var + dwError, + dwBufLen: DWORD; + pAdapterInfo, + pAdapterWalk: PTIP_ADAPTER_INFO; + pIpAddr: PTIP_ADDR_STRING; + sIp: String; +begin + Result := 0; + + dwBufLen := SizeOf(TIP_ADAPTER_INFO); + pAdapterInfo := AllocMem(dwBufLen); + + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + try + // 오버플러우일 경우 메모리 다시 할당해줘서 시도해주자 09_0706 + if dwError = ERROR_BUFFER_OVERFLOW then + begin + FreeMem(pAdapterInfo, SizeOf(TIP_ADAPTER_INFO)); + pAdapterInfo := AllocMem(dwBufLen); + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + end; + + if dwError = NO_ERROR then + begin + pAdapterWalk := pAdapterInfo; + + while pAdapterWalk <> nil do + with pAdapterWalk^ do + begin + pIpAddr := @IPAddressList; + while pIpAddr <> nil do + begin + sIp := pIpAddr.IpAddress; + if sIp <> '0.0.0.0' then + lstIP.Add(sIp); + pIpAddr := pIpAddr.Next; + end; + pAdapterWalk := Next; + end; + end; + finally + FreeMem(pAdapterInfo, dwBufLen); + end; + Result := lstIP.Count; +end; + +function GetIPAddrsToListEx(lstIP: TStrings): Integer; +var + dwError, + dwBufLen: DWORD; + pAdapterInfo, + pAdapterWalk: PTIP_ADAPTER_INFO; + pIpAddr: PTIP_ADDR_STRING; + sIp: AnsiString; +begin + Result := 0; + lstIP.Clear; + + try + dwBufLen := SizeOf(TIP_ADAPTER_INFO); + pAdapterInfo := AllocMem(dwBufLen); + + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + try + // 오버플러우일 경우 메모리 다시 할당해줘서 시도해주자 09_0706 + if dwError = ERROR_BUFFER_OVERFLOW then + begin + FreeMem(pAdapterInfo, SizeOf(TIP_ADAPTER_INFO)); + pAdapterInfo := AllocMem(dwBufLen); + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + end; + + if dwError = NO_ERROR then + begin + pAdapterWalk := pAdapterInfo; + + while pAdapterWalk <> nil do + with pAdapterWalk^ do + begin + pIpAddr := @IPAddressList; + while pIpAddr <> nil do + begin + sIp := pIpAddr.IpAddress; + if (sIp <> '') and (sIp <> IP_NULL) then + begin + // VPN, 무선 식별 추가 19_1205 15:41:18 sunk +// case aType of + case Type_ of + MIB_IF_TYPE_PPP : sIp := 'VPN:' + sIp; // 23 : VPN + IF_TYPE_IEEE80211 : sIp := 'WLS:' + sIp; // 71 : Wireless + end; + lstIP.Add(sIp); + end; + pIpAddr := pIpAddr.Next; + end; + pAdapterWalk := Next; + end; + end; + finally + FreeMem(pAdapterInfo, dwBufLen); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetIPAddrsToListEx(), Step=%d'); + end; + Result := lstIP.Count; +end; + +function GetIPAddrsToCommaStr: String; +var + StrList: TStringList; +begin + Guard(StrList, TStringList.Create); + if GetIPAddrsToList(StrList) > 0 then + Result := StrList.CommaText + else + Result := ''; +end; + +function GetIPAddrsToCommaStrEx: String; +var + StrList: TStringList; +begin + Guard(StrList, TStringList.Create); + if GetIPAddrsToListEx(StrList) > 0 then + Result := StrList.CommaText + else + Result := ''; +end; + +function GetMACAddrToList(aMacList: TStrings): Boolean; +var + dwError, + dwBufLen: DWORD; + pAdapterInfo, + pAdapterWalk: PTIP_ADAPTER_INFO; +begin + Result := false; + aMacList.Clear; + + try + dwBufLen := SizeOf(TIP_ADAPTER_INFO); + pAdapterInfo := AllocMem(dwBufLen); + + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + try + // 오버플러우일 경우 메모리 다시 할당해줘서 시도해주자 09_0706 + if dwError = ERROR_BUFFER_OVERFLOW then + begin + FreeMem(pAdapterInfo, SizeOf(TIP_ADAPTER_INFO)); + pAdapterInfo := AllocMem(dwBufLen); + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + end; + + if dwError = NO_ERROR then + begin + pAdapterWalk := pAdapterInfo; + + while pAdapterWalk <> nil do + with pAdapterWalk^ do + begin + if AddressLength > 0 then + aMacList.Add(ConvMACAddrToStr(TMacAddress(Address), AddressLength)); + pAdapterWalk := Next; + end; + + Result := aMacList.Count > 0; + end; + finally + FreeMem(pAdapterInfo, dwBufLen); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetMACAddrToList()'); + end; +end; + +function GetMACAddrToCommaStr: String; +var + lstMac: TStringList; +begin + Result := ''; + Guard(lstMac, TStringList.Create); + if GetMACAddrToList(lstMac) then + Result := lstMac.CommaText; +end; + +function GetMACAddr: String; +var + UuidCreateFunc: function (var guid: TGUID): HResult; stdcall; + hLib: THandle; + GUID: TGUID; + WinVer: TOSVersionInfo; + i: Integer; +begin + Result := ''; + + try + WinVer.dwOSVersionInfoSize := SizeOf(WinVer); + GetVersionEx(WinVer); + + hLib := LoadLibrary('RPCRT4.DLL'); + try + if WinVer.dwMajorVersion >= 5 then {Windows 2000 } + @UuidCreateFunc := GetProcAddress(hLib, 'UuidCreateSequential') + else + @UuidCreateFunc := GetProcAddress(hLib, 'UuidCreate') ; + + UuidCreateFunc(GUID); + for i := 2 to 7 do + Result := Result + IntToHex(GUID.D4[i], 2); + finally + FreeLibrary(hLib); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetMACAddr()'); + end; +end; + +function GetMACAddrUsing: String; +var + dwError, + dwBufLen : DWORD; + pAdapterWalk, + pAdapterInfo : PTIP_ADAPTER_INFO; + sIp : AnsiString; +begin + Result := ''; + try + sIp := GetHostIP; + + if sIp = '' then + exit; + + dwBufLen := SizeOf(TIP_ADAPTER_INFO); + pAdapterInfo := AllocMem(dwBufLen); + + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + try + // 오버플러우일 경우 메모리 다시 할당해줘서 시도해주자 09_0706 + if dwError = ERROR_BUFFER_OVERFLOW then + begin + FreeMem(pAdapterInfo, SizeOf(TIP_ADAPTER_INFO)); + pAdapterInfo := AllocMem(dwBufLen); + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + end; + + if dwError = NO_ERROR then + begin + pAdapterWalk := pAdapterInfo; + while pAdapterWalk <> nil do + begin + with pAdapterWalk^ do + begin + if (AddressLength > 0) and + (AnsiString(IPAddressList.IpAddress.S) = sIp) then + begin + Result := ConvMACAddrToStr(TMacAddress(Address), AddressLength); + exit; + end; + pAdapterWalk := Next; + end + end; + end; + finally + FreeMem(pAdapterInfo, dwBufLen); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetMACAddrUsing()'); + end; +end; + +function ExtractIPPort(sSrcIPort: String; var sIp: String; var nPort: Integer): Boolean; +var + nPos: Integer; +begin + Result := false; + sIp := ''; + nPort := 0; + + nPos := Pos(':', sSrcIPort); + if nPos > 0 then + begin + sIp := sSrcIPort; + nPort := StrToIntDef(Copy(sIp, nPos + 1, Length(sIp) - nPos), 0); + Delete(sIp, nPos, Length(sIp) - nPos + 1); + Result := IsValidIP(sIp); + if not Result then + begin + sIp := ''; + nPort := 0; + end; + end; +end; + +function GetNetDrives(aDrives: TStrings): Integer; +const + NET_BUFSIZE = 16384; +var + hEnum: THandle; + dwResult, + dwEntries, + dwBufSize: DWORD; + pBuf, + pDriveRes: PNetResource; + i: Integer; +begin + Result := 0; + aDrives.Clear; + + hEnum := 0; + dwResult := WNetOpenEnum(RESOURCE_REMEMBERED, RESOURCETYPE_DISK, 0, nil, hEnum); + if dwResult = NO_ERROR then + begin + dwEntries := $FFFFFFFF; + dwBufSize := NET_BUFSIZE; + Guard(pBuf, AllocMem(dwBufSize)); + + try + repeat + dwResult := WNetEnumResource(hEnum, dwEntries, pBuf, dwBufSize); + case dwResult of + NO_ERROR : + begin + pDriveRes := pBuf; + for i := 0 to dwEntries - 1 do + try + if pDriveRes.lpLocalName <> '' then + begin + aDrives.Add(UpperCase(pDriveRes.lpLocalName)); + Inc(Result); + end; + finally + Inc(pDriveRes); + end; + end; + ERROR_NO_MORE_ITEMS : ; + else break; + end; + until dwResult = ERROR_NO_MORE_ITEMS; + finally + WNetCloseEnum(hEnum); + end; + end; +end; + +function NetDriveToRemoteAddr(sNDrv: String): String; +const + NET_BUFSIZE = 16384; +var + hEnum: THandle; + dwResult, + dwEntries, + dwBufSize: DWORD; + pBuf, + pDriveRes: PNetResource; + i: Integer; +begin + Result := ''; + if sNDrv = '' then + exit; + sNDrv := UpperCase(sNDrv); + + hEnum := 0; + dwResult := WNetOpenEnum(RESOURCE_REMEMBERED, RESOURCETYPE_DISK, 0, nil, hEnum); + if dwResult = NO_ERROR then + begin + dwEntries := $FFFFFFFF; + dwBufSize := NET_BUFSIZE; + Guard(pBuf, AllocMem(dwBufSize)); + + try + repeat + dwResult := WNetEnumResource(hEnum, dwEntries, pBuf, dwBufSize); + case dwResult of + NO_ERROR : + begin + pDriveRes := pBuf; + for i := 0 to dwEntries - 1 do + try + if (pDriveRes.lpLocalName <> '') and + (UpperCase(pDriveRes.lpLocalName)[1] = sNDrv[1]) then + begin + Result := pDriveRes.lpRemoteName; + exit; + end; + finally + Inc(pDriveRes); + end; + end; + ERROR_NO_MORE_ITEMS : ; + else break; + end; + until dwResult = ERROR_NO_MORE_ITEMS; + finally + WNetCloseEnum(hEnum); + end; + end; +end; + +function IsNetDrive(cLetter: Char): Boolean; +var + NetDriveList: TStringList; +begin + cLetter := UpCase(cLetter); + Guard(NetDriveList, TStringList.Create); + Result := GetNetDrives(NetDriveList) > 0; + if Result then + Result := NetDriveList.IndexOf(Format('%s:', [cLetter])) <> -1; +end; + +function GetNicEnable(sDesc: String): Boolean; +var + hDev: HDEVINFO; + sdd: TSPDevInfoData; + i: Integer; + dwBufSize, + dwStatus, dwProblem, + dwPropertyRegDataType: DWORD; + pBuf: Pointer; +begin + Result := false; + + try + hDev := SetupDiGetClassDevs(@GUID_DEVCLASS_NET, nil, 0, DIGCF_PRESENT); + if hDev = INVALID_HANDLE_VALUE then + exit; + + pBuf := nil; + try + ZeroMemory(@sdd, SizeOf(sdd)); + sdd.cbSize := SizeOf(sdd); + + i := 0; + while SetupDiEnumDeviceInfo(hDev, i, sdd) do + begin + dwBufSize := 0; + if pBuf <> nil then + begin + FreeMem(pBuf); + pBuf := nil; + end; + + while not SetupDiGetDeviceRegistryProperty(hDev, sdd, + SPDRP_DEVICEDESC, dwPropertyRegDataType, pBuf, dwBufSize, dwBufSize) do + begin + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + if pBuf <> nil then + FreeMem(pBuf); + pBuf := AllocMem(dwBufSize); + end else break; + end; + + if pBuf <> nil then + begin + if CompareText(sDesc, String(PChar(pBuf))) = 0 then + begin + dwStatus := 0; + dwProblem := 0; + + if CM_Get_DevNode_Status(dwStatus, dwProblem, sdd.DevInst, 0) = CR_SUCCESS then + Result := not (((dwStatus and DN_HAS_PROBLEM) = 0) and (dwProblem = CM_PROB_DISABLED)); + + exit; + end; + end; + + Inc(i); + end; + + finally + SetupDiDestroyDeviceInfoList(hDev); + if pBuf <> nil then + FreeMem(pBuf); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. SetNicEnable()'); + end; +end; + +function SetNicEnable(sDesc: String; bVal: Boolean): Integer; +var + hDev: HDEVINFO; + sdd: TSPDevInfoData; + i: Integer; + dwBufSize, + dwStatus, dwProblem, + dwPropertyRegDataType: DWORD; + pBuf: Pointer; +begin + Result := -1; + + try + hDev := SetupDiGetClassDevs(@GUID_DEVCLASS_NET, nil, 0, DIGCF_PRESENT); + if hDev = INVALID_HANDLE_VALUE then + exit; + + pBuf := nil; + try + ZeroMemory(@sdd, SizeOf(sdd)); + sdd.cbSize := SizeOf(sdd); + + i := 0; + while SetupDiEnumDeviceInfo(hDev, i, sdd) do + begin + dwBufSize := 0; + if pBuf <> nil then + begin + FreeMem(pBuf); + pBuf := nil; + end; + + while not SetupDiGetDeviceRegistryProperty(hDev, sdd, + SPDRP_FRIENDLYNAME, dwPropertyRegDataType, pBuf, dwBufSize, dwBufSize) do + begin + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + if pBuf <> nil then + FreeMem(pBuf); + pBuf := AllocMem(dwBufSize); + end else break; + end; + + if pBuf <> nil then + begin + if CompareText(sDesc, String(PChar(pBuf))) = 0 then + begin + dwStatus := 0; + dwProblem := 0; + + if CM_Get_DevNode_Status(dwStatus, dwProblem, sdd.DevInst, 0) = CR_SUCCESS then + begin +// var bDisabled: Boolean := (((dwStatus and DN_HAS_PROBLEM) = 0) and (dwProblem = CM_PROB_DISABLED)); +// if bVal = bDisabled then + begin + var PropChangeParams: TSPPropChangeParams; + ZeroMemory(@PropChangeParams, SizeOf(PropChangeParams)); + PropChangeParams.ClassInstallHeader.cbSize := SizeOf(TSPClassInstallHeader); + PropChangeParams.ClassInstallHeader.InstallFunction := DIF_PROPERTYCHANGE; + PropChangeParams.Scope := DICS_FLAG_GLOBAL; + PropChangeParams.StateChange := BooleanToInt(bVal, DICS_ENABLE, DICS_DISABLE); + + if SetupDiSetClassInstallParams(hDev, @sdd, PSPClassInstallHeader(@PropChangeParams), SizeOf(PropChangeParams)) then + begin + // 64bit OS 에서는 64bit 프로그램 에서만 실행 가능하다 22_0621 13:59:21 kku + if SetupDiCallClassInstaller(DIF_PROPERTYCHANGE, hDev, @sdd) then + Result := i; + end; + end; + end; + + exit; + end; + end; + + Inc(i); + end; + + finally + SetupDiDestroyDeviceInfoList(hDev); + if pBuf <> nil then + FreeMem(pBuf); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. SetNicEnable()'); + end; +end; + +function SetNicEnableByIndex(nIdx: Integer; bVal: Boolean): Boolean; +var + hDev: HDEVINFO; + sdd: TSPDevInfoData; + dwBufSize, + dwStatus, dwProblem, + dwPropertyRegDataType: DWORD; + pBuf: Pointer; +begin + Result := false; + + try + hDev := SetupDiGetClassDevs(@GUID_DEVCLASS_NET, nil, 0, DIGCF_PRESENT); + if hDev = INVALID_HANDLE_VALUE then + exit; + + pBuf := nil; + try + ZeroMemory(@sdd, SizeOf(sdd)); + sdd.cbSize := SizeOf(sdd); + + if SetupDiEnumDeviceInfo(hDev, nIdx, sdd) then + begin + dwBufSize := 0; + if pBuf <> nil then + begin + FreeMem(pBuf); + pBuf := nil; + end; + + while not SetupDiGetDeviceRegistryProperty(hDev, sdd, + SPDRP_FRIENDLYNAME, dwPropertyRegDataType, pBuf, dwBufSize, dwBufSize) do + begin + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + if pBuf <> nil then + FreeMem(pBuf); + pBuf := AllocMem(dwBufSize); + end else break; + end; + + if pBuf <> nil then + begin + dwStatus := 0; + dwProblem := 0; + + if CM_Get_DevNode_Status(dwStatus, dwProblem, sdd.DevInst, 0) = CR_SUCCESS then + begin + var PropChangeParams: TSPPropChangeParams; + ZeroMemory(@PropChangeParams, SizeOf(PropChangeParams)); + PropChangeParams.ClassInstallHeader.cbSize := SizeOf(TSPClassInstallHeader); + PropChangeParams.ClassInstallHeader.InstallFunction := DIF_PROPERTYCHANGE; + PropChangeParams.Scope := DICS_FLAG_GLOBAL; + PropChangeParams.StateChange := BooleanToInt(bVal, DICS_ENABLE, DICS_DISABLE); + + if SetupDiSetClassInstallParams(hDev, @sdd, PSPClassInstallHeader(@PropChangeParams), SizeOf(PropChangeParams)) then + begin + // 64bit OS 에서는 64bit 프로그램 에서만 실행 가능하다 22_0621 13:59:21 kku + Result := SetupDiCallClassInstaller(DIF_PROPERTYCHANGE, hDev, @sdd); + end; + end; + end; + end; + finally + SetupDiDestroyDeviceInfoList(hDev); + if pBuf <> nil then + FreeMem(pBuf); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. SetNicEnable()'); + end; +end; + +{ TNetAdapterInfo } + +Constructor TNetAdapterInfo.Create; +begin + Inherited Create; + AdapterList_ := TNetAdapterEntList.Create; + AdapterList_.OnNotify := OnAdapterNotify; + UpdateNetAdapterInfo; +end; + +Destructor TNetAdapterInfo.Destroy; +begin + FreeAndNil(AdapterList_); + Inherited; +end; + +procedure TNetAdapterInfo.OnAdapterNotify(Sender: TObject; const Item: PNetAdapterEnt; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +function TNetAdapterInfo.GetByIndex(nIndex: Integer): PNetAdapterEnt; +begin + if (nIndex > -1) and (nIndex < AdapterList_.Count) then + Result := AdapterList_[nIndex] + else + Result := nil; +end; + +procedure TNetAdapterInfo.UpdateNetAdapterInfo; + + function GetIpAddrs(pIpAddr: PTIP_ADDR_STRING): String; + begin + Result := ''; + while pIpAddr <> nil do + begin + SumString(Result, pIpAddr.IpAddress, ','); + pIpAddr := pIpAddr.Next; + end; + end; + +var + dwError, + dwBufLen: DWORD; + pAdapterInfo, + pAdapterWalk: PTIP_ADAPTER_INFO; + pEnt: PNetAdapterEnt; +begin + AdapterList_.Clear; + + dwBufLen := SizeOf(TIP_ADAPTER_INFO); + pAdapterInfo := AllocMem(dwBufLen); + + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + try + // 오버플러우일 경우 메모리 다시 할당해줘서 시도해주자 09_0706 + if dwError = ERROR_BUFFER_OVERFLOW then + begin + FreeMem(pAdapterInfo, SizeOf(TIP_ADAPTER_INFO)); + pAdapterInfo := AllocMem(dwBufLen); + dwError := GetAdaptersInfo(pAdapterInfo, @dwBufLen); + end; + + if dwError = NO_ERROR then + begin + pAdapterWalk := pAdapterInfo; + + while pAdapterWalk <> nil do + begin + New(pEnt); + ZeroMemory(pEnt, SizeOf(TNetAdapterEnt)); + with pAdapterWalk^ do + begin + pEnt.sName := AdapterName; + pEnt.sDesc := Description; + if AddressLength > 0 then + pEnt.sMacAddr := UpperCase(ConvMACAddrToStr(TMacAddress(Address), AddressLength)); +// pEnt.sCurIpAddr := GetIpAddrs(CurrentIPAddress); + pEnt.sIpAddrs := GetIpAddrs(@IPAddressList); + pEnt.sGatewayIps := GetIpAddrs(@GatewayList); + pEnt.sDHCPServer := GetIpAddrs(@DHCPServer); + pEnt.sPriWINSServer := GetIpAddrs(@PrimaryWINSServer); + pEnt.sSecWINSServer := GetIpAddrs(@SecondaryWINSServer); + pEnt.bDHCP := DHCPEnabled <> 0; + pEnt.bHaveWINS := HaveWINS; + pEnt.dwComboIdx := ComboIndex; + pEnt.dwIndex := Index; +// pEnt.dwType := aType; + pEnt.dwType := Type_; + + pAdapterWalk := Next; + end; + AdapterList_.Add(pEnt); + end; + end; + finally + FreeMem(pAdapterInfo, dwBufLen); + end; +end; + +function TNetAdapterInfo.Count: Integer; +begin + Result := AdapterList_.Count; +end; + +{ TWlanInfo } + +Constructor TWlanInfo.Create; +begin + Inherited Create; + WLanEntList_ := TWLanEntList.Create; + WLanEntList_.OnNotify := OnWlanEntNotify; + UpdateWlanInfo; +end; + +Destructor TWlanInfo.Destroy; +begin + FreeAndNil(WLanEntList_); + Inherited; +end; + +procedure TWlanInfo.OnWlanEntNotify(Sender: TObject; const Item: PWLanEnt; + Action: TCollectionNotification); +begin + if Action = cnRemoved then + Dispose(Item); +end; + +procedure TWlanInfo.UpdateWlanInfo; +const + WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES = $00000001; +var + hClient: THandle; + dwVersion, dwResult: DWORD; + pInterface: Pndu_WLAN_INTERFACE_INFO_LIST; + i, j, c: Integer; + pAvNetList: Pndu_WLAN_AVAILABLE_NETWORK_LIST; + pBssList: Pndu_WLAN_BSS_LIST; +// pInterfaceGuid: PGUID; + InfcInfo: Tndu_WLAN_INTERFACE_INFO; + sBssid: String; +// sInterface: String; + pInfo: PWLanEnt; +begin + try + WLanEntList_.Clear; + hClient := 0; + pInterface := nil; + dwResult := WlanOpenHandle(NDU_WLAN_API_VERSION, nil, @dwVersion, @hClient); + try + if dwResult <> ERROR_SUCCESS then + begin + _Trace(Format('Error Open Client %d', [dwResult])); + exit; + end; + + dwResult := WlanEnumInterfaces(hClient, nil, @pInterface); + if dwResult <> ERROR_SUCCESS then + begin + _Trace('Error Enum Interfaces ' + IntToStr(dwResult)); + Exit; + end; + + if pInterface.dwNumberOfItems = 0 then + exit; + + for i := 0 to pInterface.dwNumberOfItems - 1 do + begin + InfcInfo := pInterface.InterfaceInfo[i]; + // sInterface := pInterface.InterfaceInfo[i].strInterfaceDescription; + // pInterfaceGuid := @pInterface.InterfaceInfo[pInterface.dwIndex].InterfaceGuid; + + dwResult := WlanGetAvailableNetworkList(hClient, @InfcInfo.InterfaceGuid, // pInterfaceGuid, + WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES, nil, pAvNetList); + if dwResult <> ERROR_SUCCESS then + begin + _Trace('Error WlanGetAvailableNetworkList, Idx=%d, Error=%d', [i, dwResult], 1); + continue; + end; + + if pAvNetList.dwNumberOfItems = 0 then + continue; + + for j := 0 to pAvNetList.dwNumberOfItems - 1 do + Begin + if j > High(pAvNetList.Network) then + break; + + New(pInfo); + pInfo.sName := InfcInfo.strInterfaceDescription; // sInterface; + pInfo.sProfile := pAvNetList.Network[j].strProfileName; + pInfo.sBssid := ''; + pInfo.nQuality := pAvNetList.Network[j].wlanSignalQuality; + pInfo.dwAlgo1 := pAvNetList.Network[j].dot11DefaultAuthAlgorithm; + pInfo.dwAlgo2 := pAvNetList.Network[j].dot11DefaultCipherAlgorithm; + pInfo.bSecurety := pAvNetList.Network[j].bSecurityEnabled; + pInfo.InterfaceGuid := InfcInfo.InterfaceGuid; // pInterfaceGuid^; + + // 아래 bssid 가져오기 잘되는데 일단 막아놓음 25_0715 15:17:45 kku + // cmd : netsh wlan show interfaces + (* + pBssList := nil; + if WlanGetNetworkBssList(hClient, @pInterface.InterfaceInfo[i].InterfaceGuid, + {@pAvNetList.Network[j].dot11Ssid}nil, dot11_BSS_type_infrastructure, + true, nil, @pBssList) = ERROR_SUCCESS then + begin + if pBssList.dwNumberOfItems > 0 then + begin + for c := 0 to High(pBssList.wlanBssEntries) do + begin + with pBssList.wlanBssEntries[c] do + sBssid := Format('%.2x:%.2x:%.2x:%.2x:%.2x:%.2x', + [dot11Bssid[0], dot11Bssid[1], dot11Bssid[2], + dot11Bssid[3], dot11Bssid[4], dot11Bssid[5]]); + + SumString(pInfo.sBssid, sBssid, ','); + end; + end; + + if pBssList <> nil then + WlanFreeMemory(pBssList); + end; + *) + + WLanEntList_.Add(pInfo); + End; + end; + finally + if pInterface <> nil then + WlanFreeMemory(pInterface); + if hClient <> 0 then + WlanCloseHandle(hClient, nil); + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Error .. UpdateWlanInfo()'); + end; +end; + +function TWlanInfo.GetByIndex(nIndex: Integer): PWLanEnt; +begin + if (nIndex > -1) and (nIndex < WLanEntList_.Count) then + Result := WLanEntList_[nIndex] + else + Result := nil; +end; + +function TWlanInfo.Count: Integer; +begin + Result := WLanEntList_.Count; +end; + +function TWlanInfo.GetWlanEntByName(sName: String): PWLanEnt; +var + i: Integer; +begin + Result := nil; + try + for i := 0 to WLanEntList_.Count - 1 do + if CompareText(WLanEntList_[i].sName, sName) = 0 then + begin + Result := WLanEntList_[i]; + exit; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Error .. GetWlanEntByName()'); + end; +end; + +{ TTcpTableInfo } + +Constructor TTcpTableInfo.Create; +begin + Inherited Create; + TcpEnts_ := TTcpInfoEntList.Create; + TcpEnts_.OnNotify := OnTcpInfoEntNotify; +end; + +Destructor TTcpTableInfo.Destroy; +begin + FreeAndNil(TcpEnts_); + Inherited; +end; + +procedure TTcpTableInfo.OnTcpInfoEntNotify(Sender: TObject; const + Item: PTcpInfoEnt; Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +procedure TTcpTableInfo.UpdateTcpTableInfo; +var + dwResult, + dtTableSize: DWORD; + i: Integer; + IpAddress: in_addr; + pTcpTable: PMIB_TCPTABLE_OWNER_PID; + pEnt: PTcpInfoEnt; +begin + TcpEnts_.Clear; + + dtTableSize := 0; + dwResult := GetExtendedTcpTable(nil, @dtTableSize, False, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0); + if dwResult <> ERROR_INSUFFICIENT_BUFFER then + exit; + + Guard(pTcpTable, AllocMem(dtTableSize)); + if GetExtendedTcpTable(pTcpTable, @dtTableSize, true, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0) = NO_ERROR then + for i := 0 to pTcpTable.dwNumEntries - 1 do + begin + New(pEnt); + + IpAddress.s_addr := pTcpTable.Table[i].dwLocalAddr; + pEnt.sLocalIpAddr := string(inet_ntoa(IpAddress)); + + IpAddress.s_addr := pTcpTable.Table[i].dwRemoteAddr; + pEnt.sRemoteIpAddr := string(inet_ntoa(IpAddress)); + + pEnt.nLocalPort := ntohs(pTcpTable.Table[i].dwLocalPort); + pEnt.nRemotePort := ntohs(pTcpTable.Table[i].dwRemotePort); + pEnt.dwPid := pTcpTable.Table[i].dwOwningPid; + pEnt.dwStatus := pTcpTable.Table[i].dwState; + + TcpEnts_.Add(pEnt); + end; +end; + +function TTcpTableInfo.Count: Integer; +begin + Result := TcpEnts_.Count; +end; + +procedure TTcpTableInfo.Delete(nIndex: Integer); +begin + if (nIndex > -1) and (nIndex < TcpEnts_.Count) then + TcpEnts_.Delete(nIndex); +end; + +function TTcpTableInfo.GetByIndex(nIndex: Integer): PTcpInfoEnt; +begin + if (nIndex > -1) and (nIndex < TcpEnts_.Count) then + Result := TcpEnts_[nIndex] + else + Result := nil; +end; + +{ TUdpTableInfo } + +Constructor TUdpTableInfo.Create; +begin + Inherited Create; + UdpEnts_ := TUdpInfoEntList.Create; + UdpEnts_.OnNotify := OnUdpInfoEntNotify; +end; + +Destructor TUdpTableInfo.Destroy; +begin + FreeAndNil(UdpEnts_); + Inherited; +end; + +procedure TUdpTableInfo.OnUdpInfoEntNotify(Sender: TObject; const Item: PUdpInfoEnt; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +procedure TUdpTableInfo.UpdateUdpTableInfo; +var + dwResult, + dtTableSize: DWORD; + i: Integer; + IpAddress: in_addr; + pUdpTable: PMIB_UDPTABLE_OWNER_PID; + pEnt: PUdpInfoEnt; +begin + UdpEnts_.Clear; + + dtTableSize := 0; + dwResult := GetExtendedUdpTable(nil, @dtTableSize, False, AF_INET, UDP_TABLE_OWNER_PID, 0); + if dwResult <> ERROR_INSUFFICIENT_BUFFER then + exit; + + Guard(pUdpTable, AllocMem(dtTableSize)); + if GetExtendedUdpTable(pUdpTable, @dtTableSize, true, AF_INET, UDP_TABLE_OWNER_PID, 0) = NO_ERROR then + for i := 0 to pUdpTable.dwNumEntries - 1 do + begin + New(pEnt); + + IpAddress.s_addr := pUdpTable.Table[i].dwLocalAddr; + pEnt.sLocalIpAddr := string(inet_ntoa(IpAddress)); + pEnt.nLocalPort := ntohs(pUdpTable.Table[i].dwLocalPort); + pEnt.dwPid := pUdpTable.Table[i].dwOwningPid; + + UdpEnts_.Add(pEnt); + end; +end; + +function TUdpTableInfo.Count: Integer; +begin + Result := UdpEnts_.Count; +end; + +procedure TUdpTableInfo.Delete(nIndex: Integer); +begin + if (nIndex > -1) and (nIndex < UdpEnts_.Count) then + UdpEnts_.Delete(nIndex); +end; + +function TUdpTableInfo.GetByIndex(nIndex: Integer): PUdpInfoEnt; +begin + if (nIndex > -1) and (nIndex < UdpEnts_.Count) then + Result := UdpEnts_[nIndex] + else + Result := nil; +end; + +{ TSharedFolder } + +Constructor TSharedFolder.Create(bUpdate: Boolean = false; sServerName: String = ''; bIgrSpecial: Boolean = false); +begin + Inherited Create; + + sSvrName_ := sServerName; + if sSvrName_ = '' then + sSvrName_ := GetComName; + if bUpdate then + UpdateShdFldList(bIgrSpecial); +end; + +procedure TSharedFolder.Notify(const Item: PShdFldEnt; Action: TCollectionNotification); +begin + if Action = cnRemoved then + Dispose(Item); +end; + +procedure TSharedFolder.UpdateShdFldList(bIgrSpecial: Boolean = false); +const + MAX_PREFERRED_LENGTH = -1; + NERR_SUCCESS = 0; +var + EntriesRead, + TotalEntries, + ResHandle: DWORD; + ShareInfo2, P: PSHARE_INFO_2; + dwStatus: NET_API_STATUS; + i: Integer; + pEnt: PShdFldEnt; +begin + try + Clear; + { + // WMI 사용하면 메모리 릭이 발생해서 뺌. 22_1221 15:18:10 kku + if WMI_GetInformationEx('', WMI_ROOT_OBJECT, '', '', 'Win32_Share', wmiResults, nVerCnt) then + begin + for i := 0 to nVerCnt - 1 do + begin + New(pEnt); + pEnt.sName := WMI_GetPropertyData(wmiResults, 'Name', i); + pEnt.sPath := WMI_GetPropertyData(wmiResults, 'Path', i); + Add(pEnt); + end; + end; + } + ResHandle := 0; + dwStatus := NetShareEnum(PChar(sSvrName_), 2, Pointer(ShareInfo2), + DWORD(MAX_PREFERRED_LENGTH), + EntriesRead, TotalEntries, ResHandle); + try + if dwStatus <> NERR_SUCCESS then + exit; + + P := ShareInfo2; + for i := 0 to TotalEntries - 1 do + begin + if bIgrSpecial then + begin + if (CompareText(P.shi2_netname, 'ADMIN$') = 0) or + (CompareText(P.shi2_netname, 'IPC$') = 0) or + (CompareText(P.shi2_netname, 'PRINT$') = 0) then + begin + Inc(P); + continue; + end; + end; + + New(pEnt); + pEnt.sName := P.shi2_netname; + pEnt.sPath := P.shi2_path; + Add(pEnt); + Inc(P); + end; + finally + NetApiBufferFree(ShareInfo2); + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. UpdateShdFldList()'); + end; +end; + +function TSharedFolder.ExistsSharedFolder(sPath: String): Boolean; +var + i: Integer; +begin + Result := false; + for i := 0 to Count - 1 do + begin + if CompareText(Items[i].sPath, sPath) = 0 then + begin + Result := true; + exit; + end; + end; +end; + +{ TRouteEntList } + +procedure TRouteEntList.Notify(const Item: PRouteEnt; Action: TCollectionNotification); +begin + if Action = cnRemoved then + Dispose(Item); +end; + +function TRouteEntList.GetEntByDestIp(sDestIp: String): PRouteEnt; +var + i: Integer; +begin + Result := nil; + try + for i := 0 to Count - 1 do + begin + if Items[i].sDestIp = sDestIp then + begin + Result := Items[i]; + exit; + end; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. GetEntByDestIp()'); + end; +end; + +{ Functions } + +function GetNetAdapterTypeToStr(dwType: DWORD): String; +begin + case dwType of + MIB_IF_TYPE_OTHER : Result := RS_NetOther; + MIB_IF_TYPE_ETHERNET : Result := RS_NetEthernet; + IF_TYPE_ISO88025_TOKENRING : Result := RS_NetTokenring; + MIB_IF_TYPE_FDDI : Result := RS_NetFDDI; + MIB_IF_TYPE_PPP : Result := 'PPP'; + MIB_IF_TYPE_LOOPBACK : Result := RS_NetLoop; + MIB_IF_TYPE_SLIP : Result := 'SLIP'; + IF_TYPE_IEEE80211 : Result := 'IEEE 802.11 (Wireless)'; + else Result := Format('Unknown (%d)', [dwType]); + end; +end; + +function IsConnectedWIFI(aInterfaceGuid: TGUID): Boolean; +var + hClient: THandle; + dwVersion, + dwResult, dwSize: DWORD; + pConnInfo: Pndu_WLAN_CONNECTION_ATTRIBUTES; +begin + Result := false; + + try + hClient := 0; + pConnInfo := nil; + dwResult := WlanOpenHandle(NDU_WLAN_API_VERSION, nil, @dwVersion, @hClient); + try + if dwResult <> ERROR_SUCCESS then + begin + TTgTrace.T(Format('Error Open Client %d', [dwResult])); + exit; + end; + + dwSize := 0; + dwResult := WlanQueryInterface( + hClient, + @aInterfaceGuid, + wlan_intf_opcode_current_connection, + nil, + @dwSize, + @pConnInfo, + nil + ); + + if dwResult = ERROR_SUCCESS then + Result := pConnInfo.isState = wlan_interface_state_connected; + finally + if pConnInfo <> nil then + WlanFreeMemory(pConnInfo); + if hClient <> 0 then + WlanCloseHandle(hClient, nil); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsConnectedWIFI()'); + end; +end; + +function DisconnectWIFI(aInterfaceGuid: TGUID): Boolean; +var + hClient: THandle; + dwVersion, dwResult: DWORD; +begin + Result := false; + + try + hClient := 0; + dwResult := WlanOpenHandle(NDU_WLAN_API_VERSION, nil, @dwVersion, @hClient); + try + if dwResult <> ERROR_SUCCESS then + begin + TTgTrace.T(Format('Error Open Client %d', [dwResult])); + exit; + end; + + Result := WlanDisconnect(hClient, @aInterfaceGuid, nil) = ERROR_SUCCESS; + finally + if hClient <> 0 then + WlanCloseHandle(hClient, nil); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. DisconnectWIFI()'); + end; +end; + +function GetRouteTables(aList: TRouteEntList): Integer; +var + pTable: PTMibIPForwardTable; + dwSize: DWORD; + i: Integer; + pRow: PTMibIPForwardRow; + pEnt: PRouteEnt; +begin + Result := 0; + try + aList.Clear; + + pTable := nil; + dwSize := 0; + + if GetIpForwardTable(pTable, @dwSize, FALSE) <> ERROR_INSUFFICIENT_BUFFER then + exit; + + pTable := AllocMem(dwSize); + try + if GetIpForwardTable(pTable, @dwSize, FALSE) <> NO_ERROR then + exit; + + if pTable.dwNumEntries = 0 then + exit; + + for i := 0 to pTable.dwNumEntries - 1 do + begin + pRow := PTMibIPForwardRow(LONGLONG(@pTable.Table[0]) + (i * SizeOf(TMibIPForwardRow))); + New(pEnt); + ZeroMemory(pEnt, SizeOf(TRouteEnt)); + pEnt.sDestIp := DWORDToIP(pRow.dwForwardDest, false); + pEnt.Info := pRow^; + aList.Add(pEnt); + end; + + Result := aList.Count; + finally + FreeMem(pTable); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetRouteTables()'); + end; +end; + +function GetPublicIP: string; +var + HttpClient: THTTPClient; + Response: IHTTPResponse; +begin + Result := ''; + try + Guard(HttpClient, THTTPClient.Create); + Response := HttpClient.Get('http://api.ipify.org'); + Result := Response.ContentAsString(); + + if (Result <> '') and not IsValidIP(Result) then + Result := ''; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetPublicIP()'); + end; +end; + +function RemoveEveryoneFromShare(const sShareName: string): Boolean; +const + ACCESS_ALLOWED_ACE_TYPE = 0; + ACCESS_DENIED_ACE_TYPE = 1; + SYSTEM_AUDIT_ACE_TYPE = 2; + SYSTEM_ALARM_ACE_TYPE = 3; + + // ACL Revision + ACL_REVISION = 2; + ACL_REVISION_DS = 4; + +type + PACE_HEADER = ^ACE_HEADER; + ACE_HEADER = packed record + AceType: Byte; + AceFlags: Byte; + AceSize: Word; + end; + + PACCESS_ALLOWED_ACE = ^ACCESS_ALLOWED_ACE; + ACCESS_ALLOWED_ACE = packed record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; // 실제 SID가 여기부터 시작 + end; + + PACCESS_DENIED_ACE = ^ACCESS_DENIED_ACE; + ACCESS_DENIED_ACE = packed record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + end; + +var + pSD: PSECURITY_DESCRIPTOR; + pDACL: PACL; + pNewDACL: PACL; + eaCount, i: DWORD; + aceHeader: PACE_HEADER; + sidEveryone: PSID; + dwAceSize: DWORD; + pAceSID: PSID; + aceAccessMask: ACCESS_MASK; + dwRes: DWORD; +begin + Result := false; + try + pSD := nil; + + // 1. 공유의 보안 정보 가져오기 + dwRes := GetNamedSecurityInfo( + PChar('\\localhost\' + sShareName), + SE_LMSHARE, + DACL_SECURITY_INFORMATION, + nil, nil, + @pDACL, + nil, + pSD + ); + + if dwRes <> ERROR_SUCCESS then + begin + TTgTrace.T('GetNamedSecurityInfo failed: %d', [dwRes]); + exit; + end; + + try + // 2. Everyone SID 생성 + if not ConvertStringSidToSid('S-1-1-0', sidEveryone) then + begin + TTgTrace.T('Failed to create Everyone SID'); + exit; + end; + + // 3. 새 DACL 생성 (기존 DACL 크기 그대로 확보) + GetAclInformation(pDACL, @eaCount, SizeOf(eaCount), AclSizeInformation); + pNewDACL := AllocMem(1024); // 충분한 크기 확보 + InitializeAcl(pNewDACL^, 1024, ACL_REVISION); + + // 4. 기존 ACE들 순회하면서 Everyone 아닌 것만 복사 + i := 0; + while GetAce(pDACL, i, Pointer(aceHeader)) do + begin + Inc(i); + // ACE SID 가져오기 + case aceHeader.AceType of + ACCESS_ALLOWED_ACE_TYPE: + begin + aceAccessMask := PACCESS_ALLOWED_ACE(aceHeader)^.Mask; + pAceSID := @PACCESS_ALLOWED_ACE(aceHeader)^.SidStart; + end; + ACCESS_DENIED_ACE_TYPE: + begin + aceAccessMask := PACCESS_DENIED_ACE(aceHeader)^.Mask; + pAceSID := @PACCESS_DENIED_ACE(aceHeader)^.SidStart; + end; + else + Continue; // 다른 ACE 타입은 패스 + end; + + // Everyone과 같으면 건너뜀 + if EqualSid(sidEveryone, pAceSID) then + Continue; + + // 새 DACL에 추가 + AddAccessAllowedAceEx( + pNewDACL^, + ACL_REVISION, + 0, + aceAccessMask, + pAceSID + ); + end; + + // 5. 수정된 DACL을 다시 설정 + dwRes := SetNamedSecurityInfo( + PChar('\\localhost\' + sShareName), + SE_LMSHARE, + DACL_SECURITY_INFORMATION, + nil, nil, + pNewDACL, + nil + ); + + Result := dwRes = ERROR_SUCCESS; + finally + if pSD <> nil then + LocalFree(HLOCAL(pSD)); + if sidEveryone <> nil then + LocalFree(HLOCAL(sidEveryone)); + if pNewDACL <> nil then + FreeMem(pNewDACL); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. RemoveEveryoneFromShare()'); + end; +end; + +end. + diff --git a/Tocsg.Lib/VCL/Tocsg.Notification.pas b/Tocsg.Lib/VCL/Tocsg.Notification.pas new file mode 100644 index 00000000..99d1dd5a --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Notification.pas @@ -0,0 +1,52 @@ +{*******************************************************} +{ } +{ Tocsg.Notification } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.Notification; + +interface + +uses + System.SysUtils, Winapi.Windows; + +procedure ShowNotification(sTitle, sText: String); + +implementation + +uses + System.Notification, Vcl.Forms; + +procedure ShowNotification(sTitle, sText: String); +var + NotificationCenter: TNotificationCenter; + Notification: TNotification; +// Channel: TChannel; +begin + NotificationCenter := TNotificationCenter.Create(nil); + Notification := NotificationCenter.CreateNotification; + if Notification <> nil then + begin + // Channel := NotificationCenter.CreateChannel; + try + Notification.Name := Format('Notification-%d', [GetTickCount]); + Notification.Title := sTitle; + Notification.AlertBody := sText; + NotificationCenter.PresentNotification(Notification); + + // Channel.Id := Format('Channel-%d', [GetTickCount]); + // Channel.Title := sTitle; + // Channel.Importance := TImportance.High; + // NotificationCenter.CreateOrUpdateChannel(Channel); + finally + Notification.Free; + // Channel.Free; + NotificationCenter.Free; + end; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.OLE.Stg.pas b/Tocsg.Lib/VCL/Tocsg.OLE.Stg.pas new file mode 100644 index 00000000..fb879bb9 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.OLE.Stg.pas @@ -0,0 +1,202 @@ +unit Tocsg.OLE.Stg; + +interface + +uses + System.Classes, Winapi.ActiveX, System.SysUtils; + +function IsStgStorageFile(const sPath: string): Boolean; +function StgStorageFileOpen(sPath: WideString; out stOpen: IStorage; nMode: Integer = STGM_READ or STGM_SHARE_EXCLUSIVE): Boolean; +function StgOpenSubStorage(stOpen: IStorage; const SubStgName: WideString; nMode: Integer; out stg: IStorage): Boolean; +function StgGetStream(stOpen: IStorage; sName: WideString; ms: TMemoryStream): Boolean; +function StgGetStreamToText(stOpen: IStorage; sName: WideString; var sText: WideString): Boolean; +function StgGetEnumElements(stOpen: IStorage; out enum: IEnumStatStg): Boolean; +function StgNextStatStg(enum: IEnumStatStg; out elStat: TStatStg): Boolean; +function StgGetStatStg(enum: IEnumStatStg; const sName: WideString; out elStat: TStatStg; bReset: Boolean = true): Boolean; +function StgGetStatStgLike(enum: IEnumStatStg; const sName: WideString; out elStat: TStatStg; bReset: Boolean = true): Boolean; +function StgGetStatStgList(enum: IEnumStatStg; const sName: WideString; aList: TStringList; bReset: Boolean = true): Boolean; + +implementation + +uses + Winapi.Windows, Tocsg.Exception; + +function IsStgStorageFile(const sPath: string): Boolean; +var + pvStg: IStorage; +begin + Result := StgStorageFileOpen(PChar(sPath), pvStg); + pvStg := nil; +end; + +function StgStorageFileOpen(sPath: WideString; out stOpen: IStorage; nMode: Integer = STGM_READ or STGM_SHARE_EXCLUSIVE): Boolean; +begin + try + Result := Winapi.ActiveX.StgOpenStorage(PWideChar(sPath), nil, nMode, nil, 0, stOpen) = S_OK; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgStorageOpen()'); + end; +end; + +function StgOpenSubStorage(stOpen: IStorage; const SubStgName: WideString; nMode: Integer; out stg: IStorage): Boolean; +begin + try + Result := stOpen.OpenStorage(PWideChar(SubStgName), nil, nMode, 0, 0, stg) = S_OK; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgOpenSubStorage()'); + end; +end; + +function StgGetStream(stOpen: IStorage; sName: WideString; ms: TMemoryStream): Boolean; +var + s: IStream; + Stat: TStatStg; + dwSize: Integer; +begin + Result := false; + try + if stOpen.OpenStream(PWideChar(sName), nil, + STGM_READ or STGM_SHARE_EXCLUSIVE, 0, s) = S_OK then + begin + if (s.Stat(Stat, STATFLAG_NONAME) = S_OK) then + begin + ms.Clear; + ms.Size := Stat.cbSize; + Result := s.Read(ms.Memory, Stat.cbSize, @dwSize) = S_OK; + end; + s := nil; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgGetStream()'); + end; +end; + +function StgGetStreamToText(stOpen: IStorage; sName: WideString; var sText: WideString): Boolean; +var + ms: TMemoryStream; +begin + Result := false; + try + ms := TMemoryStream.Create; + try + if StgGetStream(stOpen, sName, ms) then + begin + SetLength(sText, ms.Size div 2); + CopyMemory(PByte(sText), ms.Memory, ms.Size); + Result := true; + end else exit; + finally + ms.Free; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgGetStreamTextContents()'); + end; +end; + +function StgGetEnumElements(stOpen: IStorage; out enum: IEnumStatStg): Boolean; +begin + try + Result := stOpen.EnumElements(0, nil, 0, enum) = S_OK; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgEnumElements()'); + end; +end; + +function StgNextStatStg(enum: IEnumStatStg; out elStat: TStatStg): Boolean; +begin + try + Result := enum.Next(1, elStat, nil) = S_OK; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgNextStatStg()'); + end; +end; + +function StgGetStatStg(enum: IEnumStatStg; const sName: WideString; out elStat: TStatStg; bReset: Boolean = true): Boolean; +begin + Result := false; + try + if bReset then + begin + if enum.Reset <> S_OK then + exit; + end; + + while StgNextStatStg(enum, elStat) do + begin + if Pos(sName, elStat.pwcsName) = 1 then + begin + Result := true; + Break; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgGetStatStg()'); + end; +end; + +// sName가 elStat.pwcsName 문자열에 포함되면 true +function StgGetStatStgLike(enum: IEnumStatStg; const sName: WideString; out elStat: TStatStg; bReset: Boolean = true): Boolean; +begin + Result := false; + try + if bReset then + begin + if enum.Reset <> S_OK then + exit; + end; + + while StgNextStatStg(enum, elStat) do + begin + if Pos(sName, elStat.pwcsName) <> 0 then + begin + Result := true; + exit; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgGetStatStgLike()'); + end; +end; + +function StgGetStatStgList(enum: IEnumStatStg; const sName: WideString; aList: TStringList; bReset: Boolean = true): Boolean; +var + I: Integer; + list_length: Integer; + elStat: TStatStg; +begin + Result := false; + try + if bReset then + begin + if enum.Reset <> S_OK then + exit; + end; + + aList.Clear; + while StgNextStatStg(enum, elStat) do + begin + if Pos(sName, elStat.pwcsName) = 1 then + begin + aList.AddObject(elStat.pwcsName, TObject(elStat.dwType)); + continue; + end; + + end; + + Result := aList.Count > 0; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. StgGetStatStgList()'); + end; +end; + + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Obj.pas b/Tocsg.Lib/VCL/Tocsg.Obj.pas new file mode 100644 index 00000000..07958f60 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Obj.pas @@ -0,0 +1,58 @@ +{*******************************************************} +{ } +{ Tocsg.Obj } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Obj; + +interface + +uses + Winapi.Windows, System.SysUtils; + +type + TTgObject = class(TObject) + protected + nLastError_: Integer; + procedure _Trace(const sLog: String; nLevel: Integer = 0); overload; + procedure _Trace(const sFormat: String; const aArgs: array of const; nLevel: Integer = 0); overload; + public + Constructor Create; virtual; + property LastError: Integer read nLastError_; + end; + + TTgEvtWorkBegin = procedure(aSender: TTgObject; llMax: LONGLONG) of object; + TTgEvtWorkEnd = procedure(aSender: TTgObject; llPos, llMax: LONGLONG) of object; + TTgEvtWork = procedure(aSender: TTgObject; llPos: LONGLONG) of object; + +implementation + +uses + Tocsg.Trace; + +{ TTgObject } + +Constructor TTgObject.Create; +begin + Inherited Create; + nLastError_ := 0; +end; + +procedure TTgObject._Trace(const sLog: String; nLevel: Integer = 0); +begin +{$IFDEF TRACE_OBJ} + TTgTrace.T(Format('%s >> %s', [ClassName, sLog]), nLevel); +{$ENDIF} +end; + +procedure TTgObject._Trace(const sFormat: String; const aArgs: array of const; nLevel: Integer = 0); +begin +{$IFDEF TRACE_OBJ} + TTgTrace.T(Format('%s >> %s', [ClassName, sFormat]), aArgs, nLevel); +{$ENDIF} +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.PCRE.pas b/Tocsg.Lib/VCL/Tocsg.PCRE.pas new file mode 100644 index 00000000..a611998a --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.PCRE.pas @@ -0,0 +1,201 @@ +{*******************************************************} +{ } +{ Tocsg.PCRE } +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.PCRE; + +interface + +uses + Tocsg.Obj, Classes, SysUtils, + WinApi.Windows, System.RegularExpressions; + +const + PT_RX_IDNUM = '\d{2}(0[1-9]|1[0-2])(0[1-9]|[12][0-9]|3[01])\W?[1-4]\d{6}'; // or \d{2}(0[1-9]|1[0-2])(0[1-9]|[12][0-9]|3[01])-[1-4]\d{7} +//3 : JCB나 다이너스, 4 : 비자, 5 : 마스터, 6 : 중국의 은련 카드, 9 : 세계 공통 국내 전용카드 + PT_RX_CARDNUM = '(3|4|5|6|9)\d{3}\W?\d{4}\W?\d{4}\W?\d{4}'; + PT_RX_EMAIL = '[\w\-]+@(?:(?:[\w\-]{2,}\.)+[a-zA-Z]{2,})'; + //EMAIL = [_a-zA-Z0-9-]+([-+.][_a-zA-Z0-9]+)*[\^ &%*@]{0,2}\@[\^ &%*@]{0,2}[_a-zA-Z0-9]+([-.][_a-zA-Z0-9]+)*\.[-a-zA-Z0-9]+([-.][_a-zA-Z0-9]+)*; +// PT_RX_URL = '((ftp|https?)://|www)([a-zA-Z_0-9\W]*)[-\w.]+(/([\w/_.]*(\?\S+)?)?)?'; // 이건 매우좋지 않다. x 않좋은 예라 남겨놓음 +// PT_RX_URL = '((?:https?://)?(?:www\.)?[-a-z\d]{1,9}\.[-a-z\d]{2,5}(?:\.[-a-z\d]{2,4})?)'; // 이건 . 으로 구분된건 앵간에서 다 검출한다. 오탐이 많음 + PT_RX_URL = '((ftp|mms|https?)://([-\w\.]+)+(:\d+)?(/([\w/_\.]*(\?\S+)?)?)?)'; // 조건을 ftp, mms, http, https로 시작하는걸로 고정 13_1107 11:26:56 sunk + + PT_RX_IP = '(((\d{1,2})|(1\d{2})|(2[0-4]\d)|(25[0-5]))\.){3}((\d{1,2})|(1\d{2})|(2[0-4]\d)|(25[0-5]))'; + PT_RX_HP = '(\s|^)(0(1[016789]))(\)|-| )\d{3,4}(-| )\d{4}(?=([^\d-])|$)'; + PT_RX_PHONE = '0(2|([3-6][1-5]))\W?\d{3,4}\W?\d{4}'; + +type + TTgPcre = class(TTgObject) + public + class function GetMatchValues(sSrcText, sMatchText: String; + var sResult: String; + bResultClear: Boolean = true; + aRexOpt: TRegExOptions = [roIgnoreCase, roMultiLine]): Integer; + end; + +function GetCountOverlapWordsCount(sText: String): Integer; +function GetCountOverlapWords(sText: String; sDm: String = ''): String; +function RemoveOverlapWords(sText: String; sDm: String = ''): String; + +implementation + +uses + Tocsg.Strings, Tocsg.Safe, Tocsg.Exception; + +function GetCountOverlapWordsCount(sText: String): Integer; +var + StrList: TStringList; + i, nPos, nLen, nHit: Integer; + sKwd: String; +begin + Result := 0; + Guard(StrList, TStringList.Create); + if SplitString(sText, ',', StrList) = 0 then + exit; + + for i := 0 to StrList.Count - 1 do + begin + sKwd := StrList[i]; + nPos := Pos('(x', sKwd); + if nPos > 0 then + begin + nLen := Length(sKwd) - 1; + SetLength(sKwd, nLen); + Inc(Result, StrToIntDef(Copy(sKwd, nPos + 2, nLen - nPos + 2), 1)); + SetLength(sKwd, nPos - 1); + end else + Inc(Result); + end; +end; + +function GetCountOverlapWords(sText: String; sDm: String = ''): String; +var + ComList, + OverlWordList: TStringList; + i, nLastIdx, + nOverlCnt: Integer; + sCheck: String; +begin + Result := ''; + if sText = '' then + exit; + Guard(ComList, TStringList.Create); + Guard(OverlWordList, TStringList.Create); + SplitString(sText, ',', ComList); + while ComList.Count > 0 do + begin + nLastIdx := ComList.Count - 1; + sCheck := ComList[nLastIdx]; + ComList.Delete(nLastIdx); + + nOverlCnt := 0; + for i := nLastIdx - 1 downto 0 do + begin + if sCheck = ComList[i] then + begin + Inc(nOverlCnt); + ComList.Delete(i); + end; + end; + + if nOverlCnt > 0 then + sCheck := Format('%s(x%d)', [sCheck, nOverlCnt+1]); + OverlWordList.Add(sCheck); + end; + + if (sDm <> '') and (sDm <> ',') then + begin + for i := 0 to OverlWordList.Count - 1 do + SumString(Result, OverlWordList[i], sDm); + end else + Result := OverlWordList.CommaText; +end; + +function RemoveOverlapWords(sText: String; sDm: String = ''): String; +var + ComList, + OverlWordList: TStringList; + i, nLastIdx: Integer; + sCheck: String; +begin + Result := ''; + if sText = '' then + exit; + Guard(ComList, TStringList.Create); + Guard(OverlWordList, TStringList.Create); + SplitString(sText, ',', ComList); + while ComList.Count > 0 do + begin + nLastIdx := ComList.Count - 1; + sCheck := ComList[nLastIdx]; + ComList.Delete(nLastIdx); + + for i := nLastIdx - 1 downto 0 do + begin + if sCheck = ComList[i] then + ComList.Delete(i); + end; + + OverlWordList.Add(sCheck); + end; + + if (sDm <> '') and (sDm <> ',') then + begin + for i := 0 to OverlWordList.Count - 1 do + SumString(Result, OverlWordList[i], sDm); + end else + Result := OverlWordList.CommaText; +end; + +{ TTgPcre } + +class function TTgPcre.GetMatchValues(sSrcText, sMatchText: String; + var sResult: String; + bResultClear: Boolean = true; + aRexOpt: TRegExOptions = [roIgnoreCase, roMultiLine]): Integer; +// aRexOpt: TRegExOptions = [roIgnoreCase]): Integer; +var + rx: TRegEx; + mc: TMatchCollection; + i: Integer; +begin + Result := 0; + try + sSrcText := Trim(sSrcText); + if sSrcText = '' then + exit; + + if sSrcText = #13#10 then + exit; + + if bResultClear then + sResult := ''; + + if sMatchText = '' then + exit; + +// rx := TRegEx.Create(TRegEx.Escape(sMatchText, true), aRexOpt); + rx := TRegEx.Create(sMatchText, aRexOpt); + + mc := rx.Matches(sSrcText); + Result := mc.Count; + if Result > 0 then + begin + for i := 0 to Result - 1 do + if mc.Item[i].Value <> '' then + SumString(sResult, mc.Item[i].Value, ',') + else + Dec(Result); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. TTgPcre.GetMatchValues()'); + end; +end; + +end. + diff --git a/Tocsg.Lib/VCL/Tocsg.Param.pas b/Tocsg.Lib/VCL/Tocsg.Param.pas new file mode 100644 index 00000000..656d1c1b --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Param.pas @@ -0,0 +1,78 @@ +{*******************************************************} +{ } +{ Tocsg.Param } +{ } +{ Copyright (C) 2020 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Param; + +interface + +uses + Tocsg.Obj, System.SysUtils; + +type + TTgParam = class(TTgObject) + private + nParamCnt_: Integer; + sModulePath_, + sModuleName_: String; + protected + function GetParamIndex(sParam: String): Integer; + public + Constructor Create; override; + + function ExistsParam(const sParam: String): Boolean; + function GetParamValue(const sParam: String): String; + + property ModulePath: String read sModulePath_; + property ModuleName: String read sModuleName_; + property Count: Integer read nParamCnt_; + end; + +implementation + +{ TTgParam } + +Constructor TTgParam.Create; +begin + Inherited Create; + + nParamCnt_ := ParamCount; + sModulePath_ := ParamStr(0); + sModuleName_ := ExtractFileName(sModulePath_); +end; + +function TTgParam.GetParamIndex(sParam: String): Integer; +var + i: Integer; +begin + Result := -1; + + sParam := UpperCase(sParam); + for i := 1 to nParamCnt_ do + if UpperCase(ParamStr(i)) = sParam then + begin + Result := i; + exit; + end; +end; + +function TTgParam.ExistsParam(const sParam: String): Boolean; +begin + Result := GetParamIndex(sParam) > -1; +end; + +function TTgParam.GetParamValue(const sParam: String): String; +var + nIdx: Integer; +begin + Result := ''; + nIdx := GetParamIndex(sParam); + if (nIdx >= 1) and (nIdx + 1 <= nParamCnt_) then + Result := ParamStr(nIdx + 1); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Path.pas b/Tocsg.Lib/VCL/Tocsg.Path.pas new file mode 100644 index 00000000..013d98fa --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Path.pas @@ -0,0 +1,163 @@ +{*******************************************************} +{ } +{ Tocsg.Path } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Path; + +interface + +function CutFileExt(sFName: String): String; {$IFDEF RELEASE} inline; {$ENDIF} +function GetFileExt(sFName: String): String; {$IFDEF RELEASE} inline; {$ENDIF} +function GetRunExePath: String; inline; +function GetRunExePathDir: String; inline; +function GetRunExeName: String; inline; + +function GetRecentDir: String; +function GetDesktopDir: String; +function GetCommonDesktopDir: String; +function GetWindowsDir: String; +function GetSystemDir: String; +function GetProgramFilesDir: String; +function GetUserDir: String; +function GetProgramsDir: String; +function GetDocumentDir: String; +function GetCommonDocumentDir: String; +function GetCommonDataDir: String; +function GetInternetTempDir: String; +function GetInternetCookiesDir: String; + +implementation + +uses + System.SysUtils, Winapi.ShlObj, Winapi.Windows; + +function CutFileExt(sFName: String): String; +var + i: Integer; +begin + i := sFName.LastIndexOf('.'); + if i <> -1 then + SetLength(sFName, i); + Result := sFName +end; + +function GetFileExt(sFName: String): String; +var + i: Integer; +begin + i := sFName.LastIndexOf('.'); + if i <> -1 then + Result := Copy(sFName, i + 2, sFName.Length - i) + else + Result := ''; +end; + +function GetRunExePath: String; +begin + Result := ParamStr(0); +end; + +function GetRunExePathDir: String; +begin + Result := ExtractFilePath(GetRunExePath); +end; + +function GetRunExeName: String; inline; +begin + Result := ExtractFileName(GetRunExePath); +end; + +function GetSpecialDir(nFolder: Integer): String; +var + pidl: PItemIDList; + hRes: HRESULT; + bSuccess: Boolean; + sRealPath: array [0..MAX_PATH] of {$IFDEF UNICODE} WideChar {$ELSE} AnsiChar {$ENDIF}; +begin + Result := ''; + bSuccess := false; + + pidl := nil; + hRes := SHGetSpecialFolderLocation(0, nFolder, pidl); + if hRes = NO_ERROR then + begin + try + if SHGetPathFromIDList(pidl, sRealPath) then + Result := IncludeTrailingPathDelimiter(sRealPath); + finally + if pidl <> nil then + ILFree(pidl); + end; + end; +end; + +function GetRecentDir: String; +begin + Result := GetSpecialDir(CSIDL_RECENT); +end; + +function GetDesktopDir: String; +begin + Result := GetSpecialDir(CSIDL_DESKTOPDIRECTORY); +end; + +function GetCommonDesktopDir: String; +begin + Result := GetSpecialDir(CSIDL_COMMON_DESKTOPDIRECTORY); +end; + +function GetWindowsDir: String; +begin + Result := GetSpecialDir(CSIDL_WINDOWS); +end; + +function GetSystemDir: String; +begin + Result := GetSpecialDir(CSIDL_SYSTEM); +end; + +function GetProgramFilesDir: String; +begin + Result := GetSpecialDir(CSIDL_PROGRAM_FILES); +end; + +function GetUserDir: String; +begin + Result := GetSpecialDir(CSIDL_PROFILE); +end; + +function GetProgramsDir: String; +begin + Result := GetSpecialDir(CSIDL_PROGRAMS); +end; + +function GetDocumentDir: String; +begin + Result := GetSpecialDir(CSIDL_PERSONAL); +end; + +function GetCommonDocumentDir: String; +begin + Result := GetSpecialDir(CSIDL_COMMON_DOCUMENTS); +end; + +function GetCommonDataDir: String; +begin + Result := GetSpecialDir(CSIDL_COMMON_APPDATA); +end; + +function GetInternetTempDir: String; +begin + Result := GetSpecialDir(CSIDL_INTERNET_CACHE); +end; + +function GetInternetCookiesDir: String; +begin + Result := GetSpecialDir(CSIDL_COOKIES); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Prefetch.pas b/Tocsg.Lib/VCL/Tocsg.Prefetch.pas new file mode 100644 index 00000000..f64211f1 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Prefetch.pas @@ -0,0 +1,365 @@ +{*******************************************************} +{ } +{ Tocsg.Prefetch } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.Prefetch; + +interface + +uses + Tocsg.Obj, System.SysUtils, System.Classes, Winapi.Windows, + System.Generics.Collections; + +const + PF_VER_1 = 17; + PF_VER_2 = 23; + PF_VER_3 = 26; + PF_VER_4 = 30; + +type + TPfHeader = record + dwVer: DWORD; + arrSig: array[0..3] of AnsiChar; + dwUnknown1, + dwFSize: DWORD; + arrFName: array[0..29] of Char; // array[0..59] of AnsiChar; + dwPfHash, + dwUnknown2: DWORD; + end; + + TPfFileInfoVer1 = record + dwOffset, + dwEntCnt, + dwOffsetTrace, + dwEntCntTrace, + dwOffsetFName, + dwFNameSize, + dwOffsetVolInfo, + dwVolNum, + dwVolSize: DWORD; + ftLastExeTime: TFileTime; + arrUnknown1: array [0..15] of AnsiChar; + dwExeCounter: DWORD; + dwUnknown2: DWORD; + end; + + TPfFileInfoVer2 = record + dwOffset, + dwEntCnt, + dwOffsetTrace, + dwEntCntTrace, + dwOffsetFName, + dwFNameSize, + dwOffsetVolInfo, + dwVolNum, + dwVolSize: DWORD; + arrUnknown1: array [0..7] of AnsiChar; + ftLastExeTime: TFileTime; + arrUnknown2: array [0..15] of AnsiChar; + dwExeCounter: DWORD; + arrUnknown3: array [0..83] of AnsiChar; + end; + + TPfFileInfoVer34 = record + dwOffset, + dwEntCnt, + dwOffsetTrace, + dwEntCntTrace, + dwOffsetFName, + dwFNameSize, + dwOffsetVolInfo, + dwVolNum, + dwVolSize: DWORD; + arrUnknown1: array [0..7] of AnsiChar; + arrLastExeTime: array [0..7] of TFileTime; + arrUnknown2: array [0..15] of AnsiChar; + dwExeCounter: DWORD; + arrUnknown3: array [0..95] of AnsiChar; + end; + + TAssocFileEntVer1 = record + dwStartTime, + dwDuration, + dwFNameOffset, + dwFNameLen, + dwUnknown: DWORD; + end; + + TAssocFileEntVer234 = record + dwStartTime, + dwDuration, + dwAverageDuration, + dwFNameOffset, + dwFNameLen, + dwUnknown: DWORD; + arrRefNTFS: array [0..7] of AnsiChar; + end; + + TTgPrefetchAnal = class(TTgObject) + private + ms_: TMemoryStream; + PfHeader_: TPfHeader; + nRunCnt_: Integer; + ExeDtList_: TList<TDateTime>; + AssocFList_: TStringList; + sPfPath_, + sPath_, + sFName_: String; + function GetPfHeader(aStream: TStream): Boolean; + procedure ExtrPfInfoVer1; + procedure ExtrPfInfoVer2; + procedure ExtrPfInfoVer34; + function GetRunCount: Integer; + public + Constructor Create; + Destructor Destroy; override; + + function LoadFromStream(aStream: TStream): Boolean; + function LoadFromFile(sPath: String): Boolean; + + procedure Clear; + + function GetExeDateTimeToText(sDm: String = ''; sDtFormat: String = ''): String; + function GetExeDateEnum: TEnumerator<TDateTime>; + + property RunCount: Integer read GetRunCount; + property ExeDtList: TList<TDateTime> read ExeDtList_; + + property FilePath: String read sPath_; + property FileName: String read sFName_; + end; + +implementation + +uses + Tocsg.Safe, Tocsg.Exception, Tocsg.NTDLL.Decompress, Tocsg.DateTime, + Tocsg.Strings, System.Math, Tocsg.Path; + +{ TTgPrefetchAnal } + +Constructor TTgPrefetchAnal.Create; +begin + Inherited Create; + sPfPath_ := ''; + sPath_ := ''; + sFName_ := ''; + ms_ := nil; + ExeDtList_ := TList<TDateTime>.Create; + AssocFList_ := TStringList.Create; +end; + +Destructor TTgPrefetchAnal.Destroy; +begin + FreeAndNil(AssocFList_); + FreeAndNil(ExeDtList_); + if ms_ <> nil then + FreeAndNil(ms_); + Inherited; +end; + +function TTgPrefetchAnal.GetPfHeader(aStream: TStream): Boolean; +var + RtlHeader: TRtlHeader; + pSrc, pBuf: TBytes; + dwDecomLen: DWORD; +begin + Result := false; + if aStream.Size < SizeOf(PfHeader_) then + exit; + + ZeroMemory(@PfHeader_, SizeOf(PfHeader_)); + aStream.Position := 0; + + ZeroMemory(@RtlHeader, SizeOf(RtlHeader)); + if aStream.Read(RtlHeader, SizeOf(RtlHeader)) <> SizeOf(RtlHeader) then + exit; + + if not CompareMem(@RtlHeader.arrSig[0], @AnsiString('MAM')[1], 3) then + exit; + + SetLength(pSrc, aStream.Size - aStream.Position); + aStream.Read(pSrc[0], Length(pSrc)); + SetLength(pBuf, RtlHeader.dwSize); + dwDecomLen := RtlDecompress(@pSrc[0], @pBuf[0], Length(pSrc), RtlHeader.dwSize, COMPRESSION_FORMAT_XPRESS_HUFF); + if dwDecomLen > 0 then + begin + ms_ := TMemoryStream.Create; + ms_.Write(pBuf[0], dwDecomLen); + ms_.Position := 0; + ms_.Read(PfHeader_, SizeOf(PfHeader_)); + if PfHeader_.arrSig = 'SCCA' then + Result := true; + end; +end; + +procedure TTgPrefetchAnal.ExtrPfInfoVer1; +var + FInfo: TPfFileInfoVer1; +begin + if ms_ = nil then + exit; + + ms_.Read(FInfo, SizeOf(FInfo)); + nRunCnt_ := FInfo.dwExeCounter; + ExeDtList_.Add(ConvFileTimeToDateTime(FInfo.ftLastExeTime)); +end; + +procedure TTgPrefetchAnal.ExtrPfInfoVer2; +var + FInfo: TPfFileInfoVer2; +begin + if ms_ = nil then + exit; + + ms_.Read(FInfo, SizeOf(FInfo)); + nRunCnt_ := FInfo.dwExeCounter; + ExeDtList_.Add(ConvFileTimeToDateTime(FInfo.ftLastExeTime)); +end; + +procedure TTgPrefetchAnal.ExtrPfInfoVer34; +var + FInfo: TPfFileInfoVer34; + i: Integer; + dwPos, dwEntSize, + dwNameOffset: DWORD; + AssocFileEnt: TAssocFileEntVer234; + pBuf: TBytes; + sPath: String; +begin + if ms_ = nil then + exit; + + ms_.Read(FInfo, SizeOf(FInfo)); + nRunCnt_ := FInfo.dwExeCounter; + for i := Low(FInfo.arrLastExeTime) to High(FInfo.arrLastExeTime) do + if (FInfo.arrLastExeTime[i].dwLowDateTime > 0) and (FInfo.arrLastExeTime[i].dwHighDateTime > 0) then + ExeDtList_.Add(ConvFileTimeToDateTime_Local(FInfo.arrLastExeTime[i])); // 로컬 타임으로 가져옴 22_0905 15:54:59 kku +// ExeDtList_.Add(ConvFileTimeToDateTime(FInfo.arrLastExeTime[i])); + + SetLength(pBuf, 1024); + dwPos := FInfo.dwOffset; + dwNameOffset := FInfo.dwOffsetFName; + dwEntSize := SizeOf(AssocFileEnt); + for i := 0 to FInfo.dwEntCnt - 1 do + if dwPos < ms_.Size then + begin + ms_.Position := dwPos; + if ms_.Read(AssocFileEnt, dwEntSize) <> dwEntSize then + exit; + dwPos := ms_.Position; + + with AssocFileEnt do + begin + if (dwNameOffset + dwFNameOffset + (dwFNameLen * 2)) < ms_.Size then + begin + ms_.Position := dwNameOffset + dwFNameOffset; + ZeroMemory(pBuf, 1024); + if ms_.Read(pBuf[0], dwFNameLen * 2) <> (dwFNameLen * 2) then + exit; + + sPath := UpperCase(String(PChar(@pBuf[0]))); + if GetFileExt(sPath) = 'EXE' then + begin + sPath_ := ExtractFilePath(sPath); + sFName_ := ExtractFileName(sPath); + end; + + AssocFList_.Add(sPath); + end; + end; + end; + +end; + +function TTgPrefetchAnal.LoadFromStream(aStream: TStream): Boolean; +begin + Clear; + Result := false; + + try + if (aStream = nil) or (aStream.Size = 0) then + exit; + + Result := GetPfHeader(aStream); + if not Result then + exit; + + case PfHeader_.dwVer of + PF_VER_1 : ExtrPfInfoVer1; + PF_VER_2 : ExtrPfInfoVer2; + PF_VER_3, + PF_VER_4 : ExtrPfInfoVer34; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. LoadFromStream()'); + end; +end; + +function TTgPrefetchAnal.LoadFromFile(sPath: String): Boolean; +var + fs: TFileStream; +begin + Result := false; + if not FileExists(sPath) then + exit; + + try + sPfPath_ := sPath; + Guard(fs, TFileStream.Create(sPath, fmOpenRead)); + Result := LoadFromStream(fs); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. LoadFromFile()'); + end; +end; + +procedure TTgPrefetchAnal.Clear; +begin + if ms_ <> nil then + FreeAndNil(ms_); + Finalize(PfHeader_); + ZeroMemory(@PfHeader_, SizeOf(PfHeader_)); + nRunCnt_ := 0; + ExeDtList_.Clear; + AssocFList_.Clear; + sPfPath_ := ''; + sFName_ := ''; + sPath_ := ''; +end; + + +function TTgPrefetchAnal.GetRunCount: Integer; +begin + Result := Max(nRunCnt_, ExeDtList_.Count); +end; + +function TTgPrefetchAnal.GetExeDateTimeToText(sDm: String = ''; sDtFormat: String = ''): String; +var + i: Integer; +begin + Result := ''; + try + if sDm = '' then + sDm := ','; + for i := 0 to ExeDtList_.Count - 1 do + if sDtFormat <> '' then + SumString(Result, FormatDateTime(sDtFormat, ExeDtList_[i]), sDm) + else + SumString(Result, DateTimeToStr(ExeDtList_[i]), sDm); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. GetExeDateTimeToCommaText()'); + end; +end; + +function TTgPrefetchAnal.GetExeDateEnum: TEnumerator<TDateTime>; +begin + Result := ExeDtList_.GetEnumerator; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Printer.pas b/Tocsg.Lib/VCL/Tocsg.Printer.pas new file mode 100644 index 00000000..e9bc47ed --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Printer.pas @@ -0,0 +1,1773 @@ +{*******************************************************} +{ } +{ Tocsg.Printer } +{ } +{ Copyright (C) 2019 kku } +{ } +{*******************************************************} + +unit Tocsg.Printer; + +interface + +uses + Tocsg.Obj, System.SysUtils, Winapi.Windows, Winapi.WinSpool, + System.Classes, Tocsg.Thread, System.Generics.Collections; + +const + MAX_JOB = 1024; + + SIG_PJL: array[0..8] of Byte = ($1B, $25, $2D, $31, $32, $33, $34, $35, $58); + + REG_KEY_PRINTERSX = 'SYSTEM\CurrentControlSet\Control\Print\Printers'; + + DMCOLOR_MONOCHROME = 1; + {$EXTERNALSYM DMCOLOR_MONOCHROME} + DMCOLOR_COLOR = 2; + {$EXTERNALSYM DMCOLOR_COLOR} + + DMPAPER_LETTER = 1; // Letter 8 1/2 x 11 in + DMPAPER_LETTERSMALL = 2; // Letter Small 8 1/2 x 11 in + DMPAPER_TABLOID = 3; // Tabloid 11 x 17 in + DMPAPER_LEDGER = 4; // Ledger 17 x 11 in + DMPAPER_LEGAL = 5; // Legal 8 1/2 x 14 in + DMPAPER_STATEMENT = 6; // Statement 5 1/2 x 8 1/2 in + DMPAPER_EXECUTIVE = 7; // Executive 7 1/4 x 10 1/2 in + DMPAPER_A3 = 8; // A3 297 x 420 mm + DMPAPER_A4 = 9; // A4 210 x 297 mm + DMPAPER_A4SMALL = 10; // A4 Small 210 x 297 mm + DMPAPER_A5 = 11; // A5 148 x 210 mm + DMPAPER_B4 = 12; // B4 (JIS) 250 x 354 + DMPAPER_B5 = 13; // B5 (JIS) 182 x 257 mm + DMPAPER_FOLIO = 14; // Folio 8 1/2 x 13 in + DMPAPER_QUARTO = 15; // Quarto 215 x 275 mm + DMPAPER_10X14 = 16; // 10x14 in + DMPAPER_11X17 = 17; // 11x17 in + DMPAPER_NOTE = 18; // Note 8 1/2 x 11 in + DMPAPER_ENV_9 = 19; // Envelope #9 3 7/8 x 8 7/8 + DMPAPER_ENV_10 = 20; // Envelope #10 4 1/8 x 9 1/2 + DMPAPER_ENV_11 = 21; // Envelope #11 4 1/2 x 10 3/8 + DMPAPER_ENV_12 = 22; // Envelope #12 4 \276 x 11 + DMPAPER_ENV_14 = 23; // Envelope #14 5 x 11 1/2 + DMPAPER_CSHEET = 24; // C size sheet + DMPAPER_DSHEET = 25; // D size sheet + DMPAPER_ESHEET = 26; // E size sheet + DMPAPER_ENV_DL = 27; // Envelope DL 110 x 220mm + DMPAPER_ENV_C5 = 28; // Envelope C5 162 x 229 mm + DMPAPER_ENV_C3 = 29; // Envelope C3 324 x 458 mm + DMPAPER_ENV_C4 = 30; // Envelope C4 229 x 324 mm + DMPAPER_ENV_C6 = 31; // Envelope C6 114 x 162 mm + DMPAPER_ENV_C65 = 32; // Envelope C65 114 x 229 mm + DMPAPER_ENV_B4 = 33; // Envelope B4 250 x 353 mm + DMPAPER_ENV_B5 = 34; // Envelope B5 176 x 250 mm + DMPAPER_ENV_B6 = 35; // Envelope B6 176 x 125 mm + DMPAPER_ENV_ITALY = 36; // Envelope 110 x 230 mm + DMPAPER_ENV_MONARCH = 37; // Envelope Monarch 3.875 x 7.5 in + DMPAPER_ENV_PERSONAL = 38; // 6 3/4 Envelope 3 5/8 x 6 1/2 in + DMPAPER_FANFOLD_US = 39; // US Std Fanfold 14 7/8 x 11 in + DMPAPER_FANFOLD_STD_GERMAN = 40; // German Std Fanfold 8 1/2 x 12 in + DMPAPER_FANFOLD_LGL_GERMAN = 41; // German Legal Fanfold 8 1/2 x 13 in + DMPAPER_ISO_B4 = 42; // B4 (ISO) 250 x 353 mm + DMPAPER_JAPANESE_POSTCARD = 43; // Japanese Postcard 100 x 148 mm + DMPAPER_9X11 = 44; // 9 x 11 in + DMPAPER_10X11 = 45; // 10 x 11 in + DMPAPER_15X11 = 46; // 15 x 11 in + DMPAPER_ENV_INVITE = 47; // Envelope Invite 220 x 220 mm + DMPAPER_RESERVED_48 = 48; // RESERVED--DO NOT USE + DMPAPER_RESERVED_49 = 49; // RESERVED--DO NOT USE + DMPAPER_LETTER_EXTRA = 50; // Letter Extra 9 \275 x 12 in + DMPAPER_LEGAL_EXTRA = 51; // Legal Extra 9 \275 x 15 in + DMPAPER_TABLOID_EXTRA = 52; // Tabloid Extra 11.69 x 18 in + DMPAPER_A4_EXTRA = 53; // A4 Extra 9.27 x 12.69 in + DMPAPER_LETTER_TRANSVERSE = 54; // Letter Transverse 8 \275 x 11 in + DMPAPER_A4_TRANSVERSE = 55; // A4 Transverse 210 x 297 mm + DMPAPER_LETTER_EXTRA_TRANSVERSE = 56; // Letter Extra Transverse 9\275 x 12 in + DMPAPER_A_PLUS = 57; // SuperA/SuperA/A4 227 x 356 mm + DMPAPER_B_PLUS = 58; // SuperB/SuperB/A3 305 x 487 mm + DMPAPER_LETTER_PLUS = 59; // Letter Plus 8.5 x 12.69 in + DMPAPER_A4_PLUS = 60; // A4 Plus 210 x 330 mm + DMPAPER_A5_TRANSVERSE = 61; // A5 Transverse 148 x 210 mm + DMPAPER_B5_TRANSVERSE = 62; // B5 (JIS) Transverse 182 x 257 mm + DMPAPER_A3_EXTRA = 63; // A3 Extra 322 x 445 mm + DMPAPER_A5_EXTRA = 64; // A5 Extra 174 x 235 mm + DMPAPER_B5_EXTRA = 65; // B5 (ISO) Extra 201 x 276 mm + DMPAPER_A2 = 66; // A2 420 x 594 mm + DMPAPER_A3_TRANSVERSE = 67; // A3 Transverse 297 x 420 mm + DMPAPER_A3_EXTRA_TRANSVERSE = 68; // A3 Extra Transverse 322 x 445 mm + + DMPAPER_DBL_JAPANESE_POSTCARD = 69; // Japanese Double Postcard 200 x 148 mm + DMPAPER_A6 = 70; // A6 105 x 148 mm + DMPAPER_JENV_KAKU2 = 71; // Japanese Envelope Kaku #2 + DMPAPER_JENV_KAKU3 = 72; // Japanese Envelope Kaku #3 + DMPAPER_JENV_CHOU3 = 73; // Japanese Envelope Chou #3 + DMPAPER_JENV_CHOU4 = 74; // Japanese Envelope Chou #4 + DMPAPER_LETTER_ROTATED = 75; // Letter Rotated 11 x 8 1/2 11 in + DMPAPER_A3_ROTATED = 76; // A3 Rotated 420 x 297 mm + DMPAPER_A4_ROTATED = 77; // A4 Rotated 297 x 210 mm + DMPAPER_A5_ROTATED = 78; // A5 Rotated 210 x 148 mm + DMPAPER_B4_JIS_ROTATED = 79; // B4 (JIS) Rotated 364 x 257 mm + DMPAPER_B5_JIS_ROTATED = 80; // B5 (JIS) Rotated 257 x 182 mm + DMPAPER_JAPANESE_POSTCARD_ROTATED = 81; // Japanese Postcard Rotated 148 x 100 mm + DMPAPER_DBL_JAPANESE_POSTCARD_ROTATED = 82; // Double Japanese Postcard Rotated 148 x 200 mm + DMPAPER_A6_ROTATED = 83; // A6 Rotated 148 x 105 mm + DMPAPER_JENV_KAKU2_ROTATED = 84; // Japanese Envelope Kaku #2 Rotated + DMPAPER_JENV_KAKU3_ROTATED = 85; // Japanese Envelope Kaku #3 Rotated + DMPAPER_JENV_CHOU3_ROTATED = 86; // Japanese Envelope Chou #3 Rotated + DMPAPER_JENV_CHOU4_ROTATED = 87; // Japanese Envelope Chou #4 Rotated + DMPAPER_B6_JIS = 88; // B6 (JIS) 128 x 182 mm + DMPAPER_B6_JIS_ROTATED = 89; // B6 (JIS) Rotated 182 x 128 mm + DMPAPER_12X11 = 90; // 12 x 11 in + DMPAPER_JENV_YOU4 = 91; // Japanese Envelope You #4 + DMPAPER_JENV_YOU4_ROTATED = 92; // Japanese Envelope You #4 Rotated + DMPAPER_P16K = 93; // PRC 16K 146 x 215 mm + DMPAPER_P32K = 94; // PRC 32K 97 x 151 mm + DMPAPER_P32KBIG = 95; // PRC 32K(Big) 97 x 151 mm + DMPAPER_PENV_1 = 96; // PRC Envelope #1 102 x 165 mm + DMPAPER_PENV_2 = 97; // PRC Envelope #2 102 x 176 mm + DMPAPER_PENV_3 = 98; // PRC Envelope #3 125 x 176 mm + DMPAPER_PENV_4 = 99; // PRC Envelope #4 110 x 208 mm + DMPAPER_PENV_5 = 100; // PRC Envelope #5 110 x 220 mm + DMPAPER_PENV_6 = 101; // PRC Envelope #6 120 x 230 mm + DMPAPER_PENV_7 = 102; // PRC Envelope #7 160 x 230 mm + DMPAPER_PENV_8 = 103; // PRC Envelope #8 120 x 309 mm + DMPAPER_PENV_9 = 104; // PRC Envelope #9 229 x 324 mm + DMPAPER_PENV_10 = 105; // PRC Envelope #10 324 x 458 mm + DMPAPER_P16K_ROTATED = 106; // PRC 16K Rotated + DMPAPER_P32K_ROTATED = 107; // PRC 32K Rotated + DMPAPER_P32KBIG_ROTATED = 108; // PRC 32K(Big) Rotated + DMPAPER_PENV_1_ROTATED = 109; // PRC Envelope #1 Rotated 165 x 102 mm + DMPAPER_PENV_2_ROTATED = 110; // PRC Envelope #2 Rotated 176 x 102 mm + DMPAPER_PENV_3_ROTATED = 111; // PRC Envelope #3 Rotated 176 x 125 mm + DMPAPER_PENV_4_ROTATED = 112; // PRC Envelope #4 Rotated 208 x 110 mm + DMPAPER_PENV_5_ROTATED = 113; // PRC Envelope #5 Rotated 220 x 110 mm + DMPAPER_PENV_6_ROTATED = 114; // PRC Envelope #6 Rotated 230 x 120 mm + DMPAPER_PENV_7_ROTATED = 115; // PRC Envelope #7 Rotated 230 x 160 mm + DMPAPER_PENV_8_ROTATED = 116; // PRC Envelope #8 Rotated 309 x 120 mm + DMPAPER_PENV_9_ROTATED = 117; // PRC Envelope #9 Rotated 324 x 229 mm + DMPAPER_PENV_10_ROTATED = 118; // PRC Envelope #10 Rotated 458 x 324 mm + +{ + 2085 DEVMODEA = record + 2086 dmDeviceName : array[0..(CCHDEVICENAME)-1] of AnsiChar; + 2087 dmSpecVersion : WORD; + 2088 dmDriverVersion : WORD; + 2089 dmSize : WORD; + 2090 dmDriverExtra : WORD; + 2091 dmFields : DWORD; + 2092 case byte of + 2093 1: (dmOrientation : SmallInt; + 2094 dmPaperSize : SmallInt; + 2095 dmPaperLength : SmallInt; + 2096 dmPaperWidth : SmallInt; + 2097 dmScale : SmallInt; + 2098 dmCopies : SmallInt; + 2099 dmDefaultSource : SmallInt; + 2100 dmPrintQuality : SmallInt; + 2101 dmColor : SmallInt; + 2102 dmDuplex : SmallInt; + 2103 dmYResolution : SmallInt; + 2104 dmTTOption : SmallInt; + 2105 dmCollate : SmallInt; + 2106 dmFormName : array[0..(CCHFORMNAME)-1] of AnsiCHAR; + 2107 dmLogPixels : WORD; + 2108 dmBitsPerPel : DWORD; + 2109 dmPelsWidth : DWORD; + 2110 dmPelsHeight : DWORD; + 2111 dmDisplayFlags : DWORD; + 2112 dmDisplayFrequency : DWORD; + 2113 dmICMMethod : DWORD; + 2114 dmICMIntent : DWORD; + 2115 dmMediaType : DWORD; + 2116 dmDitherType : DWORD; + 2117 dmICCManufacturer : DWORD; + 2118 dmICCModel : DWORD + 2119 ); + 2120 2: (dmPosition: POINTL; + 2121 dmDisplayOrientation: DWORD; + 2122 dmDisplayFixedOutput: DWORD; + 2123 ); + 2124 end; + 2125 + 2126 LPDEVMODEA = ^DEVMODEA; + 2127 _DEVMODEA = DEVMODEA; + 2128 TDEVMODEA = DEVMODEA; + 2129 PDEVMODEA = LPDEVMODEA; + 2130 + 2131 _devicemodeA = DEVMODEA; + 2132 devicemodeA = DEVMODEA; + 2133 tdevicemodeA = DEVMODEA; + 2134 PDeviceModeA = LPDEVMODEA; + 2135 + } + + +type + POINTL = packed record + x : LONG; + y : LONG; + end; + + PDevModeW = ^TDevModeW; + TDevModeW = packed record + dmDeviceName : array[0.. CCHDEVICENAME-1] of WCHAR; + dmSpecVersion : WORD; + dmDriverVersion : WORD; + dmSize : WORD; + dmDriverExtra : WORD; + dmFields : DWORD; + case byte of + 1: + ( + dmOrientation : short; + dmPaperSize : short; + dmPaperLength : short; + dmPaperWidth : short; + dmScale : short; + dmCopies : short; + dmDefaultSource: short; + dmPrintQuality : short; + dmColor : short; + dmDuplex : short; + dmYResolution : short; + dmTTOption : short; + dmCollate : short; + dmFormName : array [0..CCHFORMNAME-1] of wchar; + dmLogPixels : WORD; + dmBitsPerPel : DWORD; + dmPelsWidth : DWORD; + dmPelsHeight : DWORD; + dmDisplayFlags : DWORD; + dmDisplayFrequency : DWORD; + dmICMMethod : DWORD; + dmICMIntent : DWORD; + dmMediaType : DWORD; + dmDitherType : DWORD; + dmReserved1 : DWORD; + dmReserved2 : DWORD; + dmPanningWidth : DWORD; + dmPanningHeight: DWORD; + ); + 2: + ( + dmPosition: POINTL; + dmDisplayOrientation: DWORD; + dmDisplayFixedOutput: DWORD; + ); + end; + + PJOB_INFO_1 = ^TJOB_INFO_1; + TJOB_INFO_1 = packed record + dwJobId : DWORD; + sPrinterName : LPTSTR; + sMachineName : LPTSTR; + sUserName : LPTSTR; + sDocument : LPTSTR; + sDatatype : LPTSTR; + sStatus : LPTSTR; + dwStatus : DWORD; + dwPriority : DWORD; + dwPosition : DWORD; + dwTotalPages : DWORD; + dwPagesPrinted : DWORD; + Submitted : SYSTEMTIME; + end; + + PJOB_INFO_2 = ^TJOB_INFO_2; + TJOB_INFO_2 = record + dwJobId : DWORD; + pPrinterName : LPTSTR; + pMachineName : LPTSTR; + pUserName : LPTSTR; + pDocument : LPTSTR; + pNotifyName : LPTSTR; + pDatatype : LPTSTR; + pPrintProcessor : LPTSTR; + pParameters : LPTSTR; + pDriverName : LPTSTR; + pDevMode : PDevModeW; + pStatus : LPTSTR; + pSecurityDescriptor : PSECURITY_DESCRIPTOR; + dwStatus : DWORD; + dwPriority : DWORD; + dwPosition : DWORD; + dwStartTime : DWORD; + dwUntilTime : DWORD; + dwTotalPages : DWORD; + dwSize : DWORD; + Submitted : SYSTEMTIME; + dwTime : DWORD; + dwPagesPrinted : DWORD; + end; + + PPrtJobDevInfo = ^TPrtJobDevInfo; + TPrtJobDevInfo = record + sDataType, + sDocName, + sPtrName, + sDrvName, + sPaperInfo, + sPrintProcessor: String; + dwScale, + dwTotalPage, + dwPaperSizeT, + dwCopyCount: DWORD; + bColor, + bPaperV: Boolean; + + DevMode: TDeviceMode; + end; + + TPrtJobState = (jsAdd, jsWork, jsDelete); + TPrtJobInfo = class(TTgObject) + private + dwID_: DWORD; + hPrtHandle_: THandle; + bCustomPause_: Boolean; + + sUserName_, + sMachine_, + sPort_, + sDocument_, + sPrinterName_: String; + dwPagesPrinted_, + dwTotalPages_, + dwBytesPrinted_, + dwTotalBytes_, + dwChange_, + dwStatus_ : DWORD; + PrtJobState_: TPrtJobState; + dtSubmitted_: TDateTime; + bWorkEnd_: Boolean; // 작업상태 체크용 22_0719 12:30:58 kku + + procedure SetJobState(aPrtJobState: TPrtJobState); + public + // 출력물 수행 프로세스 정보를 넣는데 사용 25_0605 15:17:45 kku + Wnd: HWND; +// PID: DWORD; +// PName: String; + + Constructor Create(hPrtHandle: THandle; dwID: DWORD); + + function SetPrtJob(dwControl: DWORD): Boolean; + function PausePrtJob: Boolean; + function ResumePrtJob(bForce: Boolean = false): Boolean; + procedure UpdatePrtFieldInfo(Info: TPrinterNotifyInfoData); + + function IsSpooling: Boolean; + function IsSpooling2: Boolean; + function GetJobDevInfo(var aInfo: TPrtJobDevInfo): Boolean; + + property ID: DWORD read dwID_; + property UserName: String read sUserName_; + property PrinterName: String read sPrinterName_; + property Machine: String read sMachine_; + property Port: String read sPort_; + property Document: String read sDocument_; + property JobDateTime: TDateTime read dtSubmitted_; + property PagesPrinted: DWORD read dwPagesPrinted_; + property TotalPages: DWORD read dwTotalPages_; + property BytesPrinted: DWORD read dwBytesPrinted_; + property TotalBytes: DWORD read dwTotalBytes_; + property Status: DWORD read dwStatus_; + property IsCustomPause: Boolean read bCustomPause_ write bCustomPause_; + property PtrJobState: TPrtJobState read PrtJobState_ write SetJobState; + property WorkEnd: Boolean read bWorkEnd_ write bWorkEnd_; + end; + + TThdPrtSpoolWatch = class; + + TPrtChangeNotifyEvent = procedure(Sender: TThdPrtSpoolWatch; dwChange: DWORD) of object; + TPrtNotifyJobInfoEvent = procedure(Sender: TThdPrtSpoolWatch; Job: TPrtJobInfo) of object; + + PPrtJobs = ^TPrtJobs; + TPrtJobs = array [0..MAX_JOB-1] of TJobInfo1; + + TThdPrtSpoolWatch = class(TTgThread) + private + PrtJobInfo_: TPrtJobInfo; + sSpoolDir_, + sDeviceName_: String; + hPrtChangeEvent_, + hPrinter_: THandle; + arrJobFields_: array [0..22] of WORD; + PNO_: TPrinterNotifyOptions; + bSync_: Boolean; + arrPNOT_: array [0..0] of TPrinterNotifyOptionsType; + JobList_: TDictionary<DWORD,TPrtJobInfo>; + + procedure OnJobValue(Sender: TObject; const Item: TPrtJobInfo; + Action: TCollectionNotification); + protected + dwChangeMod_: DWORD; + evPrtChangeNotifyEvent_: TPrtChangeNotifyEvent; + evPrtNotifyJobInfoEvent_: TPrtNotifyJobInfoEvent; + + procedure ProcessChangeEvent; + procedure ProcessNotifyJobInfoEvent; + + procedure Execute; override; + public + Constructor Create(bSync: Boolean; sDeviceName: String; dwWatchMod: DWORD = PRINTER_CHANGE_ALL); + Destructor Destroy; override; + + procedure StopThread; override; + + property DeviceName: String read sDeviceName_; + property SpoolDir: String read sSpoolDir_; + property OnPrtChangeNotifyEvent: TPrtChangeNotifyEvent write evPrtChangeNotifyEvent_; + property OnPrtNotifyJobInfoEvent: TPrtNotifyJobInfoEvent write evPrtNotifyJobInfoEvent_; + end; + + TTgPrtSpoolWatch = class(TTgThread) + private + bIsWatch_: Boolean; + dwWatchMod_: DWORD; + WatchThdList_: TList<TThdPrtSpoolWatch>; + bSync_: Boolean; + PrtList_: TStringList; + procedure OnPrtNotify(Sender: TObject; const Item: TThdPrtSpoolWatch; Action: TCollectionNotification); + protected + evPrtChangeNotifyEvent_: TPrtChangeNotifyEvent; + evPtrNotifyInfoEvent_: TPrtNotifyJobInfoEvent; + procedure StartPrtWatch; + procedure StopPrtWatch; + procedure Execute; override; + public + Constructor Create(bSync: Boolean; dwWatchMod: DWORD = PRINTER_CHANGE_ALL); + Destructor Destroy; override; + + property IsWatch: Boolean read bIsWatch_; + property OnPrtChangeNotificationEvent: TPrtChangeNotifyEvent write evPrtChangeNotifyEvent_; + property OnPrtNotificationEvent: TPrtNotifyJobInfoEvent write evPtrNotifyInfoEvent_; + end; + + TPrinterPortType = (PTUnknown, PTLocal, PTTcpIp, PTWsd, PTShared); + PPrinterInfo = ^TPrinterInfo; + TPrinterInfo = record + sIp, + sPrtName, + sDrvName, + sPortName: String; + PortType: TPrinterPortType; + bIsPowerSaveMode: Boolean; + dwStatus: DWORD; + end; + TPrtInfoList = TList<PPrinterInfo>; + + TPrintersInfo = class(TTgObject) + private + PrtInfoList_: TPrtInfoList; + procedure OnPrtInfoNotify(Sender: TObject; const Item: PPrinterInfo; Action: TCollectionNotification); + public + Constructor Create; + Destructor Destroy; override; + + function GetPrtInfoByPrtName(const sPrtName: String): PPrinterInfo; + + procedure RefreshList; + procedure SaveToFile(const sPath: String); + procedure LoadFromFile(const sPath: String); + + property PrtInfoList: TPrtInfoList read PrtInfoList_; + end; + +function GetPrinterSpoolDir(hPrinter: THandle = 0): String; +function GetLastSpoolPath(sSpoolDir: String): String; +function GetDefaultPrinterName: string; +function GetProcessNameByPrtDocName(sDocName: String): String; +function PrinterDriverToName(sDrvName: String): String; +function PrinterDriverToIP(sDrvName: String): String; + +function IsPJL(const sPath: String): Boolean; +function GetQtyFromPJL(const sPath: String; var bCollate: Boolean): Integer; +function IsPJLAndLanguagePLW(const sPath: string): Boolean; + +implementation + +uses + Tocsg.Registry, Tocsg.Path, Tocsg.WinInfo, Tocsg.DateTime, Tocsg.Safe, + Vcl.Printers, Tocsg.Exception, Tocsg.Files, Tocsg.Trace, Tocsg.Strings, Winapi.WinSvc, Tocsg.Service, System.Win.Registry, superobject, Tocsg.Json; + +function GetPrinterSpoolDir(hPrinter: THandle = 0): String; +var + dwLen, + dwType: DWORD; + sDir: PWideChar; +begin + Result := ''; + if hPrinter <> 0 then + begin + dwLen := 0; + dwType := REG_SZ; + GetPrinterData(hPrinter, SPLREG_DEFAULT_SPOOL_DIRECTORY, @dwType, nil, 0, dwLen); + if dwLen > 0 then + begin + sDir := AllocMem(dwLen); + try + if GetPrinterData(hPrinter, + SPLREG_DEFAULT_SPOOL_DIRECTORY, + @dwType, sDir, + dwLen, dwLen) = ERROR_SUCCESS then Result := sDir; + finally + FreeMem(sDir, dwLen); + end; + end; + end; + + if Result = '' then + Result := GetRegValueAsString(HKEY_LOCAL_MACHINE, REG_KEY_PRINTERSX, 'DefaultSpoolDirectory'); + + if Result = '' then + begin + Result := GetWindowsDir + 'System32\spool\PRINTERS\'; + if not DirectoryExists(Result) then + Result := ''; + end; + + if Result <> '' then + begin + // os가 64bit 이고 실행되는 프로그램이 32bit 용이면 system 폴더를 아래처럼 바꿔준다. + // 그래야 syswow64 여기로 인식안한다. 2012-06-20 kku + if IsWow64 and (SizeOf(NativeInt) = 4) then + Result := StringReplace(Result, 'system32', 'sysnative', [rfIgnoreCase]); + + Result := IncludeTrailingBackslash(Result); + end; +end; + +function GetLastSpoolPath(sSpoolDir: String): String; +var + wfd: TWin32FindData; + hSc: THandle; + sDir, + sPath: String; + SplList: TStringList; + i: Integer; +begin + TTgTrace.T('GetLastSpoolPath() ..', 9); + Result := ''; + try + sDir := ExtractFilePath(sSpoolDir); + if not ForceDirectories(sDir) then + exit; + + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + Guard(SplList, TStringList.Create); + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0) then + begin + TTgTrace.T('GetLastSpoolPath() .. %s', [wfd.cFileName], 9); + if (GetFileExt(wfd.cFileName).ToUpper = 'SPL') then +// (GetFileSizeHiLow(wfd.nFileSizeHigh, wfd.nFileSizeLow) > 0) then + SplList.Add(sDir + wfd.cFileName); + end; + Until not FindNextFile(hSc, wfd); + finally + FindClose(hSc); + end; + + TTgTrace.T('GetLastSpoolPath() .. Cnt=%d', [SplList.Count], 9); + if SplList.Count > 0 then + begin + SplList.CustomSort(StringListCompareFileModifyDate); + Result := SplList[SplList.Count - 1]; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetLastSpoolPath()'); + end; +end; + +{ TPrtJobInfo } + +Constructor TPrtJobInfo.Create(hPrtHandle: THandle; dwID: DWORD); +begin + Inherited Create; + + sUserName_ := ''; + sMachine_ := ''; + sPort_ := ''; + sDocument_ := ''; + dwPagesPrinted_ := 0; + dwTotalPages_ := 0; + dwBytesPrinted_ := 0; + dwTotalBytes_ := 0; + dwChange_ := 0; + dwStatus_ := 0; + dtSubmitted_ := 0; + bWorkEnd_ := false; + bCustomPause_ := false; + + hPrtHandle_ := hPrtHandle; + dwID_ := dwID; + + PrtJobState_ := jsAdd; +// PausePrtJob; +end; + +procedure TPrtJobInfo.SetJobState(aPrtJobState: TPrtJobState); +begin + if PrtJobState_ <> aPrtJobState then + PrtJobState_ := aPrtJobState; +end; + +function TPrtJobInfo.SetPrtJob(dwControl: DWORD): Boolean; +begin + try + Result := SetJob(hPrtHandle_, dwID_, 0, nil, dwControl); + if not Result then + _Trace('Fail .. Code=%d', [dwControl], 1); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. SetPrtJob()'); + end; +end; + +function TPrtJobInfo.PausePrtJob: Boolean; +begin + if not bCustomPause_ then + begin + try + // 원격 프린터의 경우.. SetJob 호출 시 ERROR_ACCESS_DENIED 날 수 있다. + // 많은걸 테스트 해보지 않아서 원인은 파악안됨 2012-06-21 kku + {bCustomPause_ := }Result := SetPrtJob(JOB_CONTROL_PAUSE); + if not Result then + begin + _Trace('Fail .. JOB_CONTROL_PAUSE'); + exit; + end; + bCustomPause_ := true; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. PausePrtJob()'); + end; + end; +end; + +function TPrtJobInfo.ResumePrtJob(bForce: Boolean = false): Boolean; +begin + if bCustomPause_ or bForce then + begin + {bCustomPause_ := not }Result := SetPrtJob(JOB_CONTROL_RESUME); + bCustomPause_ := false; + end; +end; + +procedure TPrtJobInfo.UpdatePrtFieldInfo(Info: TPrinterNotifyInfoData); +begin + case Info.Field of + JOB_NOTIFY_FIELD_PRINTER_NAME : sPrinterName_ := PChar(Info.NotifyData.Data.pBuf); + JOB_NOTIFY_FIELD_USER_NAME : sUserName_ := PChar(Info.NotifyData.Data.pBuf); + JOB_NOTIFY_FIELD_MACHINE_NAME : sMachine_ := PChar(Info.NotifyData.Data.pBuf); + JOB_NOTIFY_FIELD_PORT_NAME : sPort_ := PChar(Info.NotifyData.Data.pBuf); + JOB_NOTIFY_FIELD_DOCUMENT : sDocument_ := PChar(Info.NotifyData.Data.pBuf); + JOB_NOTIFY_FIELD_SUBMITTED : dtSubmitted_ := ConvSystemTimeToDateTime_Local(TSystemTime(Info.NotifyData.Data.pBuf^)); + JOB_NOTIFY_FIELD_PAGES_PRINTED : dwPagesPrinted_ := Info.NotifyData.adwData[0]; + JOB_NOTIFY_FIELD_TOTAL_PAGES : dwTotalPages_ := Info.NotifyData.adwData[0]; + JOB_NOTIFY_FIELD_BYTES_PRINTED : dwBytesPrinted_ := Info.NotifyData.adwData[0]; + JOB_NOTIFY_FIELD_TOTAL_BYTES : dwTotalBytes_ := Info.NotifyData.adwData[0]; + JOB_NOTIFY_FIELD_STATUS : + begin + dwStatus_ := Info.NotifyData.adwData[0]; +// if (dwStatus_ and JOB_STATUS_SPOOLING) <> 0 then +// begin +// SetPrtJob(JOB_CONTROL_PAUSE); +// dwStatus_ := dwStatus_ + 0; +// end; + end; +// else +// begin +// _Trace('%X = %s', [Info.Field, PChar(Info.NotifyData.Data.pBuf)]); +// end; + end; +end; + +function TPrtJobInfo.IsSpooling: Boolean; +begin + Result := (dwStatus_ and JOB_STATUS_SPOOLING) <> 0; +end; + +function TPrtJobInfo.IsSpooling2: Boolean; +var + dwNeed: DWORD; + pBuf: TBytes; +begin + Result := false; + + try + if hPrtHandle_ = 0 then + exit; + + dwNeed := 0; + GetJob(hPrtHandle_, dwID_, 2, nil, 0, @dwNeed); + // if not GetJob(hPrtHandle_, dwID_, 1, pBuf, 0, @dwNeed) then + // exit; + if dwNeed = 0 then + exit; + + SetLength(pBuf, dwNeed); + if GetJob(hPrtHandle_, dwID_, 2, pBuf, dwNeed, @dwNeed) then + begin + Result := (PJOB_INFO_2(pBuf).dwStatus and JOB_STATUS_SPOOLING) <> 0; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsSpooling2()'); + end; +end; + +function TPrtJobInfo.GetJobDevInfo(var aInfo: TPrtJobDevInfo): Boolean; +var + dwNeed: DWORD; + pBuf: TBytes; +begin + Result := false; + Finalize(aInfo); + ZeroMemory(@aInfo, SizeOf(aInfo)); + + try + if hPrtHandle_ = 0 then + exit; + + dwNeed := 0; + GetJob(hPrtHandle_, dwID_, 2, nil, 0, @dwNeed); + if dwNeed = 0 then + exit; + + SetLength(pBuf, dwNeed); + if GetJob(hPrtHandle_, dwID_, 2, pBuf, dwNeed, @dwNeed) then + begin + aInfo.sDocName := PJOB_INFO_2(pBuf).pDocument; + aInfo.sPtrName := PJOB_INFO_2(pBuf).pPrinterName; + aInfo.sDrvName := PJOB_INFO_2(pBuf).pDriverName; + aInfo.bColor := PJOB_INFO_2(pBuf).pDevMode.dmColor = DMCOLOR_COLOR; + aInfo.dwTotalPage := PJOB_INFO_2(pBuf).dwTotalPages; + aInfo.dwCopyCount := PJOB_INFO_2(pBuf).pDevMode.dmCopies; + aInfo.dwScale := PJOB_INFO_2(pBuf).pDevMode.dmScale; + if aInfo.dwScale = 0 then + aInfo.dwScale := 100; + aInfo.bPaperV := PJOB_INFO_2(pBuf).pDevMode.dmOrientation = 1; + aInfo.sPrintProcessor := PJOB_INFO_2(pBuf).pPrintProcessor; + aInfo.sDataType := PJOB_INFO_2(pBuf).pDatatype; + aInfo.dwPaperSizeT := PJOB_INFO_2(pBuf).pDevMode.dmPaperSize; + + case aInfo.dwPaperSizeT of + DMPAPER_LETTER : aInfo.sPaperInfo := 'Letter 8 1/2 x 11 in'; + DMPAPER_LETTERSMALL : aInfo.sPaperInfo := 'Letter Small 8 1/2 x 11 in'; + DMPAPER_TABLOID : aInfo.sPaperInfo := 'Tabloid 11 x 17 in'; + DMPAPER_LEDGER : aInfo.sPaperInfo := 'Ledger 17 x 11 in'; + DMPAPER_LEGAL : aInfo.sPaperInfo := 'Legal 8 1/2 x 14 in'; + DMPAPER_A3 : aInfo.sPaperInfo := 'A3 297 x 420 mm'; + DMPAPER_A4 : aInfo.sPaperInfo := 'A4 210 x 297 mm'; + DMPAPER_A4SMALL : aInfo.sPaperInfo := 'A4 Small 210 x 297 mm'; + DMPAPER_A5 : aInfo.sPaperInfo := 'A5 148 x 210 mm'; + DMPAPER_B4 : aInfo.sPaperInfo := 'B4 (JIS) 250 x 354'; + DMPAPER_B5 : aInfo.sPaperInfo := 'B5 (JIS) 182 x 257 mm'; + DMPAPER_FOLIO : aInfo.sPaperInfo := 'Folio 8 1/2 x 13 in'; + else aInfo.sPaperInfo := Format('ETC (%d) %d x %d', + [aInfo.dwPaperSizeT, PJOB_INFO_2(pBuf).pDevMode.dmPaperWidth, PJOB_INFO_2(pBuf).pDevMode.dmPaperLength]); + end; + + // aInfo.sPaperInfo + try + CopyMemory(@aInfo.DevMode, PJOB_INFO_2(pBuf).pDevMode, SizeOf(aInfo.DevMode)); + except + // .. + end; + Result := true; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetJobDevInfo()'); + end; +end; + +{ TThdPrtSpoolWatch } + +Constructor TThdPrtSpoolWatch.Create(bSync: Boolean; sDeviceName: String; dwWatchMod: DWORD = PRINTER_CHANGE_ALL); + + procedure InitJobFields; + begin + hPrinter_ := 0; + nLastError_ := ERROR_SUCCESS; + evPrtChangeNotifyEvent_ := nil; + evPrtNotifyJobInfoEvent_ := nil; + + arrJobFields_[0] := JOB_NOTIFY_FIELD_PRINTER_NAME; + arrJobFields_[1] := JOB_NOTIFY_FIELD_MACHINE_NAME; + arrJobFields_[2] := JOB_NOTIFY_FIELD_PORT_NAME; + arrJobFields_[3] := JOB_NOTIFY_FIELD_USER_NAME; + arrJobFields_[4] := JOB_NOTIFY_FIELD_NOTIFY_NAME; + arrJobFields_[5] := JOB_NOTIFY_FIELD_DATATYPE; + arrJobFields_[6] := JOB_NOTIFY_FIELD_PRINT_PROCESSOR; + arrJobFields_[7] := JOB_NOTIFY_FIELD_PARAMETERS; + arrJobFields_[8] := JOB_NOTIFY_FIELD_DRIVER_NAME; + arrJobFields_[9] := JOB_NOTIFY_FIELD_DEVMODE; + arrJobFields_[10] := JOB_NOTIFY_FIELD_STATUS; + arrJobFields_[11] := JOB_NOTIFY_FIELD_STATUS_STRING; + arrJobFields_[12] := JOB_NOTIFY_FIELD_DOCUMENT; + arrJobFields_[13] := JOB_NOTIFY_FIELD_PRIORITY; + arrJobFields_[14] := JOB_NOTIFY_FIELD_POSITION; + arrJobFields_[15] := JOB_NOTIFY_FIELD_SUBMITTED; + arrJobFields_[16] := JOB_NOTIFY_FIELD_START_TIME; + arrJobFields_[17] := JOB_NOTIFY_FIELD_UNTIL_TIME; + arrJobFields_[18] := JOB_NOTIFY_FIELD_TIME; + arrJobFields_[19] := JOB_NOTIFY_FIELD_TOTAL_PAGES; + arrJobFields_[20] := JOB_NOTIFY_FIELD_PAGES_PRINTED; + arrJobFields_[21] := JOB_NOTIFY_FIELD_TOTAL_BYTES; + arrJobFields_[22] := JOB_NOTIFY_FIELD_BYTES_PRINTED; + + arrPNOT_[0].wType := JOB_NOTIFY_TYPE; + arrPNOT_[0].Reserved0 := 0; + arrPNOT_[0].Reserved1 := 0; + arrPNOT_[0].Reserved2 := 0; + arrPNOT_[0].Count := SizeOf(arrJobFields_) div SizeOf(arrJobFields_[0]); + arrPNOT_[0].pFields := @arrJobFields_; + + ZeroMemory(@PNO_, SizeOf(PNO_)); + PNO_.Version := 2; + PNO_.Flags := PRINTER_NOTIFY_OPTIONS_REFRESH; + PNO_.Count := SizeOf(arrPNOT_) div SizeOf(arrPNOT_[0]); + PNO_.pTypes := @arrPNOT_; + end; + +//var +// PD: PRINTER_DEFAULTS; + +begin + Inherited Create; + + bSync_ := bSync; + FreeOnTerminate := true; + + JobList_ := TDictionary<DWORD,TPrtJobInfo>.Create; + JobList_.OnValueNotify := OnJobValue; + + dwChangeMod_ := dwWatchMod; + sDeviceName_ := sDeviceName; + + InitJobFields; + + hPrtChangeEvent_ := INVALID_HANDLE_VALUE; + hPrinter_ := 0; + +// PD.pDatatype := nil; +// PD.pDevMode := nil; +// PD.DesiredAccess := PRINTER_ALL_ACCESS; + + if OpenPrinter(PChar(sDeviceName_), hPrinter_, nil{@PD}) then + begin + hPrtChangeEvent_ := FindFirstPrinterChangeNotification(hPrinter_, + dwChangeMod_, + 0, + @PNO_); + if hPrtChangeEvent_ = INVALID_HANDLE_VALUE then + begin + nLastError_ := 2; + exit; + end; + + sSpoolDir_ := GetPrinterSpoolDir(hPrinter_); + if sSpoolDir_ = '' then + nLastError_ := 3; + end else + nLastError_ := 1; +end; + +Destructor TThdPrtSpoolWatch.Destroy; +begin + if hPrtChangeEvent_ <> INVALID_HANDLE_VALUE then + FindClosePrinterChangeNotification(hPrtChangeEvent_); + + if hPrinter_ <> 0 then + ClosePrinter(hPrinter_); + + FreeAndNil(JobList_); + + Inherited; +end; + +procedure TThdPrtSpoolWatch.StopThread; +begin + Inherited; + + if hPrtChangeEvent_ <> 0 then + SetEvent(hPrtChangeEvent_); +end; + +procedure TThdPrtSpoolWatch.OnJobValue(Sender: TObject; const Item: TPrtJobInfo; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Item.Free; + cnExtracted: ; + end; +end; + +procedure TThdPrtSpoolWatch.ProcessChangeEvent; +begin + if Assigned(evPrtChangeNotifyEvent_) then + evPrtChangeNotifyEvent_(Self, dwChangeMod_); +end; + +procedure TThdPrtSpoolWatch.ProcessNotifyJobInfoEvent; +begin + if Assigned(evPrtNotifyJobInfoEvent_) then + evPrtNotifyJobInfoEvent_(Self, PrtJobInfo_); +end; + +procedure TThdPrtSpoolWatch.Execute; + + procedure DeletePrtJob; + var + dwNumJobs, + dwByteNeeded: DWORD; + pJobs: PPrtJobs; + pJob: TJobInfo1; + p: TPrtJobInfo; + n, c: Integer; + bFind: Boolean; + enum: TEnumerator<TPrtJobInfo>; + begin + EnumJobs(hPrinter_, 0, MAX_JOB, 1, nil, 0, dwByteNeeded, dwNumJobs); + pJobs := AllocMem(dwByteNeeded); + try + dwNumJobs := 0; + if EnumJobs(hPrinter_, 0, MAX_JOB, 1, pJobs, 0, dwByteNeeded, dwNumJobs) then + begin + if dwNumJobs > 0 then + begin + bFind := false; + + Guard(enum, JobList_.Values.GetEnumerator); + while enum.MoveNext do + begin + p := enum.Current; + + for c := 0 to dwNumJobs - 1 do + begin + pJob := pJobs[c]; + if pJob.JobId = p.ID then + begin + bFind := true; + break; + end; + end; + + if not bFind then + begin + JobList_.Remove(p.dwID_); + exit; + end; + end; + end else + JobList_.Clear; + end; + + finally + FreeMem(pJobs, dwByteNeeded); + end; + end; + +var + i: Integer; + dwJobID, + dwOldFlags: DWORD; + PNI: PPrinterNotifyInfo; + pData: PPrinterNotifyInfoData; +begin + while not Terminated and not bWorkStop_ and (hPrtChangeEvent_ <> INVALID_HANDLE_VALUE) do + begin + PNI := nil; + dwChangeMod_ := 0; + try + case WaitForSingleObject(hPrtChangeEvent_, INFINITE) of + WAIT_OBJECT_0 : + begin + if Terminated or bWorkStop_ then + break; + + if not FindNextPrinterChangeNotification(hPrtChangeEvent_, + dwChangeMod_, + @PNO_, + Pointer(PNI)) then + begin + _Trace('Fail .. FindNextPrinterChangeNotification(), PrtName=%s, Error=%d', [sDeviceName_, GetLastError]); + continue; + end; + + if Assigned(evPrtChangeNotifyEvent_) then + begin + if bSync_ then + Synchronize(ProcessChangeEvent) + else + evPrtChangeNotifyEvent_(Self, dwChangeMod_); + end; + + if PNI <> nil then + try + if (PNI.Flags and PRINTER_NOTIFY_INFO_DISCARDED) <> 0 then + begin + dwOldFlags := PNO_.Flags; + PNO_.Flags := PRINTER_NOTIFY_OPTIONS_REFRESH; + + FreePrinterNotifyInfo(PNI); + + FindNextPrinterChangeNotification(hPrtChangeEvent_, + dwChangeMod_, + @PNO_, + Pointer(PNI)); + + PNO_.Flags := dwOldFlags; + end; + + PrtJobInfo_ := nil; + + for i := 0 to Integer(PNI.Count) - 1 do + begin + pData := PPrinterNotifyInfoData(ULONGLONG(@PNI.aData) + (SizeOf(TPrinterNotifyInfoData) * i)); + dwJobID := pData.Id; + {$IFDEF DEBUG} + ASSERT(pData.wType = JOB_NOTIFY_TYPE); + {$ENDIF} + if JobList_.ContainsKey(dwJobID) then + PrtJobInfo_ := JobList_[dwJobID] + else + PrtJobInfo_ := nil; + + if not Assigned(PrtJobInfo_) then + begin + {$IFDEF DEBUG} + ASSERT(not (dwChangeMod_ and PRINTER_CHANGE_ADD_JOB) <> 0); + {$ELSE} + if not ((dwChangeMod_ and PRINTER_CHANGE_ADD_JOB) <> 0) then + break; + {$ENDIF} + PrtJobInfo_ := TPrtJobInfo.Create(hPrinter_, dwJobID); + JobList_.Add(dwJobID, PrtJobInfo_); + end else begin + PrtJobInfo_.PtrJobState := jsWork; + // job이 해제되는걸 이런식으로 판단하게 한다.. + // 안그러면 계속 쌓이는데 job이 종료되는 시점을 분간할 방법이 없네;; 2011-07-25 kku + if (dwChangeMod_ and PRINTER_CHANGE_DELETE_JOB) <> 0 then + begin + PrtJobInfo_.PtrJobState := jsDelete; + end; + PrtJobInfo_.UpdatePrtFieldInfo(pData^); + + // JOB_NOTIFY_FIELD_SUBMITTED 이거 올때까지 값을 채워준다. 22_0719 13:18:58 kku + if pData.Field <> JOB_NOTIFY_FIELD_SUBMITTED then + continue; + + if Assigned(evPrtNotifyJobInfoEvent_) then + begin + if bSync_ then + Synchronize(ProcessNotifyJobInfoEvent) + else + evPrtNotifyJobInfoEvent_(Self, PrtJobInfo_); + end; + end; + end; + + if (dwChangeMod_ and PRINTER_CHANGE_DELETE_JOB) <> 0 then + DeletePrtJob; + finally + FreePrinterNotifyInfo(PNI); + PNI := nil; + end; + end else break; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. Execute()'); + end; + Sleep(50); + end; +end; + +{ TTgPrtSpoolWatch } + +Constructor TTgPrtSpoolWatch.Create(bSync: Boolean; dwWatchMod: DWORD = PRINTER_CHANGE_ALL); +begin + Inherited Create; + bIsWatch_ := false; + bSync_ := bSync; + dwWatchMod_ := dwWatchMod; + PrtList_ := TStringList.Create; + PrtList_.CaseSensitive := false; + WatchThdList_ := TList<TThdPrtSpoolWatch>.Create; + WatchThdList_.OnNotify := OnPrtNotify; +end; + +Destructor TTgPrtSpoolWatch.Destroy; +begin + StopPrtWatch; + Inherited; + FreeAndNil(WatchThdList_); + FreeAndNil(PrtList_); +end; + +procedure TTgPrtSpoolWatch.OnPrtNotify(Sender: TObject; const Item: TThdPrtSpoolWatch; Action: TCollectionNotification); +var + nStep: Integer; +begin + nStep := 0; + try + case Action of + cnAdded: ; + cnRemoved: + begin + nStep := 1; + Item.StopThread; + nStep := 2; + Item.Terminate; + nStep := 3; + // Item.Free; + end; + cnExtracted: ; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. OnPrtNotify() .. Step=%d', [nStep]); + end; +end; + +procedure TTgPrtSpoolWatch.StartPrtWatch; +var + i: Integer; + thd: TThdPrtSpoolWatch; +begin + try + if Terminated or GetWorkStop then + exit; + + if not bIsWatch_ then + begin + _Trace('StartPrtWatch() ..', 5); + PrtList_.Clear; + PrtList_.AddStrings(Printer.Printers); + + for i := 0 to PrtList_.Count - 1 do + begin + thd := TThdPrtSpoolWatch.Create(bSync_, PrtList_[i], dwWatchMod_); + if thd.LastError = ERROR_SUCCESS then + begin + WatchThdList_.Add(thd); + + thd.OnPrtChangeNotifyEvent := evPrtChangeNotifyEvent_; + thd.OnPrtNotifyJobInfoEvent := evPtrNotifyInfoEvent_; + thd.StartThread; + end else + FreeAndNil(thd); + end; + + bIsWatch_ := true; + _Trace('StartPrtWatch() .. OK', 5); + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. StartWatch()'); + end; +end; + +procedure TTgPrtSpoolWatch.StopPrtWatch; +begin + try + if Terminated or GetWorkStop then + exit; + + if bIsWatch_ then + begin + _Trace('StopPrtWatch() ..', 5); + bIsWatch_ := false; + WatchThdList_.Clear; + _Trace('StopPrtWatch() .. OK', 5); + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. StopWatch()'); + end; +end; + +procedure TTgPrtSpoolWatch.Execute; +var + llTick, + llChkTick: ULONGLONG; + ChkPrtList: TStringList; + i: Integer; +begin + llChkTick := GetTickCount64; + Guard(ChkPrtList, TStringList.Create); + ChkPrtList.CaseSensitive := false; + while not Terminated and not GetWorkStop do + begin + try + case GetServiceStatus('Spooler') of + SERVICE_RUNNING : + begin + if bIsWatch_ then + begin + llTick := GetTickCount64; + if (llTick - llChkTick) >= 3000 then // 3초에 한번 프린터 변동사항 체크 25_0827 10:31:17 kku + begin + llChkTick := llTick; + + var Prt: TPrinter; + Guard(Prt, TPrinter.Create); + ChkPrtList.Clear; + ChkPrtList.AddStrings(Prt.Printers); + + if PrtList_.Count <> ChkPrtList.Count then + begin + // 추가된 프린터 체크 + for i := ChkPrtList.Count - 1 downto 0 do + begin + if PrtList_.IndexOf(ChkPrtList[i]) = -1 then + begin + _Trace('Printer 추가됨 .. Name=%s', [ChkPrtList[i]], 1); + var thd: TThdPrtSpoolWatch := TThdPrtSpoolWatch.Create(bSync_, ChkPrtList[i], dwWatchMod_); + if thd.LastError = ERROR_SUCCESS then + begin + WatchThdList_.Add(thd); + + thd.OnPrtChangeNotifyEvent := evPrtChangeNotifyEvent_; + thd.OnPrtNotifyJobInfoEvent := evPtrNotifyInfoEvent_; + thd.StartThread; + end else begin + _Trace('Fail .. Printer 감시 활성화 실패 .. Name=%s', [ChkPrtList[i]], 1); + ChkPrtList.Delete(i); + FreeAndNil(thd); + end; + end; + end; + + // 제거된 프린터 체크 + for i := 0 to PrtList_.Count - 1 do + begin + if ChkPrtList.IndexOf(PrtList_[i]) = -1 then + begin + var c: Integer; + for c := 0 to WatchThdList_.Count - 1 do + begin + if CompareText(WatchThdList_[c].sDeviceName_, PrtList_[i]) = 0 then + begin + _Trace('Printer 제거됨 .. Name=%s', [PrtList_[i]], 1); + WatchThdList_.Delete(c); + break; + end; + end; + end; + end; + + PrtList_.Clear; + PrtList_.AddStrings(ChkPrtList); + end; + end; + end else begin + _Trace('Print Spooler 서비스 감지됨.', 1); + StartPrtWatch; + end; + end; + SERVICE_STOPPED : + begin + if bIsWatch_ then + begin + _Trace('Print Spooler 서비스 중지됨.', 1); + StopPrtWatch; + end; + end; + end; + + Sleep(1000); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. Execute()'); + end; + end; +end; + +//------------------------------------------------------------------------------ + +{ TPrintersInfo } + +Constructor TPrintersInfo.Create; +begin + Inherited Create; + PrtInfoList_ := TPrtInfoList.Create; + PrtInfoList_.OnNotify := OnPrtInfoNotify; +end; + +Destructor TPrintersInfo.Destroy; +begin + FreeAndNil(PrtInfoList_); + Inherited; +end; + +procedure TPrintersInfo.OnPrtInfoNotify(Sender: TObject; const Item: PPrinterInfo; Action: TCollectionNotification); +begin + if Action = cnRemoved then + Dispose(Item); +end; + +function TPrintersInfo.GetPrtInfoByPrtName(const sPrtName: String): PPrinterInfo; +var + i: Integer; +begin + Result := nil; + try + for i := 0 to PrtInfoList_.Count - 1 do + begin + if CompareText(sPrtName, PrtInfoList_[i].sPrtName) = 0 then + begin + Result := PrtInfoList_[i]; + exit; + end; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. GetPrtInfoByPrtName()'); + end; +end; + +procedure TPrintersInfo.RefreshList; +var + pEnt: PPrinterInfo; + Reg: TRegistry; + + procedure FillPrinterDetails; + var + sRegKey: string; + printHandle: THandle; + pPrinterInfo: PPrinterInfo2; + bytesNeeded: DWORD; + begin + try + Reg.CloseKey; + sRegKey := 'SYSTEM\CurrentControlSet\Control\Print\Printers\' + pEnt.sPrtName; + if Reg.OpenKeyReadOnly(sRegKey) then + begin + pEnt.sDrvName := Reg.ReadString('Printer Driver'); + pEnt.sPortName := Reg.ReadString('Port'); + end; + + // WSD ports + if pEnt.sPortName <> '' then + begin + Reg.CloseKey; + sRegKey := 'SYSTEM\CurrentControlSet\Control\Print\Monitors\WSD Port\Ports\' + pEnt.sPortName; + if Reg.KeyExists(sRegKey) then + begin + pEnt.sIp := pEnt.sPortName; + pEnt.PortType := PTWsd; + end else begin + Reg.CloseKey; + sRegKey := 'SYSTEM\CurrentControlSet\Control\Print\Monitors\Standard TCP/IP Port\Ports\' + pEnt.sPortName; + if Reg.OpenKeyReadOnly(sRegKey) then + begin + pEnt.PortType := PTTcpIp; + end + end; + end; + + //절약 모드 및 공유 PC 여부 확인 + pPrinterInfo:= nil; + try + if not OpenPrinter(PChar(pEnt.sPrtName), printHandle, nil) then + Exit; + + GetPrinter(printHandle, 2, nil, 0, @bytesNeeded); + if (GetLastError <> ERROR_INSUFFICIENT_BUFFER) or (bytesNeeded = 0) then + Exit; + + GetMem(pPrinterInfo, bytesNeeded); + if GetPrinter(printHandle, 2, pPrinterInfo, bytesNeeded, @bytesNeeded) then + begin + pEnt.dwStatus := pPrinterInfo.Status; + + if ((pPrinterInfo.Attributes and PRINTER_ATTRIBUTE_NETWORK) <> 0) and + ((pPrinterInfo.Attributes and PRINTER_ATTRIBUTE_SHARED) <> 0) and + (pPrinterInfo.pShareName <> nil) then + begin + pEnt.PortType := PTShared; + pEnt.sIp:= pPrinterInfo.pShareName; + end; + + if (pEnt.dwStatus and PRINTER_STATUS_POWER_SAVE) <> 0 then + pEnt.bIsPowerSaveMode:= True; + end; + + if pEnt.PortType = ptUnknown then + begin + pEnt.PortType := PTLocal; + end; + finally + if pPrinterInfo <> nil then + FreeMem(pPrinterInfo); + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. RefreshList() .. FillPrinterDetails()'); + end; + end; + +var + pPrinters, pCurrentPrinter: PPrinterInfo2; + dwPrinters, dwReturned: DWORD; + i: Integer; + portTypeStr: string; + debug: string; +begin + try + PrtInfoList_.Clear; + + EnumPrinters(PRINTER_ENUM_LOCAL or PRINTER_ENUM_CONNECTIONS, nil, 2, nil, 0, dwPrinters, dwReturned); + if dwPrinters = 0 then + begin + _Trace('Fail .. RefreshList() .. EnumPrinters()', 1); + exit; + end; + + Guard(Reg, TRegistry.Create); + Reg.RootKey := HKEY_LOCAL_MACHINE; + GetMem(pPrinters, dwPrinters); + try + if EnumPrinters(PRINTER_ENUM_LOCAL or PRINTER_ENUM_CONNECTIONS, nil, 2, pPrinters, dwPrinters, dwPrinters, dwReturned) then + begin + pCurrentPrinter := pPrinters; + for i := 0 to dwReturned - 1 do + begin + New(pEnt); + ZeroMemory(pEnt, SizeOf(TPrinterInfo)); + pEnt.sPrtName := pCurrentPrinter.pPrinterName; + pEnt.sDrvName := pCurrentPrinter.pDriverName; + pEnt.dwStatus := pCurrentPrinter.Status; + pEnt.sPortName := pCurrentPrinter.pPortName; + FillPrinterDetails; + + PrtInfoList_.Add(pEnt); + + //디버그 로깅 +// mmo1.Lines.Add(Format('--- Printer [%d]: %s ---', [i, SafePChar(pCurrentPrinter.pPrinterName)])); +// mmo1.Lines.Add(Format(' pServerName: %s', [SafePChar(pCurrentPrinter.pServerName)])); +// mmo1.Lines.Add(Format(' pShareName: %s', [SafePChar(pCurrentPrinter.pShareName)])); +// mmo1.Lines.Add(Format(' pPortName: %s', [SafePChar(pCurrentPrinter.pPortName)])); +// mmo1.Lines.Add(Format(' pDriverName: %s', [SafePChar(pCurrentPrinter.pDriverName)])); +// mmo1.Lines.Add(Format(' pComment: %s', [SafePChar(pCurrentPrinter.pComment)])); +// mmo1.Lines.Add(Format(' pLocation: %s', [SafePChar(pCurrentPrinter.pLocation)])); +// mmo1.Lines.Add(Format(' Attributes: 0x%x', [pCurrentPrinter.Attributes])); +// mmo1.Lines.Add(Format(' Status: 0x%x', [pCurrentPrinter.Status])); +// mmo1.Lines.Add(Format(' cJobs: %d', [pCurrentPrinter.cJobs])); +// mmo1.Lines.Add(Format('--------------------', [])); + +// case printerDetails.portType of +// PTLocal: portTypeStr := '로컬'; +// PTTcpIp: portTypeStr := 'TCP/IP'; +// PTWsd: portTypeStr := 'WSD PORT'; +// PTShared: portTypeStr := '공유PC'; +// else +// portTypeStr := '알 수 없음'; +// end; +// +// listItem := lvPrinters.Items.Add; +// listItem.Caption := printerDetails.deviceName; +// listItem.SubItems.Add(portTypeStr); +// listItem.SubItems.Add(printerDetails.ip); +// if printerDetails.isPowerSaveMode then +// listItem.SubItems.Add('예') +// else +// listItem.SubItems.Add('아니요'); +// listItem.SubItems.Add(printerDetails.driverName); +// listItem.SubItems.Add(printerDetails.portName); +// listItem.SubItems.Add(Format('0x%x', [printerDetails.status])); + + Inc(pCurrentPrinter); + end; + end; + finally + FreeMem(pPrinters); + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. RefreshList()'); + end; +end; + +procedure TPrintersInfo.SaveToFile(const sPath: String); +var + O, OA: ISuperObject; + i: Integer; +begin + try + OA := TSuperObject.Create(stArray); + + for i := 0 to PrtInfoList_.Count - 1 do + begin + OA.AsArray.Add(TTgJson.ValueToJsonObject<TPrinterInfo>(PrtInfoList_[i]^)); + end; + + O := SO; + O.O['List'] := OA; + SaveJsonObjToFile(O, sPath); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. SaveToFile()'); + end; +end; + +procedure TPrintersInfo.LoadFromFile(const sPath: String); +var + O: ISuperObject; + i: Integer; + pEnt: PPrinterInfo; +begin + try + PrtInfoList_.Clear; + if LoadJsonObjFromFile(O, sPath) then + begin + if (O.O['List'] = nil) or (O.O['List'].DataType <> stArray) then + exit; + + for i := 0 to O.A['List'].Length - 1 do + begin + New(pEnt); +// ZeroMemory(pEnt, SizeOf(PPrinterInfo)); + pEnt^ := TTgJson.GetDataAsType<TPrinterInfo>(O.A['List'].O[i]); + PrtInfoList_.Add(pEnt); + end; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. SaveToFile()'); + end; +end; + +//------------------------------------------------------------------------------ + +function GetDefaultPrinterName: string; +var + arrBuf: array[0..255] of Char; + dwSize: DWORD; +begin + dwSize := SizeOf(arrBuf); + if GetDefaultPrinter(@arrBuf, @dwSize) then + Result := StrPas(arrBuf) + else + Result := 'Unknown'; +end; + +function GetProcessNameByPrtDocName(sDocName: String): String; +var + sExt: String; +begin + Result := ''; + try + sDocName := LowerCase(sDocName); + if sDocName.StartsWith('microsoft powerpoint -') then + begin + Result := 'POWERPNT.EXE'; + exit; + end else + if sDocName.StartsWith('microsoft word -') then + begin + Result := 'WINWORD.EXE'; + exit; + end; + + sExt := GetFileExt(sDocName); + if (sExt = 'xls') or (sExt = 'xlsx') then + begin + Result := 'EXCEL.EXE'; + exit; + end else + if (sExt = 'hwp') or (sExt = 'hwpx') then + begin + Result := 'hwp.exe'; + exit; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetProcessNameByPrtDocName()'); + end; +end; + +function PrinterDriverToName(sDrvName: String): String; +var + dwFlags: DWORD; + pBuf: TBytes; + dwNeed, dwPrtCnt: DWORD; + pInfo: PPrinterInfo2; + i: Integer; +begin + Result := 'Unknown'; + try + dwNeed := 0; + dwPrtCnt := 0; + dwFlags := PRINTER_ENUM_LOCAL or PRINTER_ENUM_CONNECTIONS; + if not EnumPrinters(dwFlags, nil, 2, nil, 0, dwNeed, dwPrtCnt) then + begin +// LogToReg('PrinterDriverToName2222-01 .. Error', IntToStr(GetLastError)); +// exit; + end; + if dwNeed > 0 then + begin + SetLength(pBuf, dwNeed); + end else exit; + if not EnumPrinters(dwFlags, nil, 2, @pBuf[0], dwNeed, dwNeed, dwPrtCnt) then + begin + exit; + end; + + if dwPrtCnt > 0 then + begin + pInfo := PPrinterInfo2(@pBuf[0]); + for i := 0 to dwPrtCnt - 1 do + begin + if CompareText(pInfo.pDriverName, sDrvName) = 0 then + begin + Result := StrPas(pInfo.pPrinterName); + exit; + end; + Inc(pInfo); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. PrinterDriverToName()'); + end; +end; + +function PrinterDriverToIP(sDrvName: String): String; +var + dwFlags: DWORD; + pBuf: TBytes; + dwNeed, dwPrtCnt: DWORD; + pInfo: PPrinterInfo2; + i: Integer; +begin + Result := 'Unknown'; + try + dwNeed := 0; + dwPrtCnt := 0; + dwFlags := PRINTER_ENUM_LOCAL or PRINTER_ENUM_CONNECTIONS; + if not EnumPrinters(dwFlags, nil, 2, nil, 0, dwNeed, dwPrtCnt) then + begin +// LogToReg('PrinterDriverToName2222-01 .. Error', IntToStr(GetLastError)); +// exit; + end; + if dwNeed > 0 then + begin + SetLength(pBuf, dwNeed); + end else exit; + if not EnumPrinters(dwFlags, nil, 2, @pBuf[0], dwNeed, dwNeed, dwPrtCnt) then + begin + exit; + end; + + if dwPrtCnt > 0 then + begin + pInfo := PPrinterInfo2(@pBuf[0]); + for i := 0 to dwPrtCnt - 1 do + begin + if CompareText(pInfo.pDriverName, sDrvName) = 0 then + begin + Result := StrPas(pInfo.pPortName); + exit; + end; + Inc(pInfo); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. PrinterDriverToName()'); + end; +end; + +function IsPJL(const sPath: String): Boolean; +begin + try + if FileExists(sPath) then + Result := CheckSign(sPath, @SIG_PJL, Length(SIG_PJL)) + else Result := false; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsPJL()'); + end; +end; + +function GetQtyFromPJL(const sPath: String; var bCollate: Boolean): Integer; +var + fs: TFileStream; + pBuf: TBytes; + sText: AnsiString; + nRead, nCopy: Integer; +begin + bCollate := true; // 기본 "한부씩 인쇄 설정" + Result := 0; + try + if not IsPJL(sPath) then + exit; + + Guard(fs, TFileStream.Create(sPath, fmOpenRead or fmShareDenyNone)); + // 앞부분 4KB만 읽기 + SetLength(pBuf, 4096); + nRead := fs.Read(pBuf[0], Length(pBuf)); + if nRead = 0 then + exit; + + // TBytes → AnsiString 변환 + SetString(sText, PAnsiChar(@pBuf[0]), nRead); + + Result := StrToIntDef(GetCapsuleStr('@PJL SET QTY=', #10, UpperCase(sText)), 0); + nCopy := StrToIntDef(GetCapsuleStr('@PJL SET COPIES=', #10, UpperCase(sText)), 0); + if nCopy > Result then + begin + // 한부씩 인쇄 안함을 사용할 경우 COPIES 값에 부수 정보가 들어가는거 같다? 25_0904 16:51:06 kku + Result := nCopy; + bCollate := false; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetQtyFromPJL()'); + end; +end; + +function IsPJLAndLanguagePLW(const sPath: string): Boolean; +var + fs: TFileStream; + pBuf: TBytes; + sText: AnsiString; + nRead: Integer; +begin + Result := false; + try + if not IsPJL(sPath) then + exit; + + Guard(fs, TFileStream.Create(sPath, fmOpenRead or fmShareDenyNone)); + // 앞부분 4KB만 읽기 + SetLength(pBuf, 4096); + nRead := fs.Read(pBuf[0], Length(pBuf)); + if nRead = 0 then + exit; + + // TBytes → AnsiString 변환 + SetString(sText, PAnsiChar(@pBuf[0]), nRead); + + // LANGUAGE=PLW 존재 여부 확인 + if Pos('@PJL ENTER LANGUAGE=PLW', UpperCase(string(sText))) > 0 then + Result := true; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsPJLAndLanguagePLW()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Process.IPC.pas b/Tocsg.Lib/VCL/Tocsg.Process.IPC.pas new file mode 100644 index 00000000..583b183c --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Process.IPC.pas @@ -0,0 +1,1119 @@ +{*******************************************************} +{ } +{ Tocsg.Process.IPC } +{ } +{ Copyright (C) 2023 kku } +{ } +{*******************************************************} + +unit Tocsg.Process.IPC; + +interface + +uses + Tocsg.Obj, System.Classes, System.SysUtils, Winapi.Windows, + Winapi.Messages, System.Generics.Collections, System.SyncObjs, Tocsg.Packet, + Tocsg.Exception; + +const + WM_WND_HANDSHAKE = WM_USER + 4632; + + W2W_SENDFILE_INIT = 10; + W2W_SENDFILE_DATA = 11; + W2W_SENDFILE_COMPLETE = 12; + +type + PWndDataEnt = ^TWndDataEnt; + TWndDataEnt = record + llSender: LONGLONG; + pBuf: Pointer; + dwLen, + dwData: DWORD; + end; + TWndDataEntQueue = TQueue<PWndDataEnt>; + + PW2wLinkProc = ^TW2wLinkProc; + TW2wLinkProc = record +// dwPid: DWORD; + hRcvWnd: HWND; + end; + TW2wLinkProcList = class(TList<PW2wLinkProc>) + protected + procedure Notify(const Item: PW2wLinkProc; Action: TCollectionNotification); override; + end; + TW2wLinkProcEnumerator = TEnumerator<PW2wLinkProc>; + + TW2wConnState = (wcsConnect, wcsDisconnect); + TEventWnd2WndConnection = procedure(Sender: TTgObject; aState: TW2wConnState; hRcvWnd: HWND) of object; + TTgWnd2Wnd = class(TTgObject) + private + CS_: TCriticalSection; + hRcvWnd_: HWND; + qDataEnts_: TWndDataEntQueue; + evW2WConnected_: TEventWnd2WndConnection; +// {$IFDEF _IPC_TEST_} +// LinkProcList_: TW2wLinkProcList; +// procedure AddLinkProc(hRcvWnd: HWND); +// {$ENDIF} + procedure Lock; + procedure Unlock; + procedure OnWndDataNotify(Sender: TObject; const Item: PWndDataEnt; Action: TCollectionNotification); + procedure SetEventW2WConnected(evVal: TEventWnd2WndConnection); + procedure ProcessWindowMessage(var msg: TMessage); virtual; + public + Constructor Create(sClassName: String; hInst: HMODULE = 0); + Destructor Destroy; override; + + procedure ClearQueue; + function DeququeData: PWndDataEnt; + function SendData(hTargetWnd: HWND; pBuf: Pointer; dwLen: DWORD; dwData: DWORD = 0): Boolean; overload; + function SendData(hTargetWnd: HWND; aSend: ISendPacket; dwData: DWORD = 0): Boolean; overload; + function SendData(hTargetWnd: HWND; sSend: String; dwData: DWORD = 0): Boolean; overload; + +// {$IFDEF _IPC_TEST_} +// function GetLinkProcEnumerator: TW2wLinkProcEnumerator; +// {$ENDIF} + + property RcWnd: HWND read hRcvWnd_; + property OnW2WConnection: TEventWnd2WndConnection write SetEventW2WConnected; + end; + +// ....\DropBox\....\네임드 파이프 (NamedPipe)\NamedPipeExchange-master.zip 참조 +const + MaxBuffSize = MAXWORD; + + BLOCK_BUF_LEN = 60000; + +type + ETgNamedPipe = class(ETgException); + TTgNpBase = class; + TEventNpNotification = procedure(Sender: TTgNpBase; hPipe: THandle) of object; + + TTgNpBase = class(TTgObject) + protected + bIsServer_: Boolean; + sPipeName_: String; + evConnected_: TEventNpNotification; + evDisconnected_: TEventNpNotification; + procedure ProcessFail(hPipe: THandle); virtual; abstract; + function _SendData(hTgPipe: THandle; pData: Pointer; dwLen: DWORD): Boolean; + function _RcvData(hTgPipe: THandle; var pBuf: TBytes): DWORD; + public + Constructor Create(sPipeName: String); virtual; + +// function SendData(sData: UTF8String): Boolean; overload; + function SendData(aSend: ISendPacket): Boolean; virtual; abstract; + function RcvData(var pBuf: TBytes): DWORD; virtual; abstract; + + property IsServer: Boolean read bIsServer_; + property PipeName: String read sPipeName_; + property OnConnected: TEventNpNotification write evConnected_; + property OnDisconnected: TEventNpNotification write evDisconnected_; + end; + + TClientPipeList = TList<THandle>; + TTgNpServer = class(TTgNpBase) + private + bActive_: Boolean; + hEvent_: THandle; + hWaitPipe_: THandle; + ConnOvrl_: TOverlapped; + PipeList_: TClientPipeList; + CS_: TCriticalSection; + enumRcv_: TEnumerator<THandle>; + hLastRcvPipe_: THandle; + + procedure Lock; + procedure Unlock; + procedure OnClientPipeNotify(Sender: TObject; const Item: THandle; Action: TCollectionNotification); + function CreatePipeInstance(out hPipe: THandle; bAsync: Boolean = false): Boolean; + procedure SetPipeClientEnt(hPipe: THandle); + protected + procedure ProcessFail(hPipe: THandle); override; + public + Constructor Create(sPipeName: String); override; + Destructor Destroy; override; + + function Listen: Boolean; + procedure Close; + function DoAcceptPipe: Boolean; + + function SendData(aSend: ISendPacket): Boolean; override; + function RcvData(var pBuf: TBytes): DWORD; override; + + property Active: Boolean read bActive_; + property LastRcvPipe: THandle read hLastRcvPipe_; + end; + + TTgNpClient = class(TTgNpBase) + private + bConnected_: Boolean; + hConnPipe_: THandle; + protected + procedure ProcessFail(hPipe: THandle); override; + public + Constructor Create(sPipeName: String); override; + Destructor Destroy; override; + + function Connect: Boolean; + procedure Disconnect; + + function SendData(aSend: ISendPacket): Boolean; override; + function RcvData(var pBuf: TBytes): DWORD; override; + end; + +implementation + +uses + Tocsg.Param, Tocsg.Safe; + +{ TW2wLinkProcList } + +procedure TW2wLinkProcList.Notify(const Item: PW2wLinkProc; Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +{ TTgWnd2Wnd } + +function AllocateHWnd_kku(const AMethod: TWndMethod; sClassName: String; hInst: HMODULE): HWND; +var + UtilWindowClass, TempClass: TWndClass; + ClassRegistered: Boolean; +begin + Result := 0; + try + ZeroMemory(@UtilWindowClass, SizeOf(UtilWindowClass)); + UtilWindowClass.lpfnWndProc := @DefWindowProc; + UtilWindowClass.lpszClassName := PChar(sClassName); + UtilWindowClass.hInstance := HInstance; +// UtilWindowClass.cbWndExtra := SizeOf(TMethod); + + ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName, + TempClass); + if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then + begin + if ClassRegistered then + Winapi.Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance); + Winapi.Windows.RegisterClass(UtilWindowClass); + end; + Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName, + '', WS_POPUP {+ 0}, 0, 0, 0, 0, 0, 0, HInstance, nil); + if Assigned(AMethod) then + SetWindowLongPtr(Result, GWL_WNDPROC, IntPtr(MakeObjectInstance(AMethod))); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. AllocateHWnd_kku()'); + end; +end; + +Constructor TTgWnd2Wnd.Create(sClassName: String; hInst: HMODULE = 0); +begin + CS_ := TCriticalSection.Create; + Inherited Create; + + if sClassName = '' then + sClassName := 'TTgWnd2Wnd'; + + if hInst = 0 then + hInst := HInstance; + evW2WConnected_ := nil; +//{$IFDEF _IPC_TEST_} +// LinkProcList_ := TW2wLinkProcList.Create; +//{$ENDIF} + qDataEnts_ := TWndDataEntQueue.Create; + + ChangeWindowMessageFilter(WM_WND_HANDSHAKE, MSGFLT_ADD); + ChangeWindowMessageFilter(WM_COPYDATA, MSGFLT_ADD); + hRcvWnd_ := AllocateHWnd_kku(ProcessWindowMessage, sClassName, hInst); + if hRcvWnd_ = 0 then + begin + _Trace('Fail .. No Allocate HWND'); +// raise ETgException.Create('Fail .. AllocateHWnd()'); + end; +end; + +Destructor TTgWnd2Wnd.Destroy; +begin + if hRcvWnd_ <> 0 then + begin + DeallocateHWnd(hRcvWnd_); + hRcvWnd_ := 0; + end; + qDataEnts_.OnNotify := OnWndDataNotify; + FreeAndNil(qDataEnts_); +//{$IFDEF _IPC_TEST_} +// FreeAndNil(LinkProcList_); +//{$ENDIF} + Inherited; + FreeAndNil(CS_); +end; + +procedure TTgWnd2Wnd.Lock; +begin + CS_.Acquire; +end; + +procedure TTgWnd2Wnd.Unlock; +begin + CS_.Release; +end; + +procedure TTgWnd2Wnd.OnWndDataNotify(Sender: TObject; const Item: PWndDataEnt; Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: + begin + if Item.pBuf <> nil then + FreeMem(Item.pBuf, Item.dwLen); + end; + cnExtracted: ; + end; +end; + +procedure TTgWnd2Wnd.SetEventW2WConnected(evVal: TEventWnd2WndConnection); +begin + if @evW2WConnected_ <> @evVal then + evW2WConnected_ := evVal; +end; + +procedure TTgWnd2Wnd.ClearQueue; +begin + Lock; + qDataEnts_.OnNotify := OnWndDataNotify; + try + qDataEnts_.Clear; + finally + qDataEnts_.OnNotify := nil; + Unlock; + end; +end; + +function TTgWnd2Wnd.DeququeData: PWndDataEnt; +begin + Lock; + try + if qDataEnts_.Count > 0 then + Result := qDataEnts_.Dequeue + else + Result := nil; + finally + Unlock; + end; +end; + +function TTgWnd2Wnd.SendData(hTargetWnd: HWND; pBuf: Pointer; dwLen: DWORD; dwData: DWORD = 0): Boolean; +var + CD: TCopyDataStruct; +begin + if hTargetWnd <> 0 then + begin + CD.dwData := dwData; + CD.cbData := dwLen; + CD.lpData := pBuf; + Result := SendMessage(hTargetWnd, WM_COPYDATA, NativeUInt(hRcvWnd_), NativeInt(@CD)) = WM_COPYDATA; +// Result := SendMessageTimeout(hTargetWnd, WM_COPYDATA, NativeUInt(hRcvWnd_), NativeInt(@CD), +// SMTO_ABORTIFHUNG, 5000, nil) = WM_COPYDATA; + end else + Result := false; +end; + +function TTgWnd2Wnd.SendData(hTargetWnd: HWND; aSend: ISendPacket; dwData: DWORD = 0): Boolean; +var + sJsonStr: String; +begin + sJsonStr := aSend.ToJsonString; + Result := SendData(hTargetWnd, PChar(sJsonStr), (Length(sJsonStr) + 1) * 2, dwData); +end; + +function TTgWnd2Wnd.SendData(hTargetWnd: HWND; sSend: String; dwData: DWORD = 0): Boolean; +begin + Result := SendData(hTargetWnd, PChar(sSend), (Length(sSend) + 1) * 2, dwData); +end; + +procedure TTgWnd2Wnd.ProcessWindowMessage(var msg: TMessage); +var + pCD: PCopyDataStruct; + pData: PWndDataEnt; +begin + try + case msg.Msg of + WM_WND_HANDSHAKE : + begin +// {$IFDEF _IPC_TEST_} +// AddLinkProc(msg.LParam); +// {$ENDIF} + if Assigned(evW2WConnected_) then + evW2WConnected_(Self, TW2wConnState(msg.WParam), msg.LParam); + + msg.Result := WM_WND_HANDSHAKE; + end; + WM_COPYDATA : + begin + pCD := PCopyDataStruct(msg.LParam); + if pCD.cbData > 0 then + begin + New(pData); + pData.dwData := pCD.dwData; + pData.llSender := msg.WParam; + pData.dwLen := pCD.cbData; + pData.pBuf := AllocMem(pData.dwLen); + CopyMemory(pData.pBuf, pCD.lpData, pData.dwLen); + +// {$IFDEF _IPC_TEST_} +// if pData.dwData > 0 then +// begin +// case pData.dwData of +// 1 : SendData(pData.llSender, Copy(PChar(pData.pBuf), 1, pData.dwLen), 2); +// 2 : _Trace(PChar(Copy(PChar(pData.pBuf), 1, pData.dwLen) + ' : DONE')); +// end; +// Dispose(pData); +// exit; +// end; +// {$ENDIF} + + Lock; + try + qDataEnts_.Enqueue(pData); + finally + Unlock; + end; + end; + msg.Result := WM_COPYDATA; //DefWindowProc(hRcvWnd_, msg.Msg, msg.wParam, msg.lParam); + end; + else msg.Result := 0; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. ProcessWindowMessage()'); + end; +end; + +//{$IFDEF _IPC_TEST_} +//procedure TTgWnd2Wnd.AddLinkProc(hRcvWnd: HWND); +//var +// pEnt: PW2wLinkProc; +//begin +// New(pEnt); +//// pEnt.dwPid := dwPid; +// pEnt.hRcvWnd := hRcvWnd; +// LinkProcList_.Add(pEnt); +//end; +// +//function TTgWnd2Wnd.GetLinkProcEnumerator: TW2wLinkProcEnumerator; +//begin +// Result := LinkProcList_.GetEnumerator; +//end; +//{$ENDIF} + + +type + PACE_HEADER = ^ACE_HEADER; + {$EXTERNALSYM PACE_HEADER} + + _ACE_HEADER = record + AceType: Byte; + AceFlags: Byte; + AceSize: Word; + end; + {$EXTERNALSYM _ACE_HEADER} + + ACE_HEADER = _ACE_HEADER; + {$EXTERNALSYM ACE_HEADER} + TAceHeader = ACE_HEADER; + PAceHeader = PACE_HEADER; + + PACCESS_ALLOWED_ACE = ^ACCESS_ALLOWED_ACE; + {$EXTERNALSYM PACCESS_ALLOWED_ACE} + + _ACCESS_ALLOWED_ACE = record + Header: ACE_HEADER; + Mask: ACCESS_MASK; + SidStart: DWORD; + end; + {$EXTERNALSYM _ACCESS_ALLOWED_ACE} + + ACCESS_ALLOWED_ACE = _ACCESS_ALLOWED_ACE; + {$EXTERNALSYM ACCESS_ALLOWED_ACE} + TAccessAllowedAce = ACCESS_ALLOWED_ACE; + PAccessAllowedAce = PACCESS_ALLOWED_ACE; + +{ TTgNpBase } + +Constructor TTgNpBase.Create(sPipeName: String); +begin + Inherited Create; + sPipeName_ := sPipeName; + evConnected_ := nil; + evDisconnected_ := nil; +end; + +//function TTgNpBase.SendData(sData: UTF8String): Boolean; +//begin +// Result := SendData(@sData[1], Length(sData) + 1); +//end; + +function TTgNpBase._SendData(hTgPipe: THandle; pData: Pointer; dwLen: DWORD): Boolean; +var + dwWrote: DWORD; + pBuf: TBytes; + dwRead, + dwReaded: DWORD; + +Label + LB_RetryWrite1, + LB_RetryWrite2; + +begin + Result := false; + if hTgPipe <> 0 then + begin + if dwLen = 0 then + exit; + + try + // MAXBUFSIZE = 65535 + { + PIPEDATA_STX = 'PS!_'; + PIPEDATA_STX_LEN = 4; + PIPEDATA_ETX = '_!PE'; + PIPEDATA_ETX_LEN = 4; + } + if dwLen > BLOCK_BUF_LEN then + begin + SetLength(pBuf, MAXWORD); + + // 전체 크기 미리 보내놓고 + CopyMemory(@pBuf[0], @dwLen, 4); + Result := WriteFile(hTgPipe, pBuf[0], 4, dwWrote, nil); + if not Result then + begin + if Assigned(evDisconnected_) then + evDisconnected_(Self, hTgPipe); + ProcessFail(hTgPipe); + exit; + end; + + // 쪼개서 보낸다. + dwReaded := 0; + while dwReaded < dwLen do + begin + if (dwLen - dwReaded) > BLOCK_BUF_LEN then + dwRead := BLOCK_BUF_LEN + else + dwRead := dwLen - dwReaded; + + CopyMemory(@pBuf[0], @dwRead, 4); + CopyMemory(@pBuf[4], Pointer(LONGLONG(pData) + dwReaded), dwRead); + LB_RetryWrite1 : + Result := WriteFile(hTgPipe, pBuf[0], dwRead + 4, dwWrote, nil); + if Result and (dwWrote = 0) then + goto LB_RetryWrite1; + + if not Result then + begin + if Assigned(evDisconnected_) then + evDisconnected_(Self, hTgPipe); + ProcessFail(hTgPipe); + exit; + end; + if dwWrote > 4 then + Inc(dwReaded, dwWrote - 4); + end; + end else begin + SetLength(pBuf, dwLen + 4); + CopyMemory(@pBuf[0], @dwLen, 4); + CopyMemory(@pBuf[4], pData, dwLen); + LB_RetryWrite2 : + Result := WriteFile(hTgPipe, pBuf[0], dwLen + 4, dwWrote, nil); + if Result and (dwWrote = 0) then + goto LB_RetryWrite2; + + if not Result then + begin + if Assigned(evDisconnected_) then + evDisconnected_(Self, hTgPipe); + ProcessFail(hTgPipe); + end; + end; + except + on E: Exception do + ETgNamedPipe.TraceException(Self, E, 'Fail .. SendData()'); + end; + end; +end; + +function TTgNpBase._RcvData(hTgPipe: THandle; var pBuf: TBytes): DWORD; +var + dwLen, + dwWrote, + dwRead, + dwReaded: DWORD; +Label + LB_RetryRead1, + LB_RetryRead2; +begin + Result := 0; + if hTgPipe <> 0 then + begin + // ReadFile() 은 현재 XE2 문제 인지는 모르겠지만... Return 값이 항상 FALSE로 뜬다. + // dwWrote 리턴으로 성공 유무를 확인한다. 19_0509 13:56:13 sunk + dwWrote := 0; + + ReadFile(hTgPipe, dwLen, 4, dwWrote, nil); + if dwWrote = 4 then + begin + try + SetLength(pBuf, dwLen); + except + exit; + end; + + if dwLen > BLOCK_BUF_LEN then + begin + // 쪼개서 보낸거 모아서 받자 + dwReaded := 0; + while dwReaded < dwLen do + begin + LB_RetryRead1 : + ReadFile(hTgPipe, dwRead, 4, dwWrote, nil); + if dwWrote = 0 then + goto LB_RetryRead1; + + if dwWrote <> 4 then + break; + + LB_RetryRead2 : + ReadFile(hTgPipe, pBuf[dwReaded], dwRead, dwWrote, nil); + if dwWrote = 0 then + goto LB_RetryRead2; + + if dwRead <> dwWrote then + break; + + Inc(dwReaded, dwWrote); + end; + Result := dwReaded; + end else + ReadFile(hTgPipe, pBuf[0], dwLen, Result, nil); + end; + +// _Trace('_RcvData() .. Error=%d', [GetLastError]); + case GetLastError of + 234 : ; // 더 많은 데이터가 있습니다. + 232 : ; // 파이프가 닫히는 중입니다. + 233, // 파이프의 다른 끝에 프로세스가 없습니다. + 109 : // 파이프가 끝났습니다. + begin + if Assigned(evDisconnected_) then + evDisconnected_(Self, hTgPipe); + ProcessFail(hTgPipe); + end; + end; + end; +end; + +{ TTgNamedPipeServer } + +Constructor TTgNpServer.Create(sPipeName: String); +begin + Inherited Create(sPipeName); + bIsServer_ := true; + bActive_ := false; + hEvent_ := 0; + PipeList_ := TClientPipeList.Create; + PipeList_.OnNotify := OnClientPipeNotify; + enumRcv_ := nil; + hLastRcvPipe_ := 0; + CS_ := TCriticalSection.Create; +end; + +Destructor TTgNpServer.Destroy; +begin + if enumRcv_ <> nil then + FreeAndNil(enumRcv_); + + Close; + FreeAndNil(PipeList_); + + Inherited; + FreeAndnil(CS_); +end; + +procedure TTgNpServer.Lock; +begin + CS_.Acquire; +end; + +procedure TTgNpServer.Unlock; +begin + CS_.Release; +end; + +procedure TTgNpServer.OnClientPipeNotify(Sender: TObject; const Item: THandle; Action: TCollectionNotification); +begin + try + if Action = cnRemoved then + begin + if (Item <> 0) and (Item <> INVALID_HANDLE_VALUE) then + begin + DisconnectNamedPipe(Item); + CloseHandle(Item); + end; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. OnClientPipeNotify()'); + end; +end; + +procedure TTgNpServer.ProcessFail(hPipe: THandle); +var + nIdx: Integer; +begin + try + Lock; + try + nIdx := PipeList_.IndexOf(hPipe); + if nIdx <> -1 then + PipeList_.Delete(nIdx); + // Close; + finally + Unlock; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. ProcessFail()'); + end; +end; + +function TTgNpServer.Listen: Boolean; +begin + Result := false; + + if bActive_ then + exit; + + try + hWaitPipe_ := 0; + ZeroMemory(@ConnOvrl_, SizeOf(ConnOvrl_)); + + hEvent_ := CreateEvent(nil, true, true, nil); + if hEvent_ = 0 then + begin + _Trace('Fail .. SetActive() .. CreateEvent()'); + exit; + end; + + ConnOvrl_.hEvent := hEvent_; + if not CreatePipeInstance(hWaitPipe_) then + begin + _Trace('Fail .. SetActive() .. CreatePipeInstance()'); + Close; + exit; + end; + + bActive_ := true; + Result := true; + except + on E: Exception do + ETgNamedPipe.TraceException(Self, E, 'Fail .. Listen()'); + end; +end; + +procedure TTgNpServer.Close; +begin + try + if not bActive_ then + exit; + + bActive_ := false; + + PipeList_.Clear; + + // 이거 초기화 하면 크러쉬 되는 문제가 있다... + // 일반적인 정책을 받아서 쓸때는 상관없는데 정책이 비어 있을때 문제가 됨... + // 정확한 원인은 모르겠음.. 23_0412 16:36:40 kku + if (hWaitPipe_ <> 0) and (hWaitPipe_ <> INVALID_HANDLE_VALUE) then + begin + DisconnectNamedPipe(hWaitPipe_); + CLoseHandle(hWaitPipe_); + end; + hWaitPipe_ := 0; + + if hEvent_ <> 0 then + begin + CloseHandle(hEvent_); + hEvent_ := 0; + end; + ZeroMemory(@ConnOvrl_, SizeOf(TOverlapped)); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. Close()'); + end; +end; + +function TTgNpServer.DoAcceptPipe: Boolean; +var + dwResult, + dwTransferred: DWORD; +begin + Result := false; + if bActive_ and (hEvent_ <> 0) and (hWaitPipe_ <> 0) then + begin + try + try + dwResult := WaitForSingleObjectEx(hEvent_, 500, True); + except + // .. + end; + + case dwResult of + WAIT_FAILED : + begin + _Trace('Fail .. DoAcceptPipe() .. WAIT_FAILED'); + Close; + end; + + WAIT_TIMEOUT : exit; + WAIT_IO_COMPLETION : exit; + WAIT_OBJECT_0 : + begin + if not GetOverlappedResult(hWaitPipe_, ConnOvrl_, dwTransferred, False) then + begin + _Trace('Fail .. DoAcceptPipe() .. GetOverlappedResult()'); + Close; + exit; + end else + SetPipeClientEnt(hWaitPipe_); + + hWaitPipe_ := 0; + if not CreatePipeInstance(hWaitPipe_) then + begin + _Trace('Fail .. DoAcceptPipe() .. CreatePipeInstance()'); + Close; + exit; + end; + + Result := true; + +// if Assigned(evConnected_) then +// evConnected_(Self); + end; + end; + except + on E: Exception do + ETgNamedPipe.TraceException(Self, E, 'Fail .. DoAcceptPipe()'); + end; + end; +end; + +function TTgNpServer.SendData(aSend: ISendPacket): Boolean; +var + llToss: LONGLONG; + pBuf: TBytes; + dwLen: DWORD; + i, n: Integer; + enum: TEnumerator<THandle>; +begin + Result := false; + try + dwLen := aSend.ToBytes(pBuf); + if dwLen = 0 then + exit; + + llToss := TTgPacket(aSend).Toss; + if llToss = 0 then + begin + Lock; + try + enum := PipeList_.GetEnumerator; + finally + Unlock; + end; + + n := 0; + // 지정 되지 않으면 전체 전달 23_0313 18:34:50 kku + while enum.MoveNext do + begin + if _SendData(enum.Current, pBuf, dwLen) then + Inc(n); + end; + enum.Free; + + Result := n > 0; + end else + Result := _SendData(llToss, pBuf, dwLen); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. SendData()'); + end; +end; + +function TTgNpServer.RcvData(var pBuf: TBytes): DWORD; +begin + Result := 0; + try + if enumRcv_ = nil then + begin + Lock; + try + enumRcv_ := PipeList_.GetEnumerator; + finally + Unlock; + end; + + if not enumRcv_.MoveNext then + begin + FreeAndNil(enumRcv_); + exit; + end; + end; + + hLastRcvPipe_ := enumRcv_.Current; + Result := _RcvData(hLastRcvPipe_, pBuf); + + if not enumRcv_.MoveNext then + FreeAndNil(enumRcv_); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. RcvData()'); + end; +end; + +procedure TTgNpServer.SetPipeClientEnt(hPipe: THandle); +var + dwMode: DWORD; + bAdd: Boolean; +begin + if hPipe = 0 then + exit; + + Lock; + try + bAdd := PipeList_.IndexOf(hPipe) = -1; + if bAdd then + PipeList_.Add(hPipe); + finally + Unlock; + end; + + if not bAdd then + begin + _Trace('Fail .. SetPipeClientEnt() .. Already Pipe'); + exit; + end; + +// dwMode := PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_NOWAIT; // fail .. + dwMode := PIPE_READMODE_MESSAGE or PIPE_NOWAIT; + if not SetNamedPipeHandleState(hPipe, dwMode, nil, nil) then + _Trace('Fail .. SetPipeClientEnt() .. SetNamedPipeHandleState()'); +end; + +function TTgNpServer.CreatePipeInstance(out hPipe: THandle; bAsync: Boolean = false): Boolean; +const + SECURITY_WORLD_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 1)); + SECURITY_WORLD_RID = ($00000000); + ACL_REVISION = (2); +var + SIA: SID_IDENTIFIER_AUTHORITY; + SID: PSID; + pAclBuf, pSidBuf: TBytes; + nAclSize, + nSidSize: Integer; + ACL: PACL; + Descriptor: SECURITY_DESCRIPTOR; + Attributes: SECURITY_ATTRIBUTES; + dwError, + dwPipeMode: DWORD; +begin + Result := False; + try + SIA := SECURITY_WORLD_SID_AUTHORITY; + nSidSize := GetSidLengthRequired(1); + SetLength(pSidBuf, nSidSize); + ZeroMemory(pSidBuf, nSidSize); + SID := PSID(@pSidBuf[0]); // AllocMem(nSidSize); + try + Win32Check(InitializeSid(SID, SECURITY_WORLD_SID_AUTHORITY, 1)); + PDWORD(GetSidSubAuthority(SID, 0))^ := SECURITY_WORLD_RID; + nAclSize := SizeOf(ACL) + SizeOf(ACCESS_ALLOWED_ACE) + GetLengthSid(SID); + SetLength(pAclBuf, nAclSize); + ZeroMemory(pAclBuf, nAclSize); + ACL := PACL(@pAclBuf[0]); // AllocMem(nAclSize); + try + Win32Check(InitializeAcl(ACL^, nAclSize, ACL_REVISION)); + Win32Check(AddAccessAllowedAce(ACL^, ACL_REVISION, GENERIC_ALL, SID)); + Win32Check(InitializeSecurityDescriptor(@Descriptor, SECURITY_DESCRIPTOR_REVISION)); + Win32Check(SetSecurityDescriptorDacl(@Descriptor, true, ACL, False)); + Attributes.nLength := SizeOf(SECURITY_ATTRIBUTES); + Attributes.lpSecurityDescriptor := @Descriptor; + Attributes.bInheritHandle := False; + + dwPipeMode := PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE; + if bAsync then + dwPipeMode := dwPipeMode or PIPE_NOWAIT + else + dwPipeMode := dwPipeMode or PIPE_WAIT; + + hPipe := CreateNamedPipe(PChar('\\.\Pipe\' + sPipeName_), + PIPE_ACCESS_DUPLEX or FILE_FLAG_OVERLAPPED, + dwPipeMode, + PIPE_UNLIMITED_INSTANCES, + MaxBuffSize, + MaxBuffSize, + NMPWAIT_WAIT_FOREVER, + @Attributes); + + if (hPipe <> 0) and (hPipe <> INVALID_HANDLE_VALUE) then + begin + if not ConnectNamedPipe(hPipe, @ConnOvrl_) then + begin + dwError := GetLastError; + case dwError of + ERROR_IO_PENDING: + Result := true; + ERROR_PIPE_CONNECTED: + SetEvent(ConnOvrl_.hEvent); + else + _Trace('Fail .. CreatePipeInstance() .. ConnectNamedPipe(), Error=%d', [dwError]); + end; + end else + SetPipeClientEnt(hPipe); + end else + _Trace('Fail .. CreatePipeInstance() .. CreateNamedPipe()'); + finally +// FreeMem(ACL, nAclSize); // 여기서 FreeMem 하면 AS 디버그 모드에서 크러쉬 오류가 발생한다.. 그래서 수정함 23_0517 16:26:57 kku + end; + finally +// FreeMem(SID, nSidSize); // 여기서 FreeMem 하면 AS 디버그 모드에서 크러쉬 오류가 발생한다.. 그래서 수정함 23_0517 16:26:57 kku + end; + except + on E: Exception do + begin + if hPipe <> INVALID_HANDLE_VALUE then + begin + CloseHandle(hPipe); + hPipe := INVALID_HANDLE_VALUE; + end; + + ETgNamedPipe.TraceException(Self, E, 'Fail .. CreatePipeInstance()'); + end; + end; +end; + +{ TTgNpClient } + +Constructor TTgNpClient.Create(sPipeName: String); +begin + Inherited Create(sPipeName); + bIsServer_ := false; + hConnPipe_ := 0; + bConnected_ := false; +end; + +Destructor TTgNpClient.Destroy; +begin + Disconnect; + Inherited; +end; + +procedure TTgNpClient.ProcessFail(hPipe: THandle); +begin +// _Trace('ProcessFail()'); + Disconnect; +end; + +function TTgNpClient.Connect: Boolean; +var + dwError, + dwMode: DWORD; + sPName: String; +begin + Result := false; + +// _Trace('Connect() .. 1'); + if bConnected_ then + exit; +// _Trace('Connect() .. 2'); + + try + Disconnect; + + sPName := '\\.\Pipe\' + sPipeName_; + hConnPipe_ := CreateFile(PChar(sPName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0); + if (hConnPipe_ = 0) or (hConnPipe_ = INVALID_HANDLE_VALUE) then + begin + _Trace('Fail .. Connect() .. CreateFile()', 100); + Disconnect; + exit; + end; + + dwError := GetLastError; + case dwError of + NOERROR, ERROR_PIPE_BUSY : ; + else begin + _Trace('Fail .. Connect() .. Error=%d', [dwError], 9); + Disconnect; + exit; + end; + end; + + if not WaitNamedPipe(PChar(sPName), 10000 { NMPWAIT_WAIT_FOREVER } ) then + begin + _Trace('Fail .. Connect() .. WaitNamedPipe()', 9); + Disconnect; + exit; + end; + + dwMode := PIPE_READMODE_MESSAGE or PIPE_NOWAIT; + if not SetNamedPipeHandleState(hConnPipe_, dwMode, nil, nil) then + begin + _Trace('Fail .. Connect() .. SetNamedPipeHandleState()', 9); + Disconnect; + exit; + end; +// bConnected_ := true; + Result := true; + except + on E: Exception do + ETgNamedPipe.TraceException(Self, E, 'Fail .. Connect()', 4); + end; +end; + +procedure TTgNpClient.Disconnect; +begin +// _Trace('Disconnect() ..'); + try + bConnected_ := false; + if hConnPipe_ <> 0 then + begin + CloseHandle(hConnPipe_); + hConnPipe_ := 0; + end; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. Disconnect()', 3); + end; +end; + +function TTgNpClient.SendData(aSend: ISendPacket): Boolean; +var + pBuf: TBytes; + dwLen: DWORD; +begin + dwLen := aSend.ToBytes(pBuf); + Result := _SendData(hConnPipe_, pBuf, dwLen); +end; + +function TTgNpClient.RcvData(var pBuf: TBytes): DWORD; +begin + Result := _RcvData(hConnPipe_, pBuf); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Process.pas b/Tocsg.Lib/VCL/Tocsg.Process.pas new file mode 100644 index 00000000..41600cf7 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Process.pas @@ -0,0 +1,1955 @@ +{*******************************************************} +{ } +{ Tocsg.Process } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Process; + +interface + +uses + Winapi.Windows, System.SysUtils, Tocsg.Obj, Tocsg.Files, + System.Classes, Winapi.TlHelp32, superobject, + Tocsg.Thread, System.Generics.Collections, Tocsg.FileInfo; + +const + PROC_FULL_ACCESS = PROCESS_ALL_ACCESS or SYNCHRONIZE; + PROC_SAFE_ACCESS = PROCESS_QUERY_INFORMATION or PROCESS_VM_READ or SYNCHRONIZE or PROCESS_VM_WRITE; + +type + TProcessIdList = TList<ULONGLONG>; + + TTgProcessInfo = class(TTgObject) + protected + dwPID_: DWORD; + sProcPath_, + sProcName_: String; + dtCreate_: TDateTime; + FileInfo_: TTgFileInfo; + public + Constructor Create(dwPid: DWORD); + Destructor Destroy; override; + + property PID: DWORD read dwPID_; + property ModulePath: String read sProcPath_; + property ModuleName: String read sProcName_; + property FileInfo: TTgFileInfo read FileInfo_; + property CreateDT: TDateTime read dtCreate_; + end; + + TExeArchitectKind = (eakNoExe, eak32, eak64); + + PProcessEntInfo = ^TProcessEntInfo; + TProcessEntInfo = record + sOwner, + sCompany, + sVersion, + sCopyright, + sDescription, + sModuleBaseName, + sModuleFileName : String; + nPriority: Integer; + dtStart, + dtExit, + dtKernelMode, + dtUserMode: TDateTime; + dwPid, + dwPPid: DWORD; + end; + TProcessEntList = class(TList<PProcessEntInfo>) + private + bDetailInfo_: Boolean; + DcProcInfo_: TDictionary<DWORD,PProcessEntInfo>; + protected + procedure AddProcess(aProcEnt: TProcessEntry32); + procedure Notify(const Item: PProcessEntInfo; Action: TCollectionNotification); override; + public + Constructor Create(bUpdate: Boolean = false); + Destructor Destroy; override; + + procedure UpdateProcessList; + procedure DeleteProcInfoByPid(dwPid: DWORD); + function GetProcInfoByPath(sPath: String): PProcessEntInfo; + function GetProcInfoByPid(dwPid: DWORD): PProcessEntInfo; + function GetProcInfoByName(sPName: String): PProcessEntInfo; + function GetProcPathByName(sPName: String): String; + function GetProcPathByPid(dwPid: DWORD): String; + + function ToJsonObj: ISuperObject; + function ToJsonObjHE: ISuperObject; + + property DetailInfo: Boolean write bDetailInfo_; + end; + + TProcessString = reference to procedure(sText: String; var bWorkStop: Boolean); + + PPwEnt = ^TPwEnt; + TPwEnt = record + dwPid, + dwPPid: DWORD; + sPName: String; + end; + TPwEntDic = TDictionary<DWORD,PPwEnt>; + TThdProcessWatch = class; + TProcessWatchKind = (pwkUnknown, pwkInit, pwkExecute, pwkTerminated); + TEvProcessWatchNotify = procedure(aSender: TThdProcessWatch; pEnt: PPwEnt; aKind: TProcessWatchKind) of object; + TThdProcessWatch = class(TTgThread) + protected + bSync_: Boolean; + RctEnt_: PPwEnt; + RctKind_: TProcessWatchKind; + evWatchNotify_: TEvProcessWatchNotify; + procedure OnPwEntNotify(Sender: TObject; const Item: PPwEnt; Action: TCollectionNotification); + procedure ProcessNotify; + procedure Execute; override; + public + Constructor Create(bSync: Boolean = true); + + property OnProcessWatchNotify: TEvProcessWatchNotify write evWatchNotify_; + end; + +function PriorityStrByClass(nClass: Integer): String; +function TerminateProcessByPid(dwPid: DWORD; bForce: Boolean = false): Boolean; +function TerminateProcessByName(sPName: String; dwIgrPid: DWORD = 0): Boolean; +procedure TerminateProcessFromList(aList: TStringList; aIgrList: TStringList = nil); +function CheckProcessNameDeadOrTerminate(sPName: String): Boolean; + +function GetProcessOwner(hProcess: THandle): String; + +function GetProcessNameToList(aList: TStringList): Integer; +function GetProcessPidByName(sModuleName: String; dwIgnPid: DWORD = 0): DWORD; +function GetProcessPidsByName(sModuleName: String; aPIDList: TProcessIdList = nil): Integer; +function GetProcessNameByPid(dwPid: DWORD): String; +function GetProcessPPidByPid(dwPid: DWORD): DWORD; +function GetProcessPathByPid(dwPid: DWORD): String; +function GetProcessPIDFromWndHandle(hWndHandle: THandle): DWORD; +function GetProcessNameFromWndHandle(hWndHandle: THandle): String; +function GetProcessPathFromWndHandle(hWndHandle: THandle): String; + +function GetWndHandleFromPID(dwPid: DWORD; sIfWndCaption: String = ''): HWND; +function GetWndHandleFromPidEx(dwPid: DWORD; sClassName: String): HWND; +function GetWndHandlesFromPID(dwPid: DWORD; HandleList: TStrings): Integer; + +function GetProcesssUserSidFromPID(dwPid: DWORD): String; +function GetProcesssUserSidFromName(sPName: String): String; + +function GetExeFileArchitectFromeStream(aStream: TStream): TExeArchitectKind; +function GetExeFileArchitectFromePath(sPath: String): TExeArchitectKind; + +procedure ReadPipeFromCmd(sCommand, sParam: String; nShow: Integer; ProcessString: TProcessString; dwExitTimeout: DWORD = 0); +function GetCmdTextToStream(sCommand, sParam: String; aStream: TStream; dwTimeMilSec: DWORD = 0): Boolean; + +function ExecuteApp(const sPath, sParam: String; wVisible: WORD; + dwFlag: DWORD = STARTF_USESHOWWINDOW or STARTF_USEPOSITION; + nX: Integer = 0; nY: Integer = 0): TProcessInformation; +function ExecuteAppAsUser(dwFollowPID: DWORD; sPath, sParam: String; dwVisible: DWORD): TProcessInformation; overload; +function ExecuteAppAsUser(sModuleName, sPath, sParam: String; dwVisible: DWORD): TProcessInformation; overload; +function ExecuteAppWaitUntilTerminate(sPath, sParam: String; dwVisible: DWORD; nTimeOutMilSec: Integer = -1): Boolean; + +function InjectModule(dwPid: DWORD; sDllPath: String; pbIsWow64: PBoolean = nil): Integer; +function EjectModuleFromPath(sDllPaths: String; dwIgrPid: DWORD = 0): Integer; +function EjectModuleFromPath2(sDllPath: String; sIgrPNames: String): Integer; +function EjectModuleFromPathUntilZero(sDllPath: String; dwIgrPid: DWORD = 0): Integer; +function EjectModuleFromName(sName: String; dwIgrPid: DWORD = 0): Integer; + +function EjectModuleByPName(dwPid: DWORD; sDllName: String): Boolean; + +implementation + +uses + Winapi.PsAPI, Tocsg.Kernel32, Tocsg.Exception, Tocsg.Trace, Tocsg.DateTime, + Tocsg.Safe, Tocsg.WndUtil, Tocsg.Json, Tocsg.Strings, Tocsg.WinInfo; + +type + TOKEN_MANDATORY_LABEL = record + Label_: SID_AND_ATTRIBUTES; + end; + + PTOKEN_USER = ^TOKEN_USER; + TOKEN_USER = record + User: TSidAndAttributes; + end; + +function CreateEnvironmentBlock(var lpEnvironment: Pointer; + hToken: THandle; + bInherit: BOOL): BOOL; stdcall; external 'userenv.dll'; + +{ TTgProcessInfo } + +Constructor TTgProcessInfo.Create(dwPid: DWORD); + + procedure ExtractProcessInfo; + var + hProcess: THandle; + ftCreate, + ftExit, + ftKernel, + ftUser: TFileTime; + nDosTime: Integer; + dwLen: DWORD; + sPath: array [0..512] of Char; + begin + hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, dwPID); + if hProcess <> 0 then + begin + try + if GetProcessTimes(hProcess, ftCreate, ftExit, ftKernel, ftUser) then + begin + if FileTimeToLocalFileTime(ftCreate, ftCreate) then + if FileTimeToDosDateTime(ftCreate, LongRec(nDosTime).Hi, LongRec(nDosTime).Lo) then + dtCreate_ := FileDateToDateTime(nDosTime); + end; + + dwLen := 512; + ZeroMemory(@sPath, SizeOf(sPath)); + if GetModuleFileNameEx(hProcess, 0, sPath, dwLen) = 0 then + begin + CloseHandle(hProcess); + hProcess := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, false, dwPID); + if hProcess <> 0 then + QueryFullProcessImageName(hProcess, 0, sPath, dwLen); + end; + sProcPath_ := sPath; + finally + if hProcess <> 0 then + CloseHandle(hProcess); + end; + end; + + if sProcPath_ = '' then + sProcPath_ := GetProcessNameByPid(dwPID); + sProcName_ := ExtractFileName(sProcPath_); + end; + +begin + Inherited Create; + dwPid_ := dwPid; + sProcPath_ := ''; + sProcName_ := ''; + FileInfo_ := nil; + ExtractProcessInfo; + + if FileExists(sProcPath_) then + FileInfo_ := TTgFileInfo.Create(sProcPath_); +end; + +Destructor TTgProcessInfo.Destroy; +begin + if FileInfo_ <> nil then + FreeAndNil(FileInfo_); + Inherited; +end; + +{ TProcessEntList } + +Constructor TProcessEntList.Create(bUpdate: Boolean = false); +begin + DcProcInfo_ := TDictionary<DWORD,PProcessEntInfo>.Create; + Inherited Create; + bDetailInfo_ := true; + if bUpdate then + UpdateProcessList; +end; + +Destructor TProcessEntList.Destroy; +begin + Inherited; + FreeAndNil(DcProcInfo_); +end; + +procedure TProcessEntList.Notify(const Item: PProcessEntInfo; Action: TCollectionNotification); +begin + case Action of + cnAdded : + if not DcProcInfo_.ContainsKey(Item.dwPid) then + DcProcInfo_.Add(Item.dwPid, Item); + cnRemoved : + begin + DcProcInfo_.Remove(Item.dwPid); + Dispose(Item); + end; + end; +end; + +procedure TProcessEntList.AddProcess(aProcEnt: TProcessEntry32); +var + h: THandle; + pEnt: PProcessEntInfo; + arrTemp: array [0..260] of Char; + ftStart, ftExit, ftKernel, ftUser: TFileTime; + FileInfo: TTgFileInfo; +begin + h := 0; + try + h := OpenProcess(PROC_FULL_ACCESS, false, aProcEnt.th32ProcessID); + if h = 0 then + begin + h := OpenProcess(PROC_SAFE_ACCESS, false, aProcEnt.th32ProcessID); + if h = 0 then + exit; + end; + + New(pEnt); + ZeroMemory(pEnt, SizeOf(TProcessEntInfo)); + pEnt.dwPid := aProcEnt.th32ProcessID; + pEnt.dwPPid := aProcEnt.th32ParentProcessID; + pEnt.sModuleBaseName := aProcEnt.szExeFile; + + if GetModuleFileNameEx(h, 0, arrTemp, 260) = 0 then + pEnt.sModuleFileName := aProcEnt.szExeFile + else + pEnt.sModuleFileName := arrTemp; + + if bDetailInfo_ then + begin + if GetModuleBaseName(h, 0, arrTemp, 260) = 0 then + pEnt.sModuleBaseName := aProcEnt.szExeFile + else + pEnt.sModuleBaseName := arrTemp; + + pEnt.nPriority := GetPriorityClass(h); + + if GetProcessTimes(h, ftStart, ftExit, ftKernel, ftUser) then + begin + pEnt.dtStart := ConvFileTimeToDateTime_Local(ftStart); + pEnt.dtExit := ConvFileTimeToDateTime_Local(ftExit); + pEnt.dtKernelMode := ConvFileTimeToDateTime_Local(ftKernel); + pEnt.dtUserMode := ConvFileTimeToDateTime_Local(ftUser); + end; + + pEnt.sOwner := GetProcessOwner(h); + if FileExists(pEnt.sModuleFileName) then + begin + Guard(FileInfo, TTgFileInfo.Create(pEnt.sModuleFileName)); + pEnt.sCompany := FileInfo.Company; + pEnt.sVersion := FileInfo.Version; + pEnt.sCopyright := FileInfo.LegalCopyright; + pEnt.sDescription := FileInfo.Description; + if pEnt.sDescription = '' then + pEnt.sDescription := aProcEnt.szExeFile; + end else + pEnt.sDescription := aProcEnt.szExeFile; + end; + finally + if h <> 0 then + CloseHandle(h); + end; + + Add(pEnt); +end; + +procedure TProcessEntList.UpdateProcessList; +var + h: THandle; + ProcEnt: TProcessEntry32; +begin + Clear; + + h := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if h = INVALID_HANDLE_VALUE then + exit; + + try + ProcEnt.dwSize := SizeOf(ProcEnt); + + Process32First(h, ProcEnt); // system + + while Process32Next(h, ProcEnt) do + begin + AddProcess(ProcEnt); + end; + finally + CloseHandle(h); + end; +end; + +procedure TProcessEntList.DeleteProcInfoByPid(dwPid: DWORD); +var + pEnt: PProcessEntInfo; + i: Integer; +begin + pEnt := GetProcInfoByPid(dwPid); + if pEnt <> nil then + begin + i := IndexOf(pEnt); + if i <> -1 then + Delete(i); + end; +end; + +function TProcessEntList.GetProcInfoByPath(sPath: String): PProcessEntInfo; +var + enum: TEnumerator<PProcessEntInfo>; +begin + Result := nil; + Guard(enum, DcProcInfo_.Values.GetEnumerator); + while enum.MoveNext do + if CompareText(sPath, enum.Current.sModuleFileName) = 0 then + begin + Result := enum.Current; + exit; + end; +end; + +function TProcessEntList.GetProcInfoByPid(dwPid: DWORD): PProcessEntInfo; +begin + if DcProcInfo_.ContainsKey(dwPid) then + Result := DcProcInfo_[dwPid] + else + Result := nil; +end; + +function TProcessEntList.GetProcInfoByName(sPName: String): PProcessEntInfo; +var + enum: TEnumerator<PProcessEntInfo>; +begin + Result := nil; + Guard(enum, DcProcInfo_.Values.GetEnumerator); + while enum.MoveNext do + if CompareText(sPName, enum.Current.sModuleBaseName) = 0 then + begin + Result := enum.Current; + exit; + end; +end; + +function TProcessEntList.GetProcPathByName(sPName: String): String; +var + pEnt: PProcessEntInfo; +begin + Result := ''; + pEnt := GetProcInfoByName(sPName); + if pEnt <> nil then + begin + + case pEnt.dwPid of + 0 : Result := 'System Idle'; // System Idle Process 고정 + 4 : Result := 'System'; // System Process 고정 + else Result := pEnt.sModuleFileName; + end; + end; +end; + +function TProcessEntList.GetProcPathByPid(dwPid: DWORD): String; +var + pInfo: PProcessEntInfo; +begin + try + if DcProcInfo_.ContainsKey(dwPid) then + begin + pInfo := DcProcInfo_[dwPid]; + if pInfo <> nil then + Result := pInfo.sModuleFileName; + end else + Result := ''; + except + Result := ''; + end; +end; + +function TProcessEntList.ToJsonObj: ISuperObject; +var + i: Integer; +begin + Result := TSuperObject.Create(stArray); + for i := 0 to Count - 1 do + Result.AsArray.Add(TTgJson.ValueToJsonObject<TProcessEntInfo>(Items[i]^)); +end; + +function TProcessEntList.ToJsonObjHE: ISuperObject; +var + i: Integer; + pEnt: PProcessEntInfo; + O: ISuperObject; +begin + Result := TSuperObject.Create(stArray); + for i := 0 to Count - 1 do + begin + pEnt := Items[i]; + O := SO; + with pEnt^ do + begin + O.S['Owner'] := sOwner; + O.S['Company'] := sCompany; + O.S['Version'] := sVersion; + O.S['Copyright'] := sCopyright; + O.S['Description'] := sDescription; + if sModuleFileName <> '' then + O.S['PPath'] := sModuleFileName + else + O.S['PPath'] := sModuleBaseName; + O.I['StartDT'] := DelphiToJavaDateTime(dtStart); + O.S['Time'] := ConvSecBetweenToProgTime(dtStart, Now); + end; + Result.AsArray.Add(O); + end; +end; + +{ TThdProcessWatch } + +Constructor TThdProcessWatch.Create(bSync: Boolean = true); +begin + Inherited Create; + @evWatchNotify_ := nil; + RctKind_ := pwkUnknown; + bSync_ := bSync; +end; + +procedure TThdProcessWatch.OnPwEntNotify(Sender: TObject; const Item: PPwEnt; Action: TCollectionNotification); +begin + if (Action = cnRemoved) and (Item <> nil) then + Dispose(Item); +end; + +procedure TThdProcessWatch.ProcessNotify; +begin + if Assigned(evWatchNotify_) then + evWatchNotify_(Self, RctEnt_, RctKind_); +end; + +procedure TThdProcessWatch.Execute; +var + DcPwEnts: TPwEntDic; + hSnapProc: THandle; + ProcEnt: TProcessEntry32; + pEnt: PPwEnt; + enum: TEnumerator<PPwEnt>; + bInit: Boolean; + NewPidList: TProcessIdList; +begin + Guard(DcPwEnts, TPwEntDic.Create); + DcPwEnts.OnValueNotify := OnPwEntNotify; + Guard(NewPidList, TProcessIdList.Create); + while not Terminated and not GetWorkStop do + begin + bInit := DcPwEnts.Count = 0; + hSnapProc := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if hSnapProc = INVALID_HANDLE_VALUE then + begin + Sleep(3000); + exit; + end; + + try + NewPidList.Clear; + + ProcEnt.dwSize := SizeOf(TProcessEntry32); + Process32First(hSnapProc, ProcEnt); // first = "system" + + while Process32Next(hSnapProc, ProcEnt) do + begin + if not DcPwEnts.ContainsKey(ProcEnt.th32ProcessID) then + begin + New(pEnt); + pEnt.dwPid := ProcEnt.th32ProcessID; + pEnt.dwPPid := ProcEnt.th32ParentProcessID; + pEnt.sPName := ProcEnt.szExeFile; + + DcPwEnts.Add(pEnt.dwPid, pEnt); + RctEnt_ := pEnt; + if bInit then + RctKind_ := pwkInit + else + RctKind_ := pwkExecute; + + if bSync_ then + Synchronize(ProcessNotify) + else + ProcessNotify; + end; + NewPidList.Add(ProcEnt.th32ProcessID); + end; + + if NewPidList.Count > 0 then + begin + enum := DcPwEnts.Values.GetEnumerator; + try + while enum.MoveNext do + if NewPidList.IndexOf(enum.Current.dwPid) = -1 then + begin + RctEnt_ := enum.Current; + RctKind_ := pwkTerminated; + if bSync_ then + Synchronize(ProcessNotify) + else + ProcessNotify; + DcPwEnts.Remove(RctEnt_.dwPid); + end; + finally + enum.Free; + end; + end; + finally + CloseHandle(hSnapProc); + end; + + Sleep(300); + end; +end; + + +{ Function } + +function PriorityStrByClass(nClass: Integer): String; +begin + case nClass of + NORMAL_PRIORITY_CLASS : Result := 'Normal'; + ABOVE_NORMAL_PRIORITY_CLASS : Result := 'ABOVE Normal'; + BELOW_NORMAL_PRIORITY_CLASS : Result := 'Below Normal'; + HIGH_PRIORITY_CLASS : Result := 'High'; + REALTIME_PRIORITY_CLASS : Result := 'Realtime'; + IDLE_PRIORITY_CLASS : Result := 'Idle'; + else Result := 'Unknown'; + end; +end; + +function TerminateProcessByPid(dwPid: DWORD; bForce: Boolean = false): Boolean; +var + hProcess: THandle; +begin + Result := false; + +// hProcess := OpenProcess(PROC_FULL_ACCESS, false, dwPid); +// if hProcess = 0 then +// begin +// hProcess := OpenProcess(PROCESS_TERMINATE, false, dwPid); +// if hProcess = 0 then +// exit; +// end; + + hProcess := OpenProcess(PROCESS_TERMINATE, false, dwPid); + if hProcess = 0 then + begin + if bForce then + begin + // 윈도우 11에서는 관리자 권한이 있어도 OpenProcess(PROCESS_TERMINATE...) 권한 획득에 실패하는 경우가 있다. (서비스) + // 이 경우 아래처럼 하면 해결되어서 추가함 22_1208 09:39:42 kku + var ss: TStringStream; + Guard(ss, TStringStream.Create('', TEncoding.UTF8)); + GetCmdTextToStream(Format('taskkill.exe /f /pid %d', [dwPid]), '', ss, 5000); + var sData: String := UpperCase(ss.DataString); + Result := (Pos('성공', sData) > 0) or (Pos('SUCCESS', sData) > 0); + end; + exit; + end; + + try + Result := TerminateProcess(hProcess, 0); + finally + CloseHandle(hProcess); + end; +end; + +function TerminateProcessByName(sPName: String; dwIgrPid: DWORD = 0): Boolean; +var + hSnapProc: THandle; + ProcEnt: TProcessEntry32; + nTmCnt: Integer; +begin + Result := false; + + if sPName = '' then + exit; + + hSnapProc := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if hSnapProc = INVALID_HANDLE_VALUE then + exit; + + sPName := UpperCase(sPName); + + nTmCnt := 0; + try + ProcEnt.dwSize := SizeOf(TProcessEntry32); + Process32First(hSnapProc, ProcEnt); // first = "system" + + while Process32Next(hSnapProc, ProcEnt) do + begin + if (UpperCase(ProcEnt.szExeFile) = sPName) and + (ProcEnt.th32ProcessID <> dwIgrPid) then + begin + if TerminateProcessByPid(ProcEnt.th32ProcessID) then + Inc(nTmCnt); + end; + end; + finally + CloseHandle(hSnapProc); + end; + Result := nTmCnt > 0; +end; + +procedure TerminateProcessFromList(aList: TStringList; aIgrList: TStringList = nil); +var + hSnapProc: THandle; + ProcEnt: TProcessEntry32; +begin + if aList.CaseSensitive then + aList.CaseSensitive := false; + + hSnapProc := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if hSnapProc = INVALID_HANDLE_VALUE then + exit; + + try + ProcEnt.dwSize := SizeOf(TProcessEntry32); + Process32First(hSnapProc, ProcEnt); // first = "system" + + while Process32Next(hSnapProc, ProcEnt) do + begin + if aList.IndexOf(ProcEnt.szExeFile) <> -1 then + begin + if (aIgrList <> nil) and (aIgrList.IndexOf(ProcEnt.szExeFile) <> -1) then + continue; + + TerminateProcessByPid(ProcEnt.th32ProcessID); + end; + end; + finally + CloseHandle(hSnapProc); + end; +end; + +// 프로세스 실행 안되어있는지 확인하고, 실행 되어 있으면 죽임 20_1119 22:03:27 kku +function CheckProcessNameDeadOrTerminate(sPName: String): Boolean; +begin + Result := GetProcessPidByName(sPName) = 0; + if not Result then + begin + TerminateProcessByName(sPName); + Sleep(1000); + Result := GetProcessPidByName(sPName) = 0; + end; +end; + +function GetProcessOwner(hProcess: THandle): String; +var + hToken: THandle; + dwSize, + dwUserLen, + dwDomainLen: DWORD; + pUserToken: PTOKEN_USER; + sUser, sDomain: String; + sidName: SID_NAME_USE; +begin + Result := ''; + pUserToken := nil; + + hToken := 0; + if not OpenProcessToken(hProcess, TOKEN_READ, hToken) then + exit; + + try + dwSize := 0; + GetTokenInformation(hToken, TokenUser, nil, 0, dwSize); + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + GetMem(pUserToken, dwSize); + if GetTokenInformation(hToken, TokenUser, pUserToken, dwSize, dwSize) then + begin + dwUserLen := 256; + dwDomainLen := 256; + SetLength(sUser, dwUserLen); + SetLength(sDomain, dwDomainLen); + if LookupAccountSid(nil, pUserToken.User.Sid, @sUser[1], dwUserLen, @sDomain[1], dwDomainLen, sidName) then + Result := Format('%s\%s', [DeleteNullTail(sDomain), DeleteNullTail(sUser)]); + end; + end; + finally + if hToken <> 0 then + CloseHandle(hToken); + + if pUserToken <> nil then + FreeMem(pUserToken); + end; +end; + +function GetProcessNameToList(aList: TStringList): Integer; +var + hSnapProc: THandle; + ProcEnt: TProcessEntry32; +begin + if aList = nil then + begin + Result := 0; + exit; + end; + aList.Clear; + + hSnapProc := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if hSnapProc = INVALID_HANDLE_VALUE then + exit; + + try + ProcEnt.dwSize := SizeOf(TProcessEntry32); + Process32First(hSnapProc, ProcEnt); // first = "system" + + while Process32Next(hSnapProc, ProcEnt) do + aList.Add(ProcEnt.szExeFile); + finally + CloseHandle(hSnapProc); + end; + + Result := aLIst.Count; +end; + +function GetProcessPidByName(sModuleName: String; dwIgnPid: DWORD = 0): DWORD; +var + hSnapProc: THandle; + ProcEnt: TProcessEntry32; +begin + Result := 0; + + hSnapProc := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if hSnapProc = INVALID_HANDLE_VALUE then + exit; + + sModuleName := UpperCase(sModuleName); + + try + ProcEnt.dwSize := SizeOf(TProcessEntry32); + Process32First(hSnapProc, ProcEnt); // first = "system" + + while Process32Next(hSnapProc, ProcEnt) do + begin + if (dwIgnPid <> ProcEnt.th32ProcessID) and + (UpperCase(ProcEnt.szExeFile) = sModuleName) then + begin + Result := ProcEnt.th32ProcessID; + exit; + end; + end; + finally + CloseHandle(hSnapProc); + end; +end; + +function GetProcessPidsByName(sModuleName: String; aPIDList: TProcessIdList = nil): Integer; +var + hSnapProc: THandle; + ProcEnt: TProcessEntry32; +begin + Result := 0; + + if aPIDList <> nil then + aPIDList.Clear; + + hSnapProc := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if hSnapProc = INVALID_HANDLE_VALUE then + exit; + + sModuleName := UpperCase(sModuleName); + + try + ProcEnt.dwSize := SizeOf(TProcessEntry32); + Process32First(hSnapProc, ProcEnt); // first = "system" + + while Process32Next(hSnapProc, ProcEnt) do + begin + if UpperCase(ProcEnt.szExeFile) = sModuleName then + begin + Inc(Result); + if aPIDList <> nil then + aPIDList.Add(ProcEnt.th32ProcessID); + end; + end; + finally + CloseHandle(hSnapProc); + end; +end; + +function GetProcessNameByPid(dwPid: DWORD): String; +var + hSnapProc: THandle; + ProcEnt: TProcessEntry32; +begin + Result := ''; + + if dwPid = 0 then + exit; + + hSnapProc := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if hSnapProc = INVALID_HANDLE_VALUE then + exit; + + try + ProcEnt.dwSize := SizeOf(TProcessEntry32); + Process32First(hSnapProc, ProcEnt); // first = "system" + + while Process32Next(hSnapProc, ProcEnt) do + begin + if ProcEnt.th32ProcessID = dwPid then + begin + Result := StrPas(ProcEnt.szExeFile); + exit; + end; + end; + finally + CloseHandle(hSnapProc); + end; +end; + +function GetProcessPPidByPid(dwPid: DWORD): DWORD; +var + hSnapProc: THandle; + ProcEnt: TProcessEntry32; +begin + Result := 0; + + if dwPid = 0 then + exit; + + hSnapProc := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if hSnapProc = INVALID_HANDLE_VALUE then + exit; + + try + ProcEnt.dwSize := SizeOf(TProcessEntry32); + Process32First(hSnapProc, ProcEnt); // first = "system" + + while Process32Next(hSnapProc, ProcEnt) do + begin + if ProcEnt.th32ProcessID = dwPid then + begin + Result := ProcEnt.th32ParentProcessID; + exit; + end; + end; + finally + CloseHandle(hSnapProc); + end; +end; + +function GetProcessPathByPid(dwPid: DWORD): String; +var + PList: TProcessEntList; // TTgProcessList; +begin + Result := ''; + if dwPid = 0 then + exit; + + Guard(PList, TProcessEntList.Create); + PList.UpdateProcessList; + + Result := PList.GetProcPathByPid(dwPid); +end; + +function GetProcessPIDFromWndHandle(hWndHandle: THandle): DWORD; +begin + Result := 0; + if hWndHandle <> 0 then + GetWindowThreadProcessId(hWndHandle, Result); +end; + +function GetProcessNameFromWndHandle(hWndHandle: THandle): String; +var + dwPid: DWORD; +begin + Result := ''; + if hWndHandle = 0 then + exit; + + dwPid := GetProcessPIDFromWndHandle(hWndHandle); + if dwPid <> 0 then + Result := GetProcessNameByPid(dwPid); +end; + +function GetProcessPathFromWndHandle(hWndHandle: THandle): String; +var + dwPid: DWORD; +begin + Result := ''; + if hWndHandle = 0 then + exit; + + dwPid := GetProcessPIDFromWndHandle(hWndHandle); + if dwPid <> 0 then + Result := GetProcessPathByPid(dwPid); +end; + +function GetWndHandleFromPID(dwPid: DWORD; sIfWndCaption: String = ''): HWND; +var + h: HWND; + dwCheckPID: DWORD; +begin + Result := 0; + h := FindWindow(nil, nil); + while h <> 0 do + begin + if GetParent(h) = 0 then + begin // 최상위 핸들 체크 (컨트롤 무시) + GetWindowThreadProcessId(h, @dwCheckPID); + if dwCheckPID = dwPid then + begin + // 윈도우7에서는 메인 윈도우 핸들이 구해 지지 않아서 윈도우 캡션 조건을 하나 더 추가 + if (sIfWndCaption <> '') and + (GetWindowCaption(h) <> sIfWndCaption) then + begin + h := GetWindow(h, GW_HWNDNEXT); + continue; + end; + + Result := h; + exit; + end; + end; + + h := GetWindow(h, GW_HWNDNEXT); + end; +end; + +function GetWndHandleFromPidEx(dwPid: DWORD; sClassName: String): HWND; +var + h: HWND; + dwCheckPID: DWORD; +begin + Result := 0; + h := FindWindow(nil, nil); + while h <> 0 do + begin + if GetParent(h) = 0 then + begin // 최상위 핸들 체크 (컨트롤 무시) + GetWindowThreadProcessId(h, @dwCheckPID); + if (dwCheckPID = dwPid) and (GetWndClassName(h) = sClassName) then + begin + Result := h; + exit; + end; + end; + h := GetWindow(h, GW_HWNDNEXT); + end; +end; + +//function _FindWindow_GetWndHandlesFromPID(h: HWND; lParam: NativeInt): BOOL; stdcall; +//var +// dwPid, +// dwCurPid: DWORD; +//begin +// dwCurPid := 0; +// GetWindowThreadProcessId(h, dwCurPid); +// if dwCurPid = StrToInt(TStrings(lParam)[0]) then +// begin +// TStrings(lParam).Add(IntToStr(h)); +// end; +// Result := TRUE; +//end; +// +//function GetWndHandlesFromPID(dwPid: DWORD; HandleList: TStrings): Integer; +//begin +// HandleList.Clear; +// HandleList.Add(IntToStr(dwPid)); +// EnumWindows(@_FindWindow_GetWndHandlesFromPID, NativeInt(HandleList)); +// HandleList.Delete(0); +//end; + +function GetWndHandlesFromPID(dwPid: DWORD; HandleList: TStrings): Integer; +var + h: HWND; + dwCheckPID: DWORD; +begin + Result := 0; + HandleList.Clear; + h := FindWindow(nil, nil); + while h <> 0 do + begin + if GetParent(h) = 0 then + begin // 최상위 핸들 체크 (컨트롤 무시) + GetWindowThreadProcessId(h, @dwCheckPID); + if dwCheckPID = dwPid then + begin + HandleList.Add(IntToStr(h)); + Inc(Result); + end; + end; + h := GetWindow(h, GW_HWNDNEXT); + end; +end; + +function GetProcesssUserSidFromPID(dwPid: DWORD): String; +var + hProcess, + hToken: THandle; + dwSize: DWORD; + pUserToken: PTOKEN_USER; + sUserSid: PChar; +begin + Result := ''; + if dwPid = 0 then + exit; + + hToken := 0; + try + hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, dwPid); + if hProcess = 0 then + exit; + + try + if not OpenProcessToken(hProcess, TOKEN_QUERY, hToken) then + exit; + + GetTokenInformation(hToken, TokenUser, nil, 0, dwSize); + if GetLastError = ERROR_INSUFFICIENT_BUFFER then + begin + GetMem(pUserToken, dwSize); + if GetTokenInformation(hToken, TokenUser, pUserToken, dwSize, dwSize) then + begin + if ConvertSidToStringSid(pUserToken.User.Sid, sUserSid) then + Result := StrPas(sUserSid); + end; + end; + finally + if pUserToken <> nil then + FreeMem(pUserToken); + if hToken <> 0 then + CloseHandle(hToken); + CloseHandle(hProcess); + end; + + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetProcesssUserSidFromPID()'); + end; +end; + +function GetProcesssUserSidFromName(sPName: String): String; +begin + Result := GetProcesssUserSidFromPID(GetProcessPidByName(sPName)); +end; + +function GetExeFileArchitectFromeStream(aStream: TStream): TExeArchitectKind; +const + IMAGE_FILE_MACHINE_I386 = $014C; // Intel x86 + IMAGE_FILE_MACHINE_IA64 = $0200; // Intel Itanium Processor Family (IPF) + IMAGE_FILE_MACHINE_AMD64 = $8664; // x64 (AMD64 or EM64T) + // You'll unlikely encounter the things below: + IMAGE_FILE_MACHINE_R3000_BE = $160; // MIPS big-endian + IMAGE_FILE_MACHINE_R3000 = $162; // MIPS little-endian, 0x160 big-endian + IMAGE_FILE_MACHINE_R4000 = $166; // MIPS little-endian + IMAGE_FILE_MACHINE_R10000 = $168; // MIPS little-endian + IMAGE_FILE_MACHINE_ALPHA = $184; // Alpha_AXP } + IMAGE_FILE_MACHINE_POWERPC = $1F0; // IBM PowerPC Little-Endian +var + Header: TImageDosHeader; + ImgHeader: TImageNtHeaders; +begin + Result := eakNoExe; + + aStream.ReadBuffer(Header, SizeOf(Header)); + if (Header.e_magic <> IMAGE_DOS_SIGNATURE) or + (Header._lfanew = 0) then exit; + + aStream.Position := Header._lfanew; + + aStream.ReadBuffer(ImgHeader, SizeOf(ImgHeader)); + if ImgHeader.Signature <> IMAGE_NT_SIGNATURE then + exit; + + if ImgHeader.FileHeader.Machine = IMAGE_FILE_MACHINE_I386 then + Result := eak32 + else + Result := eak64; +end; + +function GetExeFileArchitectFromePath(sPath: String): TExeArchitectKind; +var + fs: TFileStream; +begin + Guard(fs, TFileStream.Create(sPath, fmOpenRead or fmShareDenyNone)); + Result := GetExeFileArchitectFromeStream(fs); +end; + +function ExecuteApp(const sPath, sParam: String; wVisible: WORD; dwFlag: DWORD; + nX: Integer; nY: Integer): TProcessInformation; +var + StartupInfo: TStartupInfo; + sDir, + sName: String; +begin + ZeroMemory(@Result, SizeOf(Result)); + ZeroMemory(@StartupInfo, SizeOf(StartupInfo)); + StartupInfo.cb := Sizeof(StartupInfo); + StartupInfo.dwFlags := dwFlag; + StartupInfo.wShowWindow := wVisible; +// StartupInfo.lpDesktop := PWideChar(WideString('WinSta0\Default')); + StartupInfo.dwX := nX; + StartupInfo.dwY := nY; + + sDir := ExtractFilePath(sPath); + sName := ExtractFileName(sPath); + +// CreateProcess(PChar(sName), +// PChar(Format('%s %s', [sPath, sParam])), { pointer to command line string } +// nil, { pointer to process security attributes } +// nil, { pointer to thread security attributes } +// false, { handle inheritance flag } +//// CREATE_NEW_PROCESS_GROUP, +// CREATE_NEW_CONSOLE or { creation flags } +// NORMAL_PRIORITY_CLASS, +// nil, { pointer to new environment block } +// PChar(sDir), { pointer to current directory name } +// StartupInfo, { pointer to STARTUPINFO } +// Result); { pointer to PROCESS_INF } + + CreateProcess(nil, + PChar(Format('%s %s', [sPath, sParam])), { pointer to command line string } + nil, { pointer to process security attributes } + nil, { pointer to thread security attributes } + false, { handle inheritance flag } +// CREATE_NEW_PROCESS_GROUP, + CREATE_NEW_CONSOLE or { creation flags } + NORMAL_PRIORITY_CLASS, + nil, { pointer to new environment block } + nil, { pointer to current directory name } + StartupInfo, { pointer to STARTUPINFO } + Result); { pointer to PROCESS_INF } +end; + +procedure ReadPipeFromCmd(sCommand, sParam: String; nShow: Integer; ProcessString: TProcessString; dwExitTimeout: DWORD = 0); +var + hReadOutPipe, + hWriteOutPipe: THandle; + SI: TStartUpInfo; + PI: TProcessInformation; + SA: TSecurityAttributes; + SD: TSecurityDescriptor; + dwBytesRead: DWORD; + sDest: AnsiString; + dwAvail, + dwExitCode, + dwWaitResult, + dwExecuteTick: DWORD; + bWorkStop: Boolean; + + function IsNT: Boolean; + var + OS: TOSVersionInfo; + begin + OS.dwOSVersionInfoSize := Sizeof(OS); + GetVersionEx(OS); + if OS.dwPlatformId = VER_PLATFORM_WIN32_NT then + Result:= true + else + Result:= false; + end; + +begin + hReadOutPipe := 0; + hWriteOutPipe := 0; + + if IsNT then + begin + InitializeSecurityDescriptor(@SD, SECURITY_DESCRIPTOR_REVISION); + SetSecurityDescriptorDacl(@SD, True, nil, False); + SA.nLength := SizeOf(SA); + SA.lpSecurityDescriptor := @SD; + SA.bInheritHandle := true; + CreatePipe(hReadOutPipe, hWriteOutPipe, @SA, 1024); + end else + CreatePipe(hReadOutPipe, hWriteOutPipe, nil, 1024); + + ZeroMemory(@PI, SizeOf(PI)); + ZeroMemory(@SI, SizeOf(SI)); + SI.cb := SizeOf(SI); + SI.wShowWindow := nShow; + SI.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; + SI.hStdOutput := hWriteOutPipe; + SI.hStdError := hWriteOutPipe; + + dwExecuteTick := GetTickCount; + bWorkStop := false; + if CreateProcess(nil,//PChar(sCommand), + PChar(sCommand + ' ' + sParam), + nil, + nil, + true, + NORMAL_PRIORITY_CLASS, + nil, + nil, + SI, + PI) then + begin + try + dwExitCode := 0; + while dwExitCode = 0 do + begin + dwWaitResult := WaitForSingleObject(PI.hProcess, 50); + if PeekNamedPipe(hReadOutPipe, nil, 0, nil, @dwAvail, nil) then + begin + if dwAvail > 0 then + begin + SetLength(sDest, dwAvail); + ReadFile(hReadOutPipe, sDest[1], dwAvail, dwBytesRead, nil); + ProcessString(sDest, bWorkStop); + if bWorkStop then + exit; + end; + end; + if dwWaitResult <> WAIT_TIMEOUT then + dwExitCode := 1; + + // 메세지 없이 계속 돌아가는 상황을 위해서 빠져나오는 타임아웃을 추가함 (tcptunnel.exe 관련을 위해 추가) + if (dwExitTimeout > 0) and ((GetTickCount - dwExecuteTick) > dwExitTimeout) then + exit; + end; + GetExitCodeProcess(PI.hProcess, dwExitCode); + finally + CloseHandle(PI.hProcess); + CloseHandle(PI.hThread); + + if hReadOutPipe <> 0 then + CloseHandle(hReadOutPipe); + + if hWriteOutPipe <> 0 then + CloseHandle(hWriteOutPipe); + end; + end; +end; + +function GetCmdTextToStream(sCommand, sParam: String; aStream: TStream; dwTimeMilSec: DWORD = 0): Boolean; +begin + Result := false; + try + ReadPipeFromCmd(sCommand, sParam, SW_HIDE, + procedure(sText: String; var bWorkStop: Boolean) + var + sData: UTF8String; + begin + sData := sText; + aStream.Write(PAnsiChar(sData)^, Length(sData)); + end, dwTimeMilSec); + Result := true; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetCmdTextToStream()'); + end; +end; + +function ExecuteAppAsUser(dwFollowPID: DWORD; sPath, sParam: String; dwVisible: DWORD): TProcessInformation; +const + DEFWINSTATION = 'WinSta0'; + + DEFDESKTOP = 'Default'; + WINLOGON = 'Winlogon'; + SCREENSAVER = 'Screen-Saver'; + + WHITESPACE = ' '{SPACE}+chr(9){TAB}+chr(10){LF}; + DOMUSERSEP = '\'; +var + StartupInfo: TStartupInfo; + ProcessInfo: TProcessInformation; + dwCreateFlag: DWORD; + pEnvBlock: Pointer; + hProc, hToken, hNewToken: THandle; + TIL: TOKEN_MANDATORY_LABEL; +begin + ZeroMemory(@Result, SizeOf(Result)); + ZeroMemory(@ProcessInfo, SizeOf(TProcessInformation)); + ZeroMemory(@TIL, SizeOf(TIL)); + + hToken := 0; + hNewToken := 0; + + if dwFollowPID = 0 then + begin + TTgTrace.T('ExecuteAppAsUser() .. FollowPID is null..'); + exit; + end; + +// hProc := OpenProcess(PROCESS_ALL_ACCESS, false, dwFollowPID); + hProc := OpenProcess(MAXIMUM_ALLOWED, false, dwFollowPID); + if hProc = 0 then + begin + TTgTrace.T('ExecuteAppAsUser() .. OpenProcess() - Fail... Error=%d', [GetLastError]); + exit; + end; + + try +// if OpenProcessToken(hProc, TOKEN_ASSIGN_PRIMARY or TOKEN_DUPLICATE, hToken) then + if OpenProcessToken(hProc, MAXIMUM_ALLOWED, hToken) then + begin +// if DuplicateTokenEx(hToken, TOKEN_ASSIGN_PRIMARY or TOKEN_ALL_ACCESS, nil, + if DuplicateTokenEx(hToken, MAXIMUM_ALLOWED, nil, + SecurityImpersonation, TokenPrimary, hNewToken) then + begin + {$IF false} + pIntSid := nil; + copy_str(sIntSid, 's-1-16-4096'); + if ConvertSidToStringSid(@sIntSid, pIntSid) then + begin + TIL.Label_.Attributes := SE_GROUP_INTEGRITY; + TIL.Label_.Sid := pIntSid; + + if SetTokenInformation(hNewToken, TokenIntegrityLevel, @TIL, SizeOf(TIL)+GetLengthSid(pIntSid)) then + begin + ZeroMemory(@StartupInfo, SizeOf(TStartupInfo)); + StartupInfo.cb := Sizeof(TStartupInfoW); + StartupInfo.lpDesktop := DEFWINSTATION + '\' + DEFDESKTOP; +// StartupInfo.lpDesktop := DEFWINSTATION + '\' + WINLOGON; + StartupInfo.wShowWindow := dwVisible; +// StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USEPOSITION; // SW_HIDE등을 적용 시키려면 이걸 활성화 시켜줘야 한다 + + dwCreateFlag := NORMAL_PRIORITY_CLASS or CREATE_NEW_CONSOLE; + pEnvBlock := nil; + CreateEnvironmentBlock(pEnvBlock, hNewToken, true); + if pEnvBlock <> nil then + dwCreateFlag := dwCreateFlag or CREATE_UNICODE_ENVIRONMENT; + + if CreateProcessAsUserW(hNewToken, + nil,//PWideChar(ExtractFileName(sPath)), + PWideChar(Format('"%s" %s', [sPath, sParam])), + nil, + nil, + false, + dwCreateFlag, + pEnvBlock, + nil,//PWideChar(ExtractFilePath(sPath)), + StartupInfo, + ProcessInfo) then + begin + Result := ProcessInfo; + end else + TTgTrace.T('ExecuteAppAsUser() .. CreateProcessAsUserW() - Fail... Error=%d', [GetLastError]); + end; +// LocalFree(pIntSid); + end; + {$ELSE} + + +// ImpersonateLoggedOnUser(hToken); +// if GetLastError <> ERROR_SUCCESS then +// exit; + + ZeroMemory(@StartupInfo, SizeOf(StartupInfo)); + StartupInfo.cb := Sizeof(StartupInfo); + StartupInfo.lpDesktop := DEFWINSTATION + '\' + DEFDESKTOP; + // StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USEPOSITION; // SW_HIDE등을 적용 시키려면 이걸 활성화 시켜줘야 한다 + StartupInfo.wShowWindow := dwVisible; + + dwCreateFlag := NORMAL_PRIORITY_CLASS or CREATE_NEW_CONSOLE; + + pEnvBlock := nil; + CreateEnvironmentBlock(pEnvBlock, hNewToken, true); + if pEnvBlock <> nil then + dwCreateFlag := dwCreateFlag or CREATE_UNICODE_ENVIRONMENT; + + if CreateProcessAsUserW(hNewToken, + nil,//PWideChar(ExtractFileName(sPath)), + PWideChar(Format('"%s" %s', [sPath, sParam])), + nil, + nil, + false, + dwCreateFlag, + pEnvBlock, + nil,//PWideChar(ExtractFilePath(sPath)), + StartupInfo, + ProcessInfo) then + begin + Result := ProcessInfo; + end else + TTgTrace.T('ExecuteAppAsUser() .. CreateProcessAsUserW() - Fail... Error=%d', [GetLastError]); + {$IFEND} + end; + end else + TTgTrace.T('ExecuteAppAsUser() .. OpenProcessToken() - Fail... Error=%d', [GetLastError]); + finally + if hToken <> 0 then + CLoseHandle(hToken); + if hNewToken <> 0 then + CloseHandle(hNewToken); + if hProc <> 0 then + CloseHandle(hProc); + end; +end; + +function ExecuteAppAsUser(sModuleName, sPath, sParam: String; dwVisible: DWORD): TProcessInformation; +begin + Result := ExecuteAppAsUser(GetProcessPidByName(sModuleName), sPath, sParam, dwVisible); +end; + +function ExecuteAppWaitUntilTerminate(sPath, sParam: String; dwVisible: DWORD; nTimeOutMilSec: Integer = -1): Boolean; +var + PI: TProcessInformation; + StartupInfo: TStartupInfo; + sDir, + sName: String; +// dwExitCode, + dwWaitResult, + dwExecuteTick: DWORD; +begin + ZeroMemory(@PI, SizeOf(PI)); + ZeroMemory(@StartupInfo, SizeOf(StartupInfo)); + StartupInfo.cb := Sizeof(StartupInfo); + StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USEPOSITION; + StartupInfo.wShowWindow := dwVisible; + + sDir := ExtractFilePath(sPath); + sName := ExtractFileName(sPath); + Result := CreateProcess(nil, + PChar(Format('%s %s', [sPath, sParam])), { pointer to command line string } + nil, { pointer to process security attributes } + nil, { pointer to thread security attributes } + false, { handle inheritance flag } + CREATE_NEW_CONSOLE or { creation flags } + NORMAL_PRIORITY_CLASS, + nil, { pointer to new environment block } + nil, { pointer to current directory name } + StartupInfo, { pointer to STARTUPINFO } + PI); { pointer to PROCESS_INF } + + if Result then + begin + dwExecuteTick := GetTickCount; + while true do + begin + dwWaitResult := WaitForSingleObject(PI.hProcess, 50); + if dwWaitResult <> WAIT_TIMEOUT then + break; + + // 메세지 없이 계속 돌아가는 상황을 위해서 빠져나오는 타임아웃을 추가함 (tcptunnel.exe 관련을 위해 추가) + if (nTimeOutMilSec > 0) and ((GetTickCount - dwExecuteTick) > nTimeOutMilSec) then + begin + TerminateProcess(PI.hProcess, 999); + exit; + end; + end; +// GetExitCodeProcess(PI.hProcess, dwExitCode); + end; +end; + +// 0 이하 : 실패, 1 : 성공, 2 : 이미 사용중 +function InjectModule(dwPid: DWORD; sDllPath: String; pbIsWow64: PBoolean = nil): Integer; +var + dwThdID: DWORD; + dwBufSize, dwWritten: NativeUInt; + hProcess, hModuleThread: THandle; + pRemoteBuf: Pointer; + bWow64: BOOL; + + hModuleSht: THandle; + MdEnt32: TModuleEntry32; +begin + Result := 0; + if dwPid = 0 then + exit; + + hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, dwPID); + if pbIsWow64 <> nil then + begin + if not IsWow64Process(hProcess, bWow64) then + begin + Result := -1; + TTgTrace.T('Fail .. InjectModule(0) .. IsWow64Process()'); + exit; + end; + + if ((pbIsWow64^ = true) and not bWow64) or + ((pbIsWow64^ = false) and bWow64) then + exit; + end; + + if hProcess = 0 then + begin + Result := -2; + TTgTrace.T('Fail .. InjectModule(0) .. OpenProcess()'); + exit; + end; + + try + // 이미 사용중인 모듈인지 체크 22_1028 13:35:00 kku + hModuleSht := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, dwPid); + try + if hModuleSht <> INVALID_HANDLE_VALUE then + begin + ZeroMemory(@MdEnt32, SizeOf(MdEnt32)); + MdEnt32.dwSize := SizeOf(MdEnt32); + if Module32First(hModuleSht, MdEnt32) then + Repeat + if CompareText(sDllPath, String(MdEnt32.szExePath)) = 0 then + begin + // 이미 로드됨 + Result := 2; + exit; + end; + Until not Module32Next(hModuleSht, MdEnt32); + end; + finally + if (hModuleSht <> 0) and (hModuleSht <> INVALID_HANDLE_VALUE) then + CloseHandle(hModuleSht); + end; + + dwBufSize := Length(sDllPath) * 2; + pRemoteBuf := VirtualAllocEx(hProcess, nil, dwBufSize, MEM_COMMIT, PAGE_READWRITE); + if pRemoteBuf = nil then + begin + Result := -3; + TTgTrace.T('Fail .. InjectModule(0) .. VirtualAllocEx()'); + exit; + end; + + + if not WriteProcessMemory(hProcess, pRemoteBuf, PChar(sDllPath), dwBufSize, dwWritten) then + begin + Result := -4; + TTgTrace.T('Fail .. InjectModule(0) .. WriteProcessMemory()'); + exit; + end; + + // DLL Injection + hModuleThread := CreateRemoteThread(hProcess, nil, 0, + GetProcAddress(LoadLibrary('kernel32.dll'), 'LoadLibraryW'), pRemoteBuf, 0, dwThdID); + if hModuleThread <> 0 then + begin + try + if WaitForSingleObject(hModuleThread, 20000{INFINITE}) = WAIT_FAILED then + Sleep(500); + finally + CloseHandle(hModuleThread); + end; + Result := 1; + end else begin + Result := GetLastError * -1; + if Result = 0 then + Result := -999; + TTgTrace.T('Fail .. InjectModule(0) .. CreateRemoteThread()'); + end; + finally + if pRemoteBuf <> nil then + VirtualFreeEx(hProcess, pRemoteBuf, dwBufSize, MEM_RELEASE); + CloseHandle(hProcess); + end; +end; + +function EjectModule(hProcess: THandle; pModBaseAddr: Pointer; hKernel32: HMODULE = 0): Boolean; +var + hModuleThread: THandle; + dwThreadId: DWORD; +begin + Result := false; + if pModBaseAddr = nil then + exit; + + if hKernel32 = 0 then + begin + hKernel32 := GetModuleHandle(kernel32); + if hKernel32 = 0 then + exit; + end; + + try + hModuleThread := CreateRemoteThread(hProcess, nil, 0, + GetProcAddress(hKernel32, 'FreeLibrary'), pModBaseAddr, 0, dwThreadId); +// hModuleThread := CreateRemoteThread(hProcess, nil, 0, +// GetProcAddress(hKernel32, 'FreeLibraryAndExitThread'), pModBaseAddr, 0, dwThreadId); + if hModuleThread <> 0 then + begin + try + if WaitForSingleObject(hModuleThread, 20000{INFINITE}) = WAIT_FAILED then + Sleep(500); + +// if WaitForSingleObject(hModuleThread, INFINITE) = WAIT_FAILED then +// Sleep(500); + finally + CloseHandle(hModuleThread); + end; + Result := true; + end; + except + on E: Exception do + ETgException.TraceException(E, 'EjectModule() .. Fail .. hModuleThread'); + end; +end; + +function EjectModuleFromPath(sDllPaths: String; dwIgrPid: DWORD = 0): Integer; +var + DllList: TStringList; + hProcess, + hModuleSht: THandle; + MdEnt32: TModuleEntry32; + hKernel32: HMODULE; + h: THandle; + ProcEnt: TProcessEntry32; + i: Integer; +begin + Result := 0; + + hKernel32 := GetModuleHandle(kernel32); + if hKernel32 = 0 then + exit; + + Result := 0; + + h := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if h = INVALID_HANDLE_VALUE then + exit; + + try + Guard(DllList, TStringList.Create); + SplitString(sDllPaths, '|', DllList); + try + ProcEnt.dwSize := SizeOf(ProcEnt); + + Process32First(h, ProcEnt); // system + while Process32Next(h, ProcEnt) do + begin + hModuleSht := 0; + + if ProcEnt.th32ProcessID = dwIgrPid then + continue; + + hProcess := OpenProcess(PROC_FULL_ACCESS, false, ProcEnt.th32ProcessID); + if hProcess <> 0 then + hModuleSht := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcEnt.th32ProcessID); + try + if hModuleSht <> INVALID_HANDLE_VALUE then + begin + ZeroMemory(@MdEnt32, SizeOf(MdEnt32)); + MdEnt32.dwSize := SizeOf(MdEnt32); + if Module32First(hModuleSht, MdEnt32) then + Repeat + for i := 0 to DllList.Count - 1 do + begin + if CompareText(DllList[i], String(MdEnt32.szExePath)) = 0 then + begin + if EjectModule(hProcess, MdEnt32.modBaseAddr, hKernel32) then + Inc(Result); + end; + end; + Until not Module32Next(hModuleSht, MdEnt32); + end; + finally + if hProcess <> 0 then + CloseHandle(hProcess); + + if (hModuleSht <> 0) and (hModuleSht <> INVALID_HANDLE_VALUE) then + CloseHandle(hModuleSht); + end; + end; + finally + CloseHandle(h); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. EjectModuleFromPath()'); + end; +end; + +function EjectModuleFromPath2(sDllPath: String; sIgrPNames: String): Integer; +var + hProcess, + hModuleSht: THandle; + MdEnt32: TModuleEntry32; + hKernel32: HMODULE; + h: THandle; + ProcEnt: TProcessEntry32; + IgrList: TStringList; +begin + Result := 0; + + hKernel32 := GetModuleHandle(kernel32); + if hKernel32 = 0 then + exit; + + Result := 0; + + h := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if h = INVALID_HANDLE_VALUE then + exit; + + try + Guard(IgrList, TStringList.Create); + IgrList.CaseSensitive := false; + SplitString(sIgrPNames, '|', IgrList); + try + ProcEnt.dwSize := SizeOf(ProcEnt); + + Process32First(h, ProcEnt); // system + while Process32Next(h, ProcEnt) do + begin + hModuleSht := 0; + + if IgrList.IndexOf(String(ProcEnt.szExeFile)) <> -1 then + continue; + + hProcess := OpenProcess(PROC_FULL_ACCESS, false, ProcEnt.th32ProcessID); + if hProcess <> 0 then + hModuleSht := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcEnt.th32ProcessID); + try + if hModuleSht <> INVALID_HANDLE_VALUE then + begin + ZeroMemory(@MdEnt32, SizeOf(MdEnt32)); + MdEnt32.dwSize := SizeOf(MdEnt32); + if Module32First(hModuleSht, MdEnt32) then + Repeat + if CompareText(sDllPath, String(MdEnt32.szExePath)) = 0 then + begin + if EjectModule(hProcess, MdEnt32.modBaseAddr, hKernel32) then + Inc(Result); + end; + Until not Module32Next(hModuleSht, MdEnt32); + end; + finally + if hProcess <> 0 then + CloseHandle(hProcess); + + if (hModuleSht <> 0) and (hModuleSht <> INVALID_HANDLE_VALUE) then + CloseHandle(hModuleSht); + end; + end; + finally + CloseHandle(h); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. EjectModuleFromPath()'); + end; +end; + +function EjectModuleFromPathUntilZero(sDllPath: String; dwIgrPid: DWORD = 0): Integer; +begin + Result := 0; + while EjectModuleFromPath(sDllPath, dwIgrPid) <> 0 do + begin + Inc(Result); + if Result > 50 then + exit; + Sleep(300); + end; +end; + +function EjectModuleFromName(sName: String; dwIgrPid: DWORD = 0): Integer; +var + hProcess, + hModuleSht: THandle; + MdEnt32: TModuleEntry32; + hKernel32: HMODULE; + h: THandle; + ProcEnt: TProcessEntry32; +begin + Result := 0; + + hKernel32 := GetModuleHandle(kernel32); + if hKernel32 = 0 then + exit; + + Result := 0; + + h := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if h = INVALID_HANDLE_VALUE then + exit; + + try + try + ProcEnt.dwSize := SizeOf(ProcEnt); + + Process32First(h, ProcEnt); // system + while Process32Next(h, ProcEnt) do + begin + hModuleSht := 0; + + if ProcEnt.th32ProcessID = dwIgrPid then + continue; + + hProcess := OpenProcess(PROC_FULL_ACCESS, false, ProcEnt.th32ProcessID); + if hProcess <> 0 then + hModuleSht := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcEnt.th32ProcessID); + try + if hModuleSht <> INVALID_HANDLE_VALUE then + begin + ZeroMemory(@MdEnt32, SizeOf(MdEnt32)); + MdEnt32.dwSize := SizeOf(MdEnt32); + if Module32First(hModuleSht, MdEnt32) then + Repeat + if CompareText(sName, ExtractFileName(String(MdEnt32.szExePath))) = 0 then + begin + if EjectModule(hProcess, MdEnt32.modBaseAddr, hKernel32) then + Inc(Result); + end; + Until not Module32Next(hModuleSht, MdEnt32); + end; + finally + if hProcess <> 0 then + CloseHandle(hProcess); + + if (hModuleSht <> 0) and (hModuleSht <> INVALID_HANDLE_VALUE) then + CloseHandle(hModuleSht); + end; + end; + finally + CloseHandle(h); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. EjectModuleFromPath()'); + end; +end; + +function EjectModuleByPName(dwPid: DWORD; sDllName: String): Boolean; +var + hProcess, + hModuleSht: THandle; + MdEnt32: TModuleEntry32; + hKernel32: HMODULE; + h: THandle; + ProcEnt: TProcessEntry32; +begin + Result := false; + + hKernel32 := GetModuleHandle(kernel32); + if hKernel32 = 0 then + exit; + + h := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + if h = INVALID_HANDLE_VALUE then + exit; + + try + try + ProcEnt.dwSize := SizeOf(ProcEnt); + + Process32First(h, ProcEnt); // system + while Process32Next(h, ProcEnt) do + begin + hModuleSht := 0; + + if dwPid = ProcEnt.th32ProcessID then + begin + hProcess := OpenProcess(PROC_FULL_ACCESS, false, ProcEnt.th32ProcessID); + if hProcess <> 0 then + hModuleSht := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcEnt.th32ProcessID); + try + if hModuleSht <> INVALID_HANDLE_VALUE then + begin + ZeroMemory(@MdEnt32, SizeOf(MdEnt32)); + MdEnt32.dwSize := SizeOf(MdEnt32); + if Module32First(hModuleSht, MdEnt32) then + Repeat + if CompareText(sDllName, ExtractFileName(String(MdEnt32.szExePath))) = 0 then + begin + if EjectModule(hProcess, MdEnt32.modBaseAddr, hKernel32) then + begin + Result := true; + exit; + end; + end; + Until not Module32Next(hModuleSht, MdEnt32); + end; + finally + if hProcess <> 0 then + CloseHandle(hProcess); + + if (hModuleSht <> 0) and (hModuleSht <> INVALID_HANDLE_VALUE) then + CloseHandle(hModuleSht); + end; + end; + end; + finally + CloseHandle(h); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. EjectModuleFromPath()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Registry.pas b/Tocsg.Lib/VCL/Tocsg.Registry.pas new file mode 100644 index 00000000..0b765ed3 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Registry.pas @@ -0,0 +1,610 @@ +{*******************************************************} +{ } +{ Tocsg.Registry } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Registry; + +interface + +uses + WinApi.Windows, System.Classes, System.Win.Registry, System.SysUtils, + System.Generics.Collections, Tocsg.Trace; + +const + REG_RUN = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Run\'; + REG_PROFILE = 'SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList\'; + +type + TRkInfo = record + sKName: string; + ftLastWriteTime: TFileTime; + end; + TRkInfoList = TList<TRkInfo>; + +function SetRegValueString(K: HKEY; const sKey, sValueName, sValue: String; bCanCreate: Boolean = false): Boolean; +function SetRegValueStringEx(K: HKEY; const sKey, sValueName, sValue: String; bCanCreate: Boolean = false): Boolean; +function SetRegValueInteger(K: HKEY; const sKey, sValueName: String; nValue: Integer; bCanCreate: Boolean = false): Boolean; + +function ExistsKey(K: HKEY; const sKey: String): Boolean; +function CountRegKeyValue(K: HKEY; const sKey: String): Integer; +function GetRegValueAsString(K: HKEY; const sKey, sValue: String; bCreate: Boolean = false): String; +function GetRegValueAsInteger(K: HKEY; const sKey, sValue: String; nDefVal: Integer = 0): Integer; + +function GetRegRecentUserSid: String; + +function DelRegKey(K: HKEY; const sKey: String): Boolean; +function DelRegValue(K: HKEY; const sKey, sValueName: String): Boolean; + +function ExtRegSubKeyToStrings(K: HKEY; sKey: String; aStrings: TStrings): Boolean; + +function ExistsRunAppByHLM(const AppName: String; aRootKey: HKEY = HKEY_LOCAL_MACHINE): Boolean; +function AddRunAppByHLM(const AppName, sValue: String; aRootKey: HKEY = HKEY_LOCAL_MACHINE): Boolean; +function DeleteRunAppByHLM(const AppName: String; aRootKey: HKEY = HKEY_LOCAL_MACHINE): Boolean; + +function GetDomainUserNameFromReg: String; +function GetUserNameFromReg(sRegKey: String = ''): String; + +procedure CopyRegKey(K: HKEY; sSrcKey, sDestKey: String); + +function ExtrSubKeySortList(K: HKEY; sKey: String; aRkInfoList: TRkInfoList): Integer; + +type +// 기본 TRegistry 클래스는 REG_MULTI_SZ 타입까지 분석하지 못한다. +// 그래서 헬퍼 클래스로 지원되도록 추가함 14_1006 15:08:25 kku + TRegDataTypeEx = (rdxUnknown, rdxString, rdxExpandString, rdxInteger, rdxBinary, rdxMultiString{추가}); + + TRegDataInfoEx = record + RegData: TRegDataTypeEx; + DataSize: Integer; + end; + + TRegistryHelper = class helper for TRegistry + private + function GetDataEx(const Name: string; Buffer: Pointer; BufSize: Integer; var RegData: TRegDataTypeEx): Integer; // 지금까지 외부에서 사용할일이 없어서 숨김 14_1006 15:09:49 kku + function GetDataInfoEx(const ValueName: string; var Value: TRegDataInfoEx): Boolean; // 지금까지 외부에서 사용할일이 없어서 숨김 14_1006 15:09:49 kku + public + function GetDataAsStringEx(const ValueName: string; PrefixType: Boolean = false): string; + function GetDataTypeEx(const ValueName: string): TRegDataTypeEx; // 외부에서는 이걸로 타입 확인하고, GetDataAsStringEx 이걸로 데이터 가져오는걸로 사용한다 14_1006 15:09:20 kku + procedure WriteMultiString(const ValueName: String; aMultiStrList: TStrings); + end; + + +implementation + +uses + System.RTLConsts, Tocsg.Safe, Tocsg.Exception, Tocsg.DateTime, Tocsg.Process, + System.Generics.Defaults; + +function CompareByLastWriteTime(const Left, Right: TRkInfo): Integer; +begin + Result := CompareFileTime(Right.ftLastWriteTime, Left.ftLastWriteTime); +end; + +function SetRegValueString(K: HKEY; const sKey, sValueName, sValue: String; bCanCreate: Boolean = false): Boolean; +var + Reg: TRegistry; +begin + Result := false; + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + if Reg.OpenKey(sKey, bCanCreate) then + if bCanCreate or Reg.ValueExists(sValueName) then + begin + try + Reg.WriteString(sValueName, sValue); + Result := true; + except + + end; + end; +end; + +function SetRegValueStringEx(K: HKEY; const sKey, sValueName, sValue: String; bCanCreate: Boolean = false): Boolean; +var + Reg: TRegistry; +begin + Result := false; + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + if Reg.OpenKey(sKey, bCanCreate) then + if bCanCreate or Reg.ValueExists(sValueName) then + begin + try + Reg.WriteExpandString(sValueName, sValue); + Result := true; + except + + end; + end; +end; + +function SetRegValueInteger(K: HKEY; const sKey, sValueName: String; nValue: Integer; bCanCreate: Boolean = false): Boolean; +var + Reg: TRegistry; +begin + Result := false; + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + if Reg.OpenKey(sKey, bCanCreate) then + if bCanCreate or Reg.ValueExists(sValueName) then + begin + try + Reg.WriteInteger(sValueName, nValue); + Result := true; + except + + end; + end; +end; + +function ExistsKey(K: HKEY; const sKey: String): Boolean; +var + Reg: TRegistry; +begin + Result := false; + + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + try + Result := Reg.KeyExists(sKey); + except + // + end; +end; + +function CountRegKeyValue(K: HKEY; const sKey: String): Integer; +var + Reg: TRegistry; + StrList: TStringList; +begin + Result := 0; + + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + try + if Reg.OpenKey(sKey, false) then + begin + Guard(StrList, TStringList.Create); + Reg.GetValueNames(StrList); + Result := StrList.Count; + end; + except + // + end; +end; + +function GetRegValueAsString(K: HKEY; const sKey, sValue: String; bCreate: Boolean = false): String; +var + Reg: TRegistry; +begin + Result := ''; + + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + try + if Reg.OpenKey(sKey, bCreate) and Reg.ValueExists(sValue) then + Result := Reg.ReadString(sValue); + except + // + end; +end; + +function GetRegValueAsInteger(K: HKEY; const sKey, sValue: String; nDefVal: Integer = 0): Integer; +var + Reg: TRegistry; +begin + Result := nDefVal; + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + try + if Reg.OpenKey(sKey, false) and Reg.ValueExists(sValue) then + begin + Result := Reg.ReadInteger(sValue); + end; + except + // + end; +end; + +function GetRegRecentUserSid: String; +var + Reg, RegCheck: TRegistry; + StrList: TStringList; + i, nHigh, nLow: Integer; + sTemp: String; + dtRecent, dtCheck: TDateTime; +begin + Result := ''; + try + Guard(Reg, TRegistry.Create); + Reg.RootKey := HKEY_LOCAL_MACHINE; + if not Reg.OpenKeyReadOnly(REG_PROFILE) then + exit; + Guard(StrList, TStringList.Create); + + dtRecent := 0; + Reg.GetKeyNames(StrList); + Reg.CloseKey; + + Guard(RegCheck, TRegistry.Create); + RegCheck.RootKey := HKEY_USERS; + for i := 0 to StrList.Count - 1 do + begin + if (Length(StrList[i]) > 20) and + RegCheck.OpenKeyReadOnly(StrList[i]) then // 키가 존재하는거 대상으로 함 (로그온된거) 22_0620 16:50:47 kku + begin + RegCheck.CloseKey; + + // LocalProfileLoadTimeHigh, LocalProfileLoadTimeLow가 0인 경우가 있다... 22_0620 16:45:02 kku + nHigh := GetRegValueAsInteger(HKEY_LOCAL_MACHINE, REG_PROFILE + StrList[i], 'LocalProfileLoadTimeHigh'); + nLow := GetRegValueAsInteger(HKEY_LOCAL_MACHINE, REG_PROFILE + StrList[i], 'LocalProfileLoadTimeLow'); + sTemp := IntToHex(nHigh) + IntToHex(nLow); + // UTC-0 + dtCheck := ConvTimestampToDateTime(LONGLONG(StrToInt64Def('$' + sTemp, 0))); + + if (dtRecent = 0) or (dtRecent < dtCheck) then + begin + dtRecent := dtCheck; + Result := StrList[i]; + end; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetRegRecentUserSid()'); + end; +end; + +function DelRegKey(K: HKEY; const sKey: String): Boolean; +var + Reg: TRegistry; +begin + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + Result := Reg.DeleteKey(sKey); +end; + +function DelRegValue(K: HKEY; const sKey, sValueName: String): Boolean; +var + Reg: TRegistry; +begin + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + Result := false; + if Reg.OpenKey(sKey, false) then + Result := Reg.DeleteValue(sValueName); +end; + +function ExtRegSubKeyToStrings(K: HKEY; sKey: String; aStrings: TStrings): Boolean; +var + Reg: TRegistry; + SubList: TStringList; + i: Integer; +begin + Result := false; + + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + + if Reg.KeyExists(sKey) then + if Reg.OpenKey(sKey, false) then + begin + sKey := IncludeTrailingPathDelimiter(sKey); + Guard(SubList, TStringList.Create); + Reg.GetKeyNames(SubList); + for i := 0 to SubList.Count - 1 do + begin + // 값까지 체크 해준다. notepad++ 같은 경우 설정값을 여기에 남겨 놓는경우가 있음 22_0614 16:20:37 kku + if GetRegValueAsString(K, sKey + SubList[i], 'DisplayName') <> '' then + aStrings.Add(sKey + SubList[i]); + end; + Result := true; + end; +end; + +function ExistsRunAppByHLM(const AppName: String; aRootKey: HKEY = HKEY_LOCAL_MACHINE): Boolean; +var + Reg: TRegistry; +begin + Result := false; + Guard(Reg, TRegistry.Create); + Reg.RootKey := aRootKey; + if Reg.OpenKey(REG_RUN, false) then + Result := Reg.ValueExists(AppName); +end; + +function AddRunAppByHLM(const AppName, sValue: String; aRootKey: HKEY = HKEY_LOCAL_MACHINE): Boolean; +var + Reg: TRegistry; +begin + Result := false; + Guard(Reg, TRegistry.Create); + Reg.RootKey := aRootKey; + if Reg.OpenKey(REG_RUN, false) then + begin + try + Reg.WriteString(AppName, sValue); + Result := true; + except + // reg write 오류? + end; + end; +end; + +function DeleteRunAppByHLM(const AppName: String; aRootKey: HKEY = HKEY_LOCAL_MACHINE): Boolean; +begin + Result := DelRegValue(aRootKey, REG_RUN, AppName); +end; + +{ TRegistryHelper } + +function DataTypeToRegDataEx(Value: Integer): TRegDataTypeEx; +begin + case Value of + REG_SZ : Result := rdxString; + REG_EXPAND_SZ : Result := rdxExpandString; + REG_MULTI_SZ : Result := rdxMultiString; + REG_DWORD : Result := rdxInteger; + REG_BINARY : Result := rdxBinary; + else Result := rdxUnknown; + end; +end; + +function BinaryToHexString(const BinaryData: array of Byte; const PrefixStr: string): string; +var + DataSize, I, Offset: Integer; + HexData: string; + PResult: PChar; +begin + OffSet := 0; + if PrefixStr <> '' then + begin + Result := PrefixStr; + Inc(Offset, Length(PrefixStr)); + end; + DataSize := Length(BinaryData); + + SetLength(Result, Offset + (DataSize*3) - 1); // less one for last ',' + PResult := PChar(Result); // Use a char pointer to reduce string overhead + for I := 0 to DataSize - 1 do + begin + HexData := IntToHex(BinaryData[I], 2); + PResult[Offset] := HexData[1]; + PResult[Offset+1] := HexData[2]; + if I < DataSize - 1 then + PResult[Offset+2] := ','; + Inc(Offset, 3); + end; +end; + +function TRegistryHelper.GetDataInfoEx(const ValueName: string; var Value: TRegDataInfoEx): Boolean; +var + DataType: Integer; +begin + FillChar(Value, SizeOf(TRegDataInfo), 0); + Result := CheckResult(RegQueryValueEx(CurrentKey, PChar(ValueName), nil, @DataType, nil, + @Value.DataSize)); + Value.RegData := DataTypeToRegDataEx(DataType); +end; + +function TRegistryHelper.GetDataTypeEx(const ValueName: string): TRegDataTypeEx; +var + Info: TRegDataInfoEx; +begin + if GetDataInfoEx(ValueName, Info) then + Result := Info.RegData else + Result := rdxUnknown; +end; + +function TRegistryHelper.GetDataEx(const Name: string; Buffer: Pointer; + BufSize: Integer; var RegData: TRegDataTypeEx): Integer; +var + DataType: Integer; +begin + DataType := REG_NONE; + if not CheckResult(RegQueryValueEx(CurrentKey, PChar(Name), nil, @DataType, PByte(Buffer), + @BufSize)) then + raise ERegistryException.CreateResFmt(@SRegGetDataFailed, [Name]); + Result := BufSize; + RegData := DataTypeToRegDataEx(DataType); +end; + +function TRegistryHelper.GetDataAsStringEx(const ValueName: string; + PrefixType: Boolean = false): string; +const + SDWORD_PREFIX = 'dword:'; + SHEX_PREFIX = 'hex:'; +var + Info: TRegDataInfoEx; + BinaryBuffer: array of Byte; + nPos: Integer; + pBuf: TBytes; +begin + Result := ''; + if GetDataInfoEx(ValueName, Info) and (Info.DataSize > 0) then + begin + case Info.RegData of + rdxString, rdxExpandString: + begin + SetString(Result, nil, Info.DataSize); + GetDataEx(ValueName, PChar(Result), Info.DataSize, Info.RegData); + SetLength(Result, StrLen(PChar(Result))); + end; + rdxMultiString : + begin + SetLength(pBuf, Info.DataSize); + GetDataEx(ValueName, pBuf, Info.DataSize, Info.RegData); + + nPos := 0; + while nPos < Info.DataSize do + begin + Result := Result + PChar(@pBuf[nPos]); + {$IFDEF UNICODE} + Inc(nPos, (Length(PChar(@pBuf[nPos])) + 1) * 2); + {$ELSE} + Inc(nPos, Length(PChar(@pBuf[nPos])) + 1); + {$ENDIF} + if nPos < Info.DataSize then + Result := Result + #13#10; + end; + end; + rdxInteger: + begin + if PrefixType then + Result := SDWORD_PREFIX+IntToHex(ReadInteger(ValueName), 8) + else + Result := IntToStr(ReadInteger(ValueName)); + end; + rdxBinary, rdxUnknown: + begin + SetLength(BinaryBuffer, Info.DataSize); + ReadBinaryData(ValueName, Pointer(BinaryBuffer)^, Info.DataSize); + if PrefixType then + Result := BinaryToHexString(BinaryBuffer, SHEX_PREFIX) + else + Result := BinaryToHexString(BinaryBuffer, ''); + end; + end; + end; +end; + +procedure TRegistryHelper.WriteMultiString(const ValueName: String; aMultiStrList: TStrings); +var + i, nSize: Integer; + pBuf: TBytes; +begin + nSize := 0; + for i := 0 to aMultiStrList.Count - 1 do + begin + {$IFDEF UNICODE} + Inc(nSize, (Length(aMultiStrList[i]) + 1) * 2); + {$ELSE} + Inc(nSize, Length(aMultiStrList[i]) + 1); + {$ENDIF} + end; + + SetLength(pBuf, nSize); + ZeroMemory(pBuf, nSize); + + nSize := 0; + for i := 0 to aMultiStrList.Count - 1 do + begin + StrCopy(PChar(@pBuf[nSize]), PChar(aMultiStrList[i])); + {$IFDEF UNICODE} + Inc(nSize, (Length(aMultiStrList[i]) + 1) * 2); + {$ELSE} + Inc(nSize, Length(aMultiStrList[i]) + 1); + {$ENDIF} + end; + + RegSetValueEx(CurrentKey, PChar(ValueName), 0, REG_MULTI_SZ, @pBuf[0], nSize); +end; + +function GetDomainUserNameFromReg: String; +var + sRegKey, + sDomain, + sUser: String; +begin + Result := ''; + try + sRegKey := GetRegRecentUserSid; + if sRegKey = '' then + exit; + + sDomain := GetRegValueAsString(HKEY_USERS, sRegKey + '\Volatile Environment', 'USERDOMAIN'); + sUser := GetRegValueAsString(HKEY_USERS, sRegKey + '\Volatile Environment', 'USERNAME'); + if (sDomain <> '') and (sUser <> '') then + Result := sDomain + '\' + sUser; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetDomainUserNameFromReg()'); + end; +end; + +function GetUserNameFromReg(sRegKey: String = ''): String; +begin + Result := ''; + try + if sRegKey = '' then + sRegKey := GetRegRecentUserSid; + + if sRegKey = '' then + exit; + + Result := GetRegValueAsString(HKEY_LOCAL_MACHINE, REG_PROFILE + sRegKey, 'ProfileImagePath'); + if Result <> '' then + Result := Trim(ExtractFileName(ExcludeTrailingPathDelimiter(Result))); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetUserNameFromReg()'); + end; +end; + +procedure CopyRegKey(K: HKEY; sSrcKey, sDestKey: String); +var + Reg: TRegistry; +begin + try + Guard(Reg, TRegistry.Create); + Reg.RootKey := K; + Reg.MoveKey(sSrcKey, sDestKey, false); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. CopyRegKey()'); + end; +end; + +function ExtrSubKeySortList(K: HKEY; sKey: String; aRkInfoList: TRkInfoList): Integer; +var + Reg: TRegistry; + SubList: TStringList; + ftLocal, ftKey: TFileTime; + RkInfo: TRkInfo; + i: Integer; +begin + Result := 0; + try + Guard(Reg, TRegistry.Create); + Reg.RootKey := HKEY_USERS; + + sKey := IncludeTrailingPathDelimiter(sKey); + if Reg.OpenKeyReadOnly(sKey) then + begin + Guard(SubList, TStringList.Create); + Reg.GetKeyNames(SubList); + Reg.CloseKey; + + if SubList.Count > 0 then + begin + for i := 0 to SubList.Count - 1 do + begin + if Reg.OpenKeyReadOnly(sKey + SubList[i]) then + begin + if RegQueryInfoKey(Reg.CurrentKey, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, @ftKey) = ERROR_SUCCESS then + begin + FileTimeToLocalFileTime(ftKey, ftLocal); + RkInfo.sKName := SubList[i]; + RkInfo.ftLastWriteTime := ftLocal; + aRkInfoList.Add(RkInfo); + end; + Reg.CloseKey; + end; + end; + + Result := aRkInfoList.Count; + if Result > 0 then + aRkInfoList.Sort(TComparer<TRkInfo>.Construct(CompareByLastWriteTime)); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ExtrSubKeySortList()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Safe.pas b/Tocsg.Lib/VCL/Tocsg.Safe.pas new file mode 100644 index 00000000..b582a9f1 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Safe.pas @@ -0,0 +1,94 @@ +{*******************************************************} +{ } +{ Tocsg.Safe } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Safe; + +interface + +uses + WinApi.Windows; + +type + TSafeObject = class(TInterfacedObject) + private + obj_: TObject; + public + Constructor Create(obj: TObject); + Destructor Destroy; override; + end; + + TSafePointer = class(TInterfacedObject) + private + ptr_: Pointer; + public + Constructor Create(aPointer: Pointer); + Destructor Destroy; override; + end; + + function Guard(out ref; aInstance: TObject): IUnknown; overload; + function Guard(out ref; aPointer: Pointer): IUnknown; overload; + function Guard(aPointer: Pointer): IUnknown; overload; + +implementation + +{ TSafeObject } + +Constructor TSafeObject.Create(obj: TObject); +begin + Inherited Create; + obj_ := obj; +end; + +Destructor TSafeObject.Destroy; +begin + if Assigned(obj_) then + obj_.Free; + Inherited; +end; + +{ TSafePointer } + +Constructor TSafePointer.Create(aPointer: Pointer); +begin + Inherited Create; + ptr_ := aPointer; +end; + +Destructor TSafePointer.Destroy; +begin + if ptr_ <> nil then + FreeMem(ptr_); + Inherited; +end; + +function Guard(out ref; aInstance: TObject): IUnknown; +begin + Result := nil; + if Assigned(aInstance) then + begin + Result := TSafeObject.Create(aInstance); + TObject(ref) := aInstance; + end; +end; + +function Guard(out ref; aPointer: Pointer): IUnknown; +begin + Result := nil; + if Assigned(aPointer) then + begin + Result := TSafePointer.Create(aPointer); + Pointer(ref) := aPointer; + end; +end; + +function Guard(aPointer: Pointer): IUnknown; +begin + Result := TSafePointer.Create(aPointer); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Serializer.pas b/Tocsg.Lib/VCL/Tocsg.Serializer.pas new file mode 100644 index 00000000..d0d25ac8 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Serializer.pas @@ -0,0 +1,498 @@ +{*******************************************************} +{ } +{ Tocsg.Serializer } +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.Serializer; + +interface + +uses + Tocsg.Obj, System.Classes, System.SysUtils, Winapi.Windows, + Tocsg.Exception; + +const + SER_SIG: AnsiString = 'KzSer.'; + SER_VER = 1; + +type + TTgSerHeader = packed record + sSig: array [0..11] of AnsiChar; + nVer: Integer; + end; + + ETgSerializer = class(ETgException); + TTgSerializerBase = class(TTgObject) + private + bStreamFree_: Boolean; + protected + Header_: TTgSerHeader; + Stream_: TStream; + function GetPosition: LONGLONG; + function GetSize: LONGLONG; + public + Constructor Create(aStream: TStream; bAutoStreamFree: Boolean = false); overload; + Constructor Create; overload; + Destructor Destroy; override; + + procedure SeekFront; + procedure SeekEnd; + + property Stream: TStream read Stream_; + property Header: TTgSerHeader read Header_; + end; + + TTgSerializerSave = class(TTgSerializerBase) + public + procedure SaveHeader(nVer: Integer = SER_VER); + procedure S_WideString(sVal: WideString); + procedure S_AnsiString(sVal: AnsiString); + procedure S_UTF8String(sVal: UTF8String); + + procedure S_Integer(nVal: Integer); + procedure S_DWORD(dwVal: DWORD); + procedure S_WORD(wVal: WORD); + procedure S_LONGLONG(llVal: LONGLONG); + procedure S_ULONGLONG(ullVal: ULONGLONG); + procedure S_DateTime(dtVal: TDateTime); + procedure S_Strings(aList: TStrings); + procedure S_Boolean(bVal: Boolean); + procedure S_Stream(aStream: TStream); + + procedure SaveToFile(sPath: String); + end; + + TTgSerializerLoad = class(TTgSerializerSave) + public + function LoadHeader: Boolean; + function L_WideString: WideString; + function L_AnsiString: AnsiString; + function L_UTF8String: UTF8String; + + function L_Integer: Integer; + function L_DWORD: DWORD; + function L_WORD: WORD; + function L_LONGLONG: LONGLONG; + function L_ULONGLONG: ULONGLONG; + function L_DateTime: TDateTime; + function L_Strings(aList: TStrings): Integer; + function L_Boolean: Boolean; + function L_Stream(aStream: TStream): LONGLONG; + + function IsEndOfFile: Boolean; + function GetRemainSize: LONGLONG; + function GetReadPercent: WORD; + + procedure LoadFromFile(sPath: String); + end; + +implementation + +{ TTgSerializerBase } + +Constructor TTgSerializerBase.Create(aStream: TStream; bAutoStreamFree: Boolean = false); +begin + Inherited Create; + ZeroMemory(@Header_, SizeOf(Header_)); + bStreamFree_ := bAutoStreamFree; + Stream_ := aStream; + if Stream_ = nil then + raise ETgSerializer.Create('스트림이 지정되지 않았습니다.'); +end; + +Constructor TTgSerializerBase.Create; +begin + Inherited Create; + ZeroMemory(@Header_, SizeOf(Header_)); + Stream_ := TMemoryStream.Create; + bStreamFree_ := true; +end; + +Destructor TTgSerializerBase.Destroy; +begin + if (Stream_ <> nil) and bStreamFree_ then + FreeAndNil(Stream_); + Inherited; +end; + +function TTgSerializerBase.GetPosition: LONGLONG; +begin + Result := Stream_.Position; +end; + +function TTgSerializerBase.GetSize: LONGLONG; +begin + Result := Stream_.Size; +end; + +procedure TTgSerializerBase.SeekFront; +begin + Stream_.Seek(0, soBeginning); +end; + +procedure TTgSerializerBase.SeekEnd; +begin + Stream_.Seek(0, soEnd) +end; + +{ TTgSerializerSave } + +procedure TTgSerializerSave.SaveHeader(nVer: Integer = SER_VER); +begin + if Stream_.Position > 0 then + raise Exception.Create('offset 값이 0보다 큽니다.'); + + if Length(SER_SIG) > SizeOf(Header_.sSig) then + raise Exception.Create('시그너처 길이가 너무 큽니다.'); + + ZeroMemory(@Header_.sSig, SizeOf(Header_.sSig)); + CopyMemory(@Header_.sSig[0], @SER_SIG[1], Length(SER_SIG)); + Header_.nVer := nVer; + + Stream_.Write(Header_, SizeOf(Header_)); +end; + +procedure TTgSerializerSave.S_WideString(sVal: WideString); +var + nLen: Integer; +begin + nLen := Length(sVal) * 2; + S_Integer(nLen); + Stream_.Write(PWideChar(sVal)^, nLen); +end; + +procedure TTgSerializerSave.S_AnsiString(sVal: AnsiString); +var + nLen: Integer; +begin + nLen := Length(sVal); + S_Integer(nLen); + Stream_.Write(PAnsiChar(sVal)^, nLen); +end; + +procedure TTgSerializerSave.S_UTF8String(sVal: UTF8String); +var + nLen: Integer; +begin + nLen := Length(sVal); + S_Integer(nLen); + Stream_.Write(PUTF8String(sVal)^, nLen); +end; + +procedure TTgSerializerSave.S_Integer(nVal: Integer); +begin + try + Stream_.Write(nVal, SizeOf(nVal)); + except + _Trace('Fail .. S_Integer()'); + end; +end; + +procedure TTgSerializerSave.S_DWORD(dwVal: DWORD); +begin + try + Stream_.Write(dwVal, SizeOf(dwVal)); + except + _Trace('Fail .. S_DWORD()'); + end; +end; + +procedure TTgSerializerSave.S_WORD(wVal: WORD); +begin + try + Stream_.Write(wVal, SizeOf(wVal)); + except + _Trace('Fail .. S_WORD()'); + end; +end; + +procedure TTgSerializerSave.S_LONGLONG(llVal: LONGLONG); +begin + try + Stream_.Write(llVal, SizeOf(llVal)); + except + _Trace('Fail .. S_LONGLONG()'); + end; +end; + +procedure TTgSerializerSave.S_ULONGLONG(ullVal: ULONGLONG); +begin + try + Stream_.Write(ullVal, SizeOf(ullVal)); + except + _Trace('Fail .. S_ULONGLONG()'); + end; +end; + +procedure TTgSerializerSave.S_DateTime(dtVal: TDateTime); +begin + try + Stream_.Write(dtVal, SizeOf(dtVal)); + except + _Trace('Fail .. S_DateTime()'); + end; +end; + +procedure TTgSerializerSave.S_Strings(aList: TStrings); +var + i: Integer; +begin + try + S_Integer(aList.Count); + for i := 0 to aList.Count - 1 do + S_UTF8String(aList[i]); + except + _Trace('Fail .. S_Strings()'); + end; +end; + +procedure TTgSerializerSave.S_Boolean(bVal: Boolean); +begin + try + Stream_.Write(bVal, SizeOf(bVal)); + except + _Trace('Fail .. S_Boolean()'); + end; +end; + +procedure TTgSerializerSave.S_Stream(aStream: TStream); +begin + try + aStream.Position := 0; + S_LONGLONG(aStream.Size); + Stream_.CopyFrom(aStream, aStream.Size); + except + _Trace('Fail .. S_Stream()'); + end; +end; + +procedure TTgSerializerSave.SaveToFile(sPath: String); +begin + if not (Stream_ is TMemoryStream) then + raise ETgSerializer.Create('Stream이 TMemoryStream가 아닙니다.'); + + try + TMemoryStream(Stream_).SaveToFile(sPath); + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. SaveToFile()'); + end; +end; + +{ TTgSerializerLoad } + +function TTgSerializerLoad.LoadHeader: Boolean; +begin + Result := false; + + ZeroMemory(@Header_, SizeOf(Header_)); + + if Stream_.Position > 0 then + raise Exception.Create('offset 값이 0보다 큽니다.'); + + try + if Stream_.Read(Header_, SizeOf(Header_)) <> SizeOf(Header_) then + exit; + + // 크기 체크 추가 19_0710 17:01:52 kku + Result := (Stream_.Size > Stream_.Position) and + CompareMem(@Header_.sSig[0], @SER_SIG[1], Length(SER_SIG)); + finally + if not Result then + Stream_.Position := 0; + end; +end; + +function TTgSerializerLoad.L_WideString: WideString; +var + nLen: Integer; +begin + Result := ''; + try + nLen := L_Integer; + if nLen = 0 then + exit; + + if nLen > GetRemainSize then + exit; +// raise ETgSerializer.Create('남은 데이터가 부족합니다.'); + + SetLength(Result, nLen div 2); + Stream_.Read(Result[1], nLen); + except + _Trace('Fail .. L_WideString()'); + end; +end; + +function TTgSerializerLoad.L_AnsiString: AnsiString; +var + nLen: Integer; +begin + Result := ''; + try + nLen := L_Integer; + if nLen = 0 then + exit; + + if nLen > GetRemainSize then + exit; +// raise ETgSerializer.Create('남은 데이터가 부족합니다.'); + + SetLength(Result, nLen); + Stream_.Read(Result[1], nLen); + except + _Trace('Fail .. L_AnsiString()'); + end; +end; + +function TTgSerializerLoad.L_UTF8String: UTF8String; +var + nLen: Integer; +begin + Result := ''; + try + nLen := L_Integer; + if nLen = 0 then + exit; + + if nLen > GetRemainSize then + exit; +// raise ETgSerializer.Create('남은 데이터가 부족합니다.'); + + SetLength(Result, nLen); + Stream_.Read(Result[1], nLen); + except + _Trace('Fail .. L_UTF8String()'); + end; +end; + +function TTgSerializerLoad.L_Integer: Integer; +begin + try + Stream_.Read(Result, SizeOf(Result)); + except + _Trace('Fail .. L_Integer()'); + end; +end; + +function TTgSerializerLoad.L_DWORD: DWORD; +begin + try + Stream_.Read(Result, SizeOf(Result)); + except + _Trace('Fail .. L_DWORD()'); + end; +end; + +function TTgSerializerLoad.L_WORD: WORD; +begin + try + Stream_.Read(Result, SizeOf(Result)); + except + _Trace('Fail .. L_WORD()'); + end; +end; + +function TTgSerializerLoad.L_LONGLONG: LONGLONG; +begin + try + Stream_.Read(Result, SizeOf(Result)); + except + _Trace('Fail .. L_LONGLONG()'); + end; +end; + +function TTgSerializerLoad.L_ULONGLONG: ULONGLONG; +begin + try + Stream_.Read(Result, SizeOf(Result)); + except + _Trace('Fail .. L_ULONGLONG()'); + end; +end; + +function TTgSerializerLoad.L_DateTime: TDateTime; +begin + try + Stream_.Read(Result, SizeOf(Result)); + except + _Trace('Fail .. L_DateTime()'); + end; +end; + +function TTgSerializerLoad.L_Strings(aList: TStrings): Integer; +var + i, nCnt: Integer; +begin + try + nCnt := L_Integer; + for i := 0 to nCnt - 1 do + aList.Add(L_UTF8String); + except + _Trace('Fail .. L_Strings()'); + end; +end; + +function TTgSerializerLoad.L_Boolean: Boolean; +begin + try + Stream_.Read(Result, SizeOf(Result)); + except + _Trace('Fail .. L_Boolean()'); + end; +end; + +function TTgSerializerLoad.L_Stream(aStream: TStream): LONGLONG; +var + llSize: LONGLONG; +begin + try + llSize := L_LONGLONG; + if llSize > 0 then + begin + Result := aStream.CopyFrom(Stream_, llSize); + if Result <> llSize then + raise ETgSerializer.Create('남은 데이터가 부족합니다.'); + end else + Result := 0; + except + _Trace('Fail .. L_Stream()'); + end; +end; + +function TTgSerializerLoad.IsEndOfFile: Boolean; +begin + Result := Stream_.Position >= Stream_.Size; +end; + +function TTgSerializerLoad.GetRemainSize: LONGLONG; +begin + Result := Stream_.Size - Stream_.Position; +end; + +function TTgSerializerLoad.GetReadPercent: WORD; +begin + if Stream_.Size > 0 then + Result := (Stream_.Position * 100) div Stream_.Size + else + Result := 0; +end; + +procedure TTgSerializerLoad.LoadFromFile(sPath: String); +begin + if not (Stream_ is TMemoryStream) then + raise ETgSerializer.Create('Stream이 TMemoryStream가 아닙니다.'); + + try + TMemoryStream(Stream_).LoadFromFile(sPath); + Stream_.Position := 0; + except + on E: Exception do + ETgException.TraceException(Self, E, 'Fail .. LoadFromFile()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Service.pas b/Tocsg.Lib/VCL/Tocsg.Service.pas new file mode 100644 index 00000000..32cbf5e5 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Service.pas @@ -0,0 +1,402 @@ +{*******************************************************} +{ } +{ Tocsg.Service } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Service; + +interface + +uses + System.SysUtils, Winapi.Messages, Winapi.Windows, Winapi.WinSvc; + +type + TInstallServiceDll = procedure(bSilent: BOOL; dwSvcType, dwSvcStart: DWORD); stdcall; + TUninstallServiceDll = procedure(bSilent: BOOL); stdcall; + +function InstallService(const sSvcName, sBinaryPath, sDisplayName: String; + dwServiceType, nStartMode: Integer): Boolean; +function UninstallService(const sSvcName: String): Boolean; + +function InstallServiceDll(const sDllPath: String; dwSvcType, dwSvcStart: DWORD): Boolean; +function UninstallServiceDll(const sDllPath: String): Boolean; + +function ServiceExists(const sSvcName: String): Boolean; + +function SetServiceStartType(const sSvcName: String; dwMode: DWORD): Boolean; +function SetServiceState(const sSvcName: String; dwStatus: DWORD): Boolean; + +function GetServiceStatus(const sSvcName: String): DWORD; + +function ServiceStart(const sSvcName: String; dwDesiredAccess: DWORD = SERVICE_ALL_ACCESS): Boolean; +function ServiceStop(const sSvcName: String; nTmSec: Integer = 0): Boolean; +function ServicePause(const sSvcName: String): Boolean; +function ServiceContinue(const sSvcName: String): Boolean; +function GetServicePid(sSvcName: String): DWORD; + +procedure SetVisibleService(sSvcName: String; bVisible: Boolean); + + +implementation + +uses + Tocsg.Registry, Tocsg.Shell, Tocsg.Trace, Tocsg.Exception; + +function InstallService(const sSvcName, sBinaryPath, sDisplayName: String; + dwServiceType, nStartMode: Integer): Boolean; +var + hScm, + hSvc: SC_HANDLE; +begin + Result := false; + + hScm := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS); + if hScm <> 0 then + begin + hSvc := OpenService(hScm, PChar(sSvcName), SERVICE_ALL_ACCESS); + if (hSvc = 0) and (GetLastError = ERROR_SERVICE_DOES_NOT_EXIST) then + begin + hSvc := CreateService(hScm, + PChar(sSvcName), + PChar(sDisplayName), + SERVICE_ALL_ACCESS, + dwServiceType, + nStartMode, + SERVICE_ERROR_NORMAL, + PChar(sBinaryPath), + nil, nil, nil, nil, nil); + + end; + + Result := hSvc <> 0; + + if hSvc <> 0 then + CloseServiceHandle(hSvc); + + CloseServiceHandle(hScm); + end; +end; + +function UninstallService(const sSvcName: String): Boolean; +var + hScm, + hSvc: SC_HANDLE; +begin + Result := true; + + hScm := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS); + if hScm <> 0 then + begin + hSvc := OpenService(hScm, PChar(sSvcName), SERVICE_ALL_ACCESS); + if hSvc <> 0 then + begin + Result := DeleteService(hSvc); + CloseServiceHandle(hSvc); + end; + CloseServiceHandle(hScm); + end; +end; + +function InstallServiceDll(const sDllPath: String; dwSvcType, dwSvcStart: DWORD): Boolean; +var + h: THandle; + fnInstSvc: TInstallServiceDll; +begin + Result := false; + if not FileExists(sDllPath) then + exit; + + h := LoadLibrary(PChar(sDllPath)); + if h = 0 then + exit; + + try + try + fnInstSvc := GetProcAddress(h, 'InstallServices_dll'); + if @fnInstSvc = nil then + exit; + + fnInstSvc(true, dwSvcType, dwSvcStart); + except + on E: EOSError do + begin + Result := E.ErrorCode = 1073; + exit; + end; + + on E: Exception do + exit; + end; + Result := true; + finally + FreeLibrary(h); + end; +end; + +function UninstallServiceDll(const sDllPath: String): Boolean; +var + h: THandle; + fnUninstSvc: TUninstallServiceDll; + bRetry: Boolean; + nReCnt: Integer; +Label + LB_Retry; +begin + Result := false; + if not FileExists(sDllPath) then + exit; + + h := LoadLibrary(PChar(sDllPath)); + if h = 0 then + exit; + + try + bRetry := false; + nReCnt := 0; + + fnUninstSvc := GetProcAddress(h, 'UnInstallServices_dll'); + if @fnUninstSvc = nil then + exit; + LB_Retry : + try + fnUninstSvc(true); + except + on E: EOSError do + begin + if E.ErrorCode = 5 then + bRetry := true + else + exit; + end; + + on E: Exception do + exit; + end; + + if bRetry then + begin + Inc(nReCnt); + if nReCnt > 5 then + exit; + Sleep(1000); + goto LB_Retry; + end; + + Result := true; + finally + FreeLibrary(h); + end; +end; + +function ServiceExists(const sSvcName: String): Boolean; +var + hScm, + hSvc: SC_HANDLE; +begin + Result := false; + + hScm := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS); + if hScm <> 0 then + begin + hSvc := OpenService(hScm, PChar(sSvcName), SERVICE_ALL_ACCESS); + if hSvc <> 0 then + begin + Result := true; + CloseServiceHandle(hSvc); + end; + CloseServiceHandle(hScm); + end; +end; + +function SetServiceStartType(const sSvcName: String; dwMode: DWORD): Boolean; +const + REG_SERVICE_KEY = 'SYSTEM\CurrentControlSet\Services\'; +begin + Result := false; + if not ServiceExists(sSvcName) then + exit; + + Result := SetRegValueInteger(HKEY_LOCAL_MACHINE, + REG_SERVICE_KEY + sSvcName, + 'Start', + dwMode); +end; + +function SetServiceState(const sSvcName: String; dwStatus: DWORD): Boolean; +var + hScm, + hSvc: SC_HANDLE; + st: SERVICE_STATUS; +begin + Result := false; + + hScm := OpenSCManager(nil, nil, SC_MANAGER_CONNECT); + if hScm <> 0 then + begin + hSvc := OpenService(hScm, PChar(sSvcName), SERVICE_ALL_ACCESS); + if hSvc <> 0 then + begin + ZeroMemory(@st, sizeof(st)); + Result := ControlService(hSvc, dwStatus, st); + CloseServiceHandle(hSvc); + end; + CloseServiceHandle(hScm); + end; +end; + +function GetServiceStatus(const sSvcName: String): DWORD; +var + hScm, hSvc : SC_HANDLE; + st : SERVICE_STATUS; +begin + Result := 0; + + hScm := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS); + + if hScm <> 0 then + begin + hSvc := OpenService(hScm, PChar(sSvcName), SERVICE_ALL_ACCESS); + if hSvc <> 0 then + begin + ZeroMemory(@st, sizeof(SERVICE_STATUS)); + if QueryServiceStatus(hSvc, st) then + begin + Result := st.dwCurrentState; + + (* + >>>>>>> dwCurrentState + {$EXTERNALSYM SERVICE_STOPPED} + SERVICE_STOPPED = $00000001; + {$EXTERNALSYM SERVICE_START_PENDING} + SERVICE_START_PENDING = $00000002; + {$EXTERNALSYM SERVICE_STOP_PENDING} + SERVICE_STOP_PENDING = $00000003; + {$EXTERNALSYM SERVICE_RUNNING} + SERVICE_RUNNING = $00000004; + {$EXTERNALSYM SERVICE_CONTINUE_PENDING} + SERVICE_CONTINUE_PENDING = $00000005; + {$EXTERNALSYM SERVICE_PAUSE_PENDING} + SERVICE_PAUSE_PENDING = $00000006; + {$EXTERNALSYM SERVICE_PAUSED} + SERVICE_PAUSED = $00000007; + *) + end; + CloseServiceHandle(hSvc); + end; + CloseServiceHandle(hScm); + end; +end; + +function ServiceStart(const sSvcName: String; dwDesiredAccess: DWORD = SERVICE_ALL_ACCESS): Boolean; +var + hScm, + hSvc: SC_HANDLE; + sServiceArg: PChar; +begin + Result := false; + + sServiceArg := nil; + + hScm := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS); + if hScm <> 0 then + begin + hSvc := OpenService(hScm, PChar(sSvcName), dwDesiredAccess); + if hSvc <> 0 then + begin + Result := StartService(hSvc, 0, sServiceArg); + CloseServiceHandle(hSvc); + end; + CloseServiceHandle(hScm); + end; +end; + +function ServiceStop(const sSvcName: String; nTmSec: Integer = 0): Boolean; +begin + if nTmSec > 0 then + begin + var nTm: Integer := nTmSec * 2; + Result := SetServiceState(sSvcName, SERVICE_CONTROL_STOP); + while not Result do + begin + Dec(nTm); + if nTm = 0 then + exit; + Sleep(500); + Result := SetServiceState(sSvcName, SERVICE_CONTROL_STOP); + end; + end else + Result := SetServiceState(sSvcName, SERVICE_CONTROL_STOP); +end; + +function ServicePause(const sSvcName: String): Boolean; +begin + Result := SetServiceState(sSvcName, SERVICE_CONTROL_PAUSE); +end; + +function ServiceContinue(const sSvcName: String): Boolean; +begin + Result := SetServiceState(sSvcName, SERVICE_CONTROL_CONTINUE); +end; + +function GetServicePid(sSvcName: String): DWORD; +var + hScm, hSvc: SC_HANDLE; + SvcProcStatus: SERVICE_STATUS_PROCESS; + dwBufLen, + dwNeedByte, + dwInfoLevel: DWORD; +begin + Result := 0; + + try + hScm := OpenSCManager(nil, nil, SC_MANAGER_CONNECT); + if hScm <> 0 then + begin + hSvc := OpenService(hScm, PChar(sSvcName), SERVICE_QUERY_STATUS); + try + if hSvc <> 0 then + begin + dwInfoLevel := 0; + dwNeedByte := 0; + dwBufLen := SizeOf(SvcProcStatus); + ZeroMemory(@SvcProcStatus, dwBufLen); + + if QueryServiceStatusEx(hSvc, SC_STATUS_TYPE(dwInfoLevel), @SvcProcStatus, + dwBufLen, dwNeedByte) then + begin + Result := SvcProcStatus.dwProcessId; + end; + end; + finally + if hSvc <> 0 then + CloseServiceHandle(hSvc); + CloseServiceHandle(hScm); + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetServicePid()'); + end; +end; + +// 서비스를 숨기면 윈도우 메이저 업데이트 시 서비스가 사라지는 문제가 있음 24_0105 08:18:24 kku +procedure SetVisibleService(sSvcName: String; bVisible: Boolean); +const + PARAM_SVC_VISIBLE_TRUE = 'sdset %s D:(A;;CCLCSWRPWPDTLOCRRC;;;SY)(A;;CCDCLCSWRPWPDTLOCRSDRCWDWO;;;BA)(A;;CCLCSWLOCRRC;;;IU)(A;;CCLCSWLOCRRC;;;SU)S:(AU;FA;CCDCLCSWRPWPDTLOCRSDRCWDWO;;;WD)'; + PARAM_SVC_VISIBLE_FALSE = 'sdset %s D:(D;;DCLCWPDTSD;;;IU)(D;;DCLCWPDTSD;;;SU)(D;;DCLCWPDTSD;;;BA)(A;;CCLCSWRPWPDTLOCRRC;;;SY)(A;;CCDCLCSWRPWPDTLOCRSDRCWDWO;;;BA)(A;;CCLCSWLOCRRC;;;IU)(A;;CCLCSWLOCRRC;;;SU)S:(AU;FA;CCDCLCSWRPWPDTLOCRSDRCWDWO;;;WD)'; +var + sParam: String; +begin +// 숨기면 OpenService()로도 찾을 수 없다. 20_0413 16:33:22 sunk + if bVisible then + sParam := Format(PARAM_SVC_VISIBLE_TRUE, [sSvcName]) + else + sParam := Format(PARAM_SVC_VISIBLE_FALSE, [sSvcName]); + + ExecutePath_hide('sc.exe', sParam); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Shell.pas b/Tocsg.Lib/VCL/Tocsg.Shell.pas new file mode 100644 index 00000000..ddcff7ff --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Shell.pas @@ -0,0 +1,416 @@ +{*******************************************************} +{ } +{ Tocsg.Shell } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Shell; + +interface + +uses + System.SysUtils, System.Classes, Winapi.Messages, Winapi.Windows, + Vcl.Controls, Vcl.Graphics; + +const + TB_ENABLEBUTTON = WM_USER + 1; + TB_CHECKBUTTON = WM_USER + 2; + TB_PRESSBUTTON = WM_USER + 3; + TB_HIDEBUTTON = WM_USER + 4; + TB_INDETERMINATE = WM_USER + 5; + TB_MARKBUTTON = WM_USER + 6; + TB_ISBUTTONENABLED = WM_USER + 9; + TB_ISBUTTONCHECKED = WM_USER + 10; + TB_ISBUTTONPRESSED = WM_USER + 11; + TB_ISBUTTONHIDDEN = WM_USER + 12; + TB_ISBUTTONINDETERMINATE = WM_USER + 13; + TB_ISBUTTONHIGHLIGHTED = WM_USER + 14; + TB_SETSTATE = WM_USER + 17; + TB_GETSTATE = WM_USER + 18; + TB_ADDBITMAP = WM_USER + 19; + TB_ADDBUTTONSA = WM_USER + 20; + TB_INSERTBUTTONA = WM_USER + 21; + TB_DELETEBUTTON = WM_USER + 22; + TB_GETBUTTON = WM_USER + 23; + TB_BUTTONCOUNT = WM_USER + 24; + TB_COMMANDTOINDEX = WM_USER + 25; + + TB_SAVERESTOREA = WM_USER + 26; + TB_ADDSTRINGA = WM_USER + 28; + TB_GETBUTTONTEXTA = WM_USER + 45; +// TBN_GETBUTTONINFOA = TBN_FIRST-0; + +type + TBBUTTON = packed record + iBitmap: Integer; + idCommand: Integer; + fsState: BYTE; + fsStyle: BYTE; + bReserved: array [0..1] of BYTE; // padding for alignment + dwData: Pointer; //DWORD_PTR; + iString: Pointer; //INT_PTR; + end; + + TBBUTTON64 = packed record + iBitmap: Integer; + idCommand: Integer; + fsState: BYTE; + fsStyle: BYTE; + bReserved: array [0..5] of BYTE; // padding for alignment 64bit + dwData: Pointer; //DWORD_PTR; + iString: Pointer; //INT_PTR; + end; + + TRAYDATA = packed record + wnd: HWND; + uID: UINT; + uCallbackMessage: UINT; + Reserved: array [0..1] of DWORD; + hIcon: HICON; + end; + +function GetShellImageHandle(bSmall: Boolean = true; dwFileAttr: DWORD = 0): THandle; +function GetShellImageIndex_path(const sPath: String): Integer; + +procedure OpenPath(const sPath: String; hParent: HWND = 0); +procedure ExecutePath(const sPath: String; sParam: String = ''; hParent: HWND = 0); inline; +procedure ExecutePath_hide(const sPath: String; sParam: String = ''); inline; +procedure ExecutePath_runAs(const sPath: String; sParam: String = ''; + nShowMode: Integer = SW_SHOWNORMAL); +procedure ExecuteExplorerOpen(const sPath: String); inline; + +procedure ExplorerSelectedPath(sPath: String; bCheckFileExists: Boolean = true); + +function GetShellExePathFromExt(sExt: String): String; +function GetTargetExeFromLink(const sPath: String): String; + +function ClearZombieTray(hTray: HWND): Integer; +function AddFileSmallIconToImageList(aList: TImageList; const sPath: string): Integer; +function GetFileSmallIcon(const sPath: String): TIcon; + +implementation + +uses + Winapi.ShellAPI, Tocsg.Exception, System.Win.Registry, Tocsg.Safe, + Tocsg.Strings, Tocsg.Registry, Tocsg.Process, Winapi.ShlObj, Winapi.ActiveX, + Tocsg.Trace; + +function GetShellImageHandle(bSmall: Boolean = true; dwFileAttr: DWORD = 0): THandle; +var + SFI: TSHFileInfo; + dwIconSize: DWORD; +begin + if bSmall then + dwIconSize := SHGFI_SMALLICON + else + dwIconSize := SHGFI_LARGEICON; + + Result := SHGetFileInfo('', dwFileAttr, SFI, SizeOf(SFI), SHGFI_ICON or SHGFI_SYSICONINDEX or dwIconSize); +end; + +// 11.1 기준, 64비트에서는 Range check error 에러가 뜬다... +// 10.x에서 만든 .dproj로 프로젝트를 다시 만들면 해결된다.. 델파이 버그... +// SearchLight.dproj로 해결함 22_0713 11:31:14 kku +function GetShellImageIndex_path(const sPath: String): Integer; +var + SFI: TSHFileInfo; + dwResult: DWORD; +begin + Result := 0; + + try + // 이걸로 체크하면 가상파일, 재문 분석이 필요한 파일 (드롭박스, 구글드라이브)의 경우 + // 파일이 바로 동기화 되어버린다. 23_0111 09:41:13 kku +// if FileExists(sPath) or DirectoryExists(sPath) then + + if GetFileAttributes(PChar(sPath)) <> INVALID_FILE_ATTRIBUTES then + begin + ZeroMemory(@SFI, SizeOf(SFI)); + dwResult := SHGetFileInfo(PChar(sPath), 0, SFI, SizeOf(SFI), +// SHGFI_ICON or SHGFI_SYSICONINDEX or dwIconSize); + SHGFI_SYSICONINDEX); // 이렇게 해야 엄청 많이 시도했을때 out of system resources 오류 안난다... 22_0628 14:37:54 kku + +// if Succeeded(dwResult) then // 64 환경에서는 계속 실패 뜬다.. 그런데 SFI.iIcon 값은 잘 나옴 22_0705 17:02:16 kku + Result := SFI.iIcon; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetShellImageIndex_path()'); + end; +end; + +procedure OpenPath(const sPath: String; hParent: HWND = 0); +//var +// sCmd: String; +// StrList: TStringList; +begin +// Guard(StrList, TStringList.Create); +// +// StrList.Add(Format('start "" "%s"', [sPath])); +// StrList.Add('pause'); +// +// sCmd := 'C:\ProgramData\HE\test.cmd'; +// StrList.SaveToFile(sCmd, TEncoding.ANSI); +// ShellExecute(hParent, nil, PChar(sCmd), nil, nil, SW_SHOWNORMAL); + +// BSOne DRM 파일을 열람 하려면 start "" "경로" 이렇게 해야 실시간 복호화 열람이 가능하다 +// 실행 기준 디렉토리를 일반사용자 권한으로 접근 가능한 곳으로 설정해야 정상 동작한다. + ShellExecute(hParent, nil, 'cmd.exe', PChar(Format('/c start "" "%s"', [sPath])), 'C:\ProgramData\', SW_HIDE); +end; + +procedure ExecutePath(const sPath: String; sParam: String = ''; hParent: HWND = 0); +begin + ShellExecute(hParent, nil, PChar(sPath), PChar(sParam), '', SW_SHOWNORMAL); +end; + +procedure ExecutePath_hide(const sPath: String; sParam: String = ''); +begin + ShellExecute(0, nil, PChar(sPath), PChar(sParam), '', SW_HIDE); +end; + +procedure ExecutePath_runAs(const sPath: String; sParam: String = ''; + nShowMode: Integer = SW_SHOWNORMAL); +const + RUN_AS: String = 'runas'; +var + ShellExecuteInfo: TShellExecuteInfo; +begin + ZeroMemory(@ShellExecuteInfo, SizeOf(ShellExecuteInfo)); + with ShellExecuteInfo do + begin + cbSize := SizeOf(ShellExecuteInfo); + fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI; + Wnd := 0; + lpVerb := PChar(RUN_AS); + lpFile := PChar(Format('"%s"', [sPath])); + lpParameters := PChar(sParam); + lpDirectory := nil; + nShow := nShowMode; + hInstApp := 0; + end; + ShellExecuteEx(@ShellExecuteInfo); +end; + +procedure ExecuteExplorerOpen(const sPath: String); inline; +begin +// ShellExecute(0, 'open', PChar(sPath), PChar(sVPath), '', SW_SHOWNORMAL); +end; + +procedure ExplorerSelectedPath(sPath: String; bCheckFileExists: Boolean = true); +begin + if not bCheckFileExists or (bCheckFileExists and FileExists(sPath)) then + begin + sPath := '/select, "' + sPath + '"'; + ShellExecute(0, 'open', 'explorer.exe', PChar(sPath), nil, SW_SHOWNORMAL); + end; +end; + +function GetShellExePathFromExt(sExt: String): String; +var + Reg: TRegistry; + sVal, + sUserSid: String; + StrList: TStringList; +begin + Result := ''; + if sExt = '' then + exit; + + if sExt[1] <> '.' then + sExt := '.' + sExt; + + sUserSid := GetProcesssUserSidFromName('explorer.exe'); + if sUserSid = '' then + sUserSid := GetRegRecentUserSid; + + Guard(Reg, TRegistry.Create); + + sVal := ''; + if sUserSid <> '' then + begin + Reg.RootKey := HKEY_USERS; + + if Reg.OpenKeyReadOnly(Format('%s\SOFTWARE\Microsoft\Windows\CurrentVersion\' + + 'Explorer\FileExts\%s\UserChoice', [sUserSid, sExt])) then + sVal := Reg.ReadString('ProgId'); + + Reg.CloseKey; + end; + + Reg.RootKey := HKEY_CLASSES_ROOT; + if sVal = '' then + begin + if not Reg.OpenKeyReadOnly(sExt) then + exit; + + sVal := Reg.ReadString(''); + if sVal = '' then + exit; + + Reg.CloseKey; + end; + + if not Reg.OpenKeyReadOnly(sVal + '\shell\Open\command') then + exit; + + sVal := Reg.ReadString(''); + if sVal = '' then + exit; + + Guard(StrList, TStringList.Create); + SplitString2(sVal, ' ', StrList); + if StrList.Count > 0 then + Result := StringReplace(StrList[0], '"', '', [rfReplaceAll]); +end; + +function GetTargetExeFromLink(const sPath: String): String; +var + psl: IShellLink; + ppf: IPersistFile; + info: array [0..MAX_PATH] of Char; + wfs: TWin32FindData; +begin + Result := ''; + + try + if not FileExists(sPath) then + exit; + + CoCreateInstance(CLSID_SHELLLINK, nil, CLSCTX_INPROC_SERVER, IShellLink, psl); + if (psl <> nil) and (psl.QueryInterface(IPersistFile, ppf) = 0) then + begin + ppf.Load(PWideChar(sPath), STGM_READ); + psl.GetPath((@info), MAX_PATH, wfs, SLGP_UNCPRIORITY); +// psl.GetPath((@info), MAX_PATH, wfs, SLGP_RELATIVEPRIORITY); + Result := info; +// if Result = '' then +// begin +// psl.GetPath((@info), MAX_PATH, wfs, SLGP_RELATIVEPRIORITY); +// Result := info; +// end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetTargetExeFromLink()'); + end; +end; + +function ClearZombieTray(hTray: HWND): Integer; +var + h: HWND; + i, nCnt: Integer; + dwTrayPid, dwPid: DWORD; + hTrayProc: THandle; + pData: ^TBBUTTON64; //^TBBUTTON; + tb: TBBUTTON64; // TBBUTTON; + tray: TRAYDATA; + IconData: NOTIFYICONDATA; + nRead: NativeUInt; + sPName: String; +begin + Result := 0; + try + nCnt := SendMessage(h, TB_BUTTONCOUNT, 0, 0); + + dwTrayPid := 0; + GetWindowThreadProcessId(h, dwTrayPid); + if dwTrayPid = 0 then + exit; + + hTrayProc := OpenProcess(PROCESS_ALL_ACCESS, FALSE, dwTrayPid); + if hTrayProc = 0 then + exit; + + try + pData := VirtualAllocEx(hTrayProc, nil, sizeof(TBBUTTON), MEM_COMMIT, PAGE_READWRITE); + if pData = nil then + exit; + + for i := 0 to nCnt - 1 do + begin + SendMessage(h, TB_GETBUTTON, i, NativeUInt(pData)); + + ReadProcessMemory(hTrayProc, pData, @tb, sizeof(TBBUTTON), nRead); + ReadProcessMemory(hTrayProc, tb.dwData, @tray, sizeof(tray), nRead); + + dwPid := 0; + GetWindowThreadProcessId(tray.Wnd, dwPid); + if dwPid <> 0 then + begin + // sPName := GetProcessNameByPid(dwPid); + // mmInfo.Lines.Add(sPName); + end else begin + Inc(Result); + // mmInfo.Lines.Add('삭제됨 : ' + IntToStr(tray.wnd)); + // ZeroMemory(@IconData, SizeOf(IconData)); + // IconData.cbSize := SizeOf(IconData); + // IconData.hIcon := tray.hIcon; + // IconData.Wnd := tray.wnd; + // IconData.uCallbackMessage := tray.uCallbackMessage; + // IconData.uID := tray.uID; + // Shell_NotifyIcon(NIM_DELETE, @IconData); + end; + end; + finally + if pData <> nil then + VirtualFreeEx(hTrayProc, pData, 0, MEM_RELEASE); + if hTrayProc <> 0 then + CloseHandle(hTrayProc); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ClearZombieTray()'); + end; +end; + +function AddFileSmallIconToImageList(aList: TImageList; const sPath: string): Integer; +var + ico: TICon; + FileInfo: TSHFileInfo; + dwFlags: UINT; +begin + Result := -1; + + try + dwFlags := SHGFI_ICON or SHGFI_USEFILEATTRIBUTES; + dwFlags := dwFlags or SHGFI_SMALLICON; + // Flags := Flags or SHGFI_LARGEICON; + + // SHGFI_USEFILEATTRIBUTES를 써야 실제 파일이 없어도 확장자만으로 아이콘을 얻을 수 있음 + if SHGetFileInfo(PChar(sPath), FILE_ATTRIBUTE_NORMAL, FileInfo, SizeOf(FileInfo), dwFlags) <> 0 then + begin + Guard(ico, TIcon.Create); + ico.Handle := FileInfo.hIcon; + Result := aList.AddIcon(ico); + end; + except + // .. + end; +end; + +function GetFileSmallIcon(const sPath: String): TIcon; +var + FileInfo: TSHFileInfo; + dwFlags: UINT; +begin + Result := nil; + + try + dwFlags := SHGFI_ICON or SHGFI_USEFILEATTRIBUTES; + dwFlags := dwFlags or SHGFI_SMALLICON; + // Flags := Flags or SHGFI_LARGEICON; + + // SHGFI_USEFILEATTRIBUTES를 써야 실제 파일이 없어도 확장자만으로 아이콘을 얻을 수 있음 + if SHGetFileInfo(PChar(sPath), FILE_ATTRIBUTE_NORMAL, FileInfo, SizeOf(FileInfo), dwFlags) <> 0 then + begin + Result := TIcon.Create; + Result.Handle := FileInfo.hIcon; + end; + except + // .. + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Strings.pas b/Tocsg.Lib/VCL/Tocsg.Strings.pas new file mode 100644 index 00000000..d7efc171 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Strings.pas @@ -0,0 +1,662 @@ +{*******************************************************} +{ } +{ Tocsg.Strings } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Strings; + +interface + +uses + System.Classes, System.SysUtils, Winapi.Windows; + +function ReverseString(const sVal: string): String; inline; +procedure SumString(var sDest: String; sTail: String; sDm: String = ''; bIgrSpace: Boolean = false); inline; +procedure SumStringA(var sDest: AnsiString; sTail: AnsiString; sDm: AnsiString = ''; bIgrSpace: Boolean = false); inline; +function DeleteChars(sSrc: String; sDelChars: String): String; +function AppendChars(sSrc: String; sIfChars, sAppendStr: String): String; +function GetCapsuleStr(sCapB, sCapE: String; sText: String; bIgrCase: Boolean = true): String; +function GetRandomStr(nMin, nMax: Byte): String; +function GetRandomStrEx(nLen: Integer; sSetStr: String = ''): String; +function DeleteNullTail(sVal: String): String; +function GetGUID: String; + +function SplitString(sText: String; const sDm: String; + aList: TStrings; + bNullStrInc: Boolean = false; + bIgrOverl: Boolean = false; + bClear: Boolean = true): Integer; +function SplitString2(sText: String; const sDelimiter: String; + aList: TStrings; + bNullStrInc: Boolean = false; + bIgrOverl: Boolean = false; + bClear: Boolean = true): Integer; + +function InsertPointString(const sInsert: String; sText: String; nPoint: Integer): String; +function InsertPointString2(const sInsert: String; sText: String; nPoint: Integer): String; +function InsertPointComma(sText: String; nPoint: Integer): String; overload; +function InsertPointComma(llData: LONGLONG; nPoint: Integer): String; overload; +function MakeCharStr(c: Char; nCnt: Integer): String; inline; +function ExtrNumStr(const sStr: String): String; +function ExtrLastDelimiterStr(sStr: String; sDm: String): String; + +function SaveStrToFile(sPath: String; sStr: String; aEncoding: TEncoding = nil): Boolean; +function LoadStrFromFile(sPath: String; aEncoding: TEncoding = nil): String; +function ExtractTextSafe(const sPath: String): String; + +function StrsReplace(const S: String; const arrOld, arrNew: array of string): String; overload; +function StrsReplace(const S: String; const arrOld: array of string; sNew: String): String; overload; +function CountStr(const sSrc, sFind: string; n: Integer = 1): Integer; + +function IsUTF8_AnsiChar(const str: PAnsiChar): Boolean; +function IsUTF8(const B: TBytes): Boolean; + +function LastIndexOf(const sFind, sSource: string): Integer; + +implementation + +uses + Tocsg.Safe, Tocsg.Exception, System.StrUtils, System.IOUtils; + +function ReverseString(const sVal: string): String; +var + i, nLen: Integer; +begin + nLen := Length(sVal); + SetLength(Result, nLen); + for i := 1 to nLen do + Result[i] := sVal[Succ(nLen - i)]; +end; + +procedure SumString(var sDest: String; sTail: String; sDm: String = ''; bIgrSpace: Boolean = false); +begin + if bIgrSpace and (sTail = '') then + exit; + + if sDest = '' then + sDest := sTail + else + sDest := sDest + sDm + sTail; +end; + +procedure SumStringA(var sDest: AnsiString; sTail: AnsiString; sDm: AnsiString = ''; bIgrSpace: Boolean = false); +begin + if bIgrSpace and (sTail = '') then + exit; + + if sDest = '' then + sDest := sTail + else + sDest := sDest + sDm + sTail; +end; + +function DeleteChars(sSrc: String; sDelChars: String): String; +var + i: Integer; +begin + Result := ''; + for i := 1 to Length(sSrc) do + if sDelChars.IndexOf(sSrc[i]) = -1 then + Result := Result + sSrc[i]; +end; + +function AppendChars(sSrc: String; sIfChars, sAppendStr: String): String; +var + i: Integer; +begin + Result := ''; + for i := 1 to Length(sSrc) do + if sIfChars.IndexOf(sSrc[i]) <> -1 then + Result := Result + sAppendStr + sSrc[i] + else + Result := Result + sSrc[i]; +end; + +function GetCapsuleStr(sCapB, sCapE: String; sText: String; bIgrCase: Boolean = true): String; +var + nPosS, nPosE: Integer; +begin + Result := ''; + + if bIgrCase then + begin + sCapB := UpperCase(sCapB); + sCapE := UpperCase(sCapE); + sText := UpperCase(sText); + end; + + nPosS := Pos(sCapB, sText); + if nPosS > 0 then + begin + Delete(sText, 1, nPosS + Length(sCapB) - 1); + nPosE := Pos(sCapE, sText); + if nPosE > 0 then + Result := Copy(sText, 1, nPosE - 1); + end; +end; + +function GetRandomStr(nMin, nMax: Byte): String; +var + i, nLen: Integer; +begin + Result := ''; + if nMax = 0 then + exit; + + if nMin > nMax then + nMin := nMax; + + Randomize; + nLen := Random(nMax); + if nMax >= (nMin + nLen) then + Inc(nLen, nMin); + + for i := 0 to nLen do + case Random(2) of + 1 : Result := Result + Char(Integer('a') + Round(Random(26))); + else Result := Result + Char(Integer('A') + Round(Random(26))); + end; +end; + +function GetRandomStrEx(nLen: Integer; sSetStr: String = ''): String; +const + DEF_SET = 'ABCDFGHIJKLMNPQRSQUVWXYZ0123456789'; // E, O 제거 +var + i, nSetLen: Integer; +begin + if sSetStr = '' then + sSetStr := DEF_SET; + + Randomize; // 난수 초기화 + Result := ''; + nSetLen := Length(sSetStr); + for i := 1 to nLen do + Result := Result + sSetStr[Random(nSetLen) + 1]; +end; + +function DeleteNullTail(sVal: String): String; +var + i: Integer; +begin + Result := sVal; + if Result = '' then + exit; + + for i := 1 to Length(Result) do + if Result[i] = #0 then + begin + SetLength(Result, i - 1); + exit; + end; +end; + +function GetGUID: String; +var + GG: TGUID; +begin + Result := ''; + try + if CreateGUID(GG) = S_OK then + Result := GUIDToString(GG); + except + // .. + end; +end; + +function SplitString(sText: String; const sDm: String; + aList: TStrings; + bNullStrInc: Boolean = false; + bIgrOverl: Boolean = false; + bClear: Boolean = true): Integer; +var + nPos: Integer; + sTemp: String; +begin + if bClear then + aList.Clear; + + while true do + begin + nPos := Pos(sDm, sText); + if nPos <> 0 then + begin + sTemp := Trim(Copy(sText, 0, nPos - 1)); + + if sTemp <> '' then + begin + if not bIgrOverl or + (aList.IndexOf(sTemp) = -1) then + aList.Add(sTemp); + end else + if bNullStrInc then + aList.Add(''); + + Delete(sText, 1, nPos + Length(sDm) - 1); + end else begin + if sText <> '' then + begin + if not bIgrOverl or + (aList.IndexOf(sText) = -1) then + aList.Add(Trim(sText)); + end else + if bNullStrInc then + aList.Add(''); + + break; + end; + end; + + Result := aList.Count; +end; + +// 따옴표 묶음 인식 +function SplitString2(sText: String; const sDelimiter: String; + aList: TStrings; + bNullStrInc: Boolean = false; + bIgrOverl: Boolean = false; + bClear: Boolean = true): Integer; + + procedure AddStr(s: String); + begin + if not bIgrOverl or + (aList.IndexOf(s) = -1) then + aList.Add(s); + end; + +var + nDdPos, + nPos: Integer; + sTemp, + sDdTemp: String; +begin + if bClear then + aList.Clear; + + while true do + begin + sDdTemp := ''; + + if (Length(sText) > 0) and (sText[1] = '"') then + begin + Delete(sText, 1, 1); + nDdPos := Pos('"', sText); + if nDdPos > 0 then + begin + sDdTemp := Copy(sText, 1, nDdPos - 1); + Delete(sText, 1, nDdPos); + end else + sText := '"' + sText; + end; + + nPos := Pos(sDelimiter, sText); + if nPos <> 0 then + begin + if sDdTemp <> '' then + sTemp := sDdTemp +// sTemp := '"' + sDdTemp + '"' + else + sTemp := Copy(sText, 0, nPos - 1); + AddStr(Trim(sTemp)); + Delete(sText, 1, nPos+Length(sDelimiter)-1); + end else begin + if sDdTemp <> '' then + begin + AddStr(sDdTemp); + end else begin + if sText <> '' then + AddStr(Trim(sText)) + else if bNullStrInc then + aList.Add(''); + end; + break; + end; + end; + + Result := aList.Count; +end; + +function InsertPointString(const sInsert: String; sText: String; nPoint: Integer): String; +var + i : integer; +begin + for i := (Length(sText) - 1) div nPoint downto 1 do + Insert(sInsert, sText, Length(sText) - (i * nPoint) + 1); + + Result := sText; +end; + +function InsertPointString2(const sInsert: String; sText: String; nPoint: Integer): String; +var + i : integer; +begin + for i := 1 to (Length(sText) div nPoint) do + Insert(sInsert, sText, i * nPoint); + + Result := sText; +end; + +function InsertPointComma(sText: String; nPoint: Integer): String; +begin + Result := InsertPointString(',', sText, nPoint); +end; + +function InsertPointComma(llData: LONGLONG; nPoint: Integer): String; +begin + Result := InsertPointString(',', IntToStr(llData), nPoint); +end; + +procedure InsertPointCommaA(var sText: AnsiString; sAdd: AnsiString; nPoint: Integer); +begin + if sAdd <> '' then + begin + if sText <> '' then + sText := sText + ',' + sAdd + else + sText := sAdd; + end; +end; + +function MakeCharStr(c: Char; nCnt: Integer): String; inline; +var + i: Integer; +begin + Result := ''; + for i := 0 to nCnt - 1 do + Result := Result + c; +end; + +function ExtrNumStr(const sStr: String): String; +var + i, nLen: Integer; +begin + Result := ''; + nLen := Length(sStr); + for i := 1 to nLen do + case Byte(sStr[i]) of + 48 .. 57 : Result := Result + sStr[i]; + end; +end; + +function ExtrLastDelimiterStr(sStr: String; sDm: String): String; +var + nPos: Integer; +begin + Result := sStr; + nPos := Result.LastDelimiter(sDm); + if nPos > 0 then + Delete(Result, 1, nPos + 1); +end; + +function SaveStrToFile(sPath: String; sStr: String; aEncoding: TEncoding = nil): Boolean; +var + StrList: TStringList; +begin + Result := false; + try + if aEncoding = nil then + aEncoding := TEncoding.UTF8; + + Guard(StrList, TStringList.Create); + StrList.Text := sStr; + StrList.SaveToFile(sPath, aEncoding); + Result := true; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. SaveStrFromFile()'); + end; +end; + +function LoadStrFromFile(sPath: String; aEncoding: TEncoding = nil): String; +var + StrList: TStringList; +begin + Result := ''; + try + if not FileExists(sPath) then + exit; + + if aEncoding = nil then + aEncoding := TEncoding.UTF8; + + Guard(StrList, TStringList.Create); + StrList.LoadFromFile(sPath, aEncoding); + Result := StrList.Text; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. LoadStrFromFile()'); + end; +end; + +function ProcessInvalidUTF8Bytes(const Data: TBytes): TBytes; +var + i, nLen: Integer; +begin + try + i := 0; + SetLength(Result, 0); + + nLen := Length(Data); + while i < nLen do + begin + if (Data[i] and $80) = 0 then + begin + // UTF-8 1바이트 (ASCII) + Result := Result + [Data[i]]; + Inc(i); + end else + if ((Data[i] and $E0) = $C0) and (i+ 1 < nLen) and + ((Data[i+1] and $C0) = $80) then + begin + // UTF-8 다중 바이트 시퀀스 시작 검사 + Result := Result + [Data[i], Data[i+1]]; + Inc(i, 2); + end else + if ((Data[i] and $F0) = $E0) and (i + 2 < nLen) and + ((Data[i+1] and $C0) = $80) and ((Data[i+2] and $C0) = $80) then + begin + Result := Result + [Data[I], Data[I+1], Data[i+2]]; + Inc(i, 3); + end else + if ((Data[i] and $F8) = $F0) and (i + 3 < nLen) and + ((Data[i+1] and $C0) = $80) and ((Data[i+2] and $C0) = $80) and + ((Data[i+3] and $C0) = $80) then + begin + Result := Result + [Data[i], Data[i+1], Data[i+2], Data[i+3]]; + Inc(i, 4); + end else + Inc(i); // 유효하지 않은 바이트 → 무시 + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ProcessInvalidUTF8Bytes()'); + end; +end; + +function ExtractTextSafe(const sPath: String): String; +var + Raw: TBytes; + FndEnc: TEncoding; +begin + Result := ''; + try + // 파일을 바이트 배열로 읽음 + Raw := TFile.ReadAllBytes(sPath);  + if Length(Raw) = 0 then + exit; + + // BOM을 기반으로 인코딩 감지 + FndEnc := nil; + if TEncoding.GetBufferEncoding(Raw, FndEnc, TEncoding.ANSI) = 0 then + begin + if IsUTF8(Raw) then + Result := TEncoding.UTF8.GetString(Raw) + else + Result := TEncoding.ANSI.GetString(Raw); + exit; + end; + + Result := FndEnc.GetString(Raw); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ExtractTextSafe()', 5); + end; +end; + +function StrsReplace(const S: String; const arrOld, arrNew: array of string): String; +var + i : Integer; +begin + Result := S; + for i := Low(arrOld) to High(arrOld) do + Result := StringReplace(Result, arrOld[i], arrNew[i], [rfReplaceAll, rfIgnoreCase]); +end; + +function StrsReplace(const S: String; const arrOld: array of string; sNew: String): String; +var + i : Integer; +begin + Result := S; + for i := Low(arrOld) to High(arrOld) do + Result := StringReplace(Result, arrOld[i], sNew, [rfReplaceAll, rfIgnoreCase]); +end; + +function CountStr(const sSrc, sFind: string; n: Integer = 1): Integer; +var + i, nLen: Integer; +begin + result := 0; + nLen := length(sSrc); + i := n; // 일정 인덱스 이후의 문자를 검색. + while i <= nLen do + begin + i := PosEx(sFind, sSrc, i); + if i > 0 then + Inc(result) + else break; + + Inc(i); + end; +end; + +function IsUTF8_AnsiChar(const str: PAnsiChar): Boolean; +var + i, len, c, bits, b: Integer; +begin + Result := True; // 기본적으로 True로 설정 + i := 0; + len := StrLen(str); + while i < len do + begin + c := Ord(str[i]); + if c > 128 then + begin + if (c >= 254) then Exit(False) + else if (c >= 252) then bits := 6 + else if (c >= 248) then bits := 5 + else if (c >= 240) then bits := 4 + else if (c >= 224) then bits := 3 + else if (c >= 192) then bits := 2 + else Exit(False); + + if (i + bits) > len then Exit(False); + while bits > 1 do + begin + Inc(i); + b := Ord(str[i]); + if (b < 128) or (b > 191) then Exit(False); + Dec(bits); + end; + end; + Inc(i); + end; +end; + +function IsUTF8(const B: TBytes): Boolean; +var + i, Len: Integer; + C: Byte; + nNeed: Integer; + bMultiByte: Boolean; +begin + Result := False; + Len := Length(B); + if Len = 0 then + Exit; + + i := 0; + nNeed := 0; + bMultiByte := False; + + while i < Len do + begin + C := B[i]; + + if nNeed = 0 then + begin + // 0xxxxxxx (ASCII) + if (C and $80) = 0 then + begin + Inc(i); + Continue; + end; + + // 110xxxxx (2바이트 시작) + if (C and $E0) = $C0 then + begin + nNeed := 1; + bMultiByte := True; + end + // 1110xxxx (3바이트 시작) + else if (C and $F0) = $E0 then + begin + nNeed := 2; + bMultiByte := True; + end + // 11110xxx (4바이트 시작) + else if (C and $F8) = $F0 then + begin + nNeed := 3; + bMultiByte := True; + end + else + Exit(False); // UTF-8 규칙 위반 + end + else + begin + // 10xxxxxx (연속 바이트) + if (C and $C0) <> $80 then + Exit(False); + Dec(nNeed); + end; + + Inc(i); + end; + + // 모든 멀티바이트 시퀀스가 완결되었고, + // 최소 1개 이상의 멀티바이트 문자가 있었을 때만 UTF-8이라고 판단 + Result := (nNeed = 0) and bMultiByte; +end; + +function LastIndexOf(const sFind, sSource: string): Integer; +var + i, nFindLen, nSrcLen: Integer; +begin + Result := 0; + nFindLen := Length(sFind); + nSrcLen := Length(sSource); + if nFindLen > nSrcLen then + exit; + for i := nSrcLen - nFindLen downto 1 do + begin + if Copy(sSource, i, nFindLen) = sFind then + begin + Result := i; + exit; + end; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Thread.pas b/Tocsg.Lib/VCL/Tocsg.Thread.pas new file mode 100644 index 00000000..cac1e191 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Thread.pas @@ -0,0 +1,738 @@ +{*******************************************************} +{ } +{ Tocsg.Thread } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Thread; + +interface + +uses + System.Classes, System.SysUtils, System.SyncObjs, Winapi.Windows, + Winapi.Messages, System.Generics.Collections; + +type + TTgThreadState = (tsInit, tsWorking, tsPause, tsStop, tsCompleted, tsFail); + TTgThread = class(TThread) + private + CS_: TCriticalSection; + protected + nLastError_: Integer; + bWorkStop_, + bWorkCancel_: Boolean; // 사용자가 수동으로 작업을 중지한건지 판단하는게.. bWorkStop_ 만으로는 부족해서 추가 13_1213 13:51:54 kku + WorkState_: TTgThreadState; // 범용적으로 사용될 스레드 상태값. 이전부터 쓰던건 스레드마다 직접 지정해서 사용했다... 기본으로 추가함 18_0416 22:50:16 kku + + procedure _Trace(const sLog: String; nLevel: Integer = 0); overload; + procedure _Trace(const sFormat: String; const aArgs: array of const; nLevel: Integer = 0); overload; + + property LastError: Integer read nLastError_; + + procedure Lock; + procedure Unlock; + procedure SetWorkStop(bVal: Boolean); virtual; + function GetWorkStop: Boolean; + function GetWorkCancel: Boolean; + + procedure SetWorkState(aKind: TTgThreadState); + function GetWorkState: TTgThreadState; + +// {$IF CompilerVersion > 21} + procedure TerminatedSet; override; +// {$IFEND} + public + Constructor Create; + Destructor Destroy; override; + + procedure TerminateWaitUntilEnd; + + procedure StartThread; virtual; + procedure PauseThread; virtual; + procedure StopThread; virtual; + procedure CancelWork; + + property IsCancel: Boolean read GetWorkCancel; + property WorkStop: Boolean read GetWorkStop; + end; + + TTgEventThread = class(TTgThread) + private + hEvent_: THandle; + bSync_: Boolean; + sEvtName_: String; + protected + bUseActiveX_: Boolean; // 스레드 내부에서 ConInit..쓸일이 있다. + procedure DoEvent; + procedure Execute; override; + procedure ProcessWorkEvent; virtual; abstract; + public + Constructor Create(const sEventName: String = 'TTgEventThread'; bSync: Boolean = false); + + procedure StartThread; override; + procedure StopThread; override; + + property EventName: String read sEvtName_; + property EventHandle: THandle read hEvent_; + end; + + PCloseFormEnt = ^TCloseFormEnt; + TCloseFormEnt = record + sClassName, + sCaption: String; + end; + + TThdCloseForm = class(TTgThread) + private + CloseFromEnt_: TList<PCloseFormEnt>; + procedure OnEntryNotify(Sender: TObject; const Item: PCloseFormEnt; Action: TCollectionNotification); + protected + procedure Execute; override; + public + Constructor Create; + Destructor Destroy; override; + + procedure ClearEntry; + + procedure AddEntry(const sClassName, sCaption: String); + end; + + TTaskTimerEnt = class(TObject) + private + fnEvent_: TNotifyEvent; + fnEvent2_: TThreadMethod; + dwTick_, + dwInterval_: DWORD; + bDefaultActive_: Boolean; + OwnerThread_: TTgThread; + public + Constructor Create(fnEvent: TNotifyEvent; dwInterval: DWORD; bDefaultActive: Boolean); overload; + Constructor Create(aOwnerThread: TTgThread; fnEvent: TThreadMethod; dwInterval: DWORD; bDefaultActive: Boolean); overload; // 추가 15_1022 15:57:14 sunk + Destructor Destroy; override; + + procedure InitTask(dwTick: DWORD); + procedure ProcessTask(dwTick: DWORD); + + property DefaultActive: Boolean read bDefaultActive_; + property Tick: DWORD read dwTick_; + property Interval: DWORD read dwInterval_; + property Event: TNotifyEvent read fnEvent_; + end; + + TTimerEntEnumerator = TEnumerator<TTaskTimerEnt>; + + TThdTaskTimer = class(TTgThread) + private + bTimerOn_, + bUseActiveX_: Boolean; + dwSleep_: DWORD; + TimerEntList_: TList<TTaskTimerEnt>; + + procedure OnEventNotifyTaskEntry(Sender: TObject; const Item: TTaskTimerEnt; + Action: TCollectionNotification); + protected + procedure Execute; override; + public + Constructor Create(dwSleep: DWORD = 1000; bUseActiveX: Boolean = false); + Destructor Destroy; override; + + procedure AddTask(fnEvent: TNotifyEvent; dwInterval: DWORD; bActive: Boolean; + bInitProcess: Boolean = false{인터벌 전에 최초실행 할건지}); overload; + procedure AddTask(fnEvent: TThreadMethod; dwInterval: DWORD; bActive: Boolean; + bInitProcess: Boolean = false{인터벌 전에 최초실행 할건지}); overload; + procedure SetTask(fnEvent: TNotifyEvent; dwInterval: DWORD; bActive: Boolean); + function GetTaskActiveState(fnEvent: TNotifyEvent): Boolean; + + procedure StartTimerThread; + procedure StopTimerThread; + end; + +implementation + +uses + Tocsg.Trace, Winapi.ActiveX; + +{ TTgThread } + +Constructor TTgThread.Create; +begin + Inherited Create(true); + + WorkState_ := tsInit; + + CS_ := TCriticalSection.Create; + + nLastError_ := ERROR_SUCCESS; + bWorkStop_ := false; + bWorkCancel_ := false; +end; + +Destructor TTgThread.Destroy; +begin + StopThread; + Inherited; + FreeAndNil(CS_); +end; + +procedure TTgThread.Lock; +begin + CS_.Acquire; +end; + +procedure TTgThread.Unlock; +begin + CS_.Release; +end; + +procedure TTgThread.SetWorkStop(bVal: Boolean); +begin + Lock; + try + bWorkStop_ := bVal; + finally + Unlock; + end; +end; + +function TTgThread.GetWorkStop: Boolean; +begin + Lock; + try + Result := bWorkStop_; + finally + Unlock; + end; +end; + +function TTgThread.GetWorkCancel: Boolean; +begin + Lock; + try + Result := bWorkCancel_; + finally + Unlock; + end; +end; + +procedure TTgThread.SetWorkState(aKind: TTgThreadState); +begin + Lock; + try + WorkState_ := aKind; + finally + Unlock; + end; +end; + +function TTgThread.GetWorkState: TTgThreadState; +begin + Lock; + try + Result := WorkState_; + finally + Unlock; + end; +end; + +procedure TTgThread.TerminatedSet; +begin + if Suspended then + Suspended := false; // 이게 true로 되어 있으면 제대로 Terminate가 되지 않아서 일케 체크 13_0911 14:56:28 kku + + SetWorkStop(true); +end; + +procedure TTgThread._Trace(const sLog: String; nLevel: Integer = 0); +begin +{$IFDEF TRACE_OBJ} + if Self <> nil then + TTgTrace.T(Format('%s :: %s', [ClassName, sLog]), nLevel); +{$ENDIF} +end; + +procedure TTgThread._Trace(const sFormat: String; const aArgs: array of const; nLevel: Integer = 0); +begin +{$IFDEF TRACE_OBJ} + TTgTrace.T(Format('%s :: %s', [ClassName, sFormat]), aArgs, nLevel); +{$ENDIF} +end; + +procedure TTgThread.TerminateWaitUntilEnd; +var + nTimeOut: Integer; +begin + if not FreeOnTerminate then + exit; + + Terminate; + + nTimeOut := 0; + while nTimeOut < 300 do + begin + Inc(nTimeOut); + Sleep(100); + if Terminated then + break; + end; +end; + +procedure TTgThread.StartThread; +begin + SetWorkStop(false); + + if Suspended then + Suspended := false; +end; + +procedure TTgThread.PauseThread; +begin + if not Suspended then + Suspended := true; +end; + +procedure TTgThread.StopThread; +begin + SetWorkStop(true); +end; + +procedure TTgThread.CancelWork; +begin + Lock; + try + bWorkCancel_ := true; + finally + Unlock; + end; + StopThread; +end; + +{ TTgEventThread } + +Constructor TTgEventThread.Create(const sEventName: String = 'TTgEventThread'; bSync: Boolean = false); +begin + Inherited Create; + + hEvent_ := 0; + +// sEventName_ := sEventName; +// 기존 단순 이벤트 이름 계속 사용하면... +// 이벤트 핸들이 제대로 닫히지 않거나 중복되면 GetLastError = 5(액세스 거부) 가 일어날 수 있다. +// 이런 현상을 최대한 줄이기 위해서 이벤트 이름을 유니크 하게 추가 보완 17_0330 10:25:24 sunk + sEvtName_ := sEventName + IntToStr(GetCurrentProcessId) + IntToStr(LONGLONG(Self)); + + bSync_ := bSync; + bUseActiveX_ := false; +end; + +procedure TTgEventThread.DoEvent; +begin + if not GetWorkStop and (hEvent_ <> 0) then + begin + SetEvent(hEvent_); + end; +end; + +procedure TTgEventThread.StartThread; +begin + if hEvent_ = 0 then + begin + hEvent_ := CreateEvent(nil, true, false, PChar(sEvtName_)); + if hEvent_ = 0 then + begin + _Trace('StartThread() .. hEvent_ is 0 .., sEventName_ = %s, LastError = %d', [sEvtName_, GetLastError]); + end; + end; + + Inherited; +end; + +procedure TTgEventThread.StopThread; +begin + Inherited; + + if hEvent_ <> 0 then + begin + SetEvent(hEvent_); + CloseHandle(hEvent_); + hEvent_ := 0; + end; +end; + +procedure TTgEventThread.Execute; +begin + if bUseActiveX_ then CoInitialize(nil); + try + while not Terminated do + begin + if hEvent_ <> 0 then + begin + case WaitForSingleObject(hEvent_, INFINITE) of + WAIT_TIMEOUT : ; + WAIT_OBJECT_0 : + begin + ResetEvent(hEvent_); + if not GetWorkStop then + if bSync_ then + Synchronize(ProcessWorkEvent) + else + ProcessWorkEvent; + end; + end; + end; + Sleep(50); + end; + finally + if bUseActiveX_ then CoUninitialize; + end; +end; + +{ TThdCloseForm } + +Constructor TThdCloseForm.Create; +begin + Inherited Create; + CloseFromEnt_ := TList<PCloseFormEnt>.Create; + CloseFromEnt_.OnNotify := OnEntryNotify; + StartThread; +end; + +Destructor TThdCloseForm.Destroy; +begin + FreeAndNil(CloseFromEnt_); + Inherited; +end; + +procedure TThdCloseForm.OnEntryNotify(Sender: TObject; const Item: PCloseFormEnt; Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: + begin +// Finalize(Item^); + Dispose(Item); + end; + cnExtracted: ; + end; +end; + +procedure TThdCloseForm.ClearEntry; +begin + CloseFromEnt_.Clear; +end; + +procedure TThdCloseForm.AddEntry(const sClassName, sCaption: String); +var + p: PCloseFormEnt; +begin + New(p); + p.sClassName := sClassName; + p.sCaption := sCaption; + + Lock; + try + CloseFromEnt_.Add(p); + finally + Unlock; + end; +end; + +procedure TThdCloseForm.Execute; +var + hWindow: HWND; + enum: TEnumerator<PCloseFormEnt>; +begin + while not Terminated do + begin + Lock; + try + enum := CloseFromEnt_.GetEnumerator; + finally + Unlock; + end; + + try + while enum.MoveNext do + begin + hWindow := FindWindow(PChar(enum.Current.sClassName), PChar(enum.Current.sCaption)); + if hWindow <> 0 then + begin + // ShowWindow(hWindow, SW_HIDE); + SendMessage(hWindow, WM_CLOSE, 0, 0); + end; + end; + finally + enum.Free; + end; + Sleep(50); + end; +end; + +{ TTaskTimerEnt } + +Constructor TTaskTimerEnt.Create(fnEvent: TNotifyEvent; dwInterval: DWORD; bDefaultActive: Boolean); +begin + Inherited Create; + + OwnerThread_ := nil; + fnEvent_ := fnEvent; + fnEvent2_ := nil; + dwTick_ := 0; + dwInterval_ := dwInterval; + bDefaultActive_ := bDefaultActive; +end; + +Constructor TTaskTimerEnt.Create(aOwnerThread: TTgThread; fnEvent: TThreadMethod; dwInterval: DWORD; bDefaultActive: Boolean); +begin + Inherited Create; + + OwnerThread_ := aOwnerThread; + fnEvent_ := nil; + fnEvent2_ := fnEvent; + dwTick_ := 0; + dwInterval_ := dwInterval; + bDefaultActive_ := bDefaultActive; +end; + +Destructor TTaskTimerEnt.Destroy; +begin + Inherited; +end; + +procedure TTaskTimerEnt.InitTask(dwTick: DWORD); +begin + if dwTick_ <> dwTick then + dwTick_ := dwTick; +end; + +procedure TTaskTimerEnt.ProcessTask(dwTick: DWORD); +var + dwMilliSec: DWORD; +begin + if dwTick_ = 0 then + exit; + + dwMilliSec := dwTick - dwTick_; + if dwMilliSec > dwInterval_ then + begin + if Assigned(fnEvent_) then + fnEvent_(Self); + if Assigned(fnEvent2_) and Assigned(OwnerThread_) then + OwnerThread_.Synchronize(fnEvent2_); + // fnEvent_ 수행중 dwTick_ 이걸 0으로 초기화 할 경우가 있다. (내부에서 타이머 끄기등) + if dwTick_ > 0 then + dwTick_ := dwTick; + end; +end; + +{ TThdTaskTimer } + +Constructor TThdTaskTimer.Create(dwSleep: DWORD = 1000; bUseActiveX: Boolean = false); +begin + Inherited Create; + + bTimerOn_ := false; + bUseActiveX_ := bUseActiveX; + + TimerEntList_ := TList<TTaskTimerEnt>.Create; + TimerEntList_.OnNotify := OnEventNotifyTaskEntry; + + dwSleep_ := dwSleep; +end; + +Destructor TThdTaskTimer.Destroy; +begin + StopTimerThread; + Inherited; + TimerEntList_.Clear; + FreeAndNil(TimerEntList_); +end; + +procedure TThdTaskTimer.OnEventNotifyTaskEntry(Sender: TObject; const Item: TTaskTimerEnt; + Action: TCollectionNotification); +begin + case Action of + cnAdded : ; + cnRemoved : Item.Free; + cnExtracted : ; + end; +end; + +procedure TThdTaskTimer.AddTask(fnEvent: TNotifyEvent; dwInterval: DWORD; bActive: Boolean; bInitProcess: Boolean = false); +var + TaskTimerEntry: TTaskTimerEnt; +begin + TaskTimerEntry := TTaskTimerEnt.Create(fnEvent, dwInterval, bActive); + Lock; + try + TimerEntList_.Add(TaskTimerEntry); + finally + Unlock; + end; + if bInitProcess and Assigned(fnEvent) then + fnEvent(TaskTimerEntry); +end; + +procedure TThdTaskTimer.AddTask(fnEvent: TThreadMethod; dwInterval: DWORD; bActive: Boolean; bInitProcess: Boolean = false); +var + TaskTimerEntry: TTaskTimerEnt; +begin + TaskTimerEntry := TTaskTimerEnt.Create(Self, fnEvent, dwInterval, bActive); + Lock; + try + TimerEntList_.Add(TaskTimerEntry); + finally + Unlock; + end; + if bInitProcess and Assigned(fnEvent) then + Synchronize(fnEvent); +end; + +procedure TThdTaskTimer.SetTask(fnEvent: TNotifyEvent; dwInterval: DWORD; bActive: Boolean); +var + enum: TTimerEntEnumerator; +begin + Lock; + try + enum := TimerEntList_.GetEnumerator; + finally + Unlock; + end; + + try + while enum.MoveNext do + if @enum.Current.Event = @fnEvent then + begin + if bActive then + enum.Current.InitTask(GetTickCount) + else + enum.Current.InitTask(0); + enum.Current.dwInterval_ := dwInterval; + exit; + end; + finally + enum.Free; + end; +end; + +function TThdTaskTimer.GetTaskActiveState(fnEvent: TNotifyEvent): Boolean; +var + enum: TTimerEntEnumerator; +begin + Result := false; + Lock; + try + enum := TimerEntList_.GetEnumerator; + finally + Unlock; + end; + + try + while enum.MoveNext do + if @enum.Current.Event = @fnEvent then + begin + Result := enum.Current.Tick <> 0; + exit; + end; + finally + enum.Free; + end; +end; + +procedure TThdTaskTimer.StartTimerThread; +var + enum: TTimerEntEnumerator; + dwTick: DWORD; +begin + if bTimerOn_ then + exit; + + bTimerOn_ := true; + + Lock; + try + enum := TimerEntList_.GetEnumerator; + finally + Unlock; + end; + + try + dwTick := GetTickCount; + while enum.MoveNext do + if enum.Current.DefaultActive then + enum.Current.InitTask(dwTick); + finally + enum.Free; + end; + + StartThread; +end; + +procedure TThdTaskTimer.StopTimerThread; +var + enum: TTimerEntEnumerator; +begin + if not bTimerOn_ then + exit; + + bTimerOn_ := false; + + StopThread; + + Lock; + try + enum := TimerEntList_.GetEnumerator; + finally + Unlock; + end; + + try + while enum.MoveNext do + enum.Current.InitTask(0); + finally + enum.Free; + end; + + PauseThread; +end; + +procedure TThdTaskTimer.Execute; +var + dwTick: DWORD; + enum: TTimerEntEnumerator; +begin + if bUseActiveX_ then CoInitialize(nil); + try + while not Terminated do + begin + Sleep(dwSleep_); + + try + if not GetWorkStop then + begin + dwTick := GetTickCount; + + Lock; + try + enum := TimerEntList_.GetEnumerator; + finally + Unlock; + end; + + try + while enum.MoveNext do + enum.Current.ProcessTask(dwTick); + finally + enum.Free; + end; + end; + except + // + end; + end; + finally + if bUseActiveX_ then CoUninitialize; + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Trace.pas b/Tocsg.Lib/VCL/Tocsg.Trace.pas new file mode 100644 index 00000000..47462287 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Trace.pas @@ -0,0 +1,493 @@ +{*******************************************************} +{ } +{ Tocsg.Trace } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Trace; + +interface + +uses + System.SysUtils, System.Classes, Winapi.Windows, Vcl.Forms, Winapi.Messages; + +const + WM_WRITE_LOG = WM_USER + 8745; + +type + PLogEnt = ^TLogEnt; + TLogEnt = record + dt: TDateTime; + nLevel: Integer; + sMsg: String; + end; + + TTgTraceForm = class(TForm) +// protected +// procedure WriteLog(dt: TDateTime; nLevel: Integer; sMsg: String); virtual; abstract; + public + Constructor Create; virtual; + Destructor Destroy; override; + end; + + TTgTrace = class(TObject) + private + sFName_, + sLPath_, + sLogHead_: String; + bEnc_, + bWFile_, + bDaliy_, + bLevelLock_, + bAllocConsole_: Boolean; + evBeforeLog_, + evAfterLog_: TNotifyEvent; + nLevel_: Integer; + procedure SetLogLevel(nVal: Integer); + public + Constructor Create(sLogDir, sLogFName: String; bDaliy: Boolean = false); overload; + Constructor Create(sLogPath: String; bDaliy: Boolean = false); overload; + Destructor Destroy; override; + procedure DeleteOldLogs(nLeaveDay: Integer = 10); + + class procedure T(sLog: String; nLevel: Integer = 0); overload; + class procedure T(const sFormat: String; const Args: array of const; nLevel: Integer = 0); overload; + class function SetAllocConsole(bVal: Boolean): Boolean; + + property OnBeforeLog: TNotifyEvent write evBeforeLog_; + property OnAfterLog: TNotifyEvent write evAfterLog_; + property LoadHead: String write sLogHead_; + property IsAllocConsole: Boolean read bAllocConsole_; + property Level: Integer read nLevel_ write SetLogLevel; + property LevelLock: Boolean read bLevelLock_ write bLevelLock_; + property LogEnc: Boolean read bEnc_ write bEnc_; + end; + +function WriteLnFileEndA(const sPath: String; const sData: AnsiString): Boolean; inline; +function WriteLnFileEndUTF8(const sPath: String; const sData: UTF8String): Boolean; inline; +function WriteLnFileEndW(const sPath, sData: WideString): Boolean; inline; + +function DecLog(sText: String): String; + +var + gTrace: TTgTrace = nil; + gTrForm: TTgTraceForm = nil; + +implementation + +uses + System.SyncObjs, Tocsg.Safe, Tocsg.Path, Tocsg.Files, System.DateUtils, + Tocsg.DateTime, Tocsg.Encrypt; + +const + PASS_LOG = 'O=5+QCU;yCV3:8Z*'; + +var + _CS: TCriticalSection = nil; + +procedure _Lock; +begin + if _CS <> nil then + _CS.Acquire; +end; + +procedure _Unlock; +begin + if _CS <> nil then + _CS.Release; +end; + +{ TTgTraceForm } + +Constructor TTgTraceForm.Create; +begin + Inherited Create(nil); + ASSERT(gTrForm = nil); + gTrForm := Self; +end; + +Destructor TTgTraceForm.Destroy; +begin + gTrForm := nil; + Inherited; +end; + +{ TTgTrace } + +Constructor TTgTrace.Create(sLogDir, sLogFName: String; bDaliy: Boolean = false); +begin + Inherited Create; + + @evBeforeLog_ := nil; + @evAfterLog_ := nil; + + gTrace := Self; + sFName_ := ''; + sLPath_ := ''; + sLogHead_ := ''; + bAllocConsole_ := false; + nLevel_ := 0; + + bEnc_ := false; + bDaliy_ := bDaliy; +{$IFDEF TRACE_FILE} + bWFile_ := (sLogDir <> '') and (sLogFName <> '') and + ForceDirectories(sLogDir) and IsValidFilename(sLogFName); + if bWFile_ then + begin + sLPath_ := IncludeTrailingBackslash(sLogDir); + sFName_ := sLogFName; + end; +{$ELSE} + bWFile_ := false; +{$ENDIF} +// if sLPath_ = '' then +// sLPath_ := GetRunExePathDir; +// +// if sFName_ = '' then +// sFName_ := CutFileExt(ExtractFileName(GetRunExePath)) + '.log'; +end; + +Constructor TTgTrace.Create(sLogPath: String; bDaliy: Boolean = false); +var + sPath, + sLName: String; +begin + sPath := ExtractFilePath(sLogPath); + sLName := ExtractFileName(sLogPath); + if GetFileExt(sLName).ToUpper <> 'LOG' then + sLName := CutFileExt(sLName) + '.log'; + + Create(sPath, sLName, bDaliy); +end; + +Destructor TTgTrace.Destroy; +begin + gTrace := nil; + Inherited; +end; + +class function TTgTrace.SetAllocConsole(bVal: Boolean): Boolean; +begin + Result := false; + try + if gTrace = nil then + exit; + + if gTrace.bAllocConsole_ <> bVal then + begin + var hConsole: HWND := GetConsoleWindow; + + gTrace.bAllocConsole_ := bVal; + if gTrace.bAllocConsole_ then + begin + if hConsole = 0 then + begin + if AllocConsole then + begin +// SetConsoleCP(CP_UTF8); +// SetConsoleOutputCP(CP_UTF8); + end; + end else + ShowWindow(hConsole, SW_SHOWNORMAL); + end else begin + if hConsole <> 0 then + ShowWindow(hConsole, SW_HIDE); +// FreeConsole; + end; + Result := true; + end; + except + // .. + end; +end; + +procedure TTgTrace.SetLogLevel(nVal: Integer); +begin + try + if bLevelLock_ then + exit; + + if nVal <> nLevel_ then + nLevel_ := nVal; + except + // .. + end; +end; + +procedure TTgTrace.DeleteOldLogs(nLeaveDay: Integer = 10); +var + dtNow: TDateTime; + + function FindLogFile(sDir: String): Boolean; + var + sPath: String; + nSubDirCnt, + nFileCnt: Integer; + wfd: TWin32FindData; + hSc: THandle; + dtLog: TDateTime; + begin + Result := false; + + sDir := IncludeTrailingPathDelimiter(sDir); + sPath := sDir + '*.*'; + + hSc := FindFirstFile(PChar(sPath), wfd); + if hSc = INVALID_HANDLE_VALUE then + exit; + + nSubDirCnt := 0; + nFileCnt := 0; + + try + Repeat + if (String(wfd.cFileName) <> '.') and (String(wfd.cFileName) <> '..') then + begin + if ((wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) then + begin + if FindLogFile(sDir + wfd.cFileName) then + DeleteDir(sDir + wfd.cFileName) + else + Inc(nSubDirCnt); + end else begin + if Pos(sFName_, wfd.cFileName) > 0 then + begin + dtLog := ConvFileTimeToDateTime_Local(wfd.ftLastWriteTime); // 마지막 수정일 기준 + if (dtLog <> 0) and (DaysBetween(dtNow, dtLog) > nLeaveDay) then + begin + if DeleteFile(PChar(sDir + wfd.cFileName)) then + continue; + end; + end; + Inc(nFileCnt); + end; + end; + Until not FindNextFile(hSc, wfd); + finally + FindClose(hSc); + end; + + Result := (nSubDirCnt + nFileCnt) = 0; + end; + +begin + _Lock; + try + if bDaliy_ then + begin + dtNow := Now; + if DirectoryExists(sLPath_) then + FindLogFile(sLPath_); + end; + finally + _Unlock; + end; +end; + +function EncLog(sText: String): String; inline; +begin + Result := ':' + EncStrToBinStr(ekAes256cbc, PASS_LOG, sText); +end; + +function DecLog(sText: String): String; +begin + Result := ''; + if Length(sText) < 2 then + exit; + + if sText[1] = ':' then + begin + Delete(sText, 1, 1); + Result := DecBinStrToStr(ekAes256cbc, PASS_LOG, sText); + end else + Result := sText; +end; + +class procedure TTgTrace.T(sLog: String; nLevel: Integer = 0); +var + dtNow: TDateTime; +begin + try + if (gTrace = nil) and (nLevel > 0) then + exit; + + dtNow := Now; + + if gTrace = nil then + begin + {$IFDEF TRACE} + OutputDebugString(PChar(FormatDateTime('[yyyy-mm-dd hh:nn:ss] ', dtNow) + sLog + #13#10)); + {$ENDIF} + + {$IFDEF TRACE_CONSOLE} + if AllocConsole then + begin +// SetConsoleCP(CP_UTF8); +// SetConsoleOutputCP(CP_UTF8); + end; + System.WriteLn(FormatDateTime('[yyyy-mm-dd hh:nn:ss] ', dtNow) + sLog); + {$ENDIF} + end; + + {$IFDEF TRACE_FILE} + if gTrace <> nil then + begin + if gTrace.Level < nLevel then + exit; + + {$IFDEF TRACE} + OutputDebugString(PChar(FormatDateTime('[yyyy-mm-dd hh:nn:ss] ', dtNow) + sLog + #13#10)); + {$ENDIF} + + if gTrForm <> nil then + begin + var Log: TLogEnt; + Log.dt := dtNow; + Log.nLevel := nLevel; + Log.sMsg := sLog; + SendMessage(gTrForm.Handle, WM_WRITE_LOG, 0, LPARAM(@Log)); +// gTrForm.WriteLog(dtNow, nLevel, sLog); // 스레드에서 실행하면 안됨... 25_0923 16:24:42 kku + end; + + if nLevel <> 0 then + sLog := Format('[L%d] ', [nLevel]) + sLog; + + if Assigned(gTrace.evBeforeLog_) then + gTrace.evBeforeLog_(gTrace); + + if gTrace.IsAllocConsole then + System.WriteLn(FormatDateTime('[yyyy-mm-dd hh:nn:ss] ', dtNow) + sLog); + + _Lock; + try + if gTrace.bWFile_ then + begin + var sLogPath: String; + if gTrace.bDaliy_ then + begin + sLogPath := gTrace.sLPath_ + FormatDateTime('yyyy\mm\', dtNow); + if not DirectoryExists(sLogPath) then + begin + if not ForceDirectories(sLogPath) then exit; + end; + sLogPath := sLogPath + FormatDateTime('yy_mmdd ', dtNow) + gTrace.sFName_; + end else + sLogPath := gTrace.sLPath_ + gTrace.sFName_; + + var sLogC: String := FormatDateTime('[yyyy-mm-dd hh:nn:ss] ', dtNow) + gTrace.sLogHead_ + sLog; + + if gTrace.bEnc_ then + WriteLnFileEndUTF8(sLogPath, EncLog(sLogC)) + else + WriteLnFileEndUTF8(sLogPath, sLogC); + end; + finally + _Unlock; + end; + +// if Assigned(gTrace.evAfterLog_) then + if @gTrace.evAfterLog_ <> nil then + gTrace.evAfterLog_(gTrace); + end; + {$ENDIF} + except + + end; +end; + +class procedure TTgTrace.T(const sFormat: string; const Args: array of const; nLevel: Integer = 0); +var + str: String; +begin + FmtStr(str, sFormat, Args); + T(str, nLevel); +end; + +{ Other } + +function WriteLnFileEndA(const sPath: String; const sData: AnsiString): Boolean; +var + fs: TFileStream; +begin + try + fs := nil; + try + if FileExists(sPath) then + begin + fs := TFileStream.Create(sPath, fmOpenWrite or fmShareDenyNone); + fs.Seek(0, soEnd); + end else + fs := TFileStream.Create(sPath, fmCreate); + + fs.Write(PAnsiChar(sData+#13#10)^, Length(sData)+2); + finally + if fs <> nil then + FreeAndNil(fs); + end; + Result := true; + except + Result := false; + end; +end; + +function WriteLnFileEndUTF8(const sPath: String; const sData: UTF8String): Boolean; +var + fs: TFileStream; +begin + try + fs := nil; + try + if FileExists(sPath) then + begin + fs := TFileStream.Create(sPath, fmOpenWrite or fmShareDenyNone); + fs.Seek(0, soEnd); + end else + fs := TFileStream.Create(sPath, fmCreate); + + fs.Write(PAnsiChar(sData+#13#10)^, Length(sData)+2); + finally + if fs <> nil then + FreeAndNil(fs); + end; + Result := true; + except + Result := false; + end; +end; + +function WriteLnFileEndW(const sPath, sData: WideString): Boolean; +var + fs: TFileStream; +begin + try + fs := nil; + try + if FileExists(sPath) then + begin + fs := TFileStream.Create(sPath, fmOpenWrite or fmShareDenyNone); + fs.Seek(0, soEnd); + end else + fs := TFileStream.Create(sPath, fmCreate); + + fs.Write(PWideChar(sData+#13#10)^, (Length(sData)+2)*2); + finally + if fs <> nil then + FreeAndNil(fs); + end; + Result := true; + except + Result := false; + end; +end; + +initialization + _CS := TCriticalSection.Create; + +finalization + if _CS <> nil then + FreeAndNil(_CS); + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.USB.pas b/Tocsg.Lib/VCL/Tocsg.USB.pas new file mode 100644 index 00000000..0b737542 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.USB.pas @@ -0,0 +1,1003 @@ +{*******************************************************} +{ } +{ Tocsg.USB } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.USB; + +interface + +uses + Tocsg.Obj, System.Classes, System.SysUtils, Winapi.Windows, + System.Generics.Collections, Winapi.Messages; + +const + GUID_DEVINTERFACE_USB_DEVICE: TGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}'; + + DBT_DEVICEARRIVAL = $8000; // system detected a new device + DBT_DEVICEREMOVECOMPLETE = $8004; // device is gone + DBT_DEVICEQUERYREMOVE = $8001; + DBT_DEVNODES_CHANGED = $0007; + + DBTF_MEDIA = $0001; + DBT_DEVTYP_VOLUME = $0002; + DBT_DEVTYP_PORT = $0003; + DBT_DEVTYP_NET = $0004; + DBT_DEVTYP_DEVICEINTERFACE = $0005; // device interface class + DBT_DEVTYP_HANDLE = $0006; + +type + PDevBroadcastHdr = ^DEV_BROADCAST_HDR; + DEV_BROADCAST_HDR = {$IFNDEF WIN64} packed {$ENDIF} record + dwSize : DWORD; + dwDevicetype : DWORD; + dwReserved : DWORD; + end; + + PDevBroadcastDeviceInterface = ^DEV_BROADCAST_DEVICEINTERFACE; + DEV_BROADCAST_DEVICEINTERFACE = record + dwSize : DWORD; + dwDevicetype : DWORD; + dwReserved : DWORD; + ClassGUID : TGUID; + nName : Short; + end; + + PDevBroadcastVolume = ^TDevBroadcastVolume; + TDevBroadcastVolume = {$IFNDEF WIN64} packed {$ENDIF} record + dwSize: DWORD; + dwDevicetype: DWORD; + dwReserved: DWORD; + dwUnitmask: DWORD; + wFlags: Word; + end; + + PDevBroadcastHandle = ^TDevBroadcastHandle; + DEV_BROADCAST_HANDLE = record + dbch_size: DWORD; + dbch_devicetype: DWORD; + dbch_reserved: DWORD; + dbch_handle: THandle; { file handle used in call to RegisterDeviceNotification } + dbch_hdevnotify: HDEVNOTIFY; { HDEVNOTIFY returned from RegisterDeviceNotification } + + { The following 3 fields are only valid if wParam is DBT_CUSTOMEVENT. } + + dbch_eventguid: TGUID; + dbch_nameoffset: LongInt; { offset (bytes) of variable-length string buffer (-1 if none)} + dbch_data: array[0..0] of BYTE; { variable-sized buffer, potentially containing binary and/or text data } + end; + TDevBroadcastHandle = DEV_BROADCAST_HANDLE; + + TUSBChangeEvent = procedure(Sender: TObject; pInfo: PDevBroadcastVolume) of object; + TDevChangeEvent = procedure(Sender: TObject; pInfo: PDevBroadcastDeviceInterface) of object; + TUSBChangeQueryEvent = procedure(Sender: TObject; sDrive: String; var bAccept: Boolean) of object; + + TTgUSBEventNotify = class(TTgObject) + private + hWindowHandle_ : HWND; + evUSBArrival_, + evUSBRemove_ : TUSBChangeEvent; + evDevArrival_, + evDevRemove_ : TDevChangeEvent; + evUSBQueryRemove_ : TUSBChangeQueryEvent; + DcQueryRemoveNotify_: TDictionary<HDEVNOTIFY,String>; + + // 특정 환경에서 USB 연결/해제 시 DBT_DEVICEARRIVAL, DBT_DEVICEREMOVECOMPLETE 값을 + // 제대로 받아오지 못하는 경우가 있다. 이 경우 기존 드라이브를 비교해서 연결/해제를 판단함. + dwLogicalDrvs_ : DWORD; + bDeviceChanging_: Boolean; + + procedure ProcessWindowMessage(var msg: TMessage); + function RegisterDeviceChange(sPath: String): Boolean; overload; + function GetQueryRemovePath(hDev: HDEVNOTIFY): String; + procedure SetEventQueryRemove(evUSBChangeQueryEvent: TUSBChangeQueryEvent); + protected + procedure process_WM_DEVICECHANGE(var msg: TMessage); + public + constructor Create; + destructor Destroy; override; + function RegisterDeviceChange: Boolean; overload;// not use + published + property OnUSBArrival: TUSBChangeEvent write evUSBArrival_; + property OnUSBQueryRemove: TUSBChangeQueryEvent write SetEventQueryRemove; + property OnUSBRemove: TUSBChangeEvent write evUSBRemove_; + property OnDevArrival: TDevChangeEvent write evDevArrival_; + property OnDevRemove: TDevChangeEvent write evDevRemove_; + end; + +const + REG_ENUM_USB = 'SYSTEM\CurrentControlSet\Enum\USB\'; + REG_ENUM_USBSTOR = 'SYSTEM\CurrentControlSet\Enum\USBSTOR\'; + REG_ENUM_USE_DISK_NUM = 'SYSTEM\CurrentControlSet\Services\disk\Enum\'; // 현재 인식된 물리디스크 넘버를 확인할수 있다. + REG_MOUNTED_DEVICES = 'SYSTEM\MountedDevices\'; + REG_USB_LASTWRITE_CONTROL1 = 'SYSTEM\CurrentControlSet\Control\DeviceClasses\{53f56307-b6bf-11d0-94f2-00a0c91efb8b}\##?#USBSTOR#%s#%s#{53f56307-b6bf-11d0-94f2-00a0c91efb8b}\Control'; + REG_USB_LASTWRITE_CONTROL2 = 'SYSTEM\CurrentControlSet\Control\DeviceClasses\{53f5630d-b6bf-11d0-94f2-00a0c91efb8b}\##?#STORAGE#RemovableMedia#%s&RM#{53f5630d-b6bf-11d0-94f2-00a0c91efb8b}\Control'; + REG_USB_LASTWRITE_CONTROL_VISTA = 'SYSTEM\CurrentControlSet\Control\DeviceClasses\{53f56307-b6bf-11d0-94f2-00a0c91efb8b}\##?#USBSTOR#%s#%s#{53f56307-b6bf-11d0-94f2-00a0c91efb8b}\Control'; + +type + PUSBRec = ^TUSBRec; + TUSBRec = record + sDeviceName, + sDescription, + sDriveLetter, + sFriendlyName, + sSerial, + sParentIdPrefix, + sVID, + sPID, + sUsbstor, + sSerial2 : AnsiString; + dtCreate, + dtLastWrite: TDateTime; + nDiskNum : Integer; // 연결되어 있다면 값이, 없다면 -1 + end; + + TTgUSBStorInfo = class(TObject) + private + bIsVista_: Boolean; + protected + USBStorList_: TList<PUSBRec>; + + procedure OnUSBStorNotify(Sender: TObject; const Item: PUSBRec; + Action: TCollectionNotification); + + function GetCount: Integer; + function GetUSBInfoStep_1: Boolean; + function GetUSBInfoStep_2: Boolean; + function GetUSBInfoStep_3: Boolean; + function GetUSBInfoStep_4: Boolean; + function GetUSBInfoStep_5: Boolean; + public + Constructor Create; + Destructor Destroy; override; + + function GetUSBInfoByLetter(cDrive: AnsiChar): PUSBRec; + + function GetInfo(nIndex: Integer): PUSBRec; + procedure PutInfo(nIndex: Integer; const pData: PUSBRec); + + function UpdateUSBStorInfo: Boolean; + +// function RemoveUSBInfo(pData: PUSBRec) : Boolean; + + property USBRecs[nIndex: Integer]: PUSBRec read GetInfo; default; + property Count: Integer read GetCount; + end; + +implementation + +uses + Tocsg.Disk, System.Win.Registry, Tocsg.Safe, + Tocsg.DateTime, Tocsg.Exception, EM.WinOSVersion, + Tocsg.Registry; + +{ TTgUSBEventNotify } + +// 이거 스레드에서 생성하면 오동작 할 가능성이 농후함. +// 내부적으로 다열로그를 만들어서 메세지를 받기 때문.. +Constructor TTgUSBEventNotify.Create; +begin + {$IFDEF TRACE1} _Trace('Create()'); {$ENDIF} + inherited Create; + + DcQueryRemoveNotify_ := TDictionary<HDEVNOTIFY,String>.Create; + + dwLogicalDrvs_ := GetLogicalDrives; + bDeviceChanging_ := false; + + hWindowHandle_ := AllocateHWnd(ProcessWindowMessage); +end; + +Destructor TTgUSBEventNotify.Destroy; +begin + DeallocateHWnd(hWindowHandle_); + FreeAndNil(DcQueryRemoveNotify_); + + inherited; + {$IFDEF TRACE1} _Trace('Destroy()'); {$ENDIF} +end; + +procedure TTgUSBEventNotify.SetEventQueryRemove(evUSBChangeQueryEvent: TUSBChangeQueryEvent); + + procedure register_notify; + var + sDrive: String; + nDrive: Integer; + begin + for nDrive := 2 to 31 do + begin + sDrive := Format('%s:\', [Char(Integer('A')+nDrive)]); + + case GetDriveType(PChar(sDrive)) of + DRIVE_FIXED, + DRIVE_REMOVABLE : + if GetDriveSize(sDrive) <> 0 then + RegisterDeviceChange(sDrive); + + end; + end; + end; + +begin + DcQueryRemoveNotify_.Clear; + evUSBQueryRemove_ := evUSBChangeQueryEvent; + if Assigned(evUSBQueryRemove_) then + register_notify; +end; + +function TTgUSBEventNotify.GetQueryRemovePath(hDev: HDEVNOTIFY): String; +begin + if DcQueryRemoveNotify_.ContainsKey(hDev) then + Result := DcQueryRemoveNotify_[hDev] + else + Result := ''; +end; + +procedure TTgUSBEventNotify.ProcessWindowMessage(var msg: TMessage); +begin + case Msg.Msg of + WM_DEVICECHANGE : process_WM_DEVICECHANGE(msg); + end; + Msg.Result := DefWindowProc(hWindowHandle_, msg.Msg, msg.wParam, msg.lParam); +end; + +procedure TTgUSBEventNotify.process_WM_DEVICECHANGE(var msg : TMessage); +var +// nTime: Integer; + dwAddDrv, + dwDelDrv, + dwNewDrvs : DWORD; + pInfo: PDevBroadcastVolume; + bAccept: Boolean; + sDrive: String; + + procedure compare_drives; + begin + dwAddDrv := dwLogicalDrvs_ xor dwNewDrvs; + dwDelDrv := dwAddDrv; + + dwAddDrv := dwNewDrvs and dwAddDrv; + dwDelDrv := dwLogicalDrvs_ and dwDelDrv; + end; + + procedure ProcessChangeDevice(dwDrvs: DWORD; bAdd: Boolean); + var + i: Integer; + m: DWORD; + begin + if dwDrvs = 0 then + exit; + + for i := 0 to 31 do + begin + m := dwDrvs and (1 shl i); + if m <> 0 then + begin + // 일단 이것만 쓰니깐 이것만 채워준다 + pInfo.dwUnitmask := m; + if bAdd and Assigned(evUSBArrival_) then + begin + evUSBArrival_(self, pInfo); + + // 추가 22_0504 13:49:21 kku + if Assigned(evUSBQueryRemove_) then + begin + var sDrive: String := GetDriveFromMask(pInfo.dwUnitmask); + if GetDriveExtent(sDrive).liExtentLength.QuadPart <> 0 then + begin + if GetDriveSize(sDrive) <> 0 then + case Integer(GetDriveType(PChar(sDrive))) of + DRIVE_REMOVABLE, + DRIVE_FIXED : RegisterDeviceChange(sDrive); + end; + end; + end; + end else + if not bAdd and Assigned(evUSBRemove_) then + evUSBRemove_(self, pInfo); + end; + end; + end; + +begin +// DBT_DEVICEQUERYREMOVE +// DBT_DEVICEQUERYREMOVEFAILED +// DBT_DEVICEREMOVECOMPLETE + + // flags & DBTF_MEDIA = 1 -> 씨디룸 + // flags & DBTF_MEDIA = 2 -> 네트워크 드라이브 + +// 반응속도가 참 느리네.. 비스타에서! + case msg.WParam of + {$IF true} + DBT_DEVICEARRIVAL : + begin + case PDevBroadcastHdr(msg.LParam).dwDevicetype of + DBT_DEVTYP_VOLUME : + begin + if Assigned(evUSBArrival_) then + begin + evUSBArrival_(self, PDevBroadcastVolume(msg.LParam)); + + // 추가 22_0504 13:49:21 kku + if Assigned(evUSBQueryRemove_) then + begin + sDrive := GetDriveFromMask(PDevBroadcastVolume(msg.LParam).dwUnitmask); + if GetDriveExtent(sDrive).liExtentLength.QuadPart <> 0 then + begin + if GetDriveSize(sDrive) <> 0 then + case Integer(GetDriveType(PChar(sDrive))) of + DRIVE_REMOVABLE, + DRIVE_FIXED : RegisterDeviceChange(sDrive); + end; + end; + end; + end; + + sDrive := GetDriveFromMask(PDevBroadcastVolume(msg.LParam).dwUnitmask); + if Assigned(evUSBQueryRemove_) then + RegisterDeviceChange(sDrive); + // begin + // if register_deviceChange(sDrive) then + // OutputDebugString('register_deviceChange Succss~~~~~~~~~~~~~~~~~') + // else + // OutputDebugString('register_deviceChange Fail!!!!!!!!!!!!!!!!!!!!!'); + // end; + end; + DBT_DEVTYP_DEVICEINTERFACE : + begin + if Assigned(evDevArrival_) then + begin + evDevArrival_(Self, PDevBroadcastDeviceInterface(msg.LParam)); + _Trace('DevArrival = %s', [GUIDToString(PDevBroadcastDeviceInterface(msg.LParam).ClassGUID)]); + end; + end; + end; + end; + DBT_DEVICEQUERYREMOVE : + begin + if PDevBroadcastHdr(msg.LParam).dwDevicetype = DBT_DEVTYP_HANDLE then + if Assigned(evUSBQueryRemove_) then + begin + sDrive := GetQueryRemovePath(PDevBroadcastHandle(msg.LParam).dbch_hdevnotify); + if sDrive <> '' then + begin + bAccept := true; + evUSBQueryRemove_(self, sDrive, bAccept); + if not bAccept then // 거부임? 그럼 거부 + msg.Result := BROADCAST_QUERY_DENY; + end; + end; + end; + DBT_DEVICEREMOVECOMPLETE : + begin + case PDevBroadcastHdr(msg.LParam).dwDevicetype of + DBT_DEVTYP_VOLUME : + begin + if Assigned(evUSBRemove_) then + evUSBRemove_(self, PDevBroadcastVolume(msg.LParam)); + end; + DBT_DEVTYP_HANDLE : + begin + try + DcQueryRemoveNotify_.Remove(PDevBroadcastHandle(msg.LParam).dbch_hdevnotify); + except + // 건덕지 없을듯 + end; + end; + DBT_DEVTYP_DEVICEINTERFACE : + begin + if Assigned(evDevRemove_) then + begin + evDevRemove_(Self, PDevBroadcastDeviceInterface(msg.LParam)); + _Trace('DevRemove = %s', [GUIDToString(PDevBroadcastDeviceInterface(msg.LParam).ClassGUID)]); + end; + end; + end; + end; + {$ELSE} + // 이건 특정한 상황(?)에서 메세지가 이거 빼곤 다른게 안받아져서 구현한 거임.. + // 급해서 이렇게 만들어서 썼는데 이거보단 위에껄 추천함 + DBT_DEVNODES_CHANGED : + begin + if bDeviceChanging_ then + exit; + + bDeviceChanging_ := true; + dwNewDrvs := GetLogicalDrives; + + nTime := 0; + while nTime < 5000 do + begin + if dwLogicalDrvs_ <> dwNewDrvs then + begin + New(pInfo); + ZeroMemory(pInfo, SizeOf(TDevBroadcastVolume)); + try + compare_drives; + dwLogicalDrvs_ := dwNewDrvs; + + ProcessChangeDevice(dwAddDrv, true); + ProcessChangeDevice(dwDelDrv, false); + finally + Dispose(pInfo); + bDeviceChanging_ := false; + end; + break; + end; + dwNewDrvs := GetLogicalDrives; + WaitForTimer(10); + Inc(nTime); + end; + end; + {$IFEND} + end; +end; + +// not use +function TTgUSBEventNotify.RegisterDeviceChange: Boolean; +var + dbi : DEV_BROADCAST_DEVICEINTERFACE; + nSize : Integer; + hDev : HDEVNOTIFY; +begin + Result := False; + nSize := SizeOf(DEV_BROADCAST_DEVICEINTERFACE); + ZeroMemory(@dbi, nSize); + dbi.dwSize := nSize; + dbi.dwDevicetype := DBT_DEVTYP_DEVICEINTERFACE; + dbi.ClassGUID := GUID_DEVINTERFACE_USB_DEVICE; + + hDev := RegisterDeviceNotification(hWindowHandle_, + @dbi, + DEVICE_NOTIFY_WINDOW_HANDLE); + + if hDev <> nil then + Result := True; +end; + +function TTgUSBEventNotify.RegisterDeviceChange(sPath: String): Boolean; +var + hDev : HDEVNOTIFY; + hPath : THandle; + DevHandle : TDevBroadcastHandle; +begin + Result := false; + + try + // 윈도우 xp에서 빈디스크 에러 메시지 걸러내기 + if GetDriveExtent(sPath).liExtentLength.QuadPart = 0 then + exit; + + if not DirectoryExists(sPath) then + exit; + + hPath := CreateFile(PChar(sPath), + GENERIC_READ, + FILE_SHARE_READ or FILE_SHARE_WRITE, + nil, + OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS or FILE_ATTRIBUTE_NORMAL, + 0); + + if hPath = INVALID_HANDLE_VALUE then + exit; + + try + ZeroMemory(@DevHandle, SizeOf(TDevBroadcastHandle)); + DevHandle.dbch_size := SizeOf(TDevBroadcastHandle); + DevHandle.dbch_devicetype := DBT_DEVTYP_HANDLE; + DevHandle.dbch_handle := hPath; + + hDev := RegisterDeviceNotification(hWindowHandle_, + @DevHandle, + DEVICE_NOTIFY_WINDOW_HANDLE); + + if hDev <> nil then + begin + DcQueryRemoveNotify_.Add(hDev, sPath); + Result := true; + end; + finally + CloseHandle(hPath); + end; + except + on E: Exception do + ETgException.TraceException(Self, E); + end; +end; + +procedure Get_VID_PID(sInfo: AnsiString; var sVid: AnsiString; var sPid: AnsiString); +var + nPos1, nPos2, nLen: Integer; +begin + sInfo := LowerCase(sInfo); + nPos1 := Pos('vid_', sInfo); + nPos2 := Pos('pid_', sInfo); + if (nPos1 = 0) or (nPos2 = 0) then exit; + + nLen := Length(sInfo); + sVid := Copy(sInfo, nPos1+4, nLen-nPos2-3); + sPid := Copy(sInfo, nPos2+4, nLen-nPos2-3); +end; + +{ TTgUSBStorInfo } + +Constructor TTgUSBStorInfo.Create; +var + ver: TWinVerInfo; +begin + Inherited Create; + + bIsVista_ := false; + + ver := GetWinVersion; +// 비스타나 체크한다 + if ver.Version.Major = 6 then + bIsVista_ := true; + + USBStorList_ := TList<PUSBRec>.Create; + USBStorList_.OnNotify := OnUSBStorNotify; +end; + +Destructor TTgUSBStorInfo.Destroy; +begin + FreeAndNil(USBStorList_); + Inherited; +end; + +procedure TTgUSBStorInfo.OnUSBStorNotify(Sender: TObject; const Item: PUSBRec; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +function TTgUSBStorInfo.GetUSBInfoByLetter(cDrive: AnsiChar): PUSBRec; +var + pData: PUSBRec; + i: Integer; +begin + Result := nil; + + for i := 0 to USBStorList_.Count - 1 do + begin + pData := USBStorList_[i]; + if (pData.sDriveLetter <> '') and + (pData.sDriveLetter[1] = cDrive) then + begin + Result := pData; + exit; + end; + end; +end; + +function TTgUSBStorInfo.GetCount: Integer; +begin + Result := USBStorList_.Count; +end; + +function TTgUSBStorInfo.GetInfo(nIndex: Integer): PUSBRec; +begin + if (nIndex >= 0) and (nIndex < Count) then + Result := USBStorList_[nIndex] + else + Result := nil; +end; + +procedure TTgUSBStorInfo.PutInfo(nIndex: Integer; const pData: PUSBRec); +begin + if (nIndex >= 0) and (nIndex < Count) then + USBStorList_[nIndex] := pData; +end; + +// USB 목록에서 Service가 USBSTOR인것을 추출하여 +// 장치이름, 설명, 생성일자, 시리얼 넘버, vid, pid를 얻어온다. +function TTgUSBStorInfo.GetUSBInfoStep_1: Boolean; +var + pData : PUSBRec; + reg, regSub : TRegistry; + lstKey, + lstSubKey, + lstSubSubKey : TStringList; + i, j, n : Integer; + sKey : String; + dtCreate, + dtCompCreate : TDateTime; + regInfo : TRegKeyInfo; +begin + Result := false; + + Guard(reg, TRegistry.Create); + reg.RootKey := HKEY_LOCAL_MACHINE; + if not reg.OpenKeyReadOnly(REG_ENUM_USB) then + begin +// ASSERT(false); + exit; + end; + + Guard(regSub, TRegistry.Create); + regSub.RootKey := HKEY_LOCAL_MACHINE; + + Guard(lstKey, TStringList.Create); + Guard(lstSubKey, TStringList.Create); + Guard(lstSubSubKey, TStringList.Create); + + reg.GetKeyNames(lstKey); + + for i := 0 to lstKey.Count - 1 do + begin + sKey := REG_ENUM_USB + lstKey[i] + '\'; + + lstSubKey.Clear; + reg.CloseKey; + if not reg.OpenKeyReadOnly(sKey) then + begin +// ASSERT(false); + exit; + end; + + reg.GetKeyNames(lstSubKey); + + for j := 0 to lstSubKey.Count - 1 do + begin + reg.CloseKey; + if not reg.OpenKeyReadOnly(sKey + lstSubKey[j]) then + begin +// ASSERT(false); + exit; + end; + + // 이 시간이.. 하위 키값때문인지 바뀔수도 있다.. + // 하위 키값이 더 오래된거면 그걸로 맞춘다. + if reg.GetKeyInfo(regInfo) then + begin + dtCreate := ConvFileTimeToDateTime_Local(regInfo.FileTime); + reg.GetKeyNames(lstSubSubKey); + for n := 0 to lstSubSubKey.Count - 1 do + if regSub.OpenKeyReadOnly(sKey + lstSubKey[j] + '\' + lstSubSubKey[n]) then + begin + if regSub.GetKeyInfo(regInfo) then + begin + dtCompCreate := ConvFileTimeToDateTime_Local(regInfo.FileTime); + if dtCompCreate < dtCreate then + dtCreate := dtCompCreate; + end; + regSub.CloseKey; + end; + end else + dtCreate := 0; + + if LowerCase(reg.ReadString('Service')) = 'usbstor' then + begin + New(pData); + ZeroMemory(pData, SizeOf(TUSBRec)); + pData.sDeviceName := reg.ReadString('LocationInformation'); + pData.sDescription := reg.ReadString('DeviceDesc'); + + // 외장 USB하드는 ParentIdPrefix가 여기에 위치하는거 같다.. + // 이건.. serial2로 넣도록하자 + // USBSTOR에 또 ParentIdPrefix가 있는데 이건 볼륨명 찾을때 필요하다. + // 둘이 무슨차이가 있는거지..? + if reg.ValueExists('ParentIdPrefix') then + begin + pData.sSerial2 := reg.ReadString('ParentIdPrefix'); + end else begin + pData.sSerial2 := lstSubKey[j]; + if Length(pData.sSerial2) > 30 then + SetLength(pData.sSerial2, 30); + end; + +// n := Pos('&', lstSubKey[j]); +// if n = 0 then pData.sSerial := lstSubKey[j]; + + pData.sSerial := lstSubKey[j]; + if Length(pData.sSerial) > 30 then + SetLength(pData.sSerial, 30); + +// pData.sSerial2 := lstSubKey[j]; + Get_VID_PID(Ansistring(lstKey[i]), pData.sVid, pData.sPid); + pData.dtCreate := dtCreate; + pData.nDiskNum := -1; + + USBStorList_.Add(pData); + end; + end; + end; + + Result := true; +end; + +// 드라이브 볼륨명을 얻기위해 ParentIdPrefix 값을 구하고 +// USB의 FriendlyName을 구한다. +function TTgUSBStorInfo.GetUSBInfoStep_2: Boolean; +var + pData : PUSBRec; + reg : TRegistry; + lstKey, lstSubKey : TStringList; + sKey : String; + i, j, c : Integer; +begin + Result := false; + + Guard(reg, TRegistry.Create); + reg.RootKey := HKEY_LOCAL_MACHINE; + if not reg.KeyExists(REG_ENUM_USBSTOR) then + begin + Result := True; + Exit; + end; + if not reg.OpenKeyReadOnly(REG_ENUM_USBSTOR) then + begin +// ASSERT(false); + exit; + end; + + Guard(lstKey, TStringList.Create); + Guard(lstSubKey, TStringList.Create); + + reg.GetKeyNames(lstKey); + + for i := 0 to lstKey.Count - 1 do + begin + sKey := REG_ENUM_USBSTOR + lstKey[i] + '\'; + + lstSubKey.Clear; + reg.CloseKey; + if not reg.OpenKeyReadOnly(sKey) then + begin +// ASSERT(false); + exit; + end; + + reg.GetKeyNames(lstSubKey); + for j := 0 to lstSubKey.Count - 1 do + begin + reg.CloseKey; + if not reg.OpenKeyReadOnly(sKey + lstSubKey[j]) then + begin +// ASSERT(false); + exit; + end; + + for c := 0 to USBStorList_.Count - 1 do + begin + pData := USBStorList_[c]; + + if Pos(pData.sSerial, lstSubKey[j]) > 0 then + begin + if reg.ValueExists('ParentIdPrefix') then + pData.sParentIdPrefix := reg.ReadString('ParentIdPrefix'); + + if pData.sFriendlyName = '' then + pData.sFriendlyName := reg.ReadString('FriendlyName'); + + // vista의 경우 추가 정보획득.. +// if bIsVista_ then + begin + pData.sUsbstor := lstKey[i]; + pData.sSerial2 := lstSubKey[j]; + end; + end else + if lstSubKey[j] = pData.sSerial2 then + begin + // 외장 USB하드의 경우를 위해 이렇게 처리 + // 마지막 사용일자를 구하는 위치가 다른데.. 그 위치를 구하기 위한 준비 + if reg.ValueExists('ParentIdPrefix') then + pData.sParentIdPrefix := reg.ReadString('ParentIdPrefix'); + pData.sUsbstor := lstKey[i]; +// pData.sSerial2 := lstSubKey[j]; + end; + end; + end; + end; + + Result := true; +end; + +// 물리디스크 번호를 얻어온다. 0이상이면 연결된 상태이고 -1이면 없는상태이다 +function TTgUSBStorInfo.GetUSBInfoStep_3: Boolean; +var + pData : PUSBRec; + reg : TRegistry; +// lstValue : TStringList; + i, c, n, nCnt : Integer; + sVal : String; +begin + Result := false; + + Guard(reg, TRegistry.Create); + reg.RootKey := HKEY_LOCAL_MACHINE; + if not reg.OpenKeyReadOnly(REG_ENUM_USE_DISK_NUM) then + begin +// ASSERT(false); + exit; + end; + + if not reg.ValueExists('Count') then + exit; + + nCnt := reg.ReadInteger('Count'); + for i := 0 to nCnt - 1 do + begin + sVal := IntToStr(i); + if not reg.ValueExists(sVal) then break; + sVal := reg.ReadString(sVal); + + for c := 0 to USBStorList_.Count - 1 do + begin + pData := USBStorList_[c]; + + // vista의 경우 serial로 검사~ +// if bIsVista_ then +// begin +// n := Pos(pData.sSerial2, sVal); +// end else +// n := Pos(pData.sParentIdPrefix, sVal); + n := Pos(pData.sSerial2, sVal); // 이건 xp나 비스타나 똑같네 + if n <> 0 then + pData.nDiskNum := i; + end; + end; + + Result := true; +end; + +// 마운트 정보를 확인해서 드라이브 볼륨명을 구한다. +function TTgUSBStorInfo.GetUSBInfoStep_4: Boolean; +var + reg : TRegistry; + lstValue : TStringList; + i, c : Integer; + sLetter, sValue, sBuf : String; + pData : PUSBRec; + regInfo : TRegDataInfo; + buf : array of WideChar; + + function ExtractDriveLetter(const str: String): String; + var + nPos: Integer; + begin + nPos := LastDelimiter('\', str); + if nPos = -1 then + begin + Result := ''; + exit; + end; + Result := UpperCase(Copy(str, nPos+1, Length(str)-nPos)); + end; + +begin + Result := false; + + Guard(reg, TRegistry.Create); + reg.RootKey := HKEY_LOCAL_MACHINE; + if not reg.OpenKeyReadOnly(REG_MOUNTED_DEVICES) then + begin +// ASSERT(false); + exit; + end; + + Guard(lstValue, TStringList.Create); + reg.GetValueNames(lstValue); + + for i := 0 to lstValue.Count - 1 do + begin + sValue := LowerCase(lstValue[i]); + if Pos('dosdevices', sValue) <> 0 then + begin + if not reg.GetDataInfo(sValue, regInfo) then + begin +// ASSERT(false); + exit; + end; + + // 20보다 작으면 아니라고 보는게 좋다.. + // 외장 하드 디스크의 경우엔 이렇게 나타나는데 다른방식으로 구해주도록 하자 + if regInfo.DataSize < 20 then + begin + sLetter := ExtractDriveLetter(sValue); + for c := 0 to USBStorList_.Count - 1 do + begin + pData := USBStorList_[c]; + if pData.nDiskNum < 0 then + continue; + + if pData.nDiskNum = GetDriveExtent(sLetter).dwDiskNumber then + begin + pData.sDriveLetter := sLetter; + break; + end; + end; + continue; + end; + + if regInfo.RegData = rdBinary then + begin + SetLength(buf, regInfo.DataSize+1); + ZeroMemory(buf, regInfo.DataSize+1); + reg.ReadBinaryData(sValue, buf[0], regInfo.DataSize); + sBuf := WideCharToString(@buf[0]); + for c := 0 to USBStorList_.Count - 1 do + begin + pData := USBStorList_[c]; + + if (Pos(pData.sParentIdPrefix, sBuf) <> 0) or + (Pos(pData.sSerial2, sBuf) <> 0) then + begin + pData.sDriveLetter := ExtractDriveLetter(sValue); + break; + end; + end; + end; + end; + end; + + Result := true; +end; + +// 가장 최근에 연결/해제한 날짜를 가져온다. +function TTgUSBStorInfo.GetUSBInfoStep_5: Boolean; +var + reg : TRegistry; + pData : PUSBRec; + i : Integer; + regInfo : TRegKeyInfo; + sKey : String; +begin + Result := true; + + Guard(reg, TRegistry.Create); + reg.RootKey := HKEY_LOCAL_MACHINE; + + for i := 0 to Count - 1 do + begin + pData := USBStorList_[i]; +// if (bIsVista_ = false) and (pData.sParentIdPrefix = '') then continue; + + // vista와 2000, xp는 다르다!! + if bIsVista_ then + sKey := Format(REG_USB_LASTWRITE_CONTROL_VISTA, [pData.sUsbstor, pData.sSerial2]) + else begin + // 외장 USB하드는 serial이 정보에 포함되지 않기때문에 이렇게 구분 + if (pData.sSerial = '') or (pData.sParentIdPrefix = '') then + sKey := Format(REG_USB_LASTWRITE_CONTROL1, [pData.sUsbstor, pData.sSerial2]) + else + sKey := Format(REG_USB_LASTWRITE_CONTROL2, [pData.sParentIdPrefix]); + end; + reg.CloseKey; + if reg.OpenKeyReadOnly(sKey) then + begin + if reg.GetKeyInfo(regInfo) then + pData.dtLastWrite := ConvFileTimeToDateTime_Local(regInfo.FileTime); + end; + end; +end; + +function TTgUSBStorInfo.UpdateUSBStorInfo: Boolean; +begin + USBStorList_.Clear; + + Result := GetUSBInfoStep_1; + if not Result then exit; + + Result := GetUSBInfoStep_2; + if not Result then exit; + + Result := GetUSBInfoStep_3; + if not Result then exit; + + Result := GetUSBInfoStep_4; + if not Result then exit; + + Result := GetUSBInfoStep_5; + if not Result then exit; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Url.pas b/Tocsg.Lib/VCL/Tocsg.Url.pas new file mode 100644 index 00000000..db75c5fe --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Url.pas @@ -0,0 +1,309 @@ +{*******************************************************} +{ } +{ Tocsg.Url } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.Url; + +interface + +uses + System.SysUtils, System.Classes; + +function GetDomainFromUrl(const sUrl: String): String; +function ExtractUrlPath(const sUrl: String): String; + +function IncludeTrailingSlash(const sUrl: String): String; +function ExcludeTrailingSlash(const sUrl: String): String; + +function RefineUrl(sHomeUrl, sSubUrl: String): String; + +function ExtractIPsFromUrl(sUrl: String; bIncIPv6: Boolean = false; sDm: String = ','): String; +function IsUrlValid(const url: string; nTmSec : Integer = 0): boolean; +function UrlEncodeUTF8(const sText: String): String; +function UrlDecodeUTF8(const sText: String): String; + +implementation + +uses + Tocsg.Exception, Tocsg.Process, Tocsg.Safe, Tocsg.Strings, Tocsg.Network, + Winapi.WinInet, Winapi.Windows; + +function GetDomainFromUrl(const sUrl: String): String; +var + nPos, b: Integer; +begin + nPos := Pos('://', sUrl); + if nPos > 0 then + Inc(nPos, 3); + + nPos := FindDelimiter('/', sUrl, nPos); + if nPos > 0 then + Result := Copy(sUrl, 1, nPos - 1) + else + Result := sUrl; +end; + +function ExtractUrlPath(const sUrl: String): String; +var + nPos: Integer; +begin + nPos := LastDelimiter('/', sUrl); + if nPos > 0 then + Result := Copy(sUrl, 1, nPos) + else + Result := sUrl; +end; + +function IncludeTrailingSlash(const sUrl: String): String; +var + nLen: Integer; +begin + nLen := Length(sUrl); + if (nLen = 0) or (sUrl[nLen] <> '/') then + Result := sUrl + '/' + else + Result := sUrl; +end; + +function ExcludeTrailingSlash(const sUrl: String): String; +var + nLen: Integer; +begin + Result := sUrl; + nLen := Length(Result); + if (nLen > 0) and (sUrl[nLen] = '/') then + SetLength(Result, nLen - 1); +end; + +function RefineUrl(sHomeUrl, sSubUrl: String): String; +var + nPos, nSubLen: Integer; +begin + nSubLen := Length(sSubUrl); + if Pos('://', sSubUrl) > 0 then + begin + Result := sSubUrl; + exit; + end else + if nSubLen = 0 then + begin + Result := ''; + exit; + end else + if sSubUrl[1] = '/' then + begin + Result := GetDomainFromUrl(sHomeUrl) + sSubUrl; + end else + if sSubUrl[1] = '?' then + begin + nPos := Pos('?', sHomeUrl); + if nPos > 0 then + Delete(sHomeUrl, nPos, Length(sHomeUrl) - nPos + 1); + Result := sHomeUrl + sSubUrl; + end else + if Pos('./', sSubUrl) = 1 then + begin + Result := ExtractUrlPath(sHomeUrl) + Copy(sSubUrl, 3, nSubLen - 2); + end else + if Pos('../', sSubUrl) = 1 then + begin + Result := ExtractUrlPath(sHomeUrl); + Result := ExcludeTrailingSlash(Result); + Result := ExtractUrlPath(Result) + Copy(sSubUrl, 4, nSubLen - 3); + end else + Result := ExtractUrlPath(sHomeUrl) + sSubUrl; +end; + +function ExtractIPsFromUrl(sUrl: String; bIncIPv6: Boolean = false; sDm: String = ','): String; +var + ss: TStringStream; + sIp, sData: String; + IpList, + ExtrIpList: TStringList; + nPos, c: Integer; +begin + Result := ''; + try + Guard(ss, TStringStream.Create('', TEncoding.UTF8)); + Guard(IpList, TStringList.Create); + Guard(ExtrIpList, TStringList.Create); + if GetCmdTextToStream('cmd.exe', Format('/c nslookup %s', [sUrl]), ss) then + begin + sData := ss.DataString.ToLower; + nPos := Pos('addresses:', sData); + if nPos <> 0 then + begin + Delete(sData, 1, nPos + 9); + end else begin + nPos := Pos('address:', sData); + if nPos <> 0 then + begin + Delete(sData, 1, nPos + 9); + nPos := Pos('address:', sData); + Delete(sData, 1, nPos + 8); + end; + end; + + sData := StringReplace(sData, #9, '', [rfReplaceAll]); + SplitString(sData, #13#10, IpList); + for c := 0 to IpList.Count - 1 do + begin + sIp := IpList[c]; + if IsValidIP(sIp, true, bIncIPv6) and (ExtrIpList.IndexOf(sIp) = -1) then + begin + ExtrIpList.Add(sIp); + SumString(Result, sIp, sDm); + end; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. ExtractIPsFromUrl()'); + end; +end; + +// https://niceit.tistory.com/264 여기서 가져옴 23_0517 16:54:28 kku +function IsUrlValid(const url: string; nTmSec : Integer = 0): boolean; +var + hInet: HINTERNET; + hConnect: HINTERNET; + infoBuffer: array [0..512] of char; + dummy: DWORD; + bufLen: DWORD; + okay: LongBool; + sReply: String; +begin + Result := false; + try + if pos('://-', url) > 0 then + exit; + + hConnect := nil; + hInet := InternetOpen(PChar('EYECOMA'), + INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY, nil, nil, 0); + + if hInet = nil then + exit; + + try + //타임아웃을 지정할 수 있음 + //간혹 지정하지 않는 경우 무한루프에 빠질 수도 있으니 지정하기를 권장 + //적어도 1~2초 이내에는 반환 하는 것이 정상이므로 2초 정도 권장 + if nTmSec > 0 then + InternetSetOption(hInet, INTERNET_OPTION_CONNECT_TIMEOUT, + @nTmSec, SizeOf(nTmSec)); + + //연결해 본다.. + hConnect := InternetOpenUrl(hInet,PChar(url), nil, 0, + INTERNET_FLAG_NO_UI, 0); + + if Assigned(hConnect) then + begin + // Wininet을 이용해 호출할 URL 정보를 만든다. + dummy := 0; + bufLen := Length(infoBuffer); + okay := HttpQueryInfo(hConnect, HTTP_QUERY_STATUS_CODE, @infoBuffer[0], bufLen, dummy); + if okay then + begin + sReply := infoBuffer; + if (sReply = '200') or (sReply = '401') or (sReply = '500') then + Result := true; + +// if sReply = '200' then +// // 네비게이션 웹페이지가 존재 한다 +// Result := true +// else if sReply = '401' then +// // 대부분 페이지는 존재하지만 인증 문제가 있다. +// // 어떤 인증문제인지는 체크 불가함 +// Result := true; + // else if sReply = '404' then + // // 호출 대상 파일을 찾을 수 없다. + // exit; + // else if sReply = '500' then + // // 대부분 웹서버 내부 오류 + // exit; + // else + // {TODO:HTTP프로토콜의 다른 응답 코드에 대해 이 부분에서 추가 처리할것} + // Result := False; + end; + end; + finally + if hConnect <> nil then + InternetCloseHandle(hConnect); + if hInet <> nil then + InternetCloseHandle(hInet); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsUrlValid()'); + end; +end; + +function UrlEncodeUTF8(const sText: String): String; +var + i: Integer; + c: AnsiChar; + sUtf8: UTF8String; +begin + Result := ''; + sUtf8 := UTF8Encode(sText); // UTF-8 변환 + + for i := 1 to Length(sUtf8) do + begin + c := sUtf8[i]; + + // URL-safe 문자 + if (c in ['A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.', '~']) then + Result := Result + Char(c) + else + Result := Result + '%' + IntToHex(Ord(c), 2); // %XX 형태로 인코딩 + end; +end; + +function UrlDecodeUTF8(const sText: String): String; +var + i, nLen: Integer; + sHex: String; + pBuf: TBytes; + uc: Byte; +begin + SetLength(pBuf, 0); + i := 1; + nLen := Length(sText); + while i <= nLen do + begin + if sText[i] = '%' then + begin + // %XX 형태인지 확인 + if (i + 2 <= nLen) then + begin + sHex := Copy(sText, i + 1, 2); + uc := Byte(StrToInt('$' + sHex)); + pBuf := pBuf + [uc]; + Inc(i, 3); // %XX 건너뛰기 + Continue; + end; + end else + if sText[i] = '+' then + begin + // 보통 URL 인코딩에서는 + 를 공백으로 처리하는 경우도 있음 + pBuf := pBuf + [Ord(' ')]; + Inc(i); + Continue; + end; + + // 일반 ASCII 문자 + pBuf := pBuf + [Ord(sText[i])]; + Inc(i); + end; + + // UTF-8 → Unicode string 변환 + Result := TEncoding.UTF8.GetString(pBuf); +end; + +end. + diff --git a/Tocsg.Lib/VCL/Tocsg.User32.pas b/Tocsg.Lib/VCL/Tocsg.User32.pas new file mode 100644 index 00000000..4bc85d45 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.User32.pas @@ -0,0 +1,70 @@ +{*******************************************************} +{ } +{ Tocsg.User32 } +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.User32; + +interface + +uses + System.SysUtils, Winapi.Windows; + +const + MSGFLT_ADD = 1; + MSGFLT_REMOVE = 2; + + MSGFLT_RESET = 0; + MSGFLT_ALLOW = 1; + MSGFLT_DISALLOW = 2; + + WM_COPYGLOBALDATA = $0049; + +type + PChangeFilterStruct = Pointer; + + TChangeWindowMessageFilter = function(dwMsg, dwFlag: DWORD): Boolean; stdcall; + TChangeWindowMessageFilterEx = function(h: hWnd; dwWndMsg: DWORD; wAction: WORD; pChangeFilterData: PChangeFilterStruct): BOOL; stdcall; + +//function ChangeWindowMessageFilter(dwMsg, dwFlag: DWORD): Boolean; // Winapi.Windows.pas 여기에 생김 +function ChangeWindowMessageFilterEx(h: hWnd; dwWndMsg: DWORD; wAction: WORD; pChangeFilterData: PChangeFilterStruct): BOOL; + +implementation + +var + _hUser32: THandle = 0; + _fnChangeWindowMessageFilter: TChangeWindowMessageFilter = nil; + _fnChangeWindowMessageFilterEx: TChangeWindowMessageFilterEx = nil; + +function InitUser32Procedure: Boolean; +begin + if _hUser32 = 0 then + begin + _hUser32 := GetModuleHandle(user32); + if _hUser32 <> 0 then + begin + @_fnChangeWindowMessageFilter := GetProcAddress(_hUser32, 'ChangeWindowMessageFilter'); + @_fnChangeWindowMessageFilterEx := GetProcAddress(_hUser32, 'ChangeWindowMessageFilterEx'); + end; + end; + Result := _hUser32 <> 0; +end; + +//function ChangeWindowMessageFilter(dwMsg, dwFlag: DWORD): Boolean; +//begin +// Result := false; +// if InitUser32Procedure and Assigned(_fnChangeWindowMessageFilter) then +// Result := _fnChangeWindowMessageFilter(dwMsg, dwFlag); +//end; + +function ChangeWindowMessageFilterEx(h: hWnd; dwWndMsg: DWORD; wAction: WORD; pChangeFilterData: PChangeFilterStruct): BOOL; +begin + Result := false; + if InitUser32Procedure and Assigned(_fnChangeWindowMessageFilterEx) then + Result := _fnChangeWindowMessageFilterEx(h, dwWndMsg, wAction, pChangeFilterData); +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.VTUtil.pas b/Tocsg.Lib/VCL/Tocsg.VTUtil.pas new file mode 100644 index 00000000..713912cc --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.VTUtil.pas @@ -0,0 +1,766 @@ +{*******************************************************} +{ } +{ Tocsg.VTUtil } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.VTUtil; + +interface + +uses + WinAPi.Windows, VirtualTrees, VirtualTrees.Types, System.Classes, System.SysUtils; + +type + TTgVirtualStringTreeHelper = class helper for TBaseVirtualTree + public + procedure SortEx(pBeginNode: PVirtualNode; nColumn: TColumnIndex; Direction: TSortDirection; nSortCount: Integer = -1); + end; + +function VT_CountTotalNode(vt: TVirtualStringTree): DWORD; +function VT_CountVisibleNode(vt: TVirtualStringTree): DWORD; +function VT_CountVisibleChildNode(pNode: PVirtualNode): DWORD; +function VT_CountVisibleCheckedNode(vt: TVirtualStringTree): DWORD; +procedure VT_ReverseSelected(vt: TVirtualStringTree); +procedure VT_CheckAll(var vt: TVirtualStringTree); +procedure VT_UnCheckAll(var vt: TVirtualStringTree); +procedure VT_ForceCheckNode(pNode: PVirtualNode); +procedure VT_ForceUnCheckNode(pNode: PVirtualNode); +procedure VT_ReverseCheckAll(vt: TVirtualStringTree); +procedure VT_SetEnalbedNode(vt: TVirtualStringTree; pNode: PVirtualNode; bVal: Boolean); +function VT_HasDisableNode(vt: TVirtualStringTree; pNode: PVirtualNode): Boolean; +procedure VT_ExpandAll(vt: TVirtualStringTree; bFlag: Boolean); +procedure VT_ExpandNodeAll(vt: TVirtualStringTree; pNode: PVirtualNode; bFlag: Boolean); +function VT_CopyToClipboardSelectedInfo(vt: TVirtualStringTree; nStartColumnIdx: Integer = 1): Integer; + +function VT_AddChild(vt: TVirtualStringTree; pParent: PVirtualNode = nil): PVirtualNode; inline; +function VT_AddChildDataN(vt: TVirtualStringTree; out pAddNode: PVirtualNode; pParent: PVirtualNode = nil): Pointer; overload; inline; +function VT_AddChildData(vt: TVirtualStringTree; pParent: PVirtualNode = nil): Pointer; inline; overload; + +function VT_HasChildNode(vt: TVirtualStringTree; pParent, pFindNode: PVirtualNode): Boolean; + +function VT_Get1SelNodeData(vt: TVirtualStringTree): Pointer; +procedure VT_SortAll(vt: TVirtualStringTree; nColumn: Integer; aDirection: TSortDirection); +procedure VT_SortNodeChilds(vt: TVirtualStringTree; pNode: PVirtualNode; nColumn: Integer; aDirection: TSortDirection); +function VT_FindNodeFromPath(vt: TVirtualStringTree; sPath: String; sDelimiter: String = '\'; nColumn: Integer = 0): PVirtualNode; +procedure VT_SetCheckTypeAllNode(vt: TVirtualStringTree; aCheckType: TCheckType); +procedure VT_SetFocuceNode(vt: TVirtualStringTree; pNode: PVirtualNode); +procedure VT_Clear(aVT: TVirtualStringTree); + +implementation + +uses + Vcl.Clipbrd, Tocsg.Safe, Tocsg.Strings; + +// pBeginNode 부터 nSortCount 수만큼 정렬을 시도한다. +// 기본 골격은 TBaseVirtualTree >> procedure Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual; +procedure TTgVirtualStringTreeHelper.SortEx(pBeginNode: PVirtualNode; nColumn: TColumnIndex; Direction: TSortDirection; nSortCount: Integer = -1); + + function MergeAscending(A, B: PVirtualNode): PVirtualNode; + 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, nColumn); + + 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; + 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, nColumn); + + 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; + 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; + + i: Integer; + bBeginFirstChild: Boolean; + pTempNode, + pSortCountNextNode, + pBeginPrevNode: PVirtualNode; + vtState: TVirtualTreeStates; +begin + with Self do + begin + InterruptValidation; + + if tsEditPending in FStates then + begin + StopTimer(EditTimer); + DoStateChange([], [tsEditPending]); + end; + + vtState := FStates; + end; + + if not (tsEditing in vtState) or DoEndEdit then + begin + if pBeginNode = nil then + exit; + + if nSortCount = -1 then + begin + nSortCount := 0; + pTempNode := pBeginNode; + while pTempNode <> nil do + begin + Inc(nSortCount); + pTempNode := pTempNode.NextSibling; + end; + pSortCountNextNode := nil; + end else begin + pTempNode := pBeginNode; + for i := 1 to nSortCount do + begin + pTempNode := pTempNode.NextSibling; + if pTempNode = nil then + begin + nSortCount := i; + break; + end; + end; + pSortCountNextNode := pTempNode; + end; + + if nSortCount > 1 then + begin + bBeginFirstChild := false; + if pBeginNode.Parent <> nil then + begin + if pBeginNode.Parent.FirstChild = pBeginNode then + bBeginFirstChild := true; + end; + + pBeginPrevNode := pBeginNode.PrevSibling; + Index := pBeginNode.Index; + + StartOperation(okSortNode); + try + // Sort the linked list, check direction flag only once. + if Direction = sdAscending then + pTempNode := MergeSortAscending(pBeginNode, nSortCount) + else + pTempNode := MergeSortDescending(pBeginNode, nSortCount); + + if pTempNode.Parent <> nil then + begin + if bBeginFirstChild then + pTempNode.Parent.FirstChild := pTempNode; + end; + finally + EndOperation(okSortNode); + end; + + // Consolidate the child list finally. + Run := pTempNode; + if pBeginPrevNode <> nil then + pBeginPrevNode.NextSibling := Run; + Run.PrevSibling := pBeginPrevNode; + + repeat + Run.Index := Index; + Inc(Index); + if Run.NextSibling = nil then + Break; + Run.NextSibling.PrevSibling := Run; + Run := Run.NextSibling; + until False; + + if pSortCountNextNode <> nil then + begin + Run.NextSibling := pSortCountNextNode; + pSortCountNextNode.PrevSibling := Run; + end else + if (Run.Parent <> nil) and (Run.NextSibling = nil) then + Run.Parent.LastChild := Run; + + InvalidateCache; + end; + + with Self do + begin + if FUpdateCount = 0 then + begin + ValidateCache; + Invalidate; + end; + end; + end; +end; + +{ Other } + +function VT_CountTotalNode(vt: TVirtualStringTree): DWORD; +var + pNode: PVirtualNode; +begin + Result := 0; + pNode := vt.GetFirst; + while pNode <> nil do + begin + Inc(Result); + pNode := vt.GetNext(pNode); + end; +end; + +function VT_CountVisibleNode(vt: TVirtualStringTree): DWORD; +var + pNode: PVirtualNode; +begin + Result := 0; + pNode := vt.GetFirst; + while pNode <> nil do + begin + if vt.IsVisible[pNode] then + Inc(Result); + pNode := vt.GetNext(pNode); + end; +end; + +function VT_CountVisibleChildNode(pNode: PVirtualNode): DWORD; +begin + Result := 0; + pNode := pNode.FirstChild; + while pNode <> nil do + begin + if vsVisible in pNode.States then + Inc(Result); + + pNode := pNode.NextSibling; + end; +end; + +function VT_CountVisibleCheckedNode(vt: TVirtualStringTree): DWORD; +var + pNode: PVirtualNode; +begin + Result := 0; + pNode := vt.GetFirst; + while pNode <> nil do + begin + if vt.IsVisible[pNode] and (pNode.CheckState = csCheckedNormal) then + Inc(Result); + pNode := vt.GetNext(pNode); + end; +end; + +procedure VT_ReverseSelected(vt: TVirtualStringTree); +var + pNode: PVirtualNode; +begin + vt.BeginUpdate; + try + pNode := vt.GetFirst; + while pNode <> nil do + begin + vt.Selected[pNode] := not vt.Selected[pNode]; + pNode := vt.GetNext(pNode); + end; + finally + vt.EndUpdate; + end; +end; + +procedure VT_CheckAll(var vt: TVirtualStringTree); +var + pNode: PVirtualNode; +begin + vt.BeginUpdate; + try + pNode := vt.GetFirst; + while pNode <> nil do + begin + if vt.IsVisible[pNode] and not vt.IsDisabled[pNode] then + pNode.CheckState := csCheckedNormal; + pNode := vt.GetNext(pNode, true); + end; + finally + vt.EndUpdate; + end; +end; + +procedure VT_UnCheckAll(var vt: TVirtualStringTree); +var + pNode: PVirtualNode; +begin + vt.BeginUpdate; + try + pNode := vt.GetFirst; + while pNode <> nil do + begin + if vt.IsVisible[pNode] and not vt.IsDisabled[pNode] then +// vt.CheckState[pNode] := csUncheckedNormal; + pNode.CheckState := csUncheckedNormal; + pNode := vt.GetNext(pNode, true); + end; + finally + vt.EndUpdate; + end; +end; + +procedure VT_ForceCheckNode(pNode: PVirtualNode); +var + pChildN: PVirtualNode; +begin + pNode.CheckState := csCheckedNormal; + pChildN := pNode.FirstChild; + while pChildN <> nil do + begin + pChildN.CheckState := csCheckedNormal; + if pChildN.ChildCount > 0 then + VT_ForceCheckNode(pChildN); + pChildN := pChildN.NextSibling; + end; +end; + +procedure VT_ForceUnCheckNode(pNode: PVirtualNode); +var + pChildN: PVirtualNode; +begin + pNode.CheckState := csUncheckedNormal; + pChildN := pNode.FirstChild; + while pChildN <> nil do + begin + pChildN.CheckState := csUncheckedNormal; + if pChildN.ChildCount > 0 then + VT_ForceCheckNode(pChildN); + pChildN := pChildN.NextSibling; + end; +end; + +procedure VT_ReverseCheckAll(vt: TVirtualStringTree); +var + pNode: PVirtualNode; +begin + vt.BeginUpdate; + try + pNode := vt.GetFirst; + while pNode <> nil do + begin + if vt.IsVisible[pNode] and not vt.IsDisabled[pNode] then + begin + if pNode.CheckState = csCheckedNormal then + pNode.CheckState := csUncheckedNormal + else + if pNode.CheckState = csUncheckedNormal then + pNode.CheckState := csCheckedNormal; + end; + + pNode := vt.GetNext(pNode); + end; + finally + vt.EndUpdate; + end; +end; + +procedure VT_SetEnalbedNode(vt: TVirtualStringTree; pNode: PVirtualNode; bVal: Boolean); +begin + vt.BeginUpdate; + try + vt.IsDisabled[pNode] := not bVal; + if pNode.ChildCount > 0 then + begin + pNode := pNode.FirstChild; + while pNode <> nil do + begin + VT_SetEnalbedNode(vt, pNode, bVal); + pNode := pNode.NextSibling; + end; + end; + finally + vt.EndUpdate; + end; +end; + +function VT_HasDisableNode(vt: TVirtualStringTree; pNode: PVirtualNode): Boolean; + + function CheckDisableNode(aNode: PVirtualNode): Boolean; + begin + Result := false; + if vt.IsDisabled[aNode] then + begin + Result := true; + exit; + end; + + if aNode.ChildCount > 0 then + begin + aNode := aNode.FirstChild; + while aNode <> nil do + begin + Result := CheckDisableNode(aNode); + if Result then + exit; + aNode := aNode.NextSibling; + end; + end; + end; + +begin + vt.BeginUpdate; + try + Result := CheckDisableNode(pNode); + finally + vt.EndUpdate; + end; +end; + +procedure VT_ExpandAll(vt: TVirtualStringTree; bFlag: Boolean); +var + pNode: PVirtualNode; +begin + vt.BeginUpdate; + try + pNode := vt.GetFirst; + while pNode <> nil do + begin + vt.Expanded[pNode] := bFlag; + pNode := vt.GetNext(pNode); + end; + finally + vt.EndUpdate; + end; +end; + +procedure VT_ExpandNodeAll(vt: TVirtualStringTree; pNode: PVirtualNode; bFlag: Boolean); +begin + vt.BeginUpdate; + try + while pNode <> nil do + begin + vt.Expanded[pNode] := bFlag; + pNode := vt.GetNext(pNode); + end; + finally + vt.EndUpdate; + end; +end; + +function VT_CopyToClipboardSelectedInfo(vt: TVirtualStringTree; nStartColumnIdx: Integer = 1): Integer; +var + pNode: PVirtualNode; + sData: String; + i: Integer; + cbd: TClipboard; +begin + Result := 0; + pNode := vt.GetFirstSelected; + if pNode = nil then + begin + Result := 1; + exit; + end; + + if vt.SelectedCount > 1000 then + begin + Result := 2; + exit; + end; + + if nStartColumnIdx >= vt.Header.Columns.Count then + nStartColumnIdx := 0; + + sData := ''; + while pNode <> nil do + begin + for i := nStartColumnIdx to vt.Header.Columns.Count - 1 do + if coVisible in vt.Header.Columns[i].Options then + begin + sData := sData + vt.Text[pNode, i] + #9; + end; + + sData := sData + #13#10; + + pNode := vt.GetNextSelected(pNode); + end; + + if sData <> '' then + begin + Guard(cbd, TClipboard.Create); + cbd.AsText := sData; + end else Result := 3; +end; + +function VT_AddChild(vt: TVirtualStringTree; pParent: PVirtualNode = nil): PVirtualNode; inline; +begin + Result := vt.AddChild(pParent); + Include(Result.States, vsInitialized); +end; + +function VT_AddChildDataN(vt: TVirtualStringTree; out pAddNode: PVirtualNode; pParent: PVirtualNode = nil): Pointer; inline; +begin + pAddNode := vt.AddChild(pParent); + Include(pAddNode.States, vsInitialized); + Result := vt.GetNodeData(pAddNode); +end; + +function VT_AddChildData(vt: TVirtualStringTree; pParent: PVirtualNode = nil): Pointer; inline; overload; +var + pNode: PVirtualNode; +begin + Result := VT_AddChildDataN(vt, pNode, pParent); +end; + +function VT_HasChildNode(vt: TVirtualStringTree; pParent, pFindNode: PVirtualNode): Boolean; +var + pNode: PVirtualNode; +begin + Result := false; + + if pParent = nil then + exit; + + if pParent = pFindNode then + begin + Result := true; + exit; + end; + + pNode := pParent.FirstChild; + while pNode <> nil do + begin + Result := VT_HasChildNode(vt, pNode, pFindNode); + if Result then + exit; + + pNode := pNode.NextSibling; + end; +end; + +function VT_Get1SelNodeData(vt: TVirtualStringTree): Pointer; +var + pNode: PVirtualNode; +begin + pNode := vt.GetFirstSelected; + if pNode <> nil then + Result := vt.GetNodeData(pNode) + else + Result := nil; +end; + +procedure VT_SortAll(vt: TVirtualStringTree; nColumn: Integer; aDirection: TSortDirection); +var + pNode: PVirtualNode; +begin + vt.Sort(nil, nColumn, aDirection); + + pNode := vt.GetFirst; + while pNode <> nil do + begin + if pNode.ChildCount > 0 then + vt.Sort(pNode, nColumn, aDirection); + pNode := vt.GetNext(pNode); + end; +end; + +procedure VT_SortNodeChilds(vt: TVirtualStringTree; pNode: PVirtualNode; nColumn: Integer; aDirection: TSortDirection); +begin + vt.Sort(pNode, nColumn, aDirection); + + if pNode = nil then + pNode := vt.RootNode; + + pNode := pNode.FirstChild; + while pNode <> nil do + begin + if pNode.ChildCount > 0 then + VT_SortNodeChilds(vt, pNode, nColumn, aDirection); + pNode := pNode.NextSibling; + end; +end; + +// 잘 동작하는지 테스트 안됨 22_0119 21:34:10 kku +// 확인 되면 이거 지워 ㅇㅇ +function VT_FindNodeFromPath(vt: TVirtualStringTree; sPath: String; sDelimiter: String = '\'; nColumn: Integer = 0): PVirtualNode; + + function GetMatchTextNode(pNode: PVirtualNode; sMatchText: String): PVirtualNode; + begin + Result := nil; + while pNode <> nil do + begin + if CompareText(vt.Text[pNode, nColumn], sMatchText) = 0 then + begin + Result := pNode; + exit; + end; + pNode := pNode.NextSibling; + end; + end; + +var + PathList: TStringList; + pNode: PVirtualNode; + i: Integer; +begin + Result := nil; + Guard(PathList, TStringList.Create); + + if SplitString2(sDelimiter, sPath, PathList) = 0 then + exit; + + vt.BeginUpdate; + try + pNode := vt.RootNode; + if pNode = nil then + exit; + + for i := 0 to PathList.Count - 1 do + begin + Result := GetMatchTextNode(pNode.FirstChild, PathList[i]); + if Result = nil then + break; + end; + finally + vt.EndUpdate; + end; +end; + +procedure VT_SetCheckTypeAllNode(vt: TVirtualStringTree; aCheckType: TCheckType); +var + pNode: PVirtualNode; +begin + pNode := vt.GetFirst; + while pNode <> nil do + begin + pNode.CheckType := aCheckType; + pNode := vt.GetNext(pNode); + end; +end; + +procedure VT_SetFocuceNode(vt: TVirtualStringTree; pNode: PVirtualNode); +begin + vt.FocusedNode := nil; + vt.ClearSelection; + + vt.FocusedNode := pNode; + vt.Selected[pNode] := true; + vt.ScrollIntoView(pNode, true); +end; + +procedure VT_Clear(aVT: TVirtualStringTree); +begin + with aVT.Header do + begin + if SortColumn <> -1 then + begin + Columns[SortColumn].Options := Columns[SortColumn].Options + [coParentColor]; + SortColumn := -1; + end; + end; + aVT.Clear; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Valid.pas b/Tocsg.Lib/VCL/Tocsg.Valid.pas new file mode 100644 index 00000000..7b01aa40 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Valid.pas @@ -0,0 +1,131 @@ +{*******************************************************} +{ } +{ Tocsg.Valid } +{ } +{ Copyright (C) 2025 kku } +{ } +{*******************************************************} + +unit Tocsg.Valid; + +interface + +uses + System.SysUtils, Winapi.Windows; + +function IsValidKoreanRegNo(sRegNo: String): Boolean; + +implementation + +uses + System.DateUtils, Tocsg.Exception; + +const +// 주민번호, 외국인등록번호 검증 가중치 + arrWeights: array[1..12] of Integer = (2, 3, 4, 5, 6, 7, 8, 9, 2, 3, 4, 5); + +// 주민번호에서 생년월일 검증 +function IsValidDateFromSSN(const SSN: string): Boolean; +var + nYear, nMonth, nDay, nFYear, n: Integer; + dtTemp: TDateTime; +begin + Result := false; + + if Length(SSN) < 7 then + exit; + + try + nYear := StrToIntDef(Copy(SSN, 1, 2), -1); + if nYear = -1 then exit; + nMonth := StrToIntDef(Copy(SSN, 3, 2), -1); + if nMonth = -1 then exit; + nDay := StrToIntDef(Copy(SSN, 5, 2), -1); + if nDay = -1 then exit; + n := StrToIntDef(SSN[7], -1); + if n = -1 then exit; + + case n of + 1, 2: nFYear := 1900 + nYear; + 3, 4: nFYear := 2000 + nYear; + 5, 6: nFYear := 1900 + nYear; // 외국인 등록번호 (2000년 이전) + 7, 8: nFYear := 2000 + nYear; // 외국인 등록번호 (2000년 이후) + else exit; + end; + + Result := TryEncodeDate(nFYear, nMonth, nDay, dtTemp); + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. IsValidDateFromSSN()'); + end; +end; + +function IsValidForeignRegNo(sRegNo: String): Boolean; +var + i, nSum, nCheck, nLastDigit: Integer; +begin + Result := false; + + if Length(sRegNo) < 13 then + exit; + + // 외국인 등록번호는 7번째 자리가 5~8번이어야 함 + if not (sRegNo[7] in ['5', '6', '7', '8']) then + exit; + + // 가중치 계산 + nSum := 0; + for i := 1 to 12 do + nSum := nSum + StrToInt(sRegNo[i]) * arrWeights[i]; + + // 검증 숫자 계산 + nCheck := (11 - (nSum mod 11) + 2) mod 10; + nLastDigit := StrToInt(sRegNo[13]); + + Result := nCheck = nLastDigit; +end; + +// 주민번호 검증 +// 외국인등록번호 검증 추가 25_0623 10:45:05 kku +// 2017년 이후 새로운 주민번호 방식(예: 지역번호 변경 등)에는 대응하지 않음 +function IsValidKoreanRegNo(sRegNo: String): Boolean; +var + i, nSum, nCheck, nCalc: Integer; +begin + Result := false; + + sRegNo := StringReplace(sRegNo, '-', '', [rfReplaceAll]); + + // 생년월일 유효성 체크 + if not IsValidDateFromSSN(sRegNo) then + exit; + + // 13자리 숫자인지 확인 + if Length(sRegNo) < 13 then + exit; + + // 외국인 등록번호는 7번째 자리가 5~8번임 + if sRegNo[7] in ['5', '6', '7', '8'] then + begin + Result := IsValidForeignRegNo(sRegNo); + exit; + end; + + // 숫자만으로 이루어졌는지 확인 + for i := 1 to 13 do + if not CharInSet(sRegNo[i], ['0'..'9']) then + exit; + + // 가중치 계산 + nSum := 0; + for i := 1 to 12 do + nSum := nSum + (Ord(sRegNo[i]) - Ord('0')) * arrWeights[i]; + + // 검증 숫자 계산 + nCalc := (11 - (nSum mod 11)) mod 10; + nCheck := Ord(sRegNo[13]) - Ord('0'); + + Result := nCalc = nCheck; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.WMI.pas b/Tocsg.Lib/VCL/Tocsg.WMI.pas new file mode 100644 index 00000000..00c22c23 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.WMI.pas @@ -0,0 +1,671 @@ +{*******************************************************} +{ } +{ Tocsg.WMI } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.WMI; + +interface + +uses + System.Classes, System.SysUtils, Winapi.Windows, + Tocsg.Thread, EM.WbemScripting_TLB; + +const + WMI_ROOT_OBJECT = 'root\cimv2'; + KBYTE = Sizeof(Byte) shl 10; + MBYTE = KBYTE shl 10; + GBYTE = MBYTE shl 10; + + WBEM_INFINITE = $FFFFFFFF; + WMI_SERVICE_NAME = 'Winmgmt'; + + WMI_EVENT_CREATE = 2084146945; + WMI_EVENT_MODIFY = 1531267689; + WMI_EVENT_DELETE = 2121895681; + +type + TWMIEventKind = (wkUnknown, wkCreate, wkDelete, wkModify); + TWMINotifyEvent = procedure(Sender: TObject; WMIEventKind: TWMIEventKind; + ovEvent: OleVariant) of object; + TTgWmiEventThread = class(TTgThread) + private + bInit_, + bSync_: Boolean; + sWMIClass_: String; + ovEvent_: OleVariant; + WMIEventKind_: TWMIEventKind; + WbemLocator_: TSWbemLocator; + WbemEvent_: ISWbemEventSource; + evWMINotify_: TWMINotifyEvent; + procedure DoWMIEvent; + protected + procedure Execute; override; + public + Constructor Create(const sWMIClass: String; bSync: Boolean = true); + Destructor Destroy; override; + + property OnWMINotify: TWMINotifyEvent write evWMINotify_; + end; + +type + T2DimStrArray = array of array of string; + +function WMI_GetPropertyString(WbemProperty: ISWbemProperty): String; +function WMI_GetSingleInstance(const sArg, sProp: String; var sResult: String): Boolean; +function WMI_GetSingleInstanceProperty(const sArg, sProp: String; var sResult: String): Boolean; +function WMI_GetInformationEx(const sCom, sNameSapce, sUser, sPass, sArg: String; + var wmiResults: T2DimStrArray; var nInstances: Integer): Boolean; +function WMI_GetPropertyIndex(wmiResults: T2DimStrArray; const sProp: String): Integer; +function WMI_GetPropertyData(wmiResults: T2DimStrArray; const sProp: String; nLine: Integer = 0): String; +function WMI_ConvWMIDateToDateTime(const sWmiDate: String; var nUTCOffset: Integer): TDateTime; + +function WMI_GetTableInfo(const sTable, sField: String): String; + +function WMI_GetOSInfo(const sField: String): String; +function WMI_GetOSInstallDateTime: TDateTime; + +function WMI_GetCpuInfo: String; + +function WMI_GetBaseboardInfo: String; +function WMI_GetMotherboardInfo: String; + +function WMI_GetBiosInfo(const sField: String): String; +function WMI_GetBiosReleaseDateTime: TDateTime; +function WMI_GetBiosVersion: String; +function WMI_GetVideoController: String; +function WMI_GetNetworkTotalTraffic: LONGLONG; +function WMI_GetMemory: LONGLONG; +function WMI_GetMonitor: String; + +implementation + +uses + Tocsg.Exception, Tocsg.Hash, Tocsg.Service, Tocsg.Safe, Tocsg.Trace, + Winapi.ActiveX, System.Win.ComObj, System.Variants, Tocsg.Strings; + +{ TTgWmiEventThread } + +Constructor TTgWmiEventThread.Create(const sWMIClass: String; bSync: Boolean = true); +begin + Inherited Create; + bSync_ := bSync; + sWMIClass_ := QuotedStr(sWMIClass); + WbemLocator_ := nil; + ovEvent_ := 0; + WbemEvent_ := nil; + evWMINotify_ := nil; +end; + +Destructor TTgWmiEventThread.Destroy; +begin + evWMINotify_ := nil; + FreeAndNil(WbemLocator_); + Inherited; +end; + +procedure TTgWmiEventThread.DoWMIEvent; +begin + if Assigned(evWMINotify_) then + evWMINotify_(Self, WMIEventKind_, ovEvent_); +end; + +procedure TTgWmiEventThread.Execute; +var + nReTryCnt: Integer; + + function InitWMI: Boolean; + var + WbemServices: ISWbemServices; + sQuery: String; + begin + Result := false; + nLastError_ := 0; + + // 알수없는 이유로... Create()에서 생성 안될거 생각해서 이렇게 변경 + if WbemLocator_ = nil then + try + WbemLocator_ := TSWbemLocator.Create(nil); + WbemServices := WbemLocator_.ConnectServer('', WMI_ROOT_OBJECT, '', '', '', '', 0, nil) + except + WbemLocator_ := nil; + exit; + end; + + try + if WbemServices = nil then + begin + nLastError_ := 1; + _Trace('WMI.ConnectServer() .. Fail, Error = %d', [GetLastError]); + exit; + end; + sQuery := Format('SELECT * FROM __InstanceOperationEvent WITHIN 1 ' + + 'WHERE TargetInstance ISA %s', [sWMIClass_]); + + WbemEvent_ := WbemServices.ExecNotificationQuery(sQuery, + 'WQL', + wbemFlagForwardOnly or wbemFlagReturnImmediately, + nil); + if WbemEvent_ = nil then + begin + nLastError_ := 2; + _Trace('WMISvc.ExecNotificationQuery() .. Fail, Error = %d', [GetLastError]); + exit; + end; + Result := true; + except + on e: Exception do + begin + nLastError_ := 3; + + exit; + end; + end; + end; + +begin + nReTryCnt := 0; + + CoInitialize(nil); + +// 운영체제가 잠금 상태일 경우 실패할 수 있다. 성공할때까지 시도.. +// 위 처럼 예외처리로 서비스 재실행을 이렇게 변경해봄 + while not Terminated and not bWorkStop_ and not InitWMI do + begin + Inc(nReTryCnt); + + if nRetryCnt > 30 then + begin + // 10분동안 시도해서 안되면 서비스 재시작 하도록 수정 + nReTryCnt := 0; + + _Trace('InitWMI() .. try 10 minute .. Class="%s"', [sWMIClass_]); + ServiceStop(WMI_SERVICE_NAME); + Sleep(30000); + ServiceStart(WMI_SERVICE_NAME); + Sleep(10000); + end; + + Sleep(10000); + end; + +// if InitWMI then + while not Terminated and not bWorkStop_ and Assigned(WbemEvent_) do + begin + try + ovEvent_ := WbemEvent_.NextEvent(5000{WBEM_INFINITE}); + + case ConvStrToHash(ovEvent_.Path_.class) of + WMI_EVENT_CREATE : WMIEventKind_ := wkCreate; // __InstanceCreationEvent + WMI_EVENT_MODIFY : WMIEventKind_ := wkModify; // __InstanceModificationEvent + WMI_EVENT_DELETE : WMIEventKind_ := wkDelete; // __InstanceDeletionEvent + else continue; + end; + if bSync_ then + Synchronize(DoWMIEvent) + else + DoWMIEvent; + except + // 이거 예외 찍게 하면 엄청 찍혀서.. 일단 막자 +// on e: Exception do +// ESunkException.TraceException(Self, e); + end; + end; + CoUninitialize; +end; + +{ Other } + +function WMI_GetPropertyString(WbemProperty: ISWbemProperty): String; +var + i: Integer; +begin + Result := ''; + + if VarIsNull(WbemProperty.Get_Value) then + Result := 'NULL' + else begin + case WbemProperty.CIMType of + wbemCimtypeSint8, + wbemCimtypeUint8, + wbemCimtypeSint16, + wbemCimtypeUint16, + wbemCimtypeSint32, + wbemCimtypeUint32, + wbemCimtypeSint64 : + begin + if VarIsArray(WbemProperty.Get_Value) then + begin + for i := 0 to VarArrayHighBound(WbemProperty.Get_Value, 1) do + begin + if i > 0 then + Result := Result + '|'; + Result := Result + IntToStr(WbemProperty.Get_Value[i]); + end; + end else + Result := IntToStr(WbemProperty.Get_Value); + end; + wbemCimtypeReal32, wbemCimtypeReal64 : result := FloatToStr (WbemProperty.Get_Value); + wbemCimtypeBoolean : if WbemProperty.Get_Value then result := 'True' else result := 'False'; + wbemCimtypeString, + wbemCimtypeUint64 : + begin + if VarIsArray(WbemProperty.Get_Value) then + begin + for i := 0 to VarArrayHighBound(WbemProperty.Get_Value, 1) do + begin + if i > 0 then + Result := Result + '|'; + Result := Result + WbemProperty.Get_Value [i]; + end; + end else + Result := WbemProperty.Get_Value; + end; + wbemCimtypeDatetime : Result := WbemProperty.Get_Value; + wbemCimtypeReference : Result := WbemProperty.Get_Value; + wbemCimtypeChar16 : Result := '<16-bit character>'; + wbemCimtypeObject : Result := '<CIM Object>'; + end ; + end; +end; + +function WMI_GetSingleInstance(const sArg, sProp: String; var sResult: String): Boolean; +var + WbemLocator: TSWbemLocator; + WbemServices: ISWbemServices; + WbemObject: ISWbemObject; + WbemProperty: ISWbemProperty; +begin + Result := false; + + sResult := ''; + Guard(WbemLocator, TSWbemLocator.Create(nil)); + try + WbemServices := WbemLocator.ConnectServer('', WMI_ROOT_OBJECT, '', '', + '', '', 0, nil); + WbemObject := WbemServices.Get(sArg, 0, nil); + WbemProperty := WbemObject.Properties_.Item(sProp, 0); + + if WbemProperty.Name <> sProp then + exit; + + sResult := WMI_GetPropertyString(WbemProperty); + + if sResult <> 'NULL' then + Result := true; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. WMI_GetSingleInstance()'); + end; +end; + +function WMI_GetSingleInstanceProperty(const sArg, sProp: String; var sResult: String): Boolean; +var + WbemLocator: TSWbemLocator; + WbemServices: ISWbemServices; + WbemObjectSet: ISWbemObjectSet; + WbemObject: ISWbemObject; + WbemProperty: ISWbemProperty; + ovVar: OleVariant; + dwValue: DWORD; + enum: IEnumVariant; + sInfo: String; +begin + Result := false; + + sResult := ''; + VarClear(ovVar); + Guard(WbemLocator, TSWbemLocator.Create(nil)); + try + WbemServices := WbemLocator.ConnectServer('', WMI_ROOT_OBJECT, '', '', + '', '', 0, nil); + WbemObjectSet := WbemServices.ExecQuery(sArg, 'WQL', + wbemFlagReturnImmediately, nil); + + enum := (WbemObjectSet._NewEnum) as IEnumVariant; + while (enum.Next(1, ovVar, dwValue) = S_OK) do + begin + WbemObject := IUnknown(ovVar) as SWBemObject; + WbemProperty := WbemObject.Properties_.Item(sProp, 0); + if WbemProperty.Name = sProp then + begin + sInfo := WMI_GetPropertyString(WbemProperty); + if sInfo <> 'NULL' then + Result := true; + + SumString(sResult, sInfo, ', '); + end; + VarClear(ovVar); + end; + except + on E: Exception do + begin + ETgException.TraceException(E, 'Fail .. WMI_GetSingleInstanceProperty()'); + VarClear(ovVar); + end; + end; +end; + +function WMI_GetInformationEx(const sCom, sNameSapce, sUser, sPass, sArg: String; + var wmiResults: T2DimStrArray; var nInstances: Integer): Boolean; +var + WbemLocator: TSWbemLocator; + WbemServices: ISWbemServices; + WbemObjectSet: ISWbemObjectSet; + WbemObject: ISWbemObject; + WbemPropertySet: ISWbemPropertySet; + WbemProperty: ISWbemProperty; + propEnum, Enum: IEnumVariant; + ovVar1, ovVar2: OleVariant; + lwValue: DWORD; + sValue: String; + nInst, nRow, nCnt: Integer; + bDimmed: Boolean; +begin + Result := true; + + nInstances := 0; + SetLength(wmiResults, 0, 0); + bDimmed := false; + VarClear(ovVar1); + VarClear(ovVar2); + Guard(WbemLocator, TSWbemLocator.Create(nil)); + try + WbemServices := WbemLocator.ConnectServer(sCom, + sNameSapce, + sUser, + sPass, + '', '', 0, nil); + + if Pos('SELECT', sArg) = 1 then + WbemObjectSet := WbemServices.ExecQuery(sArg, 'WQL', wbemFlagReturnImmediately, nil) + else + WbemObjectSet := WbemServices.InstancesOf(sArg, wbemFlagReturnImmediately or + wbemQueryFlagShallow, nil); + nInstances := WbemObjectSet.Count; + if nInstances = 0 then + exit; + + // Replicate VBScript's "for each" construct + Enum := (WbemObjectSet._NewEnum) as IEnumVariant; + nInst := 0; + while(Enum.Next (1, ovVar1, lwValue) = S_OK) do + begin + WbemObject := IUnknown(ovVar1) as SWBemObject; + WbemPropertySet := WbemObject.Properties_; + nCnt := WbemPropertySet.Count; + if not bDimmed then + begin + SetLength(wmiResults, nInstances + 1, nCnt + 1); + wmiResults[0, 0] := 'Instance'; + bDimmed := true; + end ; + propEnum := (WbemPropertySet._NewEnum) as IEnumVariant; + Inc(nInst); + nRow := 1; + wmiResults[nInst, 0] := IntToStr(nInst); + + // Replicate VBScript's "for each" construct + while (propEnum.Next(1, ovVar2, lwValue) = S_OK) do + begin + WbemProperty := IUnknown(ovVar2) as SWBemProperty; + sValue := WMI_GetPropertyString(WbemProperty); + if nInst = 1 then wmiResults[0, nRow] := WbemProperty.Name; + wmiResults[nInst, nRow] := sValue; + Inc(nRow); + VarClear(ovVar2); // whomp them mem leaks + end; + end; + VarClear (ovVar1); // whomp them mem leaks + except + on E: Exception do + begin + ETgException.TraceException(E, 'Fail .. WMI_GetInformationEx()'); + VarClear (ovVar1); + VarClear (ovVar2); + Result := false; + end; + end; +end; + +function WMI_GetPropertyIndex(wmiResults: T2DimStrArray; const sProp: String): Integer; +var + i: Integer; +begin + Result := 0; + for i := 1 to High(wmiResults[0]) do + begin + if wmiResults[0, i] = sProp then + begin + Result := i; + exit; + end; + end; +end; + +function WMI_GetPropertyData(wmiResults: T2DimStrArray; const sProp: String; nLine: Integer = 0): String; +var + i: Integer; +begin + Result := ''; + if (Length(wmiResults)-1) < (nLine+1) then + exit; + i := WMI_GetPropertyIndex(wmiResults, sProp); + if i > 0 then Result := wmiResults[nLine+1, i]; +end; + +function WMI_ConvWMIDateToDateTime(const sWmiDate: String; var nUTCOffset: Integer): TDateTime; +Const +// 지정된 고정길이 25 + LEN_WMI_DATETIME = 25; + +// yyyymmddhhnnss.zzzzzzsUUU +60 means 60 mins of UTC time +// 20030709091030.686000+060 +// 1234567890123456789012345 +var + yy, mm, dd, + hh, nn, ss, zz: Integer; + dt: TDateTime; + + function GetNum(nOffset, nLen: integer): Integer; + var + n: Integer; + begin + Val(Copy(sWmiDate, nOffset, nLen), Result, n); + end; + +begin + Result := ERROR_SUCCESS; + nUTCOffset := 0; + + if length(sWmiDate) <> LEN_WMI_DATETIME then + exit; + + yy := GetNum(1, 4); + mm := GetNum(5, 2); + if (mm = 0) or (mm > 12) then + exit; + + dd := GetNum(7, 2); + if (dd = 0) or (dd > 31) then + exit; + + if not TryEncodeDate(yy, mm, dd, result) then // D6 and later + begin + Result := -1; + exit; + end; + + hh := GetNum(9, 2); + nn := GetNum(11, 2); + ss := GetNum(13, 2); + zz := 0 ; + if Length(sWmiDate) >= 18 then + zz := GetNum(16, 3); + + if not TryEncodeTime(hh, nn, ss, zz, dt) then + exit; // D6 and later + + Result := Result + dt; + nUTCOffset := GetNum(22, 4); +end; + +function WMI_GetTableInfo(const sTable, sField: String): String; +begin + try + if not WMI_GetSingleInstanceProperty + ( + Format('SELECT %s FROM %s', [sField, sTable]), sField, Result + ) then TTgTrace.T('WMI_GetTableInfo .. Fail!!, Table = %s, Field = %s', [sTable, sField]); + except + on E: Exception do + ETgException.TraceException(E, Format('Fail .. WMI_GetTableInfo() .. Table=%s, Field=%s', [sTable, sField])); + end; +end; + +function WMI_GetOSInfo(const sField: String): String; +begin + Result := WMI_GetTableInfo('Win32_OperatingSystem', sField); +end; + +function WMI_GetOSInstallDateTime: TDateTime; +var + sWMIDate: String; + nUTCOffset: Integer; +begin + if WMI_GetSingleInstanceProperty('SELECT InstallDate FROM Win32_Registry', 'InstallDate', sWMIDate) then + Result := WMI_ConvWMIDateToDateTime(sWMIDate, nUTCOffset) + else + TTgTrace.T('WMI_GetOSInstallDateTime .. Fail!!'); +end; + +function WMI_GetCpuInfo: String; +begin + Result := WMI_GetTableInfo('Win32_Processor', 'Name'); +end; + +function WMI_GetBaseboardInfo: String; +begin + Result := WMI_GetTableInfo('Win32_BaseBoard', 'Product'); +end; + +function WMI_GetMotherboardInfo: String; +begin + Result := WMI_GetTableInfo('Win32_MotherboardDevice', 'Name'); +end; + +function WMI_GetBiosInfo(const sField: String): String; +begin + Result := WMI_GetTableInfo('Win32_BIOS', sField); +end; + +function WMI_GetBiosReleaseDateTime: TDateTime; +var + nUTCOffset: Integer; +begin + Result := WMI_ConvWMIDateToDateTime(WMI_GetBiosInfo('ReleaseDate'), nUTCOffset); +end; + +function WMI_GetBiosVersion: String; +var + nVerCnt: Integer; + wmiResults: T2DimStrArray; +begin + Result := ''; + if WMI_GetInformationEx('', WMI_ROOT_OBJECT, '', '', 'Win32_BIOS', wmiResults, nVerCnt) then + begin + if nVerCnt > 0 then + Result := Format('%s v%s.%s', [WMI_GetPropertyData(wmiResults, 'SMBIOSBIOSVersion'), + WMI_GetPropertyData(wmiResults, 'SMBIOSMajorVersion'), + WMI_GetPropertyData(wmiResults, 'SMBIOSMinorVersion')]); + end; +end; + +function WMI_GetVideoController: String; +begin + Result := WMI_GetTableInfo('Win32_VideoController', 'Name'); +end; + +function WMI_GetNetworkTotalTraffic: LONGLONG; +var + nVerCnt: Integer; + wmiResults: T2DimStrArray; + i: Integer; +begin + Result := -1; + if WMI_GetInformationEx('', WMI_ROOT_OBJECT, '', '', 'Win32_PerfFormattedData_Tcpip_NetworkInterface', wmiResults, nVerCnt) then + begin + Result := 0; + for i := 0 to nVerCnt - 1 do + Inc(Result, StrToInt64Def(WMI_GetPropertyData(wmiResults, 'BytesTotalPersec', i), 0)); + end; +end; + +function WMI_GetMemory: LONGLONG; +begin + Result := StrToInt64Def(WMI_GetTableInfo('Win32_ComputerSystem', 'TotalPhysicalMemory'), 0); +end; + +function VariantByteArrayToString(V: Variant): string; +var + i, LowIdx, HighIdx: Integer; + Ch: Integer; +begin + Result := ''; + if VarIsArray(V) then + begin + LowIdx := VarArrayLowBound(V, 1); + HighIdx := VarArrayHighBound(V, 1); + for i := LowIdx to HighIdx do + begin + try + // Null이나 비정상 값 방지 + Ch := VarAsType(VarArrayGet(V, [i]), varByte); + if Ch > 0 then + Result := Result + Chr(Ch); + except + // 오류 발생 시 무시 + end; + end; + end; +end; + +function WMI_GetMonitor: String; +var + SWbemLocator, SWbemServices, SWbemObjectSet, Item: OLEVariant; + Enum: IEnumVariant; + Value: Cardinal; + V: Variant; + Manufacturer, ProductCode: string; +begin + Result := ''; + try + SWbemLocator := CreateOleObject('WbemScripting.SWbemLocator'); + SWbemServices := SWbemLocator.ConnectServer('.', 'root\WMI'); + SWbemObjectSet := SWbemServices.ExecQuery('SELECT * FROM WmiMonitorID', 'WQL', 0); + Enum := IEnumVariant(IUnknown(SWbemObjectSet._NewEnum)); + while Enum.Next(1, Item, Value) = 0 do + begin + // 제조사와 제품 코드는 byte 배열로 리턴됨 + ProductCode := VariantByteArrayToString(Item.Properties_.Item('UserFriendlyName').Value); + if ProductCode <> '' then + begin + SumString(Result, ProductCode, ', '); + end else begin + Manufacturer := VariantByteArrayToString(Item.Properties_.Item('ManufacturerName').Value); + ProductCode := VariantByteArrayToString(Item.Properties_.Item('ProductCodeID').Value); + // SumString(Result, Format('Manufacturer: %s, Product Code: %s', [Manufacturer, ProductCode]), ', '); + SumString(Result, Manufacturer + ' ' + ProductCode, ', '); + end; + Item := Unassigned; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. WMI_GetMonitor()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.WTS.pas b/Tocsg.Lib/VCL/Tocsg.WTS.pas new file mode 100644 index 00000000..7974b137 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.WTS.pas @@ -0,0 +1,528 @@ +{*******************************************************} +{ } +{ Tocsg.WTS } +{ } +{ Copyright (C) 2022 sunk } +{ } +{*******************************************************} + +unit Tocsg.WTS; + +interface + +uses + WinApi.Windows, SysUtils, Generics.Collections, EM.WtsApi32; + +const + NEAR_SUCCESS = 0; + +type + PWTSSessionEntryInfo = ^TWTSSessionEntryInfo; + TWTSSessionEntryInfo = record + dwSessionId: DWORD; + sWinStationName: String; + end; + + TTgWTSSessionInfomation = class(TObject) + protected + lstSessionID_: TList<PWTSSessionEntryInfo>; + + procedure OnSessionInfo(Sender: TObject; const Item: PWTSSessionEntryInfo; + Action: TCollectionNotification); + function GetCount: Integer; + function GetUserNameByIndex(nIndex: Integer): String; + function GetSessionIdByIndex(nIndex: Integer): DWORD; + public + Constructor Create; + Destructor Destroy; override; + + procedure UpdateSessionInfo; + + function GetUserNameBySsid(const dwSsid: DWORD): String; + + property Count: Integer read GetCount; + property SessionIDs[nIndex: Integer]: DWORD read GetSessionIdByIndex; + property UserNames[nIndex: Integer]: String read GetUserNameByIndex; + end; + +const + UF_SCRIPT = $0001; + {$EXTERNALSYM UF_SCRIPT} + UF_ACCOUNTDISABLE = $0002; + {$EXTERNALSYM UF_ACCOUNTDISABLE} + UF_HOMEDIR_REQUIRED = $0008; + {$EXTERNALSYM UF_HOMEDIR_REQUIRED} + UF_LOCKOUT = $0010; + {$EXTERNALSYM UF_LOCKOUT} + UF_PASSWD_NOTREQD = $0020; + {$EXTERNALSYM UF_PASSWD_NOTREQD} + UF_PASSWD_CANT_CHANGE = $0040; + {$EXTERNALSYM UF_PASSWD_CANT_CHANGE} + UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED = $0080; + {$EXTERNALSYM UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED} + +// +// Account type bits as part of usri_flags. +// + + UF_TEMP_DUPLICATE_ACCOUNT = $0100; + {$EXTERNALSYM UF_TEMP_DUPLICATE_ACCOUNT} + UF_NORMAL_ACCOUNT = $0200; + {$EXTERNALSYM UF_NORMAL_ACCOUNT} + UF_INTERDOMAIN_TRUST_ACCOUNT = $0800; + {$EXTERNALSYM UF_INTERDOMAIN_TRUST_ACCOUNT} + UF_WORKSTATION_TRUST_ACCOUNT = $1000; + {$EXTERNALSYM UF_WORKSTATION_TRUST_ACCOUNT} + UF_SERVER_TRUST_ACCOUNT = $2000; + {$EXTERNALSYM UF_SERVER_TRUST_ACCOUNT} + + UF_MACHINE_ACCOUNT_MASK = UF_INTERDOMAIN_TRUST_ACCOUNT or UF_WORKSTATION_TRUST_ACCOUNT or UF_SERVER_TRUST_ACCOUNT; + {$EXTERNALSYM UF_MACHINE_ACCOUNT_MASK} + + UF_ACCOUNT_TYPE_MASK = UF_TEMP_DUPLICATE_ACCOUNT or UF_NORMAL_ACCOUNT or UF_INTERDOMAIN_TRUST_ACCOUNT or UF_WORKSTATION_TRUST_ACCOUNT or UF_SERVER_TRUST_ACCOUNT; + {$EXTERNALSYM UF_ACCOUNT_TYPE_MASK} + + UF_DONT_EXPIRE_PASSWD = $10000; + {$EXTERNALSYM UF_DONT_EXPIRE_PASSWD} + UF_MNS_LOGON_ACCOUNT = $20000; + {$EXTERNALSYM UF_MNS_LOGON_ACCOUNT} + UF_SMARTCARD_REQUIRED = $40000; + {$EXTERNALSYM UF_SMARTCARD_REQUIRED} + UF_TRUSTED_FOR_DELEGATION = $80000; + {$EXTERNALSYM UF_TRUSTED_FOR_DELEGATION} + UF_NOT_DELEGATED = $100000; + {$EXTERNALSYM UF_NOT_DELEGATED} + UF_USE_DES_KEY_ONLY = $200000; + {$EXTERNALSYM UF_USE_DES_KEY_ONLY} + UF_DONT_REQUIRE_PREAUTH = $400000; + {$EXTERNALSYM UF_DONT_REQUIRE_PREAUTH} + UF_PASSWORD_EXPIRED = DWORD($800000); + {$EXTERNALSYM UF_PASSWORD_EXPIRED} + UF_TRUSTED_TO_AUTHENTICATE_FOR_DELEGATION = $1000000; + {$EXTERNALSYM UF_TRUSTED_TO_AUTHENTICATE_FOR_DELEGATION} + + UF_SETTABLE_BITS = + UF_SCRIPT or + UF_ACCOUNTDISABLE or + UF_LOCKOUT or + UF_HOMEDIR_REQUIRED or + UF_PASSWD_NOTREQD or + UF_PASSWD_CANT_CHANGE or + UF_ACCOUNT_TYPE_MASK or + UF_DONT_EXPIRE_PASSWD or + UF_MNS_LOGON_ACCOUNT or + UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED or + UF_SMARTCARD_REQUIRED or + UF_TRUSTED_FOR_DELEGATION or + UF_NOT_DELEGATED or + UF_USE_DES_KEY_ONLY or + UF_DONT_REQUIRE_PREAUTH or + UF_PASSWORD_EXPIRED or + UF_TRUSTED_TO_AUTHENTICATE_FOR_DELEGATION; + {$EXTERNALSYM UF_SETTABLE_BITS} + + ENCRYPTED_PWLEN = 16; + +type + _USER_INFO_1 = record + usri1_name: LPWSTR; + usri1_password: LPWSTR; + usri1_password_age: DWORD; + usri1_priv: DWORD; + usri1_home_dir: LPWSTR; + usri1_comment: LPWSTR; + usri1_flags: DWORD; + usri1_script_path: LPWSTR; + end; + {$EXTERNALSYM _USER_INFO_1} + USER_INFO_1 = _USER_INFO_1; + {$EXTERNALSYM USER_INFO_1} + TUserInfo1 = USER_INFO_1; + PUserInfo1 = ^TUserInfo1; + + _USER_INFO_2 = record + usri2_name: LPWSTR; + usri2_password: LPWSTR; + usri2_password_age: DWORD; + usri2_priv: DWORD; + usri2_home_dir: LPWSTR; + usri2_comment: LPWSTR; + usri2_flags: DWORD; + usri2_script_path: LPWSTR; + usri2_auth_flags: DWORD; + usri2_full_name: LPWSTR; + usri2_usr_comment: LPWSTR; + usri2_parms: LPWSTR; + usri2_workstations: LPWSTR; + usri2_last_logon: DWORD; + usri2_last_logoff: DWORD; + usri2_acct_expires: DWORD; + usri2_max_storage: DWORD; + usri2_units_per_week: DWORD; + usri2_logon_hours: PBYTE; + usri2_bad_pw_count: DWORD; + usri2_num_logons: DWORD; + usri2_logon_server: LPWSTR; + usri2_country_code: DWORD; + usri2_code_page: DWORD; + end; + {$EXTERNALSYM _USER_INFO_2} + USER_INFO_2 = _USER_INFO_2; + {$EXTERNALSYM USER_INFO_2} + TUserInfo2 = USER_INFO_2; + PUserInfo2 = ^TUserInfo2; + + _USER_INFO_22 = record + usri22_name: LPWSTR; + usri22_password: array [0..ENCRYPTED_PWLEN - 1] of BYTE; + usri22_password_age: DWORD; + usri22_priv: DWORD; + usri22_home_dir: LPWSTR; + usri22_comment: LPWSTR; + usri22_flags: DWORD; + usri22_script_path: LPWSTR; + usri22_auth_flags: DWORD; + usri22_full_name: LPWSTR; + usri22_usr_comment: LPWSTR; + usri22_parms: LPWSTR; + usri22_workstations: LPWSTR; + usri22_last_logon: DWORD; + usri22_last_logoff: DWORD; + usri22_acct_expires: DWORD; + usri22_max_storage: DWORD; + usri22_units_per_week: DWORD; + usri22_logon_hours: PBYTE; + usri22_bad_pw_count: DWORD; + usri22_num_logons: DWORD; + usri22_logon_server: LPWSTR; + usri22_country_code: DWORD; + usri22_code_page: DWORD; + end; + {$EXTERNALSYM _USER_INFO_22} + USER_INFO_22 = _USER_INFO_22; + {$EXTERNALSYM USER_INFO_22} + TUserInfo22 = USER_INFO_22; + PUserInfo22 = ^TUserInfo22; + +// 사용자 계정에 띄어쓰기가 있는경우... +// WTSQuerySessionInformation()만으로는 풀네임을 구해올수 없다. 그래서 추가 + PUserInfo23 = ^TUserInfo23; + _USER_INFO_23 = record + usri23_name: LPWSTR; + usri23_full_name: LPWSTR; + usri23_comment: LPWSTR; + usri23_flags: DWORD; + usri23_user_sid: PSID; + end; + {$EXTERNALSYM _USER_INFO_23} + TUserInfo23 = _USER_INFO_23; + USER_INFO_23 = _USER_INFO_23; + {$EXTERNALSYM USER_INFO_23} + + TNetUserGetInfo = function(sServerName: PChar; sUserName: PChar; dwLevel: DWORD; var pBuf: Pointer): DWORD; stdcall; + TNetApiBufferFree = function(pBuf: Pointer): Integer; stdcall; + TNetUserChangePassword = function(sServerName, sUserName, sOldPass, sNewPass: PChar): DWORD; stdcall; + +function NetUserGetInfo(sServerName: PChar; sUserName: PChar; dwLevel: DWORD; var pBuf: Pointer): DWORD; +function NetApiBufferFree(pBuf : Pointer) :Integer; + +function NetUserChangePassword(sServerName, sUserName, sOldPass, sNewPass: String): DWORD; + +function GetLastChangePasswordDT(sServerName, sUserName: String): TDateTime; +function GetLastLogOnDT(sServerName, sUserName: String): TDateTime; +function GetLastLogOnDTandBadCnt(sServerName, sUserName: String; var dtLastLogOn: TDateTime; var nBadCnt: Integer): Boolean; +function HasAccountPassword(sServerName, sUserName: String): Boolean; + +function WTSGetActiveConsoleSessionId: DWORD; stdcall external 'Kernel32.dll'; +function WTS_GetString(dwSessionID: DWORD; const aWTSInfoClass: TWtsInfoClass): String; +function WTS_GetDWORD(dwSessionID: DWORD; const aWTSInfoClass: TWtsInfoClass): DWORD; +function WTS_GetUserNameFromSessionID(dwSessionID: DWORD): String; +function WTS_GetCurrentUserName: String; +function WTS_GetActiveSessionUserName: String; + +implementation + +uses + Tocsg.Exception, System.DateUtils, Tocsg.DateTime; + +var + _hNetApi32: THandle = 0; + _fnNetUserGetInfo: TNetUserGetInfo = nil; + _fnNetApiBufferFree: TNetApiBufferFree = nil; + _fnNetUserChangePassword: TNetUserChangePassword = nil; + +function InitNetApi32Procedure: Boolean; +begin + if _hNetApi32 = 0 then + begin +// _hNetApi32 := GetModuleHandle('netapi32.dll'); + _hNetApi32 := LoadLibrary('netapi32.dll'); + if _hNetApi32 <> 0 then + begin + @_fnNetUserGetInfo := GetProcAddress(_hNetApi32, 'NetUserGetInfo'); + @_fnNetApiBufferFree := GetProcAddress(_hNetApi32, 'NetApiBufferFree'); + @_fnNetUserChangePassword := GetProcAddress(_hNetApi32, 'NetUserChangePassword'); + end; + end; + Result := _hNetApi32 <> 0; +end; + +function NetUserGetInfo(sServerName, sUserName: PChar; dwLevel: DWORD; var pBuf: Pointer): DWORD; +begin + Result := DWORD(-1); + if InitNetApi32Procedure and Assigned(_fnNetUserGetInfo) then + Result := _fnNetUserGetInfo(sServerName, sUserName, dwLevel, pBuf); +end; + +function NetApiBufferFree(pBuf: Pointer) :Integer; +begin + Result := -1; + if InitNetApi32Procedure and Assigned(_fnNetUserGetInfo) then + Result := _fnNetApiBufferFree(pBuf); +end; + +function NetUserChangePassword(sServerName, sUserName, sOldPass, sNewPass: String): DWORD; +begin + Result := DWORD(-1); + if InitNetApi32Procedure and Assigned(_fnNetUserChangePassword) then + Result := _fnNetUserChangePassword(PChar(sServerName), PChar(sUserName), PChar(sOldPass), PChar(sNewPass)); +end; + +function GetLastChangePasswordDT(sServerName, sUserName: String): TDateTime; +var + pInfo: PUserInfo1; +begin + Result := 0; + try + pInfo := nil; + if NetUserGetInfo(PChar(sServerName), PChar(sUserName), 1, Pointer(pInfo)) = 0 then + begin + Result := IncSecond(Now, pInfo.usri1_password_age * -1); + NetApiBufferFree(pInfo); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetLastChangePasswordDT()'); + end; +end; + +function GetLastLogOnDT(sServerName, sUserName: String): TDateTime; +var + pInfo: PUserInfo2; +begin + Result := 0; + try + pInfo := nil; + if NetUserGetInfo(PChar(sServerName), PChar(sUserName), 2, Pointer(pInfo)) = 0 then + begin + Result := ConvTimeToDateTime(pInfo.usri2_last_logon); + NetApiBufferFree(pInfo); + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetLastLogOnDT()'); + end; +end; + +function GetLastLogOnDTandBadCnt(sServerName, sUserName: String; var dtLastLogOn: TDateTime; var nBadCnt: Integer): Boolean; +var + pInfo: PUserInfo2; +begin + Result := false; + dtLastLogOn := 0; + nBadCnt := 0; + try + pInfo := nil; + if NetUserGetInfo(PChar(sServerName), PChar(sUserName), 2, Pointer(pInfo)) = 0 then + begin + dtLastLogOn := ConvTimeToDateTime(pInfo.usri2_last_logon); + nBadCnt := pInfo.usri2_bad_pw_count; + NetApiBufferFree(pInfo); + Result := true; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetLastLogOnDTandBadCnt()'); + end; +end; + +// 임계치 초과 시 계정이 잠긴다 24_0109 13:00:48 kku +function HasAccountPassword(sServerName, sUserName: String): Boolean; +var + bRet: Boolean; + hToken: THandle; +begin + try + bRet := LogonUser(PChar(sUserName), PChar(sServerName), '', + LOGON32_LOGON_INTERACTIVE, LOGON32_PROVIDER_DEFAULT, hToken); + Result := not bRet and (GetLastError <> 1327); + + // 음 이걸로 체크하면 false 시 최근 비번 설정일이 변경된다... +// Result := NetUserChangePassword(sServerName, sUserName, '', '') = 86; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. HasAccountPassword()'); + end; +end; + +{ TTgWTSSessionInfomation } + +Constructor TTgWTSSessionInfomation.Create; +begin + Inherited Create; + lstSessionID_ := TList<PWTSSessionEntryInfo>.Create; + lstSessionID_.OnNotify := OnSessionInfo; + UpdateSessionInfo; +end; + +Destructor TTgWTSSessionInfomation.Destroy; +begin + FreeAndNil(lstSessionID_); + Inherited; +end; + +procedure TTgWTSSessionInfomation.OnSessionInfo(Sender: TObject; const Item: PWTSSessionEntryInfo; + Action: TCollectionNotification); +begin + case Action of + cnAdded: ; + cnRemoved: Dispose(Item); + cnExtracted: ; + end; +end; + +function TTgWTSSessionInfomation.GetUserNameByIndex(nIndex: Integer): String; +begin + Result := ''; + if (nIndex >= 0) and (nIndex < lstSessionID_.Count) then + Result := WTS_GetUserNameFromSessionID(lstSessionID_[nIndex].dwSessionId); +end; + +function TTgWTSSessionInfomation.GetSessionIdByIndex(nIndex: Integer): DWORD; +begin + Result := 0; + if (nIndex >= 0) and (nIndex < lstSessionID_.Count) then + Result := lstSessionID_[nIndex].dwSessionId; +end; + +function TTgWTSSessionInfomation.GetCount: Integer; +begin + Result := lstSessionID_.Count; +end; + +procedure TTgWTSSessionInfomation.UpdateSessionInfo; +var + pwsi, iter: PWtsSessionInfo; + i, dwCount: DWORD; + pInfo: PWTSSessionEntryInfo; +begin + lstSessionID_.Clear; + if WTSEnumerateSessions(WTS_CURRENT_SERVER_HANDLE, 0, 1, pwsi, dwCount) then + begin + iter := pwsi; + for i := 0 to dwCount - 1 do + begin + New(pInfo); + pInfo.dwSessionId := iter.SessionId; + pInfo.sWinStationName := iter.pWinStationName; + lstSessionID_.Add(pInfo); + Inc(iter); + end; + WTSFreeMemory(pwsi); + end; +end; + +function TTgWTSSessionInfomation.GetUserNameBySsid(const dwSsid: DWORD): String; +var + i: Integer; +begin + Result := ''; + for i := 0 to lstSessionID_.Count - 1 do + if lstSessionID_[i].dwSessionId = dwSsid then + begin + Result := lstSessionID_[i].sWinStationName; + exit; + end; +end; + +{ other } + +function WTS_GetString(dwSessionID: DWORD; const aWTSInfoClass: TWtsInfoClass): String; +var + pBuf : Pointer; + dwReturn : DWORD; +begin + Result := ''; + pBuf := nil; + dwReturn := 0; +// WTS_INFO_CLASS이 형식이 꼬였는지.. 그대로 넘겨주면 안된다.. 그래서 이렇게 두번 캐스팅 2012-01-09 sunk + if WTSQuerySessionInformation(WTS_CURRENT_SERVER_HANDLE, dwSessionID, + aWTSInfoClass, pBuf, dwReturn) then + begin + if pBuf <> nil then + begin + Result := PChar(pBuf); + WTSFreeMemory(pBuf); + end; + end; +end; + +function WTS_GetDWORD(dwSessionID: DWORD; const aWTSInfoClass: TWtsInfoClass): DWORD; +var + pBuf : Pointer; + dwReturn : DWORD; +begin + Result := 0; + pBuf := nil; + dwReturn := 0; +// WTS_INFO_CLASS이 형식이 꼬였는지.. 그대로 넘겨주면 안된다.. 그래서 이렇게 두번 캐스팅 2012-01-09 sunk + if WTSQuerySessionInformation(WTS_CURRENT_SERVER_HANDLE, dwSessionID, + aWTSInfoClass, pBuf, dwReturn) then + begin + if pBuf <> nil then + begin + Result := DWORD(pBuf); + WTSFreeMemory(pBuf); + end; + end; +end; + +function WTS_GetUserNameFromSessionID(dwSessionID: DWORD): String; +begin + Result := WTS_GetString(dwSessionID, WTSUserName); +end; + +function WTS_GetCurrentUserName: String; +var + pBuf: Pointer; + sResult: String; +begin + Result := Trim(WTS_GetUserNameFromSessionID(WTS_CURRENT_SESSION)); + if NetUserGetInfo(nil, PChar(Result), 23, pBuf) = NEAR_SUCCESS then + begin + try + if PUserInfo23(pBuf).usri23_full_name <> '' then + begin + SetLength(sResult, Length(PUserInfo23(pBuf).usri23_full_name)); + StrCopy(PChar(sResult), PUserInfo23(pBuf).usri23_full_name); + Result := Trim(sResult); + end; + NetApiBufferFree(pBuf); + except + // + exit; + end; + end; +end; + +function WTS_GetActiveSessionUserName: String; +begin + Result := WTS_GetUserNameFromSessionID(WTSGetActiveConsoleSessionId); +end; + +//finalization +// if _hNetApi32 <> 0 then +// FreeLibrary(_hNetApi32); + +end. + diff --git a/Tocsg.Lib/VCL/Tocsg.WebBrowser.pas b/Tocsg.Lib/VCL/Tocsg.WebBrowser.pas new file mode 100644 index 00000000..dd48381a --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.WebBrowser.pas @@ -0,0 +1,182 @@ +{*******************************************************} +{ } +{ Tocsg.WebBrowser } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.WebBrowser; + +interface + +uses + Windows, ComObj, ActiveX, SHDocVw; + +procedure ClearInternetExplorerHistory; + +const + CLSID_CUrlHistory: TGUID = '{3C374A40-BAE4-11CF-BF7D-00AA006946EE}'; + +type +// 자바 스크립트 오류 뜨는 문제 해결 19_0918 23:06:50 kku + TWebBrowser = class(SHDocVw.TWebBrowser, IOleCommandTarget) + private + 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; + end; + + TSTATURL = record + cbSize: DWORD; + pwcsUrl: DWORD; + pwcsTitle: DWORD; + ftLastVisited: FILETIME; + ftLastUpdated: FILETIME; + ftExpires: FILETIME; + dwFlags: DWORD; + end; + + IEnumSTATURL = interface(IUnknown) + ['{3C374A42-BAE4-11CF-BF7D-00AA006946EE}'] + function Next(celt: Integer; out elt; pceltFetched: PLongint): HRESULT; stdcall; + function Skip(celt: Longint): HRESULT; stdcall; + function Reset: HResult; stdcall; + function Clone(out ppenum: IEnumSTATURL): HResult; stdcall; + function SetFilter(poszFilter: PWideChar; dwFlags: DWORD): HResult; stdcall; + end; + + IUrlHistoryStg = interface(IUnknown) + ['{3C374A41-BAE4-11CF-BF7D-00AA006946EE}'] + function AddUrl(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer): HResult; stdcall; + function DeleteUrl(pocsUrl: PWideChar; dwFlags: Integer): HResult; stdcall; + function QueryUrl(pocsUrl: PWideChar; dwFlags: Integer; var lpSTATURL: TSTATURL): HResult; stdcall; + function BindToObject(pocsUrl: PWideChar; var riid: TIID; out ppvOut: Pointer): HResult; stdcall; + function EnumUrls(out ppenum: IEnumSTATURL): HResult; stdcall; + end; + + IUrlHistoryStg2 = interface(IUrlHistoryStg) + ['{AFA0DC11-C313-11D0-831A-00C04FD5AE38}'] + function AddUrlAndNotify(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer; +fWriteHistory: Integer; var poctNotify: Pointer; + const punkISFolder: IUnknown): HResult; stdcall; + function ClearHistory: HResult; stdcall; + end; + +function GetHtmlFromWebBrowser(webBrowser: SHDocVw.TWebBrowser): String; +function GetEntraIdFromBrowserHis(sHisPath, sUrlHead, sChDomain, sDomain: String): String; + +implementation + +uses + MSHTML, EM.SQLiteTable3, Tocsg.Safe, System.SysUtils, Tocsg.Exception; + +function GetHtmlFromWebBrowser(webBrowser: SHDocVw.TWebBrowser): String; +var + doc2: IHTMLDocument2; +begin + doc2 := webBrowser.Document as IHTMLDocument2; + result := doc2.body.innerHTML; +end; + +procedure ClearInternetExplorerHistory; +var + stg: IUrlHistoryStg2; +begin + stg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2; + stg.ClearHistory; +end; + +{ TWebBrowser } + +function TWebBrowser.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; + prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; stdcall; +begin + Result := S_OK; +end; + +function TWebBrowser.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; + const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; stdcall; +begin + // presume that all commands can be executed; for list of available commands + // see SHDocVw.pas unit, using this event you can suppress or create custom + // events for more than just script error dialogs, there are commands like + // undo, redo, refresh, open, save, print etc. etc. + // be careful, because not all command results are meaningful, like the one + // with script error message boxes, I would expect that if you return S_OK, + // the error dialog will be displayed, but it's vice-versa + Result := S_OK; + + // there's a script error in the currently executed script, so + if nCmdID = OLECMDID_SHOWSCRIPTERROR then + begin + // if you return S_FALSE, the script error dialog is shown + Result := S_FALSE; + // if you return S_OK, the script error dialog is suppressed + Result := S_OK; + end; +end; + +// 브라우저에서 MS Entra에 로그인 사용 시 히스토리에서 계정 정보를 가져온다 25_0902 09:49:58 kku +// 크롬, 엣지 지원 +// sUrlHead = enpulse365-my.sharepoint.com +// sChDomain = _partner_enpulse_co_kr +// sDomain = @partner.enpulse.co.kr +function GetEntraIdFromBrowserHis(sHisPath, sUrlHead, sChDomain, sDomain: String): String; +var + db: TSQLiteDatabase; + tbl: TSQLiteTable; + i, n: Integer; + sTable, SQL, sUrl: String; +begin + Result := ''; + + try + Guard(db, TSQLiteDatabase.Create(sHisPath)); + + sTable := 'urls'; // Opera, Chrome, Edge +// sTable := 'moz_places'; // Firefox + SQL := 'select url from urls'; +// SQL := 'select url, title, VISIT_COUNT, LAST_VISIT_time from urls'; +// SQL := 'select url, title, VISIT_COUNT, LAST_VISIT_DATE from moz_places'; // Firefox + + if db.TableExists(sTable) then + begin + Guard(tbl, db.GetTable(SQL)); + + if tbl.MoveLast then + begin + for i := tbl.Count - 1 downto 0 do + begin + sUrl := tbl.Fields[0]; +// sUrl := 'https://enpulse365-my.sharepoint.com/:p:/r/personal/shlee_partner_enpulse_co_kr/_layouts/15/doc2.aspx'; + if Pos('enpulse365-my.sharepoint.com', sUrl) > 0 then + begin + n := Pos('personal/', sUrl); + if n > 0 then + begin + Delete(sUrl, 1, n + 8); + n := Pos('/', sUrl); + if n > 0 then + begin + Delete(sUrl, n, Length(sUrl) - n + 1); + // ID에 _ 가 있을 수 있어서 아래처럼 치환 + Result := StringReplace(sUrl, '_partner_enpulse_co_kr', '@partner.enpulse.co.kr', [rfReplaceAll]); + break; + end; + end; + end; + + if not tbl.Previous then + break; + end; + end; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetEntraIdFromBrowserHis()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.Win32.pas b/Tocsg.Lib/VCL/Tocsg.Win32.pas new file mode 100644 index 00000000..02dc7cef --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.Win32.pas @@ -0,0 +1,99 @@ +{*******************************************************} +{ } +{ Tocsg.Win32 } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.Win32; + +interface + +uses + Tocsg.Obj, System.Classes, Winapi.Windows; + +type + TMutexState = (msUnknown, msCreateOk, msAlreadyExist, msFail); + TTgMutex = class(TTgObject) + private + sName_: String; + hMutex_: THandle; + MutexState_: TMutexState; + public + Constructor Create(const sName: String); + Destructor Destroy; override; + + property MutexName: String read sName_; + property MutexState: TMutexState read MutexState_; + + property LastError; + end; + +function MutexExists(const sMutex: String): Boolean; + +implementation + +function MutexExists(const sMutex: String): Boolean; +var + h: THandle; +begin + Result := false; +// h := OpenMutex(MUTEX_ALL_ACCESS, true, PChar(sMutex)); + h := OpenMutex(SYNCHRONIZE, false, PChar(sMutex)); + if h <> 0 then + begin + CloseHandle(h); + Result := true; + end; +end; + +{ TTgMutex } + +Constructor TTgMutex.Create(const sName: String); + + procedure InitCreateMutex; + var + sd: SECURITY_DESCRIPTOR; + sa: SECURITY_ATTRIBUTES; + begin + InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION); + SetSecurityDescriptorDacl(@sd, true, nil, false); + + ZeroMemory(@sa, sizeof(SECURITY_ATTRIBUTES)); + sa.nLength := sizeof(SECURITY_ATTRIBUTES); + sa.lpSecurityDescriptor := @sd; + sa.bInheritHandle := false; + + hMutex_ := CreateMutex(@sa, false, PChar(sName_)); + nLastError_ := GetLastError; + if hMutex_ > 0 then + begin + if nLastError_ = ERROR_ALREADY_EXISTS then + MutexState_ := msAlreadyExist + else + MutexState_ := msCreateOk; + end else + MutexState_ := msFail; + end; + +begin + Inherited Create; + ASSERT(sName <> '', 'no mutex name..'); + + hMutex_ := 0; + sName_ := sName; + MutexState_ := msUnknown; + + InitCreateMutex; +end; + +Destructor TTgMutex.Destroy; +begin + if hMutex_ > 0 then + CloseHandle(hMutex_); + + Inherited; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.WinInfo.pas b/Tocsg.Lib/VCL/Tocsg.WinInfo.pas new file mode 100644 index 00000000..7f9f2ef2 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.WinInfo.pas @@ -0,0 +1,259 @@ +{*******************************************************} +{ } +{ Tocsg.WinInfo } +{ } +{ Copyright (C) 2022 kkuzil } +{ } +{*******************************************************} + +unit Tocsg.WinInfo; + +interface + +uses + SysUtils, WinApi.Windows, System.Classes; + +type + TIsWow64Process = function(hProcess: THandle;var bWow64Proc: Boolean): Boolean; stdcall; + +function IsWow64: Boolean; +function IsAdminAccount: Boolean; + +function GetCPUInfo: String; +function GetComName: String; +function GetAccount: String; +function GetGUID: String; +function GetTotalPhysMem: ULONGLONG; +function GetAvailPhysMem: ULONGLONG; + +function GetWinVer: String; + +function GetWinUpdateAbleList(aList: TStringList = nil): Integer; +function GetWinUpdateInstList(aList: TStringList = nil): Integer; + +implementation + +uses + Winapi.WinSvc, Tocsg.Registry, EM.WinOSVersion, Winapi.ActiveX, System.Win.ComObj, + Tocsg.Exception, System.Variants, Tocsg.Trace; + +function IsWow64: Boolean; +var + h: THandle; + b: Boolean; + fnIsWow64Process: TIsWow64Process; +begin + Result := false; + + h := GetModuleHandle('kernel32'); + if h = 0 then + exit; + + try + fnIsWow64Process := GetProcAddress(h, 'IsWow64Process'); + if @fnIsWow64Process = nil then + exit; + + if fnIsWow64Process(GetCurrentProcess, b) = true then + Result := b; + finally + FreeLibrary(h); + end; +end; + +function IsAdminAccount: Boolean; +var + h: THandle; +begin + Result := false; + try + h := OpenSCManager(nil, nil, GENERIC_READ or GENERIC_WRITE or GENERIC_EXECUTE); + if h = 0 then + exit; + CloseServiceHandle(h); + Result := true; + except + + end; +end; + +function GetCPUInfo: String; +begin + Result := GetRegValueAsString(HKEY_LOCAL_MACHINE, + 'HARDWARE\DESCRIPTION\System\CentralProcessor\0', 'ProcessorNameString'); + if Result = '' then + Result := GetRegValueAsString(HKEY_LOCAL_MACHINE, + 'HARDWARE\DESCRIPTION\System\CentralProcessor\0', 'Identifier'); + Result := Trim(Result); +end; + +function GetComName: String; +var + sName: array[0..127] of Char; + dwLen: DWORD; +begin + try + Result := GetEnvironmentVariable('COMPUTERNAME'); + if Result = '' then + begin + dwLen := 128; + GetComputerName(@sName[0], dwLen); + Result := sName; + end; + except + Result := ''; + end; +end; + +function GetAccount: String; +var + sName: array[0..127] of Char; + dwLen: DWORD; +begin + try + Result := GetEnvironmentVariable('USERNAME'); + if Result = '' then + begin + dwLen := 128; + GetUserName(@sName[0], dwLen); + Result := sName; + end; + except + Result := ''; + end; +end; + +function GetGUID: String; +var + guid: TGuid; +begin + if CreateGUID(guid) = S_OK then + Result := GUIDToString(guid) + else + Result := ''; +end; + +function GetTotalPhysMem: ULONGLONG; +VAR + mse : MemoryStatusEx; +begin + ZeroMemory(@mse, SizeOf(MemoryStatusEx)); + mse.dwLength := SizeOf(mse); + GlobalMemoryStatusEx(mse); + Result:= mse.ullTotalPhys; +end; + +function GetAvailPhysMem: ULONGLONG; +VAR + mse : MemoryStatusEx; +begin + ZeroMemory(@mse, SizeOf(MemoryStatusEx)); + mse.dwLength := SizeOf(mse); + GlobalMemoryStatusEx(mse); + Result:= mse.ullAvailPhys; +end; + +function GetWinVer: String; +begin + Result := GetWinVersion.WinID; +end; + +function GetWinUpdateAbleList(aList: TStringList = nil): Integer; +var + oUpdateSession, + oUpdateSearcher, + oUpdateEntry, + oUpdateSearchResult, + oUpdateCollection: OleVariant; + oEnum: IEnumvariant; + iValue: LongWord; +// n: Integer; +begin + Result := 0; + try + try + oUpdateSession := CreateOleObject('Microsoft.Update.Session'); + oUpdateSearcher := oUpdateSession.CreateUpdateSearcher; + oUpdateSearchResult := oUpdateSearcher.Search('IsInstalled = 0 and Type != ''Driver'' and IsHidden = 0 and BrowseOnly = 0'); + // n := oUpdateSearchResult.ResultCode; + // TTgTrace.T('GetWinUpdateAbleList() .. ResultCode=%d', [n]); + oUpdateCollection := oUpdateSearchResult.Updates; +// if aList = nil then +// begin +// Result := oUpdateCollection.Count; +// exit; +// end; + + oEnum := IUnknown(oUpdateCollection._NewEnum) as IEnumVariant; + oEnum.Reset; + while oEnum.Next(1, oUpdateEntry, iValue) = 0 do + begin + Inc(Result); + if aList <> nil then + aList.Add(oUpdateEntry.Title); + VarClear(oUpdateEntry); + end; + finally +// oEnum._Release; + oUpdateCollection := Unassigned; + oUpdateSearchResult := Unassigned; + oUpdateSearcher := Unassigned; + oUpdateSession := Unassigned; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetWinUpdateAbleList()'); + end; +end; + +function GetWinUpdateInstList(aList: TStringList = nil): Integer; +var + oUpdateSession, + oUpdateSearcher, + oUpdateEntry, + oUpdateSearchResult, + oUpdateCollection: OleVariant; + oEnum: IEnumvariant; + iValue: LongWord; +// n: Integer; +begin + Result := 0; + try + try + oUpdateSession := CreateOleObject('Microsoft.Update.Session'); + oUpdateSearcher := oUpdateSession.CreateUpdateSearcher; + // 온라인 속성은 업데이트를 검색하기 위해 온라인 상태가 되었는지 확인한다. + // 이미 설치된 업데이트를 찾는 방법은 이 값은 false로 하면 됨 22_1124 08:51:02 kku + oUpdateSearcher.online := false; + oUpdateSearchResult := oUpdateSearcher.Search('IsInstalled = 1'); + oUpdateCollection := oUpdateSearchResult.Updates; + // n := oUpdateSearchResult.ResultCode; +// if aList = nil then +// begin +// Result := oUpdateCollection.Count; +// exit; +// end; + + oEnum := IUnknown(oUpdateCollection._NewEnum) as IEnumVariant; + oEnum.Reset; + while oEnum.Next(1, oUpdateEntry, iValue) = 0 do + begin + Inc(Result); + if aList <> nil then + aList.Add(oUpdateEntry.Title); + VarClear(oUpdateEntry); + end; + finally +// oEnum._Release; + oUpdateCollection := Unassigned; + oUpdateSearchResult := Unassigned; + oUpdateSearcher := Unassigned; + oUpdateSession := Unassigned; + end; + except + on E: Exception do + ETgException.TraceException(E, 'Fail .. GetWinUpdateInstList()'); + end; +end; + +end. diff --git a/Tocsg.Lib/VCL/Tocsg.WndUtil.pas b/Tocsg.Lib/VCL/Tocsg.WndUtil.pas new file mode 100644 index 00000000..cb16a1b3 --- /dev/null +++ b/Tocsg.Lib/VCL/Tocsg.WndUtil.pas @@ -0,0 +1,440 @@ +{*******************************************************} +{ } +{ Tocsg.WndUtil } +{ } +{ Copyright (C) 2022 kku } +{ } +{*******************************************************} + +unit Tocsg.WndUtil; + +interface + +uses + System.SysUtils, Winapi.Windows, Winapi.Messages, Vcl.Forms, Tocsg.Thread, + System.Generics.Collections; + + + +type + TEvActiveWndNotify = procedure(aSender: TObject; hActiveWnd: HWND) of object; + TThdActiveWndMon = class(TTgThread) + protected + bSync_: Boolean; + evNotify_: TEvActiveWndNotify; + hActiveWnd_: HWND; + procedure ProcessNotify; + procedure Execute; override; + public + Constructor Create(bSync: Boolean = true); + + property OnActiveWndNotify: TEvActiveWndNotify write evNotify_; + end; + +const + // GWL_STYLE + WS_VAL: array [0..19] of DWORD = ( + WS_OVERLAPPED, WS_POPUP, WS_CHILD, WS_MINIMIZE, WS_VISIBLE, WS_DISABLED, + WS_CLIPSIBLINGS, WS_CLIPCHILDREN, WS_MAXIMIZE, WS_CAPTION, WS_BORDER, + WS_DLGFRAME, WS_VSCROLL, WS_HSCROLL, WS_SYSMENU, WS_THICKFRAME, WS_GROUP, + WS_TABSTOP, WS_MINIMIZEBOX, WS_MAXIMIZEBOX + ); + + WS_STR: array [0..19] of String = ( + 'WS_OVERLAPPED', 'WS_POPUP', 'WS_CHILD', 'WS_MINIMIZE', 'WS_VISIBLE', 'WS_DISABLED', + 'WS_CLIPSIBLINGS', 'WS_CLIPCHILDREN', 'WS_MAXIMIZE', 'WS_CAPTION', 'WS_BORDER', + 'WS_DLGFRAME', 'WS_VSCROLL', 'WS_HSCROLL', 'WS_SYSMENU', 'WS_THICKFRAME', 'WS_GROUP', + 'WS_TABSTOP', 'WS_MINIMIZEBOX', 'WS_MAXIMIZEBOX' + ); + + // GWL_EXSTYLE + WS_EX_VAL: array [0..23] of LongInt = ( + WS_EX_DLGMODALFRAME, WS_EX_NOPARENTNOTIFY, WS_EX_TOPMOST, WS_EX_ACCEPTFILES, + WS_EX_TRANSPARENT, WS_EX_MDICHILD, WS_EX_TOOLWINDOW, WS_EX_WINDOWEDGE, + WS_EX_CLIENTEDGE, WS_EX_CONTEXTHELP, WS_EX_RIGHT, WS_EX_LEFT, WS_EX_RTLREADING, + WS_EX_LTRREADING, WS_EX_LEFTSCROLLBAR, WS_EX_RIGHTSCROLLBAR, WS_EX_CONTROLPARENT, + WS_EX_STATICEDGE, WS_EX_APPWINDOW, WS_EX_LAYERED, WS_EX_NOINHERITLAYOUT, + WS_EX_LAYOUTRTL, WS_EX_COMPOSITED, WS_EX_NOACTIVATE + ); + + WS_EX_STR: array [0..23] of String = ( + 'WS_EX_DLGMODALFRAME', 'WS_EX_NOPARENTNOTIFY', 'WS_EX_TOPMOST', 'WS_EX_ACCEPTFILES', + 'WS_EX_TRANSPARENT', 'WS_EX_MDICHILD', 'WS_EX_TOOLWINDOW', 'WS_EX_WINDOWEDGE', + 'WS_EX_CLIENTEDGE', 'WS_EX_CONTEXTHELP', 'WS_EX_RIGHT', 'WS_EX_LEFT', 'WS_EX_RTLREADING', + 'WS_EX_LTRREADING', 'WS_EX_LEFTSCROLLBAR', 'WS_EX_RIGHTSCROLLBAR', 'WS_EX_CONTROLPARENT', + 'WS_EX_STATICEDGE', 'WS_EX_APPWINDOW', 'WS_EX_LAYERED', 'WS_EX_NOINHERITLAYOUT', + 'WS_EX_LAYOUTRTL', 'WS_EX_COMPOSITED', 'WS_EX_NOACTIVATE' + ); + +function GetWindowStyle(h: HWND): NativeInt; +function GetWindowStyleStr(h: HWND): String; + +function GetWindowExStyle(h: HWND): NativeInt; +function GetWindowExStyleStr(h: HWND): String; + +function GetWindowCaption(h: HWND): String; +function GetEditText(h: HWND): String; +procedure SetEditText(h: HWND; const sText: String); +function GetTopParentHWND(h: HWND): HWND; +function GetWndChildClass(h: HWND; const sClassName: String; hNextChild: HWND = 0): HWND; +function GetWndChildByCaption(h: HWND; const sFindCaption: String; hNextChild: HWND = 0): HWND; +function GetWndClassName(h: HWND): String; +function HasWndChild(hParent, hSrc: HWND): Boolean; + +function GetProgressMax(h: HWND): Integer; // for "msctls_progress32" class +function GetProgressPos(h: HWND): Integer; // for "msctls_progress32" class + +procedure SetScreenCenterForm(aForm: TForm); + +function FindWindowFromProcessName(sPName: String; bIncInvisible: Boolean = false): HWND; + +function SendData(h: HWND; dwCmd: DWORD; const sData: String): LONGLONG; + +implementation + +uses + Tocsg.Trace, Tocsg.Exception, Tocsg.Process; + +{ TThdActiveWndMon } + +Constructor TThdActiveWndMon.Create(bSync: Boolean = true); +begin + Inherited Create; + bSync_ := bSync; + hActiveWnd_ := 0; + @evNotify_ := nil; +end; + +procedure TThdActiveWndMon.ProcessNotify; +begin + if Assigned(evNotify_) and (hActiveWnd_ <> 0) then + evNotify_(Self, hActiveWnd_); +end; + +procedure TThdActiveWndMon.Execute; +var + h, hRecentWnd: HWND; +begin + hRecentWnd := 0; + while not Terminated and not GetWorkStop do + begin + h := GetForegroundWindow; + if h <> hRecentWnd then + begin + hRecentWnd := h; + if bSync_ then + begin + hActiveWnd_ := h; + Synchronize(ProcessNotify); + end else + if Assigned(evNotify_) then + evNotify_(Self, h); + end; + Sleep(500); + end; +end; + + +{ Other } + +// GWL_STYLE +function GetWindowStyle(h: HWND): NativeInt; +begin + Result := 0; + if h <> 0 then + Result := GetWindowLong(h, GWL_STYLE); +end; + +function GetWindowStyleStr(h: HWND): String; +var + i: Integer; + wStyle: LongInt; +begin + Result := ''; + + wStyle := GetWindowStyle(h); + if wStyle <> 0 then + for i := 0 to Length(WS_VAL) - 1 do + if (WS_VAL[i] and wStyle) = WS_VAL[i] then + begin + if Length(Result) > 0 then + Result := Result + '|' + WS_STR[i] + else + Result := WS_STR[i]; + end; +end; + + +// GWL_EXSTYLE +function GetWindowExStyle(h: HWND): NativeInt; +begin + Result := 0; + if h <> 0 then + Result := GetWindowLong(h, GWL_EXSTYLE); +end; + + +function GetWindowExStyleStr(h: HWND): String; +var + i: Integer; + wExStyle: LongInt; +begin + Result := ''; + + wExStyle := GetWindowExStyle(h); + if wExStyle <> 0 then + begin + for i := 0 to Length(WS_EX_VAL) - 1 do + begin + if (WS_EX_VAL[i] and wExStyle) = WS_EX_VAL[i] then + begin + if Length(Result) > 0 then + Result := Result + '|' + WS_EX_STR[i] + else + Result := WS_EX_STR[i]; + end; + end; + end; +end; + +function GetWindowCaption(h: HWND): String; +var + nLen: Integer; + str: array of Char; +begin + + Result := ''; + nLen := GetWindowTextLength(h); + if nLen > 0 then + begin + Inc(nLen); // GetWindowText()에서 1 더해줘야 정상 처리 되는 경우 있음 24_1209 13:39:07 kku + + SetLength(str, nLen); + ZeroMemory(@str[0], nLen * 2); + if GetWindowText(h, @str[0], nLen) <> 0 then + Result := String(PChar(@str[0])); + end; +end; + +function GetEditText(h: HWND): String; +var + str: array of Char; + dwResult: DWORD; +begin + Result := ''; + + SetLength(str, 1024); + try +// SendMessageTimeout(h, WM_GETTEXT, 1024, LPARAM(str), SMTO_NORMAL, 3000, @dwResult); + SendMessage(h, WM_GETTEXT, 1024, LPARAM(str)); + Result := PChar(@str[0]); + finally + SetLength(str, 0); + end; +end; + +procedure SetEditText(h: HWND; const sText: String); +begin + SendMessage(h, WM_SETTEXT, 0, LPARAM(@sText[1])); +end; + +function GetTopParentHWND(h: HWND): HWND; +begin + Result := h; + while Result <> 0 do + begin + if GetParent(Result) = 0 then + exit; + Result:= GetParent(Result); + end; +end; + +function GetWndChildClass(h: HWND; const sClassName: String; hNextChild: HWND = 0): HWND; +var + hChild: HWND; + arrClassName: array [0..255] of Char; +begin + Result := 0; + hChild := GetWindow(h, GW_CHILD); + + if hChild <> 0 then + begin + if hNextChild <> 0 then + hChild := GetWindow(hNextChild, GW_HWNDNEXT); + + while hChild <> 0 do + begin + if GetClassName(hChild, arrClassName, SizeOf(arrClassName)) > 0 then + begin + if CompareMem(@arrClassName[0], @sClassName[1], Length(sClassName)) then + begin + Result := hChild; + exit; + end; + end; + + if GetWindow(hChild, GW_CHILD) <> 0 then + begin + Result := GetWndChildClass(hChild, sClassName); + if Result <> 0 then + exit; + end; + + hChild := GetWindow(hChild, GW_HWNDNEXT); + end; + end; +end; + +function GetWndChildByCaption(h: HWND; const sFindCaption: String; hNextChild: HWND = 0): HWND; +var + hChild: HWND; + sCaption: String; +begin + Result := 0; + hChild := GetWindow(h, GW_CHILD); + + if hChild <> 0 then + begin + if hNextChild <> 0 then + while hNextChild <> hChild do + hChild := GetWindow(hChild, GW_HWNDNEXT); + + while hChild <> 0 do + begin + sCaption := GetWindowCaption(hChild); + if sCaption = sFindCaption then + begin + Result := hChild; + exit; + end; + + if GetWindow(hChild, GW_CHILD) <> 0 then + begin + Result := GetWndChildClass(hChild, sFindCaption); + if Result <> 0 then + exit; + end; + + hChild := GetWindow(hChild, GW_HWNDNEXT); + end; + end; +end; + +function GetWndClassName(h: HWND): String; +var + arrClassName: array [0..255] of Char; +begin + Result := ''; + if h <> 0 then + if GetClassName(h, arrClassName, SizeOf(arrClassName)) > 0 then + Result := String(arrClassName); +end; + +function HasWndChild(hParent, hSrc: HWND): Boolean; +var + hChild: HWND; +begin + Result := false; + hChild := GetWindow(hParent, GW_CHILD); + + while hChild <> 0 do + begin + if hChild = hSrc then + begin + Result := true; + exit; + end; + + if HasWndChild(hChild, hSrc) then + begin + Result := true; + exit; + end; + + hChild := GetWindow(hChild, GW_HWNDNEXT); + end; +end; + +function GetProgressMax(h: HWND): Integer; // for "msctls_progress32" class +const + PBM_GETRANGE = $0407; +begin + Result := SendMessage(h, PBM_GETRANGE, 0, 0); +end; + +function GetProgressPos(h: HWND): Integer; // for "msctls_progress32" class +const + PBM_GETPOS = $0408; +begin + Result := SendMessage(h, PBM_GETPOS, 0, 0); +end; + +procedure SetScreenCenterForm(aForm: TForm); +var + i: Integer; +begin + for i := 0 to Screen.MonitorCount - 1 do + if Screen.Monitors[i].Primary then + begin + if (Screen.Monitors[i].Width > aForm.Width) and + (Screen.Monitors[i].Height > aForm.Height) then + begin + aForm.Left := (Screen.Monitors[i].Width div 2) - (aForm.Width div 2); + aForm.Top := (Screen.Monitors[i].Height div 2) - (aForm.Height div 2); + end else begin + aForm.Left := 0; + aForm.Top := 0; + end; + break; + end; +end; + +function FindWindowFromProcessName(sPName: String; bIncInvisible: Boolean = false): HWND; +var + h: HWND; + llStyle: LONGLONG; + sTemp: String; +begin + Result := 0; + try + h := FindWindow(nil, nil); + while h <> 0 do + begin + llStyle := GetWindowStyle(h); + if bIncInvisible or + ( ((llStyle and WS_VISIBLE) <> 0) and + ((llStyle and WS_MINIMIZE) = 0) ) then + begin + sTemp := GetWindowCaption(h); + if sTemp <> '' then + begin + sTemp := GetProcessNameFromWndHandle(h); + if sTemp = sPName then + begin + Result := h; + exit; + end; + end; + end; + h := GetWindow(h, GW_HWNDNEXT); + end; + except + on E: ETgException do + ETgException.TraceException(E, 'Fail .. FindWindowFromProcessName()'); + end; +end; + +function SendData(h: HWND; dwCmd: DWORD; const sData: String): LONGLONG; +var + CopyData: TCopyDataStruct; +begin + CopyData.dwData := dwCmd; + + CopyData.cbData := (Length(sData) + 1) * 2; + CopyData.lpData := PChar(sData); + + Result := SendMessage(h, WM_COPYDATA, 0, NativeInt(@CopyData)); + Application.ProcessMessages; +end; + +end.