├── Dump.pas ├── JCL ├── Jcl8087.pas ├── JclBase.pas ├── JclConsole.pas ├── JclDateTime.pas ├── JclFileUtils.pas ├── JclIniFiles.pas ├── JclLogic.pas ├── JclMath.pas ├── JclPeImage.pas ├── JclRegistry.pas ├── JclResources.pas ├── JclSecurity.pas ├── JclShell.pas ├── JclStreams.pas ├── JclStrings.pas ├── JclSysInfo.pas ├── JclSysUtils.pas ├── JclWideStrings.pas ├── JclWin32.pas ├── Snmp.pas ├── crossplatform.inc ├── jcl.inc ├── jcld7.inc ├── jedi.inc └── windowsonly.inc ├── LICENSE ├── Main.dfm ├── Main.pas ├── README.md ├── RTTI ├── HVInterfaceMethods.pas ├── HVMethodInfoClasses.pas ├── HVMethodSignature.pas ├── HVPublishedMethodParams.pas └── HVVMT.pas ├── vclexp.cfg ├── vclexp.dof ├── vclexp.dpr └── vclexp.res /Dump.pas: -------------------------------------------------------------------------------- 1 | unit Dump; 2 | 3 | interface 4 | 5 | Uses SysUtils,JclPeImage,VirtualTrees; 6 | 7 | Type 8 | node_type = (ntUnit,ntClass,ntVirtualGrp,ntDynamicGrp,ntInterfaceGrp,ntVProc,ntDProc,ntIProc,ntGUID); 9 | ClassNode = Record 10 | Txt,Ancestor:AnsiString; 11 | ofs:Cardinal; 12 | gid:TGUID; 13 | kind:node_type; 14 | end; 15 | PClassNode = ^ClassNode; 16 | 17 | var 18 | bpl:TJclPeImage; 19 | 20 | function uncode(m:AnsiString):Ansistring; 21 | Function GetAncestor(ClassTypeInfo: TClass):AnsiString; 22 | function AddVirt(vt:TVirtualStringTree;n:PVirtualNode;ClassTypeInfo: TClass): PVirtualNode; 23 | function AddDyna(vt:TVirtualStringTree;n:PVirtualNode;ClassTypeInfo: TClass): PVirtualNode; 24 | procedure AddInter(vt:TVirtualStringTree;n,v,d:PVirtualNode;ClassTypeInfo: TClass); 25 | 26 | implementation 27 | 28 | Uses StrUtils,TypInfo,HVInterfaceMethods,HVVMT; 29 | 30 | // convert image RVA into memory VA 31 | function conv(adr:Pointer):Pointer; overload; 32 | Begin 33 | Result:=bpl.RvaToVaEx(Cardinal(adr)); 34 | end; 35 | 36 | // convert image RVA into memory VA 37 | function conv(adr:Integer):Pointer; overload; 38 | Begin 39 | Result:=bpl.RvaToVaEx(Cardinal(adr)); 40 | end; 41 | 42 | // dumb unmangling for class names 43 | function uncode(m:AnsiString):Ansistring; 44 | Var 45 | i:Integer; 46 | ctr:Boolean; 47 | dtr:Boolean; 48 | Begin 49 | ctr:=False; 50 | dtr:=False; 51 | i:=Pos('$',m); 52 | if i<>0 then 53 | begin 54 | if (m[i+1]='b')and(m[i+3]='t')and(m[i+4]='r')and(m[i+5]='$') then 55 | begin 56 | if m[i+2]='c' then ctr:=True 57 | else if m[i+2]='d' then dtr:=True; 58 | end; 59 | m:=Copy(m,1,i-1); 60 | end; 61 | if m[1]='@' then m[1]:=' '; 62 | i:=Length(m); 63 | if m[i]='@' then m[i]:=' '; 64 | Result:=Trim(AnsiReplaceStr(m,'@','.')); 65 | if ctr then Result:=Concat(Result,' = CONSTRUCTOR') 66 | else if dtr then Result:=Concat(Result,' = DESTRUCTOR'); 67 | end; 68 | 69 | // find first class table after or equal to VMT entry - i.e. end of Virtual table 70 | procedure Min(p_new,p_base:Pointer; var p_cur:Cardinal); 71 | Begin 72 | if Cardinal(p_new)>=Cardinal(p_base) Then 73 | if Cardinal(p_new)=0)and Assigned(v) then GetProc(v,Cardinal(K)); 172 | end 173 | Else If (adr[0]=#$50)and(adr[1]=#$8B)and(adr[3]=#$8B) Then 174 | Begin 175 | // virtual method 176 | // 403EF5D8 0534FFFFFF add eax,FFFFFF34h 177 | // 403EF5DD 50 push eax 178 | // 403EF5DE 8B00 mov eax,[eax] 179 | // 403EF5E0 8B4030 mov eax,[eax+30h] 180 | //// 403EF5E0 8B80A0000000 mov eax,[eax+A0h] 181 | //// can be also MOV EAX,[EAX] instead of EAX+00h 182 | //// 403EF5E0 8B00 mov eax,[eax] 183 | // 403EF5E3 870424 xchg eax,[esp] 184 | // 403EF5E6 C3 retn 185 | If (adr[4]=#0)and(adr[8]=#$C3) then K:=0 186 | else If (adr[4]=#$40)and(adr[9]=#$C3) then K:=PShortInt(adr+5)^ 187 | Else If (adr[4]=#$80)and(adr[12]=#$C3) then K:=PInteger(adr+5)^ 188 | else K:=-1; 189 | if (K>=0)And Assigned(v) Then GetProc(v,Cardinal(K)); 190 | end 191 | Else if (adr[0]=#$50)and(adr[1]=#$52)and(adr[2]=#$51)and(adr[3]=#$66)and(adr[17]=#$C3) Then 192 | Begin 193 | // dynamic method 194 | // 403EF77C 0534FFFFFF add eax,FFFFFF34h 195 | // 403EF781 50 push eax 196 | // 403EF782 52 push edx 197 | // 403EF783 51 push ecx 198 | // 403EF784 66BAE7FF mov dx,FFE7h 199 | // 403EF788 E8FB18F8FF call jmp_rtl70.bpl!@System@@FindDynaInst$qqrv 200 | // 403EF78D 59 pop ecx 201 | // 403EF78E 5A pop edx 202 | // 403EF78F 870424 xchg eax,[esp] 203 | // 403EF792 C3 retn 204 | if Assigned(d) Then GetProc(d,PWord(adr+5)^); 205 | end; 206 | end; 207 | 208 | Function GetAncestor(ClassTypeInfo: TClass):AnsiString; 209 | var 210 | ClassVMT:PVmt; 211 | p:Pointer; 212 | Begin 213 | Result:=''; 214 | ClassVMT:=GetVmt(ClassTypeInfo); 215 | if Assigned(ClassVMT.Parent) then 216 | begin 217 | // first check if this class is imported from other BPL 218 | p:=conv(Pointer(PInteger(conv(ClassVMT.Parent))^)); 219 | if Assigned(p) and (PWord(p)^=0) then Result:=uncode(PAnsiChar(p)+2) 220 | else if conv(ClassVMT.Parent)<>NIL Then 221 | // local class 222 | Result:=PShortString(conv(PVmt(conv(ClassVMT.Parent))^.ClassName))^; 223 | end; 224 | end; 225 | 226 | Function AddVirt(vt:TVirtualStringTree;n:PVirtualNode;ClassTypeInfo: TClass):PVirtualNode; 227 | Var 228 | ClassVMT:PVmt; 229 | i,vmt: Cardinal; 230 | p:Pointer; 231 | vptr:PInteger; 232 | node:PVirtualNode; 233 | data:PClassNode; 234 | s:AnsiString; 235 | Begin 236 | ClassVMT:=GetVmt(ClassTypeInfo); 237 | // compute count of virtual methods - first find the smallest address 238 | // from VMT tables, then subtract VMTptr from it and divide result by 4 239 | vptr:=Pointer(ClassVMT.SelfPtr); 240 | vmt:=Cardinal(Pointer(ClassVMT.ClassName)); 241 | Min(ClassVMT.IntfTable,vptr,vmt); 242 | Min(ClassVMT.AutoTable,vptr,vmt); 243 | Min(ClassVMT.InitTable,vptr,vmt); 244 | Min(ClassVMT.TypeInfo,vptr,vmt); 245 | Min(ClassVMT.FieldTable,vptr,vmt); 246 | Min(ClassVMT.MethodTable,vptr,vmt); 247 | Min(ClassVMT.DynamicTable,vptr,vmt); 248 | vmt:=(vmt - Cardinal(vptr)) div SizeOf(Pointer); 249 | // enumerate virtual methods 250 | Result:=Nil; 251 | if vmt<>0 then 252 | begin 253 | n:=vt.AddChild(n); 254 | data:=vt.GetNodeData(n); 255 | data.kind:=ntVirtualGrp; 256 | for i := 0 to vmt-1 do 257 | begin 258 | // exported addresses are relative to ImageBase 259 | if bpl.ExportList.ItemFromAddress[PCardinal(conv(vptr))^-bpl.OptionalHeader.ImageBase]<>nil then 260 | s:=bpl.ExportList.ItemFromAddress[PCardinal(conv(vptr))^-bpl.OptionalHeader.ImageBase].Name 261 | else 262 | begin 263 | p:=conv(Pointer(vptr)); // get VMT entry 264 | p:=conv(Pointer(PInteger(p)^)); // get value of VMT entry 265 | // this is "trampoline" stub - JMP 266 | if PWord(p)^=$25FF then p:=conv(Pointer(PInteger(PChar(p)+2)^)); 267 | p:=conv(Pointer(PInteger(p)^)); 268 | s:=PAnsiChar(PAnsiChar(p)+2); 269 | //if imp_name(p)<>NIL Then n:=imp_name(p).Name 270 | //else n:='unknown'; 271 | end; 272 | node:=vt.AddChild(n); 273 | data:=vt.GetNodeData(node); 274 | data.kind:=ntVProc; 275 | data.ofs:=i*4; 276 | data.Txt:=uncode(s); 277 | Inc(vptr); 278 | End; 279 | vt.ReinitNode(n,True); 280 | Result:=n; 281 | end; 282 | end; 283 | 284 | Function AddDyna(vt:TVirtualStringTree;n:PVirtualNode;ClassTypeInfo: TClass):PVirtualNode; 285 | Var 286 | ClassVMT,curClass:PVmt; 287 | dynTable: PDmt; 288 | i: Cardinal; 289 | dyn:PDmtMethods; 290 | node:PVirtualNode; 291 | data:PClassNode; 292 | Begin 293 | ClassVMT:=GetVmt(ClassTypeInfo); 294 | Result:=Nil; 295 | // enumerate dynamic methods - including all parent classes 296 | curClass:=ClassVMT; 297 | while True Do 298 | begin 299 | if Assigned(curClass.DynamicTable) Then 300 | Begin 301 | dynTable:=conv(curClass.DynamicTable); 302 | if dynTable.Count<>0 then 303 | begin 304 | if Not Assigned(Result) Then 305 | Begin 306 | Result:=vt.AddChild(n); 307 | data:=vt.GetNodeData(Result); 308 | data.kind:=ntDynamicGrp; 309 | end; 310 | dyn:=Pointer(Cardinal(@dynTable.Indicies)+dynTable.Count*SizeOf(TDMTIndex)); 311 | for i:=0 to dynTable.Count-1 Do 312 | Begin 313 | node:=vt.AddChild(Result); 314 | data:=vt.GetNodeData(node); 315 | data.kind:=ntDProc; 316 | data.ofs:=Word(dynTable.Indicies[i]); 317 | // dynamic methods are always local - i.e. exported 318 | if bpl.ExportList.ItemFromAddress[Cardinal(dyn^[i])-bpl.OptionalHeader.ImageBase]<>nil then 319 | data.Txt:=uncode(bpl.ExportList.ItemFromAddress[Cardinal(dyn^[i])-bpl.OptionalHeader.ImageBase].Name) 320 | else data.Txt:='unknown'; 321 | end; 322 | End; 323 | end; 324 | // stop when reach imported parent or parent is NIL 325 | if curClass.Parent=NIL then Break; 326 | curClass:=conv(curClass.Parent); 327 | if Cardinal(curClass.SelfPtr) < bpl.OptionalHeader.ImageBase then Break; 328 | End; 329 | end; 330 | 331 | Procedure AddInter(vt:TVirtualStringTree;n,v,d:PVirtualNode;ClassTypeInfo: TClass); 332 | Var 333 | ClassVMT:PVmt; 334 | i,j: Cardinal; 335 | tmp:Pointer; 336 | vptr:PInteger; 337 | intf:PInterfaceTable; 338 | node,grp,grp2:PVirtualNode; 339 | data:PClassNode; 340 | Begin 341 | ClassVMT:=GetVmt(ClassTypeInfo); 342 | // enumerate interfaces 343 | if Assigned(ClassVMT.IntfTable) Then 344 | Begin 345 | intf:=conv(ClassVMT.IntfTable); 346 | vptr:=Pointer(intf); 347 | for i:=0 to intf.EntryCount-1 do 348 | begin 349 | tmp:=conv(intf.Entries[I].VTable); 350 | if Cardinal(tmp) < Cardinal(vptr) then vptr:=tmp; 351 | End; 352 | j:=0; 353 | while vptr <> Pointer(intf) do 354 | Begin 355 | if Not Assigned(grp) Then 356 | Begin 357 | grp:=vt.AddChild(n); 358 | data:=vt.GetNodeData(grp); 359 | data.kind:=ntInterfaceGrp; 360 | end; 361 | for i:=0 to intf.EntryCount-1 do 362 | if vptr = conv(intf.Entries[I].VTable) then 363 | begin 364 | grp2:=vt.AddChild(grp); 365 | data:=vt.GetNodeData(grp2); 366 | data.kind:=ntGUID; 367 | data.gid:=intf.Entries[i].IID; 368 | j:=0; 369 | end; 370 | node:=vt.AddChild(grp2); 371 | data:=vt.GetNodeData(node); 372 | data.kind:=ntIProc; 373 | data.ofs:=j; 374 | data.Txt:=intf_name(vt,n,v,d,conv(vptr^)); 375 | Inc(j,4); 376 | Inc(vptr); 377 | end; 378 | end; 379 | end; 380 | 381 | Initialization 382 | bpl:=TJclPeImage.Create; 383 | 384 | Finalization 385 | bpl.Free; 386 | 387 | end. 388 | -------------------------------------------------------------------------------- /JCL/Jcl8087.pas: -------------------------------------------------------------------------------- 1 | {**************************************************************************************************} 2 | { } 3 | { Project JEDI Code Library (JCL) } 4 | { } 5 | { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); } 6 | { you may not use this file except in compliance with the License. You may obtain a copy of the } 7 | { License at http://www.mozilla.org/MPL/ } 8 | { } 9 | { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } 10 | { ANY KIND, either express or implied. See the License for the specific language governing rights } 11 | { and limitations under the License. } 12 | { } 13 | { The Original Code is Jcl8087.pas } 14 | { } 15 | { The Initial Developer of the Original Code is Marcel van Brakel. } 16 | { Portions created by Marcel van Brakel are Copyright Marcel van Brakel. All rights reserved. } 17 | { } 18 | { Contributor(s): } 19 | { Marcel van Brakel } 20 | { ESB Consultancy } 21 | { Robert Marquardt (marquardt) } 22 | { Robert Rossmair (rrossmair) } 23 | { Matthias Thoma (mthoma) } 24 | { Petr Vones } 25 | { } 26 | {**************************************************************************************************} 27 | { } 28 | { This unit contains various routine for manipulating the math coprocessor. This includes such } 29 | { things as querying and setting the rounding precision of floating point operations and } 30 | { retrieving the coprocessor's status word. } 31 | { } 32 | {**************************************************************************************************} 33 | { } 34 | { Last modified: $Date:: 2007-09-17 23:41:02 +0200 (lun., 17 sept. 2007) $ } 35 | { Revision: $Rev:: 2175 $ } 36 | { Author: $Author:: outchy $ } 37 | { } 38 | {**************************************************************************************************} 39 | 40 | unit Jcl8087; 41 | 42 | {$I jcl.inc} 43 | 44 | interface 45 | 46 | {$IFDEF UNITVERSIONING} 47 | uses 48 | JclUnitVersioning; 49 | {$ENDIF UNITVERSIONING} 50 | 51 | type 52 | T8087Precision = (pcSingle, pcReserved, pcDouble, pcExtended); 53 | T8087Rounding = (rcNearestOrEven, rcDownInfinity, rcUpInfinity, rcChopOrTruncate); 54 | T8087Infinity = (icProjective, icAffine); 55 | T8087Exception = (emInvalidOp, emDenormalizedOperand, emZeroDivide, emOverflow, 56 | emUnderflow, emPrecision); 57 | T8087Exceptions = set of T8087Exception; 58 | 59 | const 60 | All8087Exceptions = [Low(T8087Exception)..High(T8087Exception)]; 61 | 62 | function Get8087ControlWord: Word; 63 | function Get8087Infinity: T8087Infinity; 64 | function Get8087Precision: T8087Precision; 65 | function Get8087Rounding: T8087Rounding; 66 | function Get8087StatusWord(ClearExceptions: Boolean): Word; 67 | 68 | function Set8087Infinity(const Infinity: T8087Infinity): T8087Infinity; 69 | function Set8087Precision(const Precision: T8087Precision): T8087Precision; 70 | function Set8087Rounding(const Rounding: T8087Rounding): T8087Rounding; 71 | function Set8087ControlWord(const Control: Word): Word; 72 | 73 | function ClearPending8087Exceptions: T8087Exceptions; 74 | function GetPending8087Exceptions: T8087Exceptions; 75 | function GetMasked8087Exceptions: T8087Exceptions; 76 | function SetMasked8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean = True): T8087Exceptions; 77 | function Mask8087Exceptions(Exceptions: T8087Exceptions): T8087Exceptions; 78 | function Unmask8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean = True): T8087Exceptions; 79 | 80 | {$IFDEF UNITVERSIONING} 81 | const 82 | UnitVersioning: TUnitVersionInfo = ( 83 | RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-1.102-Build3072/jcl/source/common/Jcl8087.pas $'; 84 | Revision: '$Revision: 2175 $'; 85 | Date: '$Date: 2007-09-17 23:41:02 +0200 (lun., 17 sept. 2007) $'; 86 | LogPath: 'JCL\source\common' 87 | ); 88 | {$ENDIF UNITVERSIONING} 89 | 90 | implementation 91 | 92 | const 93 | X87ExceptBits = $3F; 94 | 95 | function Get8087ControlWord: Word; assembler; 96 | asm 97 | {$IFDEF FPC} 98 | SUB ESP, $2 99 | {$ELSE} 100 | SUB ESP, TYPE WORD 101 | {$ENDIF FPC} 102 | FSTCW [ESP] 103 | FWAIT 104 | POP AX 105 | end; 106 | 107 | function Get8087Infinity: T8087Infinity; 108 | begin 109 | Result := T8087Infinity((Get8087ControlWord and $1000) shr 12); 110 | end; 111 | 112 | function Get8087Precision: T8087Precision; 113 | begin 114 | Result := T8087Precision((Get8087ControlWord and $0300) shr 8); 115 | end; 116 | 117 | function Get8087Rounding: T8087Rounding; 118 | begin 119 | Result := T8087Rounding((Get8087ControlWord and $0C00) shr 10); 120 | end; 121 | 122 | function Get8087StatusWord(ClearExceptions: Boolean): Word; assembler; 123 | asm 124 | TEST AX, AX // if ClearExceptions then 125 | JE @@NoClearExceptions 126 | FSTSW AX // get status word (clears exceptions) 127 | RET 128 | @@NoClearExceptions: // else 129 | FNSTSW AX // get status word (without clearing exceptions) 130 | end; 131 | 132 | function Set8087Infinity(const Infinity: T8087Infinity): T8087Infinity; 133 | var 134 | CW: Word; 135 | begin 136 | CW := Get8087ControlWord; 137 | Result := T8087Infinity((CW and $1000) shr 12); 138 | Set8087ControlWord((CW and $EFFF) or (Word(Infinity) shl 12)); 139 | end; 140 | 141 | function Set8087Precision(const Precision: T8087Precision): T8087Precision; 142 | var 143 | CW: Word; 144 | begin 145 | CW := Get8087ControlWord; 146 | Result := T8087Precision((CW and $0300) shr 8); 147 | Set8087ControlWord((CW and $FCFF) or (Word(Precision) shl 8)); 148 | end; 149 | 150 | function Set8087Rounding(const Rounding: T8087Rounding): T8087Rounding; 151 | var 152 | CW: Word; 153 | begin 154 | CW := Get8087ControlWord; 155 | Result := T8087Rounding((CW and $0C00) shr 10); 156 | Set8087ControlWord((CW and $F3FF) or (Word(Rounding) shl 10)); 157 | end; 158 | 159 | function Set8087ControlWord(const Control: Word): Word; assembler; 160 | asm 161 | FNCLEX 162 | {$IFDEF FPC} 163 | SUB ESP, $2 164 | {$ELSE} 165 | SUB ESP, TYPE WORD 166 | {$ENDIF FPC} 167 | FSTCW [ESP] 168 | XCHG [ESP], AX 169 | FLDCW [ESP] 170 | {$IFDEF FPC} 171 | ADD ESP, $2 172 | {$ELSE} 173 | ADD ESP, TYPE WORD 174 | {$ENDIF FPC} 175 | end; 176 | 177 | function ClearPending8087Exceptions: T8087Exceptions; 178 | asm 179 | FNSTSW AX 180 | AND AX, X87ExceptBits 181 | FNCLEX 182 | end; 183 | 184 | function GetPending8087Exceptions: T8087Exceptions; 185 | asm 186 | FNSTSW AX 187 | AND AX, X87ExceptBits 188 | end; 189 | 190 | function GetMasked8087Exceptions: T8087Exceptions; 191 | asm 192 | {$IFDEF FPC} 193 | SUB ESP, $2 194 | {$ELSE} 195 | SUB ESP, TYPE WORD 196 | {$ENDIF FPC} 197 | FSTCW [ESP] 198 | FWAIT 199 | POP AX 200 | AND AX, X87ExceptBits 201 | end; 202 | 203 | function SetMasked8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean): T8087Exceptions; 204 | asm 205 | TEST DL, DL // if ClearBefore then 206 | JZ @1 207 | FNCLEX // clear pending exceptions 208 | @1: 209 | {$IFDEF FPC} 210 | SUB ESP, $2 211 | {$ELSE} 212 | SUB ESP, TYPE WORD 213 | {$ENDIF FPC} 214 | FSTCW [ESP] 215 | FWAIT 216 | AND AX, X87ExceptBits // mask exception mask bits 0..5 217 | MOV DX, [ESP] 218 | AND WORD PTR [ESP], NOT X87ExceptBits 219 | OR [ESP], AX 220 | FLDCW [ESP] 221 | {$IFDEF FPC} 222 | ADD ESP, $2 223 | {$ELSE} 224 | ADD ESP, TYPE WORD 225 | {$ENDIF FPC} 226 | MOV AX, DX 227 | AND AX, X87ExceptBits 228 | end; 229 | 230 | function Mask8087Exceptions(Exceptions: T8087Exceptions): T8087Exceptions; 231 | begin 232 | Result := GetMasked8087Exceptions; 233 | Exceptions := Exceptions + Result; 234 | SetMasked8087Exceptions(Exceptions, False); 235 | end; 236 | 237 | function Unmask8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean): T8087Exceptions; 238 | begin 239 | Result := GetMasked8087Exceptions; 240 | Exceptions := Result - Exceptions; 241 | SetMasked8087Exceptions(Exceptions, ClearBefore); 242 | end; 243 | 244 | {$IFDEF UNITVERSIONING} 245 | initialization 246 | RegisterUnitVersion(HInstance, UnitVersioning); 247 | 248 | finalization 249 | UnregisterUnitVersion(HInstance); 250 | {$ENDIF UNITVERSIONING} 251 | 252 | end. 253 | -------------------------------------------------------------------------------- /JCL/JclIniFiles.pas: -------------------------------------------------------------------------------- 1 | {**************************************************************************************************} 2 | { } 3 | { Project JEDI Code Library (JCL) } 4 | { } 5 | { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); } 6 | { you may not use this file except in compliance with the License. You may obtain a copy of the } 7 | { License at http://www.mozilla.org/MPL/ } 8 | { } 9 | { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } 10 | { ANY KIND, either express or implied. See the License for the specific language governing rights } 11 | { and limitations under the License. } 12 | { } 13 | { The Original Code is JclIniFiles.pas. } 14 | { } 15 | { The Initial Developer of the Original Code is John C Molyneux. } 16 | { Portions created by John C Molyneux are Copyright (C) John C Molyneux. } 17 | { } 18 | { Contributors: } 19 | { Eric S. Fisher } 20 | { John C Molyneux } 21 | { Petr Vones (pvones) } 22 | { Robert Marquardt (marquardt) } 23 | { Robert Rossmair (rrossmair) } 24 | { } 25 | {**************************************************************************************************} 26 | { } 27 | { Last modified: $Date:: 2007-09-17 23:41:02 +0200 (lun., 17 sept. 2007) $ } 28 | { Revision: $Rev:: 2175 $ } 29 | { Author: $Author:: outchy $ } 30 | { } 31 | {**************************************************************************************************} 32 | 33 | unit JclIniFiles; 34 | 35 | {$I jcl.inc} 36 | 37 | interface 38 | 39 | uses 40 | {$IFDEF UNITVERSIONING} 41 | JclUnitVersioning, 42 | {$ENDIF UNITVERSIONING} 43 | SysUtils, Classes, IniFiles; 44 | 45 | // Initialization (ini) Files 46 | function IniReadBool(const FileName, Section, Line: string): Boolean; // John C Molyneux 47 | function IniReadInteger(const FileName, Section, Line: string): Integer; // John C Molyneux 48 | function IniReadString(const FileName, Section, Line: string): string; // John C Molyneux 49 | procedure IniWriteBool(const FileName, Section, Line: string; Value: Boolean); // John C Molyneux 50 | procedure IniWriteInteger(const FileName, Section, Line: string; Value: Integer); // John C Molyneux 51 | procedure IniWriteString(const FileName, Section, Line, Value: string); // John C Molyneux 52 | 53 | // Initialization (ini) Files helper routines 54 | procedure IniReadStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings); 55 | procedure IniWriteStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings); 56 | 57 | {$IFDEF UNITVERSIONING} 58 | const 59 | UnitVersioning: TUnitVersionInfo = ( 60 | RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-1.102-Build3072/jcl/source/common/JclIniFiles.pas $'; 61 | Revision: '$Revision: 2175 $'; 62 | Date: '$Date: 2007-09-17 23:41:02 +0200 (lun., 17 sept. 2007) $'; 63 | LogPath: 'JCL\source\common' 64 | ); 65 | {$ENDIF UNITVERSIONING} 66 | 67 | implementation 68 | 69 | {$IFDEF CLR} 70 | type 71 | TIniFile = TMemIniFile; 72 | {$ENDIF CLR} 73 | 74 | // Initialization Files 75 | function IniReadBool(const FileName, Section, Line: string): Boolean; 76 | var 77 | Ini: TIniFile; 78 | begin 79 | Ini := TIniFile.Create(FileName); 80 | try 81 | Result := Ini.ReadBool(Section, Line, False); 82 | finally 83 | Ini.Free; 84 | end; 85 | end; 86 | 87 | function IniReadInteger(const FileName, Section, Line: string): Integer; 88 | var 89 | Ini: TIniFile; 90 | begin 91 | Ini := TIniFile.Create(FileName); 92 | try 93 | Result := Ini.ReadInteger(Section, Line, 0); 94 | finally 95 | Ini.Free; 96 | end; 97 | end; 98 | 99 | function IniReadString(const FileName, Section, Line: string): string; 100 | var 101 | Ini: TIniFile; 102 | begin 103 | Ini := TIniFile.Create(FileName); 104 | try 105 | Result := Ini.ReadString(Section, Line, ''); 106 | finally 107 | Ini.Free; 108 | end; 109 | end; 110 | 111 | procedure IniWriteBool(const FileName, Section, Line: string; Value: Boolean); 112 | var 113 | Ini: TIniFile; 114 | begin 115 | Ini := TIniFile.Create(FileName); 116 | try 117 | Ini.WriteBool(Section, Line, Value); 118 | {$IFDEF CLR} 119 | Ini.UpdateFile; 120 | {$ENDIF CLR} 121 | finally 122 | Ini.Free; 123 | end; 124 | end; 125 | 126 | procedure IniWriteInteger(const FileName, Section, Line: string; Value: Integer); 127 | var 128 | Ini: TIniFile; 129 | begin 130 | Ini := TIniFile.Create(FileName); 131 | try 132 | Ini.WriteInteger(Section, Line, Value); 133 | {$IFDEF CLR} 134 | Ini.UpdateFile; 135 | {$ENDIF CLR} 136 | finally 137 | Ini.Free; 138 | end; 139 | end; 140 | 141 | procedure IniWriteString(const FileName, Section, Line, Value: string); 142 | var 143 | Ini: TIniFile; 144 | begin 145 | Ini := TIniFile.Create(FileName); 146 | try 147 | Ini.WriteString(Section, Line, Value); 148 | {$IFDEF CLR} 149 | Ini.UpdateFile; 150 | {$ENDIF CLR} 151 | finally 152 | Ini.Free; 153 | end; 154 | end; 155 | 156 | // Initialization (ini) Files helper routines 157 | const 158 | ItemCountName = 'Count'; 159 | 160 | procedure IniReadStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings); 161 | var 162 | Count, I: Integer; 163 | begin 164 | with IniFile do 165 | begin 166 | Strings.BeginUpdate; 167 | try 168 | Strings.Clear; 169 | Count := ReadInteger(Section, ItemCountName, 0); 170 | for I := 0 to Count - 1 do 171 | Strings.Add(ReadString(Section, IntToStr(I), '')); 172 | finally 173 | Strings.EndUpdate; 174 | end; 175 | end; 176 | end; 177 | 178 | procedure IniWriteStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings); 179 | var 180 | I: Integer; 181 | begin 182 | with IniFile do 183 | begin 184 | EraseSection(Section); 185 | WriteInteger(Section, ItemCountName, Strings.Count); 186 | for I := 0 to Strings.Count - 1 do 187 | WriteString(Section, IntToStr(I), Strings[I]); 188 | end; 189 | end; 190 | 191 | {$IFDEF UNITVERSIONING} 192 | initialization 193 | RegisterUnitVersion(HInstance, UnitVersioning); 194 | 195 | finalization 196 | UnregisterUnitVersion(HInstance); 197 | {$ENDIF UNITVERSIONING} 198 | 199 | end. 200 | -------------------------------------------------------------------------------- /JCL/JclSecurity.pas: -------------------------------------------------------------------------------- 1 | {**************************************************************************************************} 2 | { } 3 | { Project JEDI Code Library (JCL) } 4 | { } 5 | { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); } 6 | { you may not use this file except in compliance with the License. You may obtain a copy of the } 7 | { License at http://www.mozilla.org/MPL/ } 8 | { } 9 | { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } 10 | { ANY KIND, either express or implied. See the License for the specific language governing rights } 11 | { and limitations under the License. } 12 | { } 13 | { The Original Code is JclSecurity.pas. } 14 | { } 15 | { The Initial Developer of the Original Code is Marcel van Brakel. } 16 | { Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All Rights Reserved. } 17 | { } 18 | { Contributor(s): } 19 | { Marcel van Brakel } 20 | { Peter Friese } 21 | { Robert Marquardt (marquardt) } 22 | { John C Molyneux } 23 | { Robert Rossmair (rrossmair) } 24 | { Matthias Thoma (mthoma) } 25 | { Petr Vones (pvones) } 26 | { Christoph Lindeman } 27 | { } 28 | {**************************************************************************************************} 29 | { } 30 | { Various NT security related routines to perform commen asks such as enabling and disabling } 31 | { privileges. } 32 | { } 33 | {**************************************************************************************************} 34 | { } 35 | { Last modified: $Date:: 2008-01-31 10:21:45 +0100 (jeu., 31 janv. 2008) $ } 36 | { Revision: $Rev:: 2334 $ } 37 | { Author: $Author:: marcovtje $ } 38 | { } 39 | {**************************************************************************************************} 40 | 41 | unit JclSecurity; 42 | 43 | {$I jcl.inc} 44 | {$I windowsonly.inc} 45 | 46 | {$HPPEMIT '#define TTokenInformationClass TOKEN_INFORMATION_CLASS'} 47 | 48 | interface 49 | 50 | uses 51 | {$IFDEF UNITVERSIONING} 52 | JclUnitVersioning, 53 | {$ENDIF UNITVERSIONING} 54 | Windows, SysUtils, 55 | JclBase; 56 | 57 | type 58 | EJclSecurityError = class(EJclError); 59 | 60 | // Access Control 61 | function CreateNullDacl(var Sa: TSecurityAttributes; 62 | const Inheritable: Boolean): PSecurityAttributes; 63 | function CreateInheritable(var Sa: TSecurityAttributes): PSecurityAttributes; 64 | 65 | // Privileges 66 | function IsAdministrator: Boolean; 67 | function EnableProcessPrivilege(const Enable: Boolean; 68 | const Privilege: string): Boolean; 69 | function EnableThreadPrivilege(const Enable: Boolean; 70 | const Privilege: string): Boolean; 71 | function IsPrivilegeEnabled(const Privilege: string): Boolean; 72 | 73 | function GetPrivilegeDisplayName(const PrivilegeName: string): string; 74 | function SetUserObjectFullAccess(hUserObject: THandle): Boolean; 75 | function GetUserObjectName(hUserObject: THandle): string; 76 | 77 | // Account Information 78 | procedure LookupAccountBySid(Sid: PSID; out Name, Domain: AnsiString); overload; 79 | procedure LookupAccountBySid(Sid: PSID; out Name, Domain: WideString); overload; 80 | procedure QueryTokenInformation(Token: THandle; InformationClass: TTokenInformationClass; var Buffer: Pointer); 81 | procedure FreeTokenInformation(var Buffer: Pointer); 82 | function GetInteractiveUserName: string; 83 | 84 | // SID utilities 85 | function SIDToString(ASID: PSID): string; 86 | procedure StringToSID(const SIDString: String; SID: PSID; cbSID: DWORD); 87 | 88 | // Computer Information 89 | function GetComputerSID(SID: PSID; cbSID: DWORD): Boolean; 90 | 91 | // Windows Vista/Server 2008 UAC (User Account Control) 92 | function IsUACEnabled: Boolean; 93 | function IsElevated: Boolean; 94 | 95 | {$IFDEF UNITVERSIONING} 96 | const 97 | UnitVersioning: TUnitVersionInfo = ( 98 | RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-1.102-Build3072/jcl/source/windows/JclSecurity.pas $'; 99 | Revision: '$Revision: 2334 $'; 100 | Date: '$Date: 2008-01-31 10:21:45 +0100 (jeu., 31 janv. 2008) $'; 101 | LogPath: 'JCL\source\windows' 102 | ); 103 | {$ENDIF UNITVERSIONING} 104 | 105 | implementation 106 | 107 | uses 108 | Classes, 109 | {$IFDEF FPC} 110 | WinSysUt, 111 | JwaAccCtrl, 112 | {$ELSE} 113 | AccCtrl, 114 | {$ENDIF FPC} 115 | JclRegistry, JclResources, JclStrings, JclSysInfo, JclWin32; 116 | 117 | //=== Access Control ========================================================= 118 | 119 | function CreateNullDacl(var Sa: TSecurityAttributes; 120 | const Inheritable: Boolean): PSecurityAttributes; 121 | begin 122 | if IsWinNT then 123 | begin 124 | Sa.lpSecurityDescriptor := AllocMem(SizeOf(TSecurityDescriptor)); 125 | try 126 | Sa.nLength := SizeOf(Sa); 127 | Sa.bInheritHandle := Inheritable; 128 | Win32Check(InitializeSecurityDescriptor(Sa.lpSecurityDescriptor, SECURITY_DESCRIPTOR_REVISION)); 129 | Win32Check(SetSecurityDescriptorDacl(Sa.lpSecurityDescriptor, True, nil, False)); 130 | Result := @Sa; 131 | except 132 | FreeMem(Sa.lpSecurityDescriptor); 133 | Sa.lpSecurityDescriptor := nil; 134 | raise; 135 | end; 136 | end 137 | else 138 | begin 139 | Sa.lpSecurityDescriptor := nil; 140 | Result := nil; 141 | end; 142 | end; 143 | 144 | function CreateInheritable(var Sa: TSecurityAttributes): PSecurityAttributes; 145 | begin 146 | Sa.nLength := SizeOf(Sa); 147 | Sa.lpSecurityDescriptor := nil; 148 | Sa.bInheritHandle := True; 149 | if IsWinNT then 150 | Result := @Sa 151 | else 152 | Result := nil; 153 | end; 154 | 155 | //=== Privileges ============================================================= 156 | 157 | function IsAdministrator: Boolean; 158 | var 159 | psidAdmin: Pointer; 160 | Token: THandle; 161 | Count: DWORD; 162 | TokenInfo: PTokenGroups; 163 | HaveToken: Boolean; 164 | I: Integer; 165 | begin 166 | Result := not IsWinNT; 167 | if Result then // Win9x/ME 168 | Exit; 169 | psidAdmin := nil; 170 | TokenInfo := nil; 171 | HaveToken := False; 172 | try 173 | HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, Token); 174 | if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then 175 | HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, Token); 176 | if HaveToken then 177 | begin 178 | {$IFDEF FPC} 179 | Win32Check(AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, 180 | SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, 181 | psidAdmin)); 182 | if GetTokenInformation(Token, TokenGroups, nil, 0, @Count) or 183 | (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then 184 | RaiseLastOSError; 185 | TokenInfo := PTokenGroups(AllocMem(Count)); 186 | Win32Check(GetTokenInformation(Token, TokenGroups, TokenInfo, Count, @Count)); 187 | {$ELSE FPC} 188 | Win32Check(AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, 189 | SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, 190 | psidAdmin)); 191 | if GetTokenInformation(Token, TokenGroups, nil, 0, Count) or 192 | (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then 193 | RaiseLastOSError; 194 | TokenInfo := PTokenGroups(AllocMem(Count)); 195 | Win32Check(GetTokenInformation(Token, TokenGroups, TokenInfo, Count, Count)); 196 | {$ENDIF FPC} 197 | for I := 0 to TokenInfo^.GroupCount - 1 do 198 | begin 199 | {$RANGECHECKS OFF} // Groups is an array [0..0] of TSIDAndAttributes, ignore ERangeError 200 | Result := EqualSid(psidAdmin, TokenInfo^.Groups[I].Sid); 201 | {$IFDEF RANGECHECKS_ON} 202 | {$RANGECHECKS ON} 203 | {$ENDIF RANGECHECKS_ON} 204 | if Result then 205 | Break; 206 | end; 207 | end; 208 | finally 209 | if TokenInfo <> nil then 210 | FreeMem(TokenInfo); 211 | if HaveToken then 212 | CloseHandle(Token); 213 | if psidAdmin <> nil then 214 | FreeSid(psidAdmin); 215 | end; 216 | end; 217 | 218 | function EnableProcessPrivilege(const Enable: Boolean; 219 | const Privilege: string): Boolean; 220 | const 221 | PrivAttrs: array [Boolean] of DWORD = (0, SE_PRIVILEGE_ENABLED); 222 | var 223 | Token: THandle; 224 | TokenPriv: TTokenPrivileges; 225 | begin 226 | Result := not IsWinNT; 227 | if Result then // if Win9x, then function return True 228 | Exit; 229 | if OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, Token) then 230 | begin 231 | TokenPriv.PrivilegeCount := 1; 232 | LookupPrivilegeValue(nil, PChar(Privilege), TokenPriv.Privileges[0].Luid); 233 | TokenPriv.Privileges[0].Attributes := PrivAttrs[Enable]; 234 | JclWin32.AdjustTokenPrivileges(Token, False, TokenPriv, SizeOf(TokenPriv), nil, nil); 235 | Result := GetLastError = ERROR_SUCCESS; 236 | CloseHandle(Token); 237 | end; 238 | end; 239 | 240 | function EnableThreadPrivilege(const Enable: Boolean; 241 | const Privilege: string): Boolean; 242 | const 243 | PrivAttrs: array [Boolean] of DWORD = (0, SE_PRIVILEGE_ENABLED); 244 | var 245 | Token: THandle; 246 | TokenPriv: TTokenPrivileges; 247 | HaveToken: Boolean; 248 | begin 249 | Result := not IsWinNT; 250 | if Result then // Win9x/ME 251 | Exit; 252 | Token := 0; 253 | HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_ADJUST_PRIVILEGES, 254 | False, Token); 255 | if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then 256 | HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, Token); 257 | if HaveToken then 258 | begin 259 | TokenPriv.PrivilegeCount := 1; 260 | LookupPrivilegeValue(nil, PChar(Privilege), TokenPriv.Privileges[0].Luid); 261 | TokenPriv.Privileges[0].Attributes := PrivAttrs[Enable]; 262 | JclWin32.AdjustTokenPrivileges(Token, False, TokenPriv, SizeOf(TokenPriv), nil, nil); 263 | Result := GetLastError = ERROR_SUCCESS; 264 | CloseHandle(Token); 265 | end; 266 | end; 267 | 268 | function IsPrivilegeEnabled(const Privilege: string): Boolean; 269 | var 270 | Token: THandle; 271 | TokenPriv: TPrivilegeSet; 272 | Res: LongBool; 273 | HaveToken: Boolean; 274 | begin 275 | Result := not IsWinNT; 276 | if Result then // Win9x/ME 277 | Exit; 278 | Token := 0; 279 | HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, False, Token); 280 | if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then 281 | HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, Token); 282 | if HaveToken then 283 | begin 284 | TokenPriv.PrivilegeCount := 1; 285 | TokenPriv.Control := 0; 286 | LookupPrivilegeValue(nil, PChar(Privilege), TokenPriv.Privilege[0].Luid); 287 | Result := PrivilegeCheck(Token, TokenPriv, Res) and Res; 288 | CloseHandle(Token); 289 | end; 290 | end; 291 | 292 | function GetPrivilegeDisplayName(const PrivilegeName: string): string; 293 | var 294 | Count: DWORD; 295 | LangID: DWORD; 296 | begin 297 | if IsWinNT then 298 | begin 299 | Count := 0; 300 | LangID := LANG_USER_DEFAULT; 301 | 302 | // have the the API function determine the required string length 303 | if not LookupPrivilegeDisplayName(nil, PChar(PrivilegeName), PChar(Result), Count, LangID) then 304 | Count := 256; 305 | SetLength(Result, Count + 1); 306 | 307 | if LookupPrivilegeDisplayName(nil, PChar(PrivilegeName), PChar(Result), Count, LangID) then 308 | StrResetLength(Result) 309 | else 310 | Result := ''; 311 | end 312 | else 313 | Result := ''; // Win9x/ME 314 | end; 315 | 316 | function SetUserObjectFullAccess(hUserObject: THandle): Boolean; 317 | var 318 | Sd: PSecurity_Descriptor; 319 | Si: Security_Information; 320 | begin 321 | Result := not IsWinNT; 322 | if Result then // Win9x/ME 323 | Exit; 324 | { TODO : Check the success of called functions } 325 | Sd := PSecurity_Descriptor(LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH)); 326 | InitializeSecurityDescriptor(Sd, SECURITY_DESCRIPTOR_REVISION); 327 | SetSecurityDescriptorDacl(Sd, True, nil, False); 328 | 329 | Si := DACL_SECURITY_INFORMATION; 330 | Result := SetUserObjectSecurity(hUserObject, Si, Sd); 331 | 332 | LocalFree(HLOCAL(Sd)); 333 | end; 334 | 335 | function GetUserObjectName(hUserObject: THandle): string; 336 | var 337 | Count: DWORD; 338 | begin 339 | if IsWinNT then 340 | begin 341 | // have the API function determine the required string length 342 | GetUserObjectInformation(hUserObject, UOI_NAME, PChar(Result), 0, Count); 343 | SetLength(Result, Count + 1); 344 | 345 | if GetUserObjectInformation(hUserObject, UOI_NAME, PChar(Result), Count, Count) then 346 | StrResetLength(Result) 347 | else 348 | Result := ''; 349 | end 350 | else 351 | Result := ''; 352 | end; 353 | 354 | //=== Account Information ==================================================== 355 | 356 | procedure LookupAccountBySid(Sid: PSID; out Name, Domain: AnsiString); 357 | var 358 | NameSize, DomainSize: DWORD; 359 | Use: SID_NAME_USE; 360 | begin 361 | if IsWinNT then 362 | begin 363 | NameSize := 0; 364 | DomainSize := 0; 365 | LookupAccountSidA(nil, Sid, nil, NameSize, nil, DomainSize, Use); 366 | if NameSize > 0 then 367 | SetLength(Name, NameSize - 1); 368 | if DomainSize > 0 then 369 | SetLength(Domain, DomainSize - 1); 370 | Win32Check(LookupAccountSidA(nil, Sid, PAnsiChar(Name), NameSize, PAnsiChar(Domain), DomainSize, Use)); 371 | end 372 | else 373 | begin // if Win9x, then function return '' 374 | Name := ''; 375 | Domain := ''; 376 | end; 377 | end; 378 | 379 | procedure LookupAccountBySid(Sid: PSID; out Name, Domain: WideString); 380 | var 381 | NameSize, DomainSize: DWORD; 382 | Use: SID_NAME_USE; 383 | begin 384 | if IsWinNT then 385 | begin 386 | NameSize := 0; 387 | DomainSize := 0; 388 | Win32Check(LookupAccountSidW(nil, Sid, nil, NameSize, nil, DomainSize, Use)); 389 | SetLength(Name, NameSize); 390 | SetLength(Domain, DomainSize); 391 | Win32Check(LookupAccountSidW(nil, Sid, PWideChar(Name), NameSize, PWideChar(Domain), DomainSize, Use)); 392 | end 393 | else 394 | begin 395 | Name := ''; 396 | Domain := ''; 397 | end; 398 | end; 399 | 400 | procedure QueryTokenInformation(Token: THandle; 401 | InformationClass: TTokenInformationClass; var Buffer: Pointer); 402 | var 403 | Ret: BOOL; 404 | Length, LastError: DWORD; 405 | begin 406 | Buffer := nil; 407 | if not IsWinNT then // Win9x/ME 408 | Exit; 409 | Length := 0; 410 | {$IFDEF FPC} 411 | Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, @Length); 412 | {$ELSE} 413 | Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, Length); 414 | {$ENDIF FPC} 415 | if (not Ret) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then 416 | begin 417 | GetMem(Buffer, Length); 418 | {$IFDEF FPC} 419 | Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, @Length); 420 | {$ELSE} 421 | Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, Length); 422 | {$ENDIF FPC} 423 | if not Ret then 424 | begin 425 | LastError := GetLastError; 426 | FreeTokenInformation(Buffer); 427 | SetLastError(LastError); 428 | end; 429 | end; 430 | end; 431 | 432 | procedure FreeTokenInformation(var Buffer: Pointer); 433 | begin 434 | if Buffer <> nil then 435 | FreeMem(Buffer); 436 | Buffer := nil; 437 | end; 438 | 439 | function GetInteractiveUserName: string; 440 | var 441 | Handle: THandle; 442 | Token: THandle; 443 | User: PTokenUser; 444 | Name, Domain: AnsiString; 445 | begin 446 | Result := ''; 447 | if not IsWinNT then // if Win9x, then function return '' 448 | Exit; 449 | Handle := GetShellProcessHandle; 450 | try 451 | Win32Check(OpenProcessToken(Handle, TOKEN_QUERY, Token)); 452 | try 453 | QueryTokenInformation(Token, TokenUser, Pointer(User)); 454 | try 455 | LookupAccountBySid(User.User.Sid, Name, Domain); 456 | Result := Domain + '\' + Name; 457 | finally 458 | FreeMem(User); 459 | end; 460 | finally 461 | CloseHandle(Token); 462 | end; 463 | finally 464 | CloseHandle(Handle); 465 | end; 466 | end; 467 | 468 | //=== SID utilities ========================================================== 469 | 470 | function SIDToString(ASID: PSID): string; 471 | var 472 | SidIdAuthority: PSIDIdentifierAuthority; 473 | SubAuthorities, SidRev, SidSize: DWORD; 474 | Counter: Integer; 475 | begin 476 | SidRev := SID_REVISION; 477 | 478 | // Validate the binary SID. 479 | if not IsValidSid(ASid) then 480 | Raise EJclSecurityError.CreateRes(@RsInvalidSID); 481 | 482 | // Get the identifier authority value from the SID. 483 | SidIdAuthority := GetSidIdentifierAuthority(ASid); 484 | 485 | // Get the number of subauthorities in the SID. 486 | SubAuthorities := GetSidSubAuthorityCount(ASid)^; 487 | 488 | //Compute the buffer length. 489 | // S-SID_REVISION- + IdentifierAuthority- + subauthorities- + NULL 490 | SidSize := (15 + 12 + (12 * SubAuthorities) + 1) * SizeOf(CHAR); 491 | 492 | SetLength(Result, SidSize+1); 493 | 494 | // Add 'S' prefix and revision number to the string. 495 | Result := Format('S-%u-',[SidRev]); 496 | 497 | // Add SID identifier authority to the string. 498 | if (SidIdAuthority^.Value[0] <> 0) or (SidIdAuthority^.Value[1] <> 0) then 499 | Result := Result + AnsiLowerCase(Format('0x%2.2x%2.2x%2.2x%2.2x%2.2x%2.2x', 500 | [USHORT(SidIdAuthority^.Value[0]), 501 | USHORT(SidIdAuthority^.Value[1]), 502 | USHORT(SidIdAuthority^.Value[2]), 503 | USHORT(SidIdAuthority^.Value[3]), 504 | USHORT(SidIdAuthority^.Value[4]), 505 | USHORT(SidIdAuthority^.Value[5])])) 506 | else 507 | Result := Result + Format('%u', 508 | [ULONG(SidIdAuthority^.Value[5])+ 509 | ULONG(SidIdAuthority^.Value[4] shl 8)+ 510 | ULONG(SidIdAuthority^.Value[3] shl 16)+ 511 | ULONG(SidIdAuthority^.Value[2] shl 24)]); 512 | 513 | // Add SID subauthorities to the string. 514 | for Counter := 0 to SubAuthorities-1 do 515 | Result := Result + Format('-%u',[GetSidSubAuthority(ASid, Counter)^]); 516 | end; 517 | 518 | procedure StringToSID(const SIDString: String; SID: PSID; cbSID: DWORD); 519 | var 520 | {$ifdef FPC} ASID: PSID; {$else} ASID : ^_SID; {$ENDIF} 521 | CurrentPos, TempPos: Integer; 522 | AuthorityValue, RequiredSize: DWORD; 523 | Authority: string; 524 | begin 525 | if (Length (SIDString) <= 3) or (SIDString [1] <> 'S') or (SIDString [2] <> '-') then 526 | raise EJclSecurityError.CreateRes(@RsInvalidSID); 527 | 528 | RequiredSize := SizeOf(_SID) - SizeOf(DWORD); // _SID.Revision + _SID.SubAuthorityCount + _SID.IdentifierAuthority 529 | if cbSID < RequiredSize then 530 | raise EJclSecurityError.CreateRes(@RsSIDBufferTooSmall); 531 | 532 | ASID := SID; // typecast from opaque structure 533 | 534 | CurrentPos := StrFind('-', SIDString, 3); 535 | if CurrentPos <= 0 then 536 | raise EJclSecurityError.CreateRes(@RsInvalidSID); 537 | ASID^.Revision := StrToInt(Copy(SIDString, 3, CurrentPos - 3)); 538 | 539 | Inc(CurrentPos); 540 | TempPos := StrFind('-', SIDString, CurrentPos); 541 | if TempPos = 0 then 542 | Authority := Copy(SIDString, CurrentPos, Length(SIDString) - CurrentPos + 1) 543 | else 544 | Authority := Copy(SIDString, CurrentPos, TempPos - CurrentPos); 545 | 546 | if Length(Authority) < 1 then 547 | raise EJclSecurityError.CreateRes(@RsInvalidSID); 548 | if (Length(Authority) = 14) and (Authority[1] = '0') and (Authority[2] = 'x') then 549 | begin 550 | ASID^.IdentifierAuthority.Value[0] := StrToInt(AnsiHexPrefix + Authority[3] + Authority[4]); 551 | ASID^.IdentifierAuthority.Value[1] := StrToInt(AnsiHexPrefix + Authority[5] + Authority[6]); 552 | ASID^.IdentifierAuthority.Value[2] := StrToInt(AnsiHexPrefix + Authority[7] + Authority[8]); 553 | ASID^.IdentifierAuthority.Value[3] := StrToInt(AnsiHexPrefix + Authority[9] + Authority[10]); 554 | ASID^.IdentifierAuthority.Value[4] := StrToInt(AnsiHexPrefix + Authority[11] + Authority[12]); 555 | ASID^.IdentifierAuthority.Value[5] := StrToInt(AnsiHexPrefix + Authority[13] + Authority[14]); 556 | end 557 | else 558 | begin 559 | ASID^.IdentifierAuthority.Value[0] := 0; 560 | ASID^.IdentifierAuthority.Value[1] := 0; 561 | AuthorityValue := StrToInt(Authority); 562 | ASID^.IdentifierAuthority.Value[2] := (AuthorityValue and $FF000000) shr 24; 563 | ASID^.IdentifierAuthority.Value[3] := (AuthorityValue and $00FF0000) shr 16; 564 | ASID^.IdentifierAuthority.Value[4] := (AuthorityValue and $0000FF00) shr 8; 565 | ASID^.IdentifierAuthority.Value[5] := AuthorityValue and $000000FF; 566 | end; 567 | 568 | CurrentPos := TempPos + 1; 569 | ASID^.SubAuthorityCount := 0; 570 | 571 | while CurrentPos > 1 do 572 | begin 573 | TempPos := StrFind('-', SIDString, CurrentPos); 574 | 575 | Inc(RequiredSize, SizeOf(DWORD)); // _SID.SubAuthority[x] 576 | if cbSID < RequiredSize then 577 | raise EJclSecurityError.CreateRes(@RsSIDBufferTooSmall); 578 | 579 | if TempPos = 0 then 580 | Authority := Copy(SIDString, CurrentPos, Length(SIDString) - CurrentPos + 1) 581 | else 582 | Authority := Copy(SIDString, CurrentPos, TempPos - CurrentPos); 583 | 584 | {$R-} 585 | ASID^.SubAuthority[ASID^.SubAuthorityCount] := StrToInt64(Authority); 586 | {$IFDEF RANGECHECKS_ON} 587 | {$R+} 588 | {$ENDIF RANGECHECKS_ON} 589 | Inc(ASID^.SubAuthorityCount); 590 | 591 | CurrentPos := TempPos + 1; 592 | end; 593 | end; 594 | 595 | //=== Computer Information =================================================== 596 | 597 | function LsaNTCheck(NTResult: Cardinal) : Cardinal; 598 | var 599 | WinError: Cardinal; 600 | begin 601 | Result := NTResult; 602 | if ($C0000000 and Cardinal(NTResult)) = $C0000000 then 603 | begin 604 | WinError := LsaNtStatusToWinError(NTResult); 605 | if WinError <> ERROR_SUCCESS then 606 | raise EJclSecurityError.CreateResFmt(@RsLsaError, [NTResult, SysErrorMessage(WinError)]); 607 | end; 608 | end; 609 | 610 | function GetComputerSID(SID: PSID; cbSID: DWORD): Boolean; 611 | var 612 | ObjectAttributes: TLsaObjectAttributes; 613 | PolicyHandle: TLsaHandle; 614 | Info: PPolicyAccountDomainInfo; 615 | begin 616 | if IsWinNT then 617 | begin 618 | ZeroMemory(@ObjectAttributes,SizeOf(ObjectAttributes)); 619 | 620 | LsaNTCheck(LsaOpenPolicy(nil, // Use local system 621 | ObjectAttributes, //Object attributes. 622 | POLICY_VIEW_LOCAL_INFORMATION, // We're just looking 623 | PolicyHandle)); //Receives the policy handle. 624 | try 625 | LsaNTCheck(LsaQueryInformationPolicy(PolicyHandle, PolicyAccountDomainInformation, 626 | Pointer(Info))); 627 | try 628 | Result := CopySid(cbSID,SID,Info^.DomainSid); 629 | finally 630 | LsaFreeMemory(Info); 631 | end; 632 | finally 633 | LsaClose(PolicyHandle); 634 | end; 635 | end 636 | else 637 | Result := False; // Win9x 638 | end; 639 | 640 | //=== Windows Vista/Server 2008 UAC (User Account Control) =================== 641 | 642 | function IsUACEnabled: Boolean; 643 | begin 644 | Result := (IsWinVista or IsWinServer2008) and 645 | RegReadBoolDef(HKLM, '\Software\Microsoft\Windows\CurrentVersion\Policies\System', 'EnableLUA', False); 646 | end; 647 | 648 | // source: Vista elevator from the Code Project 649 | function IsElevated: Boolean; 650 | const 651 | TokenElevation = TTokenInformationClass(20); 652 | type 653 | TOKEN_ELEVATION = record 654 | TokenIsElevated: DWORD; 655 | end; 656 | var 657 | TokenHandle: THandle; 658 | ResultLength: Cardinal; 659 | ATokenElevation: TOKEN_ELEVATION; 660 | begin 661 | if IsWinVista or IsWinServer2008 then 662 | begin 663 | if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, TokenHandle) then 664 | begin 665 | try 666 | if GetTokenInformation(TokenHandle, TokenElevation, @ATokenElevation, SizeOf(ATokenElevation), ResultLength) then 667 | Result := ATokenElevation.TokenIsElevated <> 0 668 | else 669 | Result := False; 670 | finally 671 | CloseHandle(TokenHandle); 672 | end; 673 | end 674 | else 675 | Result := False; 676 | end 677 | else 678 | Result := IsAdministrator; 679 | end; 680 | 681 | {$IFDEF UNITVERSIONING} 682 | initialization 683 | RegisterUnitVersion(HInstance, UnitVersioning); 684 | 685 | finalization 686 | UnregisterUnitVersion(HInstance); 687 | {$ENDIF UNITVERSIONING} 688 | 689 | end. 690 | -------------------------------------------------------------------------------- /JCL/JclSysInfo.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tmcdos/VCL-explorer/60e3774c4bfd14c833d79eb67051b6d52069d6c7/JCL/JclSysInfo.pas -------------------------------------------------------------------------------- /JCL/JclSysUtils.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tmcdos/VCL-explorer/60e3774c4bfd14c833d79eb67051b6d52069d6c7/JCL/JclSysUtils.pas -------------------------------------------------------------------------------- /JCL/Snmp.pas: -------------------------------------------------------------------------------- 1 | {**************************************************************************************************} 2 | { } 3 | { Borland Delphi Runtime Library } 4 | { SNMP functions interface unit } 5 | { } 6 | { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License") } 7 | { you may not use this file except in compliance with the License. You may obtain a copy of the } 8 | { License at http://www.mozilla.org/MPL/ } 9 | { } 10 | { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } 11 | { ANY KIND, either express or implied. See the License for the specific language governing rights } 12 | { and limitations under the License. } 13 | { } 14 | { The Original Code is: snmp.h. } 15 | { The Initial Developer of the Original Code is Microsoft. Portions created by Microsoft are } 16 | { Copyright (C) 1992-1999 Microsoft Corporation. All Rights Reserved. } 17 | { } 18 | { The Original Pascal code is: Snmp.pas, released 2001-10-05. } 19 | { The Initial Developer of the Original Pascal code is Petr Vones } 20 | { (petrdott v att mujmail dott cz). Portions created by Petr Vones are Copyright (C) 2001 Petr } 21 | { Vones. All Rights Reserved. } 22 | { } 23 | { Obtained through: } 24 | { Joint Endeavour of Delphi Innovators (Project JEDI) } 25 | { } 26 | { You may retrieve the latest version of this file at the Project JEDI homepage, located at } 27 | { http://delphi-jedi.org } 28 | { } 29 | { Contributor(s): } 30 | { } 31 | {**************************************************************************************************} 32 | { } 33 | { Last modified: $Date:: 2007-09-17 23:41:02 +0200 (lun., 17 sept. 2007) $ } 34 | { Revision: $Rev:: 2175 $ } 35 | { Author: $Author:: outchy $ } 36 | { } 37 | {**************************************************************************************************} 38 | 39 | unit Snmp; 40 | 41 | interface 42 | 43 | {$I jcl.inc} 44 | 45 | {$DEFINE SNMP_DYNAMIC_LINK} 46 | {$DEFINE SNMP_DYNAMIC_LINK_EXPLICIT} 47 | {$DEFINE SNMPSTRICT} 48 | 49 | {$ALIGN ON} 50 | {$MINENUMSIZE 4} 51 | {$IFNDEF SNMP_DYNAMIC_LINK} 52 | {$IFDEF SUPPORTS_WEAKPACKAGEUNIT} 53 | {$WEAKPACKAGEUNIT ON} 54 | {$ENDIF SUPPORTS_WEAKPACKAGEUNIT} 55 | {$ENDIF ~SNMP_DYNAMIC_LINK} 56 | 57 | uses 58 | Windows, SysUtils; 59 | 60 | (*$HPPEMIT '#include '*) 61 | 62 | type 63 | PAsnOctetString = ^TAsnOctetString; 64 | TAsnOctetString = record 65 | stream: PChar; 66 | length: UINT; 67 | dynamic_: Boolean; 68 | end; 69 | 70 | PAsnObjectIdentifier = ^TAsnObjectIdentifier; 71 | TAsnObjectIdentifier = record 72 | idLength: UINT; 73 | ids: PUINT; 74 | end; 75 | 76 | TAsnInteger32 = LongInt; 77 | {$EXTERNALSYM TAsnInteger32} 78 | TAsnUnsigned32 = ULONG; 79 | {$EXTERNALSYM TAsnUnsigned32} 80 | TAsnCounter64 = ULARGE_INTEGER; 81 | {$EXTERNALSYM TAsnCounter64} 82 | TAsnCounter32 = TAsnUnsigned32; 83 | {$EXTERNALSYM TAsnCounter32} 84 | TAsnGauge32 = TAsnUnsigned32; 85 | {$EXTERNALSYM TAsnGauge32} 86 | TAsnTimeticks = TAsnUnsigned32; 87 | {$EXTERNALSYM TAsnTimeticks} 88 | TAsnBits = TAsnOctetString; 89 | {$EXTERNALSYM TAsnBits} 90 | TAsnSequence = TAsnOctetString; 91 | {$EXTERNALSYM TAsnSequence} 92 | TAsnImplicitSequence = TAsnOctetString; 93 | {$EXTERNALSYM TAsnImplicitSequence} 94 | TAsnIPAddress = TAsnOctetString; 95 | {$EXTERNALSYM TAsnIPAddress} 96 | TAsnNetworkAddress = TAsnOctetString; 97 | {$EXTERNALSYM TAsnNetworkAddress} 98 | TAsnDisplayString = TAsnOctetString; 99 | {$EXTERNALSYM TAsnDisplayString} 100 | TAsnOpaque = TAsnOctetString; 101 | {$EXTERNALSYM TAsnOpaque} 102 | 103 | PAsnAny = ^TAsnAny; 104 | TAsnAny = record 105 | asnType: Byte; 106 | case Integer of 107 | 0: (number: TAsnInteger32); // ASN_INTEGER, ASN_INTEGER32 108 | 1: (unsigned32: TAsnUnsigned32); // ASN_UNSIGNED32 109 | 2: (counter64: TAsnCounter64); // ASN_COUNTER64 110 | 3: (string_: TAsnOctetString); // ASN_OCTETSTRING 111 | 4: (bits: TAsnBits); // ASN_BITS 112 | 5: (object_: TAsnObjectIdentifier); // ASN_OBJECTIDENTIFIER 113 | 6: (sequence: TAsnSequence); // ASN_SEQUENCE 114 | 7: (address: TAsnIPAddress); // ASN_IPADDRESS 115 | 8: (counter: TAsnCounter32); // ASN_COUNTER32 116 | 9: (gauge: TAsnGauge32); // ASN_GAUGE32 117 | 10: (ticks: TAsnTimeticks); // ASN_TIMETICKS 118 | 11: (arbitrary: TAsnOpaque); // ASN_OPAQUE 119 | end; 120 | 121 | TAsnObjectName = TAsnObjectIdentifier; 122 | TAsnObjectSyntax = TAsnAny; 123 | 124 | PSnmpVarBind = ^TSnmpVarBind; 125 | TSnmpVarBind = record 126 | name: TAsnObjectName; 127 | value: TAsnObjectSyntax; 128 | end; 129 | 130 | PSnmpVarBindList = ^TSnmpVarBindList; 131 | TSnmpVarBindList = record 132 | list: PSnmpVarBind; 133 | len: UINT; 134 | end; 135 | 136 | const 137 | 138 | { ASN/BER Base Types } 139 | 140 | ASN_UNIVERSAL = $00; 141 | {$EXTERNALSYM ASN_UNIVERSAL} 142 | ASN_APPLICATION = $40; 143 | {$EXTERNALSYM ASN_APPLICATION} 144 | ASN_CONTEXT = $80; 145 | {$EXTERNALSYM ASN_CONTEXT} 146 | ASN_PRIVATE = $C0; 147 | {$EXTERNALSYM ASN_PRIVATE} 148 | 149 | ASN_PRIMITIVE = $00; 150 | {$EXTERNALSYM ASN_PRIMITIVE} 151 | ASN_CONSTRUCTOR = $20; 152 | {$EXTERNALSYM ASN_CONSTRUCTOR} 153 | 154 | { PDU Type Values } 155 | 156 | SNMP_PDU_GET = (ASN_CONTEXT or ASN_CONSTRUCTOR or $0); 157 | {$EXTERNALSYM SNMP_PDU_GET} 158 | SNMP_PDU_GETNEXT = (ASN_CONTEXT or ASN_CONSTRUCTOR or $1); 159 | {$EXTERNALSYM SNMP_PDU_GETNEXT} 160 | SNMP_PDU_RESPONSE = (ASN_CONTEXT or ASN_CONSTRUCTOR or $2); 161 | {$EXTERNALSYM SNMP_PDU_RESPONSE} 162 | SNMP_PDU_SET = (ASN_CONTEXT or ASN_CONSTRUCTOR or $3); 163 | {$EXTERNALSYM SNMP_PDU_SET} 164 | SNMP_PDU_V1TRAP = (ASN_CONTEXT or ASN_CONSTRUCTOR or $4); 165 | {$EXTERNALSYM SNMP_PDU_V1TRAP} 166 | SNMP_PDU_GETBULK = (ASN_CONTEXT or ASN_CONSTRUCTOR or $5); 167 | {$EXTERNALSYM SNMP_PDU_GETBULK} 168 | SNMP_PDU_INFORM = (ASN_CONTEXT or ASN_CONSTRUCTOR or $6); 169 | {$EXTERNALSYM SNMP_PDU_INFORM} 170 | SNMP_PDU_TRAP = (ASN_CONTEXT or ASN_CONSTRUCTOR or $7); 171 | {$EXTERNALSYM SNMP_PDU_TRAP} 172 | 173 | { SNMP Simple Syntax Values } 174 | 175 | ASN_INTEGER = (ASN_UNIVERSAL or ASN_PRIMITIVE or $02); 176 | {$EXTERNALSYM ASN_INTEGER} 177 | ASN_BITS = (ASN_UNIVERSAL or ASN_PRIMITIVE or $03); 178 | {$EXTERNALSYM ASN_BITS} 179 | ASN_OCTETSTRING = (ASN_UNIVERSAL or ASN_PRIMITIVE or $04); 180 | {$EXTERNALSYM ASN_OCTETSTRING} 181 | ASN_NULL = (ASN_UNIVERSAL or ASN_PRIMITIVE or $05); 182 | {$EXTERNALSYM ASN_NULL} 183 | ASN_OBJECTIDENTIFIER = (ASN_UNIVERSAL or ASN_PRIMITIVE or $06); 184 | {$EXTERNALSYM ASN_OBJECTIDENTIFIER} 185 | ASN_INTEGER32 = ASN_INTEGER; 186 | {$EXTERNALSYM ASN_INTEGER32} 187 | 188 | { SNMP Constructor Syntax Values } 189 | 190 | ASN_SEQUENCE = (ASN_UNIVERSAL or ASN_CONSTRUCTOR or $10); 191 | {$EXTERNALSYM ASN_SEQUENCE} 192 | ASN_SEQUENCEOF = ASN_SEQUENCE; 193 | {$EXTERNALSYM ASN_SEQUENCEOF} 194 | 195 | { SNMP Application Syntax Values } 196 | 197 | ASN_IPADDRESS = (ASN_APPLICATION or ASN_PRIMITIVE or $00); 198 | {$EXTERNALSYM ASN_IPADDRESS} 199 | ASN_COUNTER32 = (ASN_APPLICATION or ASN_PRIMITIVE or $01); 200 | {$EXTERNALSYM ASN_COUNTER32} 201 | ASN_GAUGE32 = (ASN_APPLICATION or ASN_PRIMITIVE or $02); 202 | {$EXTERNALSYM ASN_GAUGE32} 203 | ASN_TIMETICKS = (ASN_APPLICATION or ASN_PRIMITIVE or $03); 204 | {$EXTERNALSYM ASN_TIMETICKS} 205 | ASN_OPAQUE = (ASN_APPLICATION or ASN_PRIMITIVE or $04); 206 | {$EXTERNALSYM ASN_OPAQUE} 207 | ASN_COUNTER64 = (ASN_APPLICATION or ASN_PRIMITIVE or $06); 208 | {$EXTERNALSYM ASN_COUNTER64} 209 | ASN_UNSIGNED32 = (ASN_APPLICATION or ASN_PRIMITIVE or $07); 210 | {$EXTERNALSYM ASN_UNSIGNED32} 211 | 212 | { SNMP Exception Conditions } 213 | 214 | SNMP_EXCEPTION_NOSUCHOBJECT = (ASN_CONTEXT or ASN_PRIMITIVE or $00); 215 | {$EXTERNALSYM SNMP_EXCEPTION_NOSUCHOBJECT} 216 | SNMP_EXCEPTION_NOSUCHINSTANCE = (ASN_CONTEXT or ASN_PRIMITIVE or $01); 217 | {$EXTERNALSYM SNMP_EXCEPTION_NOSUCHINSTANCE} 218 | SNMP_EXCEPTION_ENDOFMIBVIEW = (ASN_CONTEXT or ASN_PRIMITIVE or $02); 219 | {$EXTERNALSYM SNMP_EXCEPTION_ENDOFMIBVIEW} 220 | 221 | { SNMP Request Types (used in SnmpExtensionQueryEx) } 222 | 223 | SNMP_EXTENSION_GET = SNMP_PDU_GET; 224 | {$EXTERNALSYM SNMP_EXTENSION_GET} 225 | SNMP_EXTENSION_GET_NEXT = SNMP_PDU_GETNEXT; 226 | {$EXTERNALSYM SNMP_EXTENSION_GET_NEXT} 227 | SNMP_EXTENSION_GET_BULK = SNMP_PDU_GETBULK; 228 | {$EXTERNALSYM SNMP_EXTENSION_GET_BULK} 229 | SNMP_EXTENSION_SET_TEST = (ASN_PRIVATE or ASN_CONSTRUCTOR or $0); 230 | {$EXTERNALSYM SNMP_EXTENSION_SET_TEST} 231 | SNMP_EXTENSION_SET_COMMIT = SNMP_PDU_SET; 232 | {$EXTERNALSYM SNMP_EXTENSION_SET_COMMIT} 233 | SNMP_EXTENSION_SET_UNDO = (ASN_PRIVATE or ASN_CONSTRUCTOR or $1); 234 | {$EXTERNALSYM SNMP_EXTENSION_SET_UNDO} 235 | SNMP_EXTENSION_SET_CLEANUP = (ASN_PRIVATE or ASN_CONSTRUCTOR or $2); 236 | {$EXTERNALSYM SNMP_EXTENSION_SET_CLEANUP} 237 | 238 | { SNMP Error Codes } 239 | 240 | SNMP_ERRORSTATUS_NOERROR = 0; 241 | {$EXTERNALSYM SNMP_ERRORSTATUS_NOERROR} 242 | SNMP_ERRORSTATUS_TOOBIG = 1; 243 | {$EXTERNALSYM SNMP_ERRORSTATUS_TOOBIG} 244 | SNMP_ERRORSTATUS_NOSUCHNAME = 2; 245 | {$EXTERNALSYM SNMP_ERRORSTATUS_NOSUCHNAME} 246 | SNMP_ERRORSTATUS_BADVALUE = 3; 247 | {$EXTERNALSYM SNMP_ERRORSTATUS_BADVALUE} 248 | SNMP_ERRORSTATUS_READONLY = 4; 249 | {$EXTERNALSYM SNMP_ERRORSTATUS_READONLY} 250 | SNMP_ERRORSTATUS_GENERR = 5; 251 | {$EXTERNALSYM SNMP_ERRORSTATUS_GENERR} 252 | SNMP_ERRORSTATUS_NOACCESS = 6; 253 | {$EXTERNALSYM SNMP_ERRORSTATUS_NOACCESS} 254 | SNMP_ERRORSTATUS_WRONGTYPE = 7; 255 | {$EXTERNALSYM SNMP_ERRORSTATUS_WRONGTYPE} 256 | SNMP_ERRORSTATUS_WRONGLENGTH = 8; 257 | {$EXTERNALSYM SNMP_ERRORSTATUS_WRONGLENGTH} 258 | SNMP_ERRORSTATUS_WRONGENCODING = 9; 259 | {$EXTERNALSYM SNMP_ERRORSTATUS_WRONGENCODING} 260 | SNMP_ERRORSTATUS_WRONGVALUE = 10; 261 | {$EXTERNALSYM SNMP_ERRORSTATUS_WRONGVALUE} 262 | SNMP_ERRORSTATUS_NOCREATION = 11; 263 | {$EXTERNALSYM SNMP_ERRORSTATUS_NOCREATION} 264 | SNMP_ERRORSTATUS_INCONSISTENTVALUE = 12; 265 | {$EXTERNALSYM SNMP_ERRORSTATUS_INCONSISTENTVALUE} 266 | SNMP_ERRORSTATUS_RESOURCEUNAVAILABLE = 13; 267 | {$EXTERNALSYM SNMP_ERRORSTATUS_RESOURCEUNAVAILABLE} 268 | SNMP_ERRORSTATUS_COMMITFAILED = 14; 269 | {$EXTERNALSYM SNMP_ERRORSTATUS_COMMITFAILED} 270 | SNMP_ERRORSTATUS_UNDOFAILED = 15; 271 | {$EXTERNALSYM SNMP_ERRORSTATUS_UNDOFAILED} 272 | SNMP_ERRORSTATUS_AUTHORIZATIONERROR = 16; 273 | {$EXTERNALSYM SNMP_ERRORSTATUS_AUTHORIZATIONERROR} 274 | SNMP_ERRORSTATUS_NOTWRITABLE = 17; 275 | {$EXTERNALSYM SNMP_ERRORSTATUS_NOTWRITABLE} 276 | SNMP_ERRORSTATUS_INCONSISTENTNAME = 18; 277 | {$EXTERNALSYM SNMP_ERRORSTATUS_INCONSISTENTNAME} 278 | 279 | { SNMPv1 Trap Types } 280 | 281 | SNMP_GENERICTRAP_COLDSTART = 0; 282 | {$EXTERNALSYM SNMP_GENERICTRAP_COLDSTART} 283 | SNMP_GENERICTRAP_WARMSTART = 1; 284 | {$EXTERNALSYM SNMP_GENERICTRAP_WARMSTART} 285 | SNMP_GENERICTRAP_LINKDOWN = 2; 286 | {$EXTERNALSYM SNMP_GENERICTRAP_LINKDOWN} 287 | SNMP_GENERICTRAP_LINKUP = 3; 288 | {$EXTERNALSYM SNMP_GENERICTRAP_LINKUP} 289 | SNMP_GENERICTRAP_AUTHFAILURE = 4; 290 | {$EXTERNALSYM SNMP_GENERICTRAP_AUTHFAILURE} 291 | SNMP_GENERICTRAP_EGPNEIGHLOSS = 5; 292 | {$EXTERNALSYM SNMP_GENERICTRAP_EGPNEIGHLOSS} 293 | SNMP_GENERICTRAP_ENTERSPECIFIC = 6; 294 | {$EXTERNALSYM SNMP_GENERICTRAP_ENTERSPECIFIC} 295 | 296 | { SNMP Access Types } 297 | 298 | SNMP_ACCESS_NONE = 0; 299 | {$EXTERNALSYM SNMP_ACCESS_NONE} 300 | SNMP_ACCESS_NOTIFY = 1; 301 | {$EXTERNALSYM SNMP_ACCESS_NOTIFY} 302 | SNMP_ACCESS_READ_ONLY = 2; 303 | {$EXTERNALSYM SNMP_ACCESS_READ_ONLY} 304 | SNMP_ACCESS_READ_WRITE = 3; 305 | {$EXTERNALSYM SNMP_ACCESS_READ_WRITE} 306 | SNMP_ACCESS_READ_CREATE = 4; 307 | {$EXTERNALSYM SNMP_ACCESS_READ_CREATE} 308 | 309 | { SNMP API Return Code Definitions } 310 | 311 | type 312 | SNMPAPI = Integer; 313 | {$EXTERNALSYM SNMPAPI} 314 | const 315 | SNMPAPI_NOERROR = True; 316 | {$EXTERNALSYM SNMPAPI_NOERROR} 317 | SNMPAPI_ERROR = False; 318 | {$EXTERNALSYM SNMPAPI_ERROR} 319 | 320 | { SNMP Extension API Type Definitions } 321 | 322 | type 323 | TSnmpExtensionInit = function (dwUptimeReference: DWORD; var phSubagentTrapEvent: THandle; 324 | var pFirstSupportedRegion: PAsnObjectIdentifier): Boolean; stdcall; 325 | 326 | TSnmpExtensionInitEx = function (var pNextSupportedRegion: PAsnObjectIdentifier): Boolean; stdcall; 327 | 328 | TSnmpExtensionMonitor = function (pAgentMgmtData: Pointer): Boolean; stdcall; 329 | 330 | TSnmpExtensionQuery = function (bPduType: Byte; var pVarBindList: TSnmpVarBindList; 331 | var pErrorStatus: TAsnInteger32; var pErrorIndex: TAsnInteger32): Boolean; stdcall; 332 | 333 | TSnmpExtensionQueryEx = function (nRequestType: UINT; nTransactionId: UINT; var pVarBindList: PSnmpVarBindList; 334 | var pContextInfo: PAsnOctetString; var pErrorStatus: TAsnInteger32; var pErrorIndex: TAsnInteger32): Boolean; stdcall; 335 | 336 | TSnmpExtensionTrap = function (pEnterpriseOid: PAsnObjectIdentifier; var pGenericTrapId: TAsnInteger32; 337 | var pSpecificTrapId: TAsnInteger32; var pTimeStamp: TAsnTimeticks; var pVarBindList: PSnmpVarBindList): Boolean; stdcall; 338 | 339 | TSnmpExtensionClose = procedure; stdcall; 340 | 341 | { SNMP API Prototypes } 342 | 343 | {$IFDEF SNMP_DYNAMIC_LINK} 344 | 345 | var 346 | SnmpUtilOidCpy: function(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall; 347 | SnmpUtilOidAppend: function(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall; 348 | SnmpUtilOidNCmp: function(pOid1, pOid2: PAsnObjectIdentifier; nSubIds: UINT): SNMPAPI; stdcall; 349 | SnmpUtilOidCmp: function(pOid1, pOid2: PAsnObjectIdentifier): SNMPAPI; stdcall; 350 | SnmpUtilOidFree: procedure(pOid: TAsnObjectIdentifier); stdcall; 351 | SnmpUtilOctetsCmp: function(pOctets1, pOctets2: PAsnOctetString): SNMPAPI; stdcall; 352 | SnmpUtilOctetsNCmp: function(pOctets1, pOctets2: PAsnOctetString; nChars: UINT): SNMPAPI; stdcall; 353 | SnmpUtilOctetsCpy: function(pOctetsDst, pOctetsSrc: PAsnOctetString): SNMPAPI; stdcall; 354 | SnmpUtilOctetsFree: procedure(pOctets: PAsnOctetString); stdcall; 355 | SnmpUtilAsnAnyCpy: function(pAnyDst, pAnySrc: PAsnAny): SNMPAPI; stdcall; 356 | SnmpUtilAsnAnyFree: procedure(pAny: PAsnAny); stdcall; 357 | SnmpUtilVarBindCpy: function(pVbDst: PSnmpVarBind; pVbSrc: PSnmpVarBind): SNMPAPI; stdcall; 358 | SnmpUtilVarBindFree: procedure(pVb: PSnmpVarBind); stdcall; 359 | SnmpUtilVarBindListCpy: function(pVblDst: PSnmpVarBindList; pVblSrc: PSnmpVarBindList): SNMPAPI; stdcall; 360 | SnmpUtilVarBindListFree: procedure(pVbl: PSnmpVarBindList); stdcall; 361 | SnmpUtilMemFree: procedure(pMem: Pointer); stdcall; 362 | SnmpUtilMemAlloc: function(nBytes: UINT): Pointer; stdcall; 363 | SnmpUtilMemReAlloc: function(pMem: Pointer; nBytes: UINT): Pointer; stdcall; 364 | SnmpUtilOidToA: function(Oid: PAsnObjectIdentifier): PChar; stdcall; 365 | SnmpUtilIdsToA: function(Ids: PUINT; IdLength: UINT): PChar; stdcall; 366 | SnmpUtilPrintOid: procedure(Oid: PAsnObjectIdentifier); stdcall; 367 | SnmpUtilPrintAsnAny: procedure(pAny: PAsnAny); stdcall; 368 | SnmpSvcGetUptime: function: DWORD; stdcall; 369 | SnmpSvcSetLogLevel: procedure(nLogLevel: Integer); stdcall; 370 | SnmpSvcSetLogType: procedure(nLogType: Integer); stdcall; 371 | 372 | {$ELSE} 373 | 374 | function SnmpUtilOidCpy(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall; 375 | function SnmpUtilOidAppend(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall; 376 | function SnmpUtilOidNCmp(pOid1, pOid2: PAsnObjectIdentifier; nSubIds: UINT): SNMPAPI; stdcall; 377 | function SnmpUtilOidCmp(pOid1, pOid2: PAsnObjectIdentifier): SNMPAPI; stdcall; 378 | procedure SnmpUtilOidFree(pOid: TAsnObjectIdentifier); stdcall; 379 | function SnmpUtilOctetsCmp(pOctets1, pOctets2: PAsnOctetString): SNMPAPI; stdcall; 380 | function SnmpUtilOctetsNCmp(pOctets1, pOctets2: PAsnOctetString; nChars: UINT): SNMPAPI; stdcall; 381 | function SnmpUtilOctetsCpy(pOctetsDst, pOctetsSrc: PAsnOctetString): SNMPAPI; stdcall; 382 | procedure SnmpUtilOctetsFree(pOctets: PAsnOctetString); stdcall; 383 | function SnmpUtilAsnAnyCpy(pAnyDst, pAnySrc: PAsnAny): SNMPAPI; stdcall; 384 | procedure SnmpUtilAsnAnyFree(pAny: PAsnAny); stdcall; 385 | function SnmpUtilVarBindCpy(pVbDst: PSnmpVarBind; pVbSrc: PSnmpVarBind): SNMPAPI; stdcall; 386 | procedure SnmpUtilVarBindFree(pVb: PSnmpVarBind); stdcall; 387 | function SnmpUtilVarBindListCpy(pVblDst: PSnmpVarBindList; pVblSrc: PSnmpVarBindList): SNMPAPI; stdcall; 388 | procedure SnmpUtilVarBindListFree(pVbl: PSnmpVarBindList); stdcall; 389 | procedure SnmpUtilMemFree(pMem: Pointer); stdcall; 390 | function SnmpUtilMemAlloc(nBytes: UINT): Pointer; stdcall; 391 | function SnmpUtilMemReAlloc(pMem: Pointer; nBytes: UINT): Pointer; stdcall; 392 | function SnmpUtilOidToA(Oid: PAsnObjectIdentifier): PChar; stdcall; 393 | function SnmpUtilIdsToA(Ids: PUINT; IdLength: UINT): PChar; stdcall; 394 | procedure SnmpUtilPrintOid(Oid: PAsnObjectIdentifier); stdcall; 395 | procedure SnmpUtilPrintAsnAny(pAny: PAsnAny); stdcall; 396 | function SnmpSvcGetUptime: DWORD; stdcall; 397 | procedure SnmpSvcSetLogLevel(nLogLevel: Integer); stdcall; 398 | procedure SnmpSvcSetLogType(nLogType: Integer); stdcall; 399 | 400 | {$ENDIF SNMP_DYNAMIC_LINK} 401 | 402 | {$EXTERNALSYM SnmpUtilOidCpy} 403 | {$EXTERNALSYM SnmpUtilOidAppend} 404 | {$EXTERNALSYM SnmpUtilOidNCmp} 405 | {$EXTERNALSYM SnmpUtilOidCmp} 406 | {$EXTERNALSYM SnmpUtilOidFree} 407 | {$EXTERNALSYM SnmpUtilOctetsCmp} 408 | {$EXTERNALSYM SnmpUtilOctetsNCmp} 409 | {$EXTERNALSYM SnmpUtilOctetsCpy} 410 | {$EXTERNALSYM SnmpUtilOctetsFree} 411 | {$EXTERNALSYM SnmpUtilAsnAnyCpy} 412 | {$EXTERNALSYM SnmpUtilAsnAnyFree} 413 | {$EXTERNALSYM SnmpUtilVarBindCpy} 414 | {$EXTERNALSYM SnmpUtilVarBindFree} 415 | {$EXTERNALSYM SnmpUtilVarBindListCpy} 416 | {$EXTERNALSYM SnmpUtilVarBindListFree} 417 | {$EXTERNALSYM SnmpUtilMemFree} 418 | {$EXTERNALSYM SnmpUtilMemAlloc} 419 | {$EXTERNALSYM SnmpUtilMemReAlloc} 420 | {$EXTERNALSYM SnmpUtilOidToA} 421 | {$EXTERNALSYM SnmpUtilIdsToA} 422 | {$EXTERNALSYM SnmpUtilPrintOid} 423 | {$EXTERNALSYM SnmpUtilPrintAsnAny} 424 | {$EXTERNALSYM SnmpSvcGetUptime} 425 | {$EXTERNALSYM SnmpSvcSetLogLevel} 426 | {$EXTERNALSYM SnmpSvcSetLogType} 427 | 428 | { SNMP Debugging Definitions } 429 | 430 | const 431 | SNMP_LOG_SILENT = $0; 432 | {$EXTERNALSYM SNMP_LOG_SILENT} 433 | SNMP_LOG_FATAL = $1; 434 | {$EXTERNALSYM SNMP_LOG_FATAL} 435 | SNMP_LOG_ERROR = $2; 436 | {$EXTERNALSYM SNMP_LOG_ERROR} 437 | SNMP_LOG_WARNING = $3; 438 | {$EXTERNALSYM SNMP_LOG_WARNING} 439 | SNMP_LOG_TRACE = $4; 440 | {$EXTERNALSYM SNMP_LOG_TRACE} 441 | SNMP_LOG_VERBOSE = $5; 442 | {$EXTERNALSYM SNMP_LOG_VERBOSE} 443 | 444 | SNMP_OUTPUT_TO_CONSOLE = $1; 445 | {$EXTERNALSYM SNMP_OUTPUT_TO_CONSOLE} 446 | SNMP_OUTPUT_TO_LOGFILE = $2; 447 | {$EXTERNALSYM SNMP_OUTPUT_TO_LOGFILE} 448 | SNMP_OUTPUT_TO_EVENTLOG = $4; // no longer supported 449 | {$EXTERNALSYM SNMP_OUTPUT_TO_EVENTLOG} 450 | SNMP_OUTPUT_TO_DEBUGGER = $8; 451 | {$EXTERNALSYM SNMP_OUTPUT_TO_DEBUGGER} 452 | 453 | { SNMP Debugging Prototypes } 454 | 455 | {$IFNDEF SNMP_DYNAMIC_LINK} 456 | 457 | procedure SnmpUtilDbgPrint(nLogLevel: Integer; szFormat: PChar); stdcall; 458 | 459 | {$ELSE SNMP_DYNAMIC_LINK} 460 | 461 | var 462 | SnmpUtilDbgPrint: procedure (nLogLevel: Integer; szFormat: PChar); stdcall; 463 | 464 | {$ENDIF ~SNMP_DYNAMIC_LINK} 465 | 466 | {$EXTERNALSYM SnmpUtilDbgPrint} 467 | 468 | { Miscellaneous definitions } 469 | 470 | const 471 | DEFINE_NULLOID: TAsnObjectIdentifier = (idLength: 0; ids: nil); 472 | {$EXTERNALSYM DEFINE_NULLOID} 473 | DEFINE_NULLOCTETS: TAsnOctetString = (stream: nil; length: 0; dynamic_: False); 474 | {$EXTERNALSYM DEFINE_NULLOCTETS} 475 | 476 | DEFAULT_SNMP_PORT_UDP = 161; 477 | {$EXTERNALSYM DEFAULT_SNMP_PORT_UDP} 478 | DEFAULT_SNMP_PORT_IPX = 36879; 479 | {$EXTERNALSYM DEFAULT_SNMP_PORT_IPX} 480 | DEFAULT_SNMPTRAP_PORT_UDP = 162; 481 | {$EXTERNALSYM DEFAULT_SNMPTRAP_PORT_UDP} 482 | DEFAULT_SNMPTRAP_PORT_IPX = 36880; 483 | {$EXTERNALSYM DEFAULT_SNMPTRAP_PORT_IPX} 484 | SNMP_MAX_OID_LEN = 128; 485 | {$EXTERNALSYM SNMP_MAX_OID_LEN} 486 | 487 | { API Error Code Definitions } 488 | 489 | SNMP_MEM_ALLOC_ERROR = 1; 490 | {$EXTERNALSYM SNMP_MEM_ALLOC_ERROR} 491 | SNMP_BERAPI_INVALID_LENGTH = 10; 492 | {$EXTERNALSYM SNMP_BERAPI_INVALID_LENGTH} 493 | SNMP_BERAPI_INVALID_TAG = 11; 494 | {$EXTERNALSYM SNMP_BERAPI_INVALID_TAG} 495 | SNMP_BERAPI_OVERFLOW = 12; 496 | {$EXTERNALSYM SNMP_BERAPI_OVERFLOW} 497 | SNMP_BERAPI_SHORT_BUFFER = 13; 498 | {$EXTERNALSYM SNMP_BERAPI_SHORT_BUFFER} 499 | SNMP_BERAPI_INVALID_OBJELEM = 14; 500 | {$EXTERNALSYM SNMP_BERAPI_INVALID_OBJELEM} 501 | SNMP_PDUAPI_UNRECOGNIZED_PDU = 20; 502 | {$EXTERNALSYM SNMP_PDUAPI_UNRECOGNIZED_PDU} 503 | SNMP_PDUAPI_INVALID_ES = 21; 504 | {$EXTERNALSYM SNMP_PDUAPI_INVALID_ES} 505 | SNMP_PDUAPI_INVALID_GT = 22; 506 | {$EXTERNALSYM SNMP_PDUAPI_INVALID_GT} 507 | SNMP_AUTHAPI_INVALID_VERSION = 30; 508 | {$EXTERNALSYM SNMP_AUTHAPI_INVALID_VERSION} 509 | SNMP_AUTHAPI_INVALID_MSG_TYPE = 31; 510 | {$EXTERNALSYM SNMP_AUTHAPI_INVALID_MSG_TYPE} 511 | SNMP_AUTHAPI_TRIV_AUTH_FAILED = 32; 512 | {$EXTERNALSYM SNMP_AUTHAPI_TRIV_AUTH_FAILED} 513 | 514 | { Support for old definitions (support disabled via SNMPSTRICT) } 515 | 516 | {$IFNDEF SNMPSTRICT} 517 | 518 | {$IFNDEF SNMP_DYNAMIC_LINK} 519 | 520 | var 521 | SNMP_oidcpy: function (pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall; 522 | SNMP_oidappend: function (pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall; 523 | SNMP_oidncmp: function (pOid1, pOid2: PAsnObjectIdentifier; nSubIds: UINT): SNMPAPI; stdcall; 524 | SNMP_oidcmp: function (pOid1, pOid2: PAsnObjectIdentifier): SNMPAPI; stdcall; 525 | SNMP_oidfree: procedure (pOid: TAsnObjectIdentifier); stdcall; 526 | 527 | SNMP_CopyVarBind: function (pVbDst: PSnmpVarBind; pVbSrc: PSnmpVarBind): SNMPAPI; stdcall; 528 | SNMP_FreeVarBind: procedure (pVb: PSnmpVarBind); stdcall; 529 | SNMP_CopyVarBindList: function (pVblDst: PSnmpVarBindList; pVblSrc: PSnmpVarBindList): SNMPAPI; stdcall; 530 | SNMP_FreeVarBindList: procedure (pVbl: PSnmpVarBindList); stdcall; 531 | 532 | SNMP_printany: procedure (pAny: PAsnAny); stdcall; 533 | 534 | SNMP_free: procedure (pMem: Pointer); stdcall; 535 | SNMP_malloc: function (nBytes: UINT): Pointer; stdcall; 536 | SNMP_realloc: function (pMem: Pointer; nBytes: UINT): Pointer; stdcall; 537 | 538 | SNMP_DBG_free: procedure (pMem: Pointer); stdcall; 539 | SNMP_DBG_malloc: function (nBytes: UINT): Pointer; stdcall; 540 | SNMP_DBG_realloc: function (pMem: Pointer; nBytes: UINT): Pointer; stdcall; 541 | 542 | {$ELSE} 543 | 544 | function SNMP_oidcpy(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall; 545 | function SNMP_oidappend(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall; 546 | function SNMP_oidncmp(pOid1, pOid2: PAsnObjectIdentifier; nSubIds: UINT): SNMPAPI; stdcall; 547 | function SNMP_oidcmp(pOid1, pOid2: PAsnObjectIdentifier): SNMPAPI; stdcall; 548 | procedure SNMP_oidfree(pOid: TAsnObjectIdentifier); stdcall; 549 | 550 | function SNMP_CopyVarBind(pVbDst: PSnmpVarBind; pVbSrc: PSnmpVarBind): SNMPAPI; stdcall; 551 | procedure SNMP_FreeVarBind(pVb: PSnmpVarBind); stdcall; 552 | function SNMP_CopyVarBindList(pVblDst: PSnmpVarBindList; pVblSrc: PSnmpVarBindList): SNMPAPI; stdcall; 553 | procedure SNMP_FreeVarBindList(pVbl: PSnmpVarBindList); stdcall; 554 | 555 | procedure SNMP_printany(pAny: PAsnAny); stdcall; 556 | 557 | procedure SNMP_free(pMem: Pointer); stdcall; 558 | function SNMP_malloc(nBytes: UINT): Pointer; stdcall; 559 | function SNMP_realloc(pMem: Pointer; nBytes: UINT): Pointer; stdcall; 560 | 561 | procedure SNMP_DBG_free(pMem: Pointer); stdcall; 562 | function SNMP_DBG_malloc(nBytes: UINT): Pointer; stdcall; 563 | function SNMP_DBG_realloc(pMem: Pointer; nBytes: UINT): Pointer; stdcall; 564 | 565 | {$ENDIF SNMP_DYNAMIC_LINK} 566 | 567 | {$EXTERNALSYM SNMP_oidcpy} 568 | {$EXTERNALSYM SNMP_oidappend} 569 | {$EXTERNALSYM SNMP_oidncmp} 570 | {$EXTERNALSYM SNMP_oidcmp} 571 | {$EXTERNALSYM SNMP_oidfree} 572 | 573 | {$EXTERNALSYM SNMP_CopyVarBind} 574 | {$EXTERNALSYM SNMP_FreeVarBind} 575 | {$EXTERNALSYM SNMP_CopyVarBindList} 576 | {$EXTERNALSYM SNMP_FreeVarBindList} 577 | 578 | {$EXTERNALSYM SNMP_printany} 579 | 580 | {$EXTERNALSYM SNMP_free} 581 | {$EXTERNALSYM SNMP_malloc} 582 | {$EXTERNALSYM SNMP_realloc} 583 | 584 | {$EXTERNALSYM SNMP_DBG_free} 585 | {$EXTERNALSYM SNMP_DBG_malloc} 586 | {$EXTERNALSYM SNMP_DBG_realloc} 587 | 588 | const 589 | ASN_RFC1155_IPADDRESS = ASN_IPADDRESS; 590 | {$EXTERNALSYM ASN_RFC1155_IPADDRESS} 591 | ASN_RFC1155_COUNTER = ASN_COUNTER32; 592 | {$EXTERNALSYM ASN_RFC1155_COUNTER} 593 | ASN_RFC1155_GAUGE = ASN_GAUGE32; 594 | {$EXTERNALSYM ASN_RFC1155_GAUGE} 595 | ASN_RFC1155_TIMETICKS = ASN_TIMETICKS; 596 | {$EXTERNALSYM ASN_RFC1155_TIMETICKS} 597 | ASN_RFC1155_OPAQUE = ASN_OPAQUE; 598 | {$EXTERNALSYM ASN_RFC1155_OPAQUE} 599 | ASN_RFC1213_DISPSTRING = ASN_OCTETSTRING; 600 | {$EXTERNALSYM ASN_RFC1213_DISPSTRING} 601 | 602 | ASN_RFC1157_GETREQUEST = SNMP_PDU_GET; 603 | {$EXTERNALSYM ASN_RFC1157_GETREQUEST} 604 | ASN_RFC1157_GETNEXTREQUEST = SNMP_PDU_GETNEXT; 605 | {$EXTERNALSYM ASN_RFC1157_GETNEXTREQUEST} 606 | ASN_RFC1157_GETRESPONSE = SNMP_PDU_RESPONSE; 607 | {$EXTERNALSYM ASN_RFC1157_GETRESPONSE} 608 | ASN_RFC1157_SETREQUEST = SNMP_PDU_SET; 609 | {$EXTERNALSYM ASN_RFC1157_SETREQUEST} 610 | ASN_RFC1157_TRAP = SNMP_PDU_V1TRAP; 611 | {$EXTERNALSYM ASN_RFC1157_TRAP} 612 | 613 | ASN_CONTEXTSPECIFIC = ASN_CONTEXT; 614 | {$EXTERNALSYM ASN_CONTEXTSPECIFIC} 615 | ASN_PRIMATIVE = ASN_PRIMITIVE; 616 | {$EXTERNALSYM ASN_PRIMATIVE} 617 | 618 | type 619 | RFC1157VarBindList = TSnmpVarBindList; 620 | {$EXTERNALSYM RFC1157VarBindList} 621 | RFC1157VarBind = TSnmpVarBind; 622 | {$EXTERNALSYM RFC1157VarBind} 623 | TAsnInteger = TAsnInteger32; 624 | {$EXTERNALSYM TAsnInteger} 625 | TAsnCounter = TAsnCounter32; 626 | {$EXTERNALSYM TAsnCounter} 627 | TAsnGauge = TAsnGauge32; 628 | {$EXTERNALSYM TAsnGauge} 629 | 630 | {$ENDIF ~SNMPSTRICT} 631 | 632 | { SNMP Extension API Prototypes } 633 | 634 | var 635 | SnmpExtensionInit: TSnmpExtensionInit; 636 | {$EXTERNALSYM SnmpExtensionInit} 637 | SnmpExtensionInitEx: TSnmpExtensionInitEx; 638 | {$EXTERNALSYM SnmpExtensionInitEx} 639 | SnmpExtensionMonitor: TSnmpExtensionMonitor; 640 | {$EXTERNALSYM SnmpExtensionMonitor} 641 | SnmpExtensionQuery: TSnmpExtensionQuery; 642 | {$EXTERNALSYM SnmpExtensionQuery} 643 | SnmpExtensionQueryEx: TSnmpExtensionQueryEx; 644 | {$EXTERNALSYM SnmpExtensionQueryEx} 645 | SnmpExtensionTrap: TSnmpExtensionTrap; 646 | {$EXTERNALSYM SnmpExtensionTrap} 647 | SnmpExtensionClose: TSnmpExtensionClose; 648 | {$EXTERNALSYM SnmpExtensionClose} 649 | 650 | function SnmpExtensionLoaded: Boolean; 651 | function LoadSnmpExtension(const LibName: string): Boolean; 652 | function UnloadSnmpExtension: Boolean; 653 | 654 | {$IFDEF SNMP_DYNAMIC_LINK} 655 | function SnmpLoaded: Boolean; 656 | {$IFDEF SNMP_DYNAMIC_LINK_EXPLICIT} 657 | function LoadSnmp: Boolean; 658 | function UnloadSnmp: Boolean; 659 | {$ENDIF SNMP_DYNAMIC_LINK_EXPLICIT} 660 | {$ENDIF SNMP_DYNAMIC_LINK} 661 | 662 | implementation 663 | 664 | const 665 | snmpapilib = 'snmpapi.dll'; 666 | 667 | var 668 | ExtensionLibHandle: THandle; 669 | 670 | function SnmpExtensionLoaded: Boolean; 671 | begin 672 | Result := ExtensionLibHandle <> 0; 673 | end; 674 | 675 | function LoadSnmpExtension(const LibName: string): Boolean; 676 | begin 677 | Result := UnloadSnmpExtension; 678 | if Result then 679 | begin 680 | ExtensionLibHandle := SafeLoadLibrary(LibName); 681 | Result := SnmpExtensionLoaded; 682 | if Result then 683 | begin 684 | @SnmpExtensionInit := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionInit'); 685 | @SnmpExtensionInitEx := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionInitEx'); 686 | @SnmpExtensionMonitor := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionMonitor'); 687 | @SnmpExtensionQuery := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionQuery'); 688 | @SnmpExtensionQueryEx := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionQueryEx'); 689 | @SnmpExtensionTrap := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionTrap'); 690 | @SnmpExtensionClose := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionClose'); 691 | Result := Assigned(SnmpExtensionInit); 692 | if not Result then 693 | UnloadSnmpExtension; 694 | end; 695 | end; 696 | end; 697 | 698 | function UnloadSnmpExtension: Boolean; 699 | begin 700 | if SnmpExtensionLoaded then 701 | begin 702 | Result := FreeLibrary(ExtensionLibHandle); 703 | ExtensionLibHandle := 0; 704 | @SnmpExtensionInit := nil; 705 | @SnmpExtensionInitEx := nil; 706 | @SnmpExtensionMonitor := nil; 707 | @SnmpExtensionQuery := nil; 708 | @SnmpExtensionQueryEx := nil; 709 | @SnmpExtensionTrap := nil; 710 | @SnmpExtensionClose := nil; 711 | end 712 | else 713 | Result := True; 714 | end; 715 | 716 | {$IFDEF SNMP_DYNAMIC_LINK} 717 | 718 | var 719 | SnmpLibHandle: THandle; 720 | 721 | function SnmpLoaded: Boolean; 722 | begin 723 | Result := SnmpLibHandle <> 0; 724 | end; 725 | 726 | function UnloadSnmp: Boolean; 727 | begin 728 | Result := True; 729 | if SnmpLoaded then 730 | begin 731 | Result := FreeLibrary(SnmpLibHandle); 732 | SnmpLibHandle := 0; 733 | @SnmpUtilOidCpy := nil; 734 | @SnmpUtilOidAppend := nil; 735 | @SnmpUtilOidNCmp := nil; 736 | @SnmpUtilOidCmp := nil; 737 | @SnmpUtilOidFree := nil; 738 | @SnmpUtilOctetsCmp := nil; 739 | @SnmpUtilOctetsNCmp := nil; 740 | @SnmpUtilOctetsCpy := nil; 741 | @SnmpUtilOctetsFree := nil; 742 | @SnmpUtilAsnAnyCpy := nil; 743 | @SnmpUtilAsnAnyFree := nil; 744 | @SnmpUtilVarBindCpy := nil; 745 | @SnmpUtilVarBindFree := nil; 746 | @SnmpUtilVarBindListCpy := nil; 747 | @SnmpUtilVarBindListFree := nil; 748 | @SnmpUtilMemFree := nil; 749 | @SnmpUtilMemAlloc := nil; 750 | @SnmpUtilMemReAlloc := nil; 751 | @SnmpUtilOidToA := nil; 752 | @SnmpUtilIdsToA := nil; 753 | @SnmpUtilPrintOid := nil; 754 | @SnmpUtilPrintAsnAny := nil; 755 | @SnmpSvcGetUptime := nil; 756 | @SnmpSvcSetLogLevel := nil; 757 | @SnmpSvcSetLogType := nil; 758 | @SnmpUtilDbgPrint := nil; 759 | {$IFNDEF SNMPSTRICT} 760 | @SNMP_oidcpy := nil; 761 | @SNMP_oidappend := nil; 762 | @SNMP_oidncmp := nil; 763 | @SNMP_oidcmp := nil; 764 | @SNMP_oidfree := nil; 765 | @SNMP_CopyVarBind := nil; 766 | @SNMP_FreeVarBind := nil; 767 | @SNMP_CopyVarBindList := nil; 768 | @SNMP_FreeVarBindList := nil; 769 | @SNMP_printany := nil; 770 | @SNMP_free := nil; 771 | @SNMP_malloc := nil; 772 | @SNMP_realloc := nil; 773 | @SNMP_DBG_free := nil; 774 | @SNMP_DBG_malloc := nil; 775 | @SNMP_DBG_realloc := nil; 776 | {$ENDIF ~SNMPSTRICT} 777 | end; 778 | end; 779 | 780 | function LoadSnmp: Boolean; 781 | begin 782 | Result := SnmpLoaded; 783 | if not Result then 784 | begin 785 | SnmpLibHandle := SafeLoadLibrary(snmpapilib); 786 | if SnmpLoaded then 787 | begin 788 | @SnmpUtilOidCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidCpy'); 789 | @SnmpUtilOidAppend := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidAppend'); 790 | @SnmpUtilOidNCmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidNCmp'); 791 | @SnmpUtilOidCmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidCmp'); 792 | @SnmpUtilOidFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidFree'); 793 | @SnmpUtilOctetsCmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOctetsCmp'); 794 | @SnmpUtilOctetsNCmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOctetsNCmp'); 795 | @SnmpUtilOctetsCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilOctetsCpy'); 796 | @SnmpUtilOctetsFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilOctetsFree'); 797 | @SnmpUtilAsnAnyCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilAsnAnyCpy'); 798 | @SnmpUtilAsnAnyFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilAsnAnyFree'); 799 | @SnmpUtilVarBindCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindCpy'); 800 | @SnmpUtilVarBindFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindFree'); 801 | @SnmpUtilVarBindListCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindListCpy'); 802 | @SnmpUtilVarBindListFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindListFree'); 803 | @SnmpUtilMemFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemFree'); 804 | @SnmpUtilMemAlloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemAlloc'); 805 | @SnmpUtilMemReAlloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemReAlloc'); 806 | @SnmpUtilOidToA := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidToA'); 807 | @SnmpUtilIdsToA := GetProcAddress(SnmpLibHandle, 'SnmpUtilIdsToA'); 808 | @SnmpUtilPrintOid := GetProcAddress(SnmpLibHandle, 'SnmpUtilPrintOid'); 809 | @SnmpUtilPrintAsnAny := GetProcAddress(SnmpLibHandle, 'SnmpUtilPrintAsnAny'); 810 | @SnmpSvcGetUptime := GetProcAddress(SnmpLibHandle, 'SnmpSvcGetUptime'); 811 | @SnmpSvcSetLogLevel := GetProcAddress(SnmpLibHandle, 'SnmpSvcSetLogLevel'); 812 | @SnmpSvcSetLogType := GetProcAddress(SnmpLibHandle, 'SnmpSvcSetLogType'); 813 | @SnmpUtilDbgPrint := GetProcAddress(SnmpLibHandle, 'SnmpUtilDbgPrint'); 814 | {$IFNDEF SNMPSTRICT} 815 | @SNMP_oidcpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidCpy'); 816 | @SNMP_oidappend := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidAppend'); 817 | @SNMP_oidncmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidNCmp'); 818 | @SNMP_oidcmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidCmp'); 819 | @SNMP_oidfree := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidFree'); 820 | @SNMP_CopyVarBind := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindCpy'); 821 | @SNMP_FreeVarBind := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindFree'); 822 | @SNMP_CopyVarBindList := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindListCpy'); 823 | @SNMP_FreeVarBindList := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindListFree'); 824 | @SNMP_printany := GetProcAddress(SnmpLibHandle, 'SnmpUtilPrintAsnAny'); 825 | @SNMP_free := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemFree'); 826 | @SNMP_malloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemAlloc'); 827 | @SNMP_realloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemReAlloc'); 828 | @SNMP_DBG_free := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemFree'); 829 | @SNMP_DBG_malloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemAlloc'); 830 | @SNMP_DBG_realloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemReAlloc'); 831 | {$ENDIF ~SNMPSTRICT} 832 | Result := True; 833 | end; 834 | end; 835 | end; 836 | 837 | {$ELSE} 838 | 839 | function SnmpUtilOidCpy; external snmpapilib name 'SnmpUtilOidCpy'; 840 | function SnmpUtilOidAppend; external snmpapilib name 'SnmpUtilOidAppend'; 841 | function SnmpUtilOidNCmp; external snmpapilib name 'SnmpUtilOidNCmp'; 842 | function SnmpUtilOidCmp; external snmpapilib name 'SnmpUtilOidCmp'; 843 | procedure SnmpUtilOidFree; external snmpapilib name 'SnmpUtilOidFree'; 844 | function SnmpUtilOctetsCmp; external snmpapilib name 'SnmpUtilOctetsCmp'; 845 | function SnmpUtilOctetsNCmp; external snmpapilib name 'SnmpUtilOctetsNCmp'; 846 | function SnmpUtilOctetsCpy; external snmpapilib name 'SnmpUtilOctetsCpy'; 847 | procedure SnmpUtilOctetsFree; external snmpapilib name 'SnmpUtilOctetsFree'; 848 | function SnmpUtilAsnAnyCpy; external snmpapilib name 'SnmpUtilAsnAnyCpy'; 849 | procedure SnmpUtilAsnAnyFree; external snmpapilib name 'SnmpUtilAsnAnyFree'; 850 | function SnmpUtilVarBindCpy; external snmpapilib name 'SnmpUtilVarBindCpy'; 851 | procedure SnmpUtilVarBindFree; external snmpapilib name 'SnmpUtilVarBindFree'; 852 | function SnmpUtilVarBindListCpy; external snmpapilib name 'SnmpUtilVarBindListCpy'; 853 | procedure SnmpUtilVarBindListFree; external snmpapilib name 'SnmpUtilVarBindListFree'; 854 | procedure SnmpUtilMemFree; external snmpapilib name 'SnmpUtilMemFree'; 855 | function SnmpUtilMemAlloc; external snmpapilib name 'SnmpUtilMemAlloc'; 856 | function SnmpUtilMemReAlloc; external snmpapilib name 'SnmpUtilMemReAlloc'; 857 | function SnmpUtilOidToA; external snmpapilib name 'SnmpUtilOidToA'; 858 | function SnmpUtilIdsToA; external snmpapilib name 'SnmpUtilIdsToA'; 859 | procedure SnmpUtilPrintOid; external snmpapilib name 'SnmpUtilPrintOid'; 860 | procedure SnmpUtilPrintAsnAny; external snmpapilib name 'SnmpUtilPrintAsnAny'; 861 | function SnmpSvcGetUptime; external snmpapilib name 'SnmpSvcGetUptime'; 862 | procedure SnmpSvcSetLogLevel; external snmpapilib name 'SnmpSvcSetLogLevel'; 863 | procedure SnmpSvcSetLogType; external snmpapilib name 'SnmpSvcSetLogType'; 864 | procedure SnmpUtilDbgPrint; external snmpapilib name 'SnmpUtilDbgPrint'; 865 | 866 | {$IFNDEF SNMPSTRICT} 867 | function SNMP_oidcpy; external snmpapilib name 'SnmpUtilOidCpy'; 868 | function SNMP_oidappend; external snmpapilib name 'SnmpUtilOidAppend'; 869 | function SNMP_oidncmp; external snmpapilib name 'SnmpUtilOidNCmp'; 870 | function SNMP_oidcmp; external snmpapilib name 'SnmpUtilOidCmp'; 871 | procedure SNMP_oidfree; external snmpapilib name 'SnmpUtilOidFree'; 872 | function SNMP_CopyVarBind; external snmpapilib name 'SnmpUtilVarBindCpy'; 873 | procedure SNMP_FreeVarBind; external snmpapilib name 'SnmpUtilVarBindFree'; 874 | function SNMP_CopyVarBindList; external snmpapilib name 'SnmpUtilVarBindListCpy'; 875 | procedure SNMP_FreeVarBindList; external snmpapilib name 'SnmpUtilVarBindListFree'; 876 | procedure SNMP_printany; external snmpapilib name 'SnmpUtilPrintAsnAny'; 877 | procedure SNMP_free; external snmpapilib name 'SnmpUtilMemFree'; 878 | function SNMP_malloc; external snmpapilib name 'SnmpUtilMemAlloc'; 879 | function SNMP_realloc; external snmpapilib name 'SnmpUtilMemReAlloc'; 880 | procedure SNMP_DBG_free; external snmpapilib name 'SnmpUtilMemFree'; 881 | function SNMP_DBG_malloc; external snmpapilib name 'SnmpUtilMemAlloc'; 882 | function SNMP_DBG_realloc; external snmpapilib name 'SnmpUtilMemReAlloc'; 883 | {$ENDIF ~SNMPSTRICT} 884 | 885 | {$ENDIF SNMP_DYNAMIC_LINK} 886 | 887 | {$IFDEF SNMP_DYNAMIC_LINK} 888 | {$IFNDEF SNMP_DYNAMIC_LINK_EXPLICIT} 889 | 890 | initialization 891 | LoadSnmp; 892 | 893 | finalization 894 | UnloadSnmp; 895 | 896 | {$ENDIF ~SNMP_DYNAMIC_LINK_EXPLICIT} 897 | {$ENDIF SNMP_DYNAMIC_LINK} 898 | 899 | end. 900 | -------------------------------------------------------------------------------- /JCL/crossplatform.inc: -------------------------------------------------------------------------------- 1 | {**************************************************************************************************} 2 | { } 3 | { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License");} 4 | { you may not use this file except in compliance with the License. You may obtain a copy of the } 5 | { License at http://www.mozilla.org/MPL/ } 6 | { } 7 | { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } 8 | { ANY KIND, either express or implied. See the License for the specific language governing rights } 9 | { and limitations under the License. } 10 | { } 11 | { The Original Code is: crossplatform.inc, released on 2004-05-16. } 12 | { } 13 | { You may retrieve the latest version of this file at the JCL home page, } 14 | { located at http://jcl.sourceforge.net/ } 15 | { } 16 | {**************************************************************************************************} 17 | { } 18 | { Last modified: $Date:: 2007-09-17 23:41:02 +0200 (lun., 17 sept. 2007) $ } 19 | { Revision: $Rev:: 2175 $ } 20 | { Author: $Author:: outchy $ } 21 | { } 22 | {**************************************************************************************************} 23 | 24 | // This inc file depends on jedi.inc which has to 25 | // be included first (usually indirectly through 26 | // the inclusion of jcl.inc). 27 | 28 | // Suppress platform warnings which are irrelevant 29 | // because the including unit inherently has to handle 30 | // platform specifics already. 31 | 32 | {$IFDEF SUPPORTS_PLATFORM_WARNINGS} 33 | {$WARN UNIT_PLATFORM OFF} 34 | {$WARN SYMBOL_PLATFORM OFF} 35 | {$ENDIF SUPPORTS_PLATFORM_WARNINGS} -------------------------------------------------------------------------------- /JCL/jcl.inc: -------------------------------------------------------------------------------- 1 | {**************************************************************************************************} 2 | { } 3 | { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License");} 4 | { you may not use this file except in compliance with the License. You may obtain a copy of the } 5 | { License at http://www.mozilla.org/MPL/ } 6 | { } 7 | { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } 8 | { ANY KIND, either express or implied. See the License for the specific language governing rights } 9 | { and limitations under the License. } 10 | { } 11 | { The Original Code is jcl.inc } 12 | { } 13 | { The Initial Developer of the Original Code is Marcel van Brakel. } 14 | { Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. } 15 | { } 16 | { Contributors: } 17 | { Marcel van Brakel } 18 | { Matthias Thoma (mthoma) } 19 | { Petr Vones } 20 | { Robert Marquardt (marquardt) } 21 | { Robert Rossmair (rrossmair) } 22 | { } 23 | {**************************************************************************************************} 24 | { } 25 | { This include file defines various JCL specific defines. The more generic defines are defined in } 26 | { the jedi.inc file which is shared with the JEDI VCL. } 27 | { } 28 | {**************************************************************************************************} 29 | { } 30 | { Last modified: $Date:: 2008-01-30 18:34:47 +0100 (mer., 30 janv. 2008) $ } 31 | { Revision: $Rev:: 2331 $ } 32 | { Author: $Author:: marcovtje $ } 33 | { } 34 | {**************************************************************************************************} 35 | 36 | {$B-} // Boolean shortcut evaluation 37 | {$H+} // Long strings 38 | {$J-} // Read-only typed constants 39 | {$T-} // Type checked pointers off 40 | 41 | {$I jedi.inc} // Pull in the JCL/J-VCL shared directives 42 | 43 | {$IFNDEF JEDI_INC} 44 | ALERT_jedi_inc_incompatible 45 | // secure against old versions of jedi.inc. 46 | {$ENDIF ~JEDI_INC} 47 | 48 | {$IFNDEF JCLINSTALL} 49 | {$IFDEF CLR} 50 | {----------------------------} 51 | { BDS } 52 | {----------------------------} 53 | {$IFDEF BDS3} 54 | {$I jcld9.net.inc} 55 | {$DEFINE JCL_CONFIGURED} 56 | {$ENDIF BDS3} 57 | {----------------------------} 58 | {$IFDEF BDS4} 59 | {$I jcld10.net.inc} 60 | {$DEFINE JCL_CONFIGURED} 61 | {$ENDIF BDS4} 62 | {----------------------------} 63 | {$IFDEF BDS5} 64 | {$I jcld11.net.inc} 65 | {$DEFINE JCL_CONFIGURED} 66 | {$ENDIF BDS5} 67 | {----------------------------} 68 | {$ELSE ~CLR} 69 | {----------------------------} 70 | { Kylix } 71 | {----------------------------} 72 | // KYLIX3 is not defined (version numbers comparisons are wrong) 73 | // won't fix because of possible bug with floating point comparisons 74 | // at compile time 75 | {$IFDEF KYLIX} 76 | {$IFDEF BCB} 77 | {$I jclkc3.inc} 78 | {$ELSE ~BCB} 79 | {$I jclkd3.inc} 80 | {$ENDIF ~BCB} 81 | {$DEFINE JCL_CONFIGURED} 82 | {$ENDIF KYLIX} 83 | {----------------------------} 84 | { C++Builder } 85 | {----------------------------} 86 | {$IFDEF BCB5} 87 | {$I jclc5.inc} 88 | {$DEFINE JCL_CONFIGURED} 89 | {$ENDIF BCB5} 90 | {----------------------------} 91 | {$IFDEF BCB6} 92 | {$I jclc6.inc} 93 | {$DEFINE JCL_CONFIGURED} 94 | {$ENDIF BCB6} 95 | {----------------------------} 96 | { Delphi } 97 | {----------------------------} 98 | {$IFDEF DELPHI5} 99 | {$I jcld5.inc} 100 | {$DEFINE JCL_CONFIGURED} 101 | {$ENDIF DELPIH5} 102 | {----------------------------} 103 | {$IFDEF DELPHI6} 104 | {$I jcld6.inc} 105 | {$DEFINE JCL_CONFIGURED} 106 | {$ENDIF DELPIH6} 107 | {----------------------------} 108 | {$IFDEF DELPHI7} 109 | {$I jcld7.inc} 110 | {$DEFINE JCL_CONFIGURED} 111 | {$ENDIF DELPIH7} 112 | {----------------------------} 113 | { BDS } 114 | {----------------------------} 115 | // BDS 1 and BDS 2 have the same version numbers for their native compilers 116 | // no compiler defines are used for BDS 1 and BDS 2 117 | {$IFDEF BDS1} 118 | //{$I jclcs1.inc} 119 | {$DEFINE JCL_CONFIGURED} 120 | {$ENDIF BDS1} 121 | {----------------------------} 122 | {$IFDEF BDS2} 123 | //{$I jcld8.inc} 124 | {$DEFINE JCL_CONFIGURED} 125 | {$ENDIF BDS2} 126 | {----------------------------} 127 | {$IFDEF BDS3} 128 | {$I jcld9.inc} 129 | {$DEFINE JCL_CONFIGURED} 130 | {$ENDIF BDS3} 131 | {----------------------------} 132 | {$IFDEF BDS4} 133 | {$I jcld10.inc} 134 | {$DEFINE JCL_CONFIGURED} 135 | {$ENDIF BDS4} 136 | {----------------------------} 137 | {$IFDEF BDS5} 138 | {$I jcld11.inc} 139 | {$DEFINE JCL_CONFIGURED} 140 | {$ENDIF BDS5} 141 | {----------------------------} 142 | {$IFDEF FPC} 143 | {$I jclfpc.inc} 144 | {$DEFINE JCL_CONFIGURED} 145 | {$ENDIF FPC} 146 | {----------------------------} 147 | {$ENDIF ~CLR} 148 | 149 | // check configuration 150 | {$IFNDEF JCL_CONFIGURED} 151 | {$IFDEF SUPPORTS_COMPILETIME_MESSAGES} 152 | {$MESSAGE FATAL 'Your Delphi/BCB version is not supported by this JCL version!'} 153 | {$ELSE} 154 | 'Your Delphi/BCB version is not supported by this JCL version!' 155 | {$ENDIF SUPPORTS_COMPILETIME_MESSAGES} 156 | {$ENDIF !JCL_CONFIGURED} 157 | 158 | {$ENDIF ~JCLINSTALL} 159 | 160 | // Math precision selection, mutually exclusive 161 | {$IFDEF MATH_EXTENDED_PRECISION} 162 | {$UNDEF MATH_SINGLE_PRECISION} 163 | {$UNDEF MATH_DOUBLE_PRECISION} 164 | {$ENDIF} 165 | {$IFDEF MATH_DOUBLE_PRECISION} 166 | {$UNDEF MATH_SINGLE_PRECISION} 167 | {$UNDEF MATH_EXTENDED_PRECISION} 168 | {$ENDIF} 169 | {$IFDEF MATH_SINGLE_PRECISION} 170 | {$UNDEF MATH_DOUBLE_PRECISION} 171 | {$UNDEF MATH_EXTENDED_PRECISION} 172 | {$ENDIF} 173 | 174 | {$IFNDEF MATH_EXTENDED_PRECISION} 175 | {$IFNDEF MATH_DOUBLE_PRECISION} 176 | {$IFNDEF MATH_SINGLE_PRECISION} 177 | {$DEFINE MATH_EXTENDED_PRECISION} 178 | {$ENDIF} 179 | {$ENDIF} 180 | {$ENDIF} 181 | 182 | // PCRE options, mutually exclusive 183 | {$IFDEF PCRE_STATICLINK} 184 | {$UNDEF PCRE_LINKDLL} 185 | {$UNDEF PCRE_LINKONREQUEST} 186 | {$ENDIF PCRE_STATICLINK} 187 | {$IFDEF PCRE_LINKDLL} 188 | {$UNDEF PCRE_LINKONREQUEST} 189 | {$ENDIF PCRE_LINKDLL} 190 | 191 | {$IFNDEF PCRE_STATICLINK} 192 | {$IFNDEF PCRE_LINKDLL} 193 | {$IFNDEF PCRE_LINKONREQUEST} 194 | {$DEFINE PCRE_LINKONREQUEST} 195 | {$ENDIF ~PCRE_LINKONREQUEST} 196 | {$ENDIF ~PCRE_LINKDLL} 197 | {$ENDIF ~PCRE_STATICLINK} 198 | 199 | {$IFNDEF PCRE_STATICLINK} 200 | {$DEFINE PCRE_EXPORT_CDECL} 201 | {$ENDIF ~PCRE_STATICLINK} 202 | 203 | // BZip2 options 204 | {$IFDEF BZIP2_STATICLINK} 205 | {$UNDEF BZIP2_LINKDLL} 206 | {$UNDEF BZIP2_LINKONREQUEST} 207 | {$ENDIF BZIP2_STATICLINK} 208 | {$IFDEF BZIP2_LINKDLL} 209 | {$UNDEF BZIP2_LINKONREQUEST} 210 | {$ENDIF BZIP2_LINKDLL} 211 | 212 | {$IFNDEF BZIP2_STATICLINK} 213 | {$IFNDEF BZIP2_LINKDLL} 214 | {$IFNDEF BZIP2_LINKONREQUEST} 215 | {$DEFINE BZIP2_LINKONREQUEST} 216 | {$ENDIF ~BZIP2_LINKONREQUEST} 217 | {$ENDIF ~BZIP2_LINKDLL} 218 | {$ENDIF ~BZIP2_STATICLINK} 219 | 220 | {$IFDEF BZIP2_STATICLINK} 221 | {$DEFINE BZIP2_EXPORT_STDCALL} 222 | {$ENDIF BZIP2_STATICLINK} 223 | 224 | {$IFDEF BZIP2_LINKDLL} 225 | {$DEFINE BZIP2_EXPORT_CDECL} 226 | {$ENDIF BZIP2_LINKDLL} 227 | 228 | {$IFDEF BZIP2_LINKONREQUEST} 229 | {$DEFINE BZIP2_EXPORT_CDECL} 230 | {$ENDIF BZIP2_LINKONREQUEST} 231 | 232 | {$IFDEF UNICODE_RAW_DATA} 233 | {$UNDEF UNICODE_ZLIB_DATA} 234 | {$UNDEF UNICODE_BZIP2_DATA} 235 | {$ENDIF UNICODE_RAW_DATA} 236 | 237 | {$IFDEF UNICODE_ZLIB_DATA} 238 | {$UNDEF UNICODE_RAW_DATA} 239 | {$UNDEF UNICODE_BZIP2_DATA} 240 | {$ENDIF UNICODE_ZLIB_DATA} 241 | 242 | {$IFNDEF UNICODE_ZLIB_DATA} 243 | {$IFNDEF UNICODE_BZIP2_DATA} 244 | {$DEFINE UNICODE_RAW_DATA} 245 | {$ENDIF ~UNICODE_BZIP2_DATA} 246 | {$ENDIF ~UNICODE_ZLIB_DATA} 247 | 248 | {$IFDEF CONTAINER_ANSISTR} 249 | {$UNDEF CONTAINER_WIDESTR} 250 | {$UNDEF CONTAINER_NOSTR} 251 | {$ENDIF CONTAINER_ANSISTR} 252 | 253 | {$IFDEF CONTAINER_WIDESTR} 254 | {$UNDEF CONTAINER_NOSTR} 255 | {$ENDIF CONTAINER_WIDESTR} 256 | 257 | {$IFNDEF CONTAINER_ANSISTR} 258 | {$IFNDEF CONTAINER_WIDESTR} 259 | {$IFNDEF CONTAINER_NOSTR} 260 | {$DEFINE CONTAINER_ANSISTR} 261 | {$ENDIF ~CONTAINER_NOSTR} 262 | {$ENDIF ~CONTAINER_WIDESTR} 263 | {$ENDIF ~CONTAINER_ANSISTR} 264 | 265 | // 7zip options 266 | {$IFDEF 7ZIP_STATICLINK} 267 | {$UNDEF 7ZIP_LINKDLL} 268 | {$UNDEF 7ZIP_LINKONREQUEST} 269 | {$ENDIF 7ZIP_STATICLINK} 270 | 271 | {$IFDEF 7ZIP_LINKDLL} 272 | {$UNDEF 7ZIP_LINKONREQUEST} 273 | {$ENDIF 7ZIP_LINKDLL} 274 | 275 | {$IFNDEF 7ZIP_STATICLINK} 276 | {$IFNDEF 7ZIP_LINKDLL} 277 | {$IFNDEF 7ZIP_LINKONREQUEST} 278 | {$DEFINE 7ZIP_LINKONREQUEST} 279 | {$ENDIF ~7ZIP_LINKONREQUEST} 280 | {$ENDIF ~7ZIP_LINKDLL} 281 | {$ENDIF ~7ZIP_STATICLINK} 282 | 283 | {$IFDEF SUPPORTS_UNSAFE_WARNINGS} 284 | {$WARN UNSAFE_TYPE OFF} 285 | {$WARN UNSAFE_CODE OFF} 286 | {$WARN UNSAFE_CAST OFF} 287 | {$ENDIF} 288 | 289 | {$IFNDEF DROP_OBSOLETE_CODE} 290 | {$IFNDEF JCLINSTALL} 291 | {$DEFINE KEEP_DEPRECATED} 292 | {$ENDIF} 293 | {$ENDIF} 294 | 295 | {$IFDEF CLR} 296 | {$WARN UNSAFE_TYPE ON} 297 | {$WARN UNSAFE_CODE ON} 298 | {$WARN UNSAFE_CAST ON} 299 | {$WARN UNIT_PLATFORM OFF} 300 | 301 | {$DEFINE MSWINDOWS} 302 | {$DEFINE PIC} 303 | {$DEFINE PUREPASCAL} 304 | {$ENDIF CLR} 305 | -------------------------------------------------------------------------------- /JCL/jcld7.inc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tmcdos/VCL-explorer/60e3774c4bfd14c833d79eb67051b6d52069d6c7/JCL/jcld7.inc -------------------------------------------------------------------------------- /JCL/windowsonly.inc: -------------------------------------------------------------------------------- 1 | {$IFNDEF WINDOWSONLY_INC} 2 | {$DEFINE WINDOWSONLY_INC} 3 | 4 | {**************************************************************************************************} 5 | { } 6 | { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License");} 7 | { you may not use this file except in compliance with the License. You may obtain a copy of the } 8 | { License at http://www.mozilla.org/MPL/ } 9 | { } 10 | { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } 11 | { ANY KIND, either express or implied. See the License for the specific language governing rights } 12 | { and limitations under the License. } 13 | { } 14 | { The Original Code is: windowsonly.inc, released on 2002-07-04. } 15 | { } 16 | { You may retrieve the latest version of this file at the JCL home page, } 17 | { located at http://jcl.sourceforge.net/ } 18 | { } 19 | {**************************************************************************************************} 20 | { } 21 | { Last modified: $Date:: 2007-09-17 23:41:02 +0200 (lun., 17 sept. 2007) $ } 22 | { Revision: $Rev:: 2175 $ } 23 | { Author: $Author:: outchy $ } 24 | { } 25 | {**************************************************************************************************} 26 | 27 | {$IFNDEF JEDI_INC} 28 | ALERT_jedi_inc_missing 29 | // This inc file depends on jedi.inc which has to 30 | // be included first (usually indirectly through 31 | // the inclusion of jcl.inc). 32 | {$ENDIF ~JEDI_INC} 33 | 34 | // Suppress platform warnings which are irrelevant 35 | // because the including unit can only be compiled 36 | // for the Windows platform anyway. 37 | 38 | {$IFDEF SUPPORTS_PLATFORM_WARNINGS} 39 | {$WARN UNIT_PLATFORM OFF} 40 | {$WARN SYMBOL_PLATFORM OFF} 41 | {$ENDIF SUPPORTS_PLATFORM_WARNINGS} 42 | 43 | // Cause a compilation error for any platform except Windows. 44 | 45 | {$IFNDEF MSWINDOWS} 46 | {$IFDEF SUPPORTS_COMPILETIME_MESSAGES} 47 | {$MESSAGE FATAL 'This unit is only supported on Windows!'} 48 | {$ELSE} 49 | 'This unit is only supported on Windows!' 50 | {$ENDIF SUPPORTS_COMPILETIME_MESSAGES} 51 | {$ENDIF ~MSWINDOWS} 52 | 53 | {$ENDIF ~WINDOWSONLY_INC} 54 | 55 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 tmcdos 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Main.pas: -------------------------------------------------------------------------------- 1 | unit Main; 2 | 3 | interface 4 | 5 | uses 6 | Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ComCtrls, 7 | ExtCtrls, TntComCtrls, EnhListView, Buttons, ActnList, ImgList, ToolWin, 8 | VirtualTrees, Menus; 9 | 10 | type 11 | TForm1 = class(TForm) 12 | Panel1: TPanel; 13 | OpenDialog1: TOpenDialog; 14 | nameParent: TLabeledEdit; 15 | img1: TImageList; 16 | actList1: TActionList; 17 | actImport: TAction; 18 | actLoad: TAction; 19 | actSave: TAction; 20 | vtClass: TVirtualStringTree; 21 | btnLoad: TBitBtn; 22 | btnImport: TBitBtn; 23 | btnSave: TBitBtn; 24 | edFilter: TLabeledEdit; 25 | findProc: TLabeledEdit; 26 | dlgSave1: TSaveDialog; 27 | popup1: TPopupMenu; 28 | actCopy: TAction; 29 | actCopy1: TMenuItem; 30 | procedure actCopyExecute(Sender: TObject); 31 | procedure actCopyUpdate(Sender: TObject); 32 | procedure actImportExecute(Sender: TObject); 33 | procedure actImportUpdate(Sender: TObject); 34 | procedure actLoadExecute(Sender: TObject); 35 | procedure actSaveExecute(Sender: TObject); 36 | procedure actSaveUpdate(Sender: TObject); 37 | procedure edFilterChange(Sender: TObject); 38 | procedure edFilterMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 39 | procedure FormCreate(Sender: TObject); 40 | procedure vtClassCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer); 41 | procedure vtClassFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex); 42 | procedure vtClassFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); 43 | procedure vtClassGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: WideString); 44 | procedure vtClassLoadNode(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream); 45 | procedure vtClassMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 46 | procedure vtClassSaveNode(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream); 47 | private 48 | { Private declarations } 49 | Procedure AddUnitClass (n:PVirtualNode;t:AnsiString;idx:Integer); 50 | Procedure BPL_load (f:TFileName); 51 | public 52 | { Public declarations } 53 | end; 54 | 55 | var 56 | Form1: TForm1; 57 | 58 | implementation 59 | 60 | {$R *.dfm} 61 | 62 | uses Dump, CommCtrl,Clipbrd; 63 | 64 | procedure TForm1.actCopyExecute(Sender: TObject); 65 | var 66 | data:PClassNode; 67 | s:AnsiString; 68 | begin 69 | data:=vtClass.GetNodeData(vtClass.FocusedNode); 70 | s:=''; 71 | Case data.kind Of 72 | ntGUID: s:=GUIDToString(data.gid); 73 | ntUnit,ntClass: s:=data.Txt; 74 | ntVProc,ntDProc,ntIProc: s:='('+IntToHex(data.ofs,4)+') '+data.Txt; 75 | end; 76 | if s<>'' Then 77 | with Clipboard do 78 | Begin 79 | Open; 80 | SetTextBuf(@s[1]); 81 | Close; 82 | end; 83 | end; 84 | 85 | procedure TForm1.actCopyUpdate(Sender: TObject); 86 | begin 87 | TAction(Sender).Enabled:=Assigned(vtClass.FocusedNode); 88 | end; 89 | 90 | procedure TForm1.AddUnitClass(n:PVirtualNode;t:AnsiString;idx:Integer); 91 | var 92 | node,Virt,Dyna:PVirtualNode; 93 | data:PClassNode; 94 | objInfo:TClass; 95 | Begin 96 | node:=vtClass.AddChild(n); 97 | data:=vtClass.GetNodeData(node); 98 | data.Txt:=t; 99 | data.kind:=ntClass; 100 | objInfo:=Pointer(bpl.ExportList.Items[idx].MappedAddress); 101 | data.Ancestor:=GetAncestor(objInfo); 102 | Virt:=AddVirt(vtClass,node,objInfo); 103 | Dyna:=AddDyna(vtClass,node,objInfo); 104 | AddInter(vtClass,node,Virt,Dyna,objInfo); 105 | if node.ChildCount<>0 then vtClass.ReinitNode(node,False) 106 | Else vtClass.DeleteNode(node); 107 | end; 108 | 109 | procedure TForm1.BPL_load(f:TFileName); 110 | var 111 | I,p:Integer; 112 | s:String; 113 | node:PVirtualNode; 114 | data:PClassNode; 115 | lst:TStringList; 116 | Begin 117 | lst:=Nil; 118 | node:=Nil; 119 | if vtClass.RootNodeCount<>0 then 120 | if MessageDlg('Clear the tree before importing BPL ?',mtConfirmation,[mbYes,mbNo],0)=mrYes then vtClass.Clear; 121 | bpl.FileName:=f; 122 | bpl.ReadOnlyAccess:=True; 123 | vtClass.BeginUpdate; 124 | Screen.Cursor:=crHourGlass; 125 | try 126 | lst:=TStringList.Create; 127 | lst.Sorted:=False; 128 | for I:=0 to bpl.ExportList.FunctionCount-1 Do 129 | begin 130 | s:=bpl.ExportList.Items[I].Name; 131 | if (s[1]='@')And(s[Length(s)]='@') then 132 | lst.AddObject(uncode(s),Pointer(I)); 133 | end; 134 | lst.Sort; 135 | s:=''; 136 | for I:=0 to lst.Count-1 do 137 | begin 138 | p:=Pos('.',lst[I]); 139 | If s=Copy(lst[I],1,p-1) then AddUnitClass(node,Copy(lst[I],p+1,250),Integer(lst.Objects[I])) 140 | Else 141 | begin 142 | If Assigned(node) and (node.ChildCount=0) then vtClass.DeleteNode(node); 143 | s:=Copy(lst[I],1,p-1); 144 | node:=vtClass.AddChild(Nil); 145 | data:=vtClass.GetNodeData(node); 146 | data.Txt:=s; 147 | data.kind:=ntUnit; 148 | AddUnitClass(node,Copy(lst[I],p+1,250),Integer(lst.Objects[I])); 149 | vtClass.ReinitNode(node,False) 150 | end; 151 | end; 152 | If Assigned(node) And (node.ChildCount=0) then vtClass.DeleteNode(node); 153 | Finally 154 | lst.Free; 155 | Screen.Cursor:=crDefault; 156 | With vtClass do 157 | begin 158 | Header.SortColumn:=0; 159 | SortTree(0,sdAscending); 160 | EndUpdate; 161 | SetFocus; 162 | end; 163 | end; 164 | Caption:='VCL explorer - '+ExtractFileName(f); 165 | nameParent.Text:=''; 166 | edFilter.Text:=''; 167 | end; 168 | 169 | procedure TForm1.actImportExecute(Sender: TObject); 170 | begin 171 | OpenDialog1.Filter:='BPL files|*.bpl|All files|*.*'; 172 | if OpenDialog1.Execute Then BPL_load(OpenDialog1.FileName); 173 | end; 174 | 175 | procedure TForm1.actImportUpdate(Sender: TObject); 176 | begin 177 | TAction(Sender).Enabled:=True; 178 | end; 179 | 180 | procedure TForm1.actLoadExecute(Sender: TObject); 181 | begin 182 | OpenDialog1.Filter:='KB files|*.kb|All files|*.*'; 183 | if OpenDialog1.Execute Then 184 | try 185 | Screen.Cursor:=crHourGlass; 186 | vtClass.LoadFromFile(OpenDialog1.FileName); 187 | Finally 188 | Screen.Cursor:=crDefault; 189 | end; 190 | end; 191 | 192 | procedure TForm1.actSaveExecute(Sender: TObject); 193 | begin 194 | if dlgSave1.Execute Then 195 | try 196 | Screen.Cursor:=crHourGlass; 197 | vtClass.SaveToFile(dlgSave1.FileName); 198 | Finally 199 | Screen.Cursor:=crDefault; 200 | end; 201 | end; 202 | 203 | procedure TForm1.actSaveUpdate(Sender: TObject); 204 | begin 205 | TAction(Sender).Enabled:=vtClass.RootNodeCount<>0; 206 | end; 207 | 208 | procedure TForm1.edFilterChange(Sender: TObject); 209 | var 210 | P,S,Q:PVirtualNode; 211 | D,D2:PClassNode; 212 | v,empty:Boolean; 213 | s_trim,s_up,p_trim,p_up:AnsiString; 214 | begin 215 | if vtClass.RootNodeCount=0 then Exit; 216 | s_trim:=Trim(edFilter.Text); 217 | s_up:=UpperCase(s_trim); 218 | p_trim:=Trim(FindProc.Text); 219 | p_up:=UpperCase(p_trim); 220 | empty:=(s_trim='')and(p_trim=''); 221 | With vtClass Do 222 | try 223 | BeginUpdate; 224 | P:=RootNode.FirstChild; 225 | While Assigned(P) Do 226 | Begin 227 | if empty then IsVisible[P]:=True 228 | else 229 | begin 230 | D:=GetNodeData(P); 231 | Case D.kind Of 232 | ntClass: if s_trim<>'' then v:=Pos(s_up,UpperCase(D.Txt))>0 else v:=False; 233 | ntVProc, 234 | ntDProc: 235 | Begin 236 | Q:=P.Parent.Parent; // class node 237 | If p_trim='' then v:=IsVisible[Q] 238 | else 239 | Begin 240 | v:=Pos(p_up,UpperCase(D.Txt))>0; 241 | If v and (s_trim<>'') Then 242 | Begin 243 | D2:=GetNodeData(Q); 244 | // filtering on both class & method 245 | v:=Pos(s_up,UpperCase(D2.Txt))>0; 246 | end; 247 | end; 248 | end; 249 | ntIProc: 250 | Begin 251 | Q:=P.Parent.Parent.Parent; // class node 252 | If p_trim='' then v:=IsVisible[Q] 253 | else 254 | Begin 255 | v:=Pos(p_up,UpperCase(D.Txt))>0; 256 | If v and (s_trim<>'') Then 257 | Begin 258 | D2:=GetNodeData(Q); 259 | // filtering on both class & method 260 | v:=Pos(s_up,UpperCase(D2.Txt))>0; 261 | end; 262 | end; 263 | end; 264 | ntGUID: 265 | Begin 266 | Q:=P.Parent.Parent; // class node 267 | If p_trim='' then v:=IsVisible[Q] 268 | else 269 | Begin 270 | v:=Pos(p_up,GUIDToString(D.gid))>0; 271 | If v and (s_trim<>'') Then 272 | Begin 273 | D2:=GetNodeData(Q); 274 | // filtering on both class & method 275 | v:=Pos(s_up,UpperCase(D2.Txt))>0; 276 | end; 277 | End; 278 | End; 279 | Else v:=False; 280 | end; 281 | IsVisible[P]:=v; 282 | if v Then 283 | Begin 284 | S:=P.Parent; 285 | While Assigned(S) and (S<>RootNode) and not IsVisible[S] Do 286 | Begin 287 | IsVisible[S]:=True; 288 | S:=S.Parent; 289 | end; 290 | end; 291 | End; 292 | P:=GetNext(P); 293 | end; 294 | Finally 295 | EndUpdate; 296 | End; 297 | end; 298 | 299 | procedure TForm1.edFilterMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 300 | begin 301 | if TWinControl(Sender).CanFocus then ActiveControl:=TWinControl(Sender); 302 | end; 303 | 304 | procedure TForm1.FormCreate(Sender: TObject); 305 | begin 306 | vtClass.NodeDataSize:=SizeOf(ClassNode); 307 | end; 308 | 309 | procedure TForm1.vtClassCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer); 310 | var 311 | D1,D2:PClassNode; 312 | begin 313 | D1:=vtClass.GetNodeData(Node1); 314 | D2:=vtClass.GetNodeData(Node2); 315 | // 1st column shows names 316 | // 2nd column shows virtual offsets, dynamic IDs, interface offsets 317 | case D1.kind of 318 | ntGUID: Result:=lstrcmpA(PAnsiChar(GUIDToString(D1.gid)),PAnsiChar(GUIDToString(D2.gid))); 319 | ntVirtualGrp, 320 | ntDynamicGrp, 321 | ntInterfaceGrp: 322 | if D1.kind < D2.kind then Result:=-1 323 | else if D1.kind > D2.kind then Result:=1 324 | else Result:=0; 325 | ntVProc, 326 | ntIProc: 327 | if D1.ofs < D2.ofs then Result:=-1 328 | else if D1.ofs > D2.ofs then Result:=1 329 | else Result:=0; 330 | ntDProc: 331 | if Word(D1.ofs) < Word(D2.ofs) then Result:=1 332 | else if Word(D1.ofs) > Word(D2.ofs) then Result:=-1 333 | else Result:=0; 334 | else Result:=lstrcmpiA(PAnsiChar(D1.Txt),PAnsiChar(D2.Txt)); 335 | end; 336 | end; 337 | 338 | procedure TForm1.vtClassFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex); 339 | var 340 | data:PClassNode; 341 | begin 342 | if Assigned(node) Then 343 | Begin 344 | data:=Sender.GetNodeData(Node); 345 | nameParent.Text:=data.Ancestor; 346 | end 347 | else nameParent.Text:=''; 348 | end; 349 | 350 | procedure TForm1.vtClassFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); 351 | var 352 | data:PClassNode; 353 | begin 354 | data:=Sender.GetNodeData(Node); 355 | if Assigned(data) then Finalize(data^); 356 | end; 357 | 358 | procedure TForm1.vtClassGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: WideString); 359 | var 360 | data:PClassNode; 361 | begin 362 | // 1st column shows - Units, Classes, Virtual/Dynamic/Interface groups, GUIDs 363 | // 2nd column shows - virtual offsets, dynamic IDs, interface offsets 364 | data:=Sender.GetNodeData(Node); 365 | case Column Of 366 | 0: 367 | Case data.kind of 368 | ntGUID: 369 | CellText:=GUIDToString(data.gid); 370 | ntVirtualGrp: 371 | CellText:='('+IntToStr(Node.ChildCount)+') Virtual methods'; 372 | ntDynamicGrp: 373 | CellText:='('+IntToStr(Node.ChildCount)+') Dynamic methods'; 374 | ntInterfaceGrp: 375 | CellText:='('+IntToStr(Node.ChildCount)+') Interfaces'; 376 | else CellText:=data.txt; 377 | End; 378 | 1: if data.kind=ntDProc then CellText:=IntToHex(Word(data.ofs),4) 379 | else if data.kind in [ntVProc,ntIProc] then CellText:=IntToHex(data.ofs,4) 380 | Else CellText:=''; 381 | end; 382 | end; 383 | 384 | procedure TForm1.vtClassLoadNode(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream); 385 | var 386 | data:PClassNode; 387 | n:Integer; 388 | begin 389 | data:=Sender.GetNodeData(Node); 390 | with Stream, data^ do 391 | begin 392 | Read(ofs,SizeOf(ofs)); 393 | Read(gid,SizeOf(gid)); 394 | Read(kind,SizeOf(kind)); 395 | Read(n,SizeOf(n)); 396 | SetLength(Txt,n); 397 | Read(txt[1],n); 398 | Read(n,SizeOf(n)); 399 | SetLength(Ancestor,n); 400 | Read(ancestor[1],n); 401 | end; 402 | end; 403 | 404 | procedure TForm1.vtClassMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 405 | begin 406 | If vtClass.CanFocus then ActiveControl:=vtClass; 407 | end; 408 | 409 | procedure TForm1.vtClassSaveNode(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream); 410 | var 411 | data:PClassNode; 412 | n:Integer; 413 | begin 414 | data:=Sender.GetNodeData(Node); 415 | with Stream, data^ do 416 | begin 417 | Write(ofs,SizeOf(ofs)); 418 | Write(gid,SizeOf(gid)); 419 | Write(kind,SizeOf(kind)); 420 | n:=Length(Txt); 421 | Write(n,SizeOf(n)); 422 | Write(txt[1],n); 423 | n:=Length(Ancestor); 424 | Write(n,SizeOf(n)); 425 | Write(ancestor[1],n); 426 | end; 427 | end; 428 | 429 | end. 430 | 431 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VCL-explorer 2 | 3 | This small tool loads the chosen BPL (compiled by Delphi) and lists all exported classes. For each class it then shows: 4 | - virtual methods by their index 5 | - dynamic methods by their 16-bit identifier 6 | - implemented interfaces and their methods 7 | 8 | There is also quick-search (filtration) and the results of the reverse-engineering can be exported/imported. 9 | 10 | ![](https://a.fsdn.com/con/app/proj/vclexp/screenshots/shot-1.png/max/max/1) 11 | -------------------------------------------------------------------------------- /RTTI/HVInterfaceMethods.pas: -------------------------------------------------------------------------------- 1 | unit HVInterfaceMethods; 2 | 3 | interface 4 | 5 | uses TypInfo, HVMethodSignature; 6 | 7 | type 8 | // Easy-to-use fixed size structure 9 | PInterfaceInfo = ^TInterfaceInfo; 10 | TInterfaceInfo = record 11 | UnitName: string; 12 | Name: string; 13 | Flags: TIntfFlags; 14 | ParentInterface: PTypeInfo; 15 | Guid: TGUID; 16 | MethodCount: Word; 17 | HasMethodRTTI: boolean; 18 | Methods: array of TMethodSignature; 19 | end; 20 | 21 | procedure GetInterfaceInfo(InterfaceTypeInfo: PTypeInfo; var InterfaceInfo: TInterfaceInfo); 22 | 23 | implementation 24 | 25 | type 26 | // compiler implementation-specific structures, subject to change in future Delphi versions 27 | PPackedShortString = ^TPackedShortString; 28 | TPackedShortString = string[1]; 29 | PInterfaceParameterRTTI = ^TInterfaceParameterRTTI; 30 | TInterfaceParameterRTTI = packed record 31 | Flags: TParamFlags; 32 | ParamName: TPackedShortString; 33 | TypeName: TPackedShortString; 34 | TypeInfo: PPTypeInfo; 35 | end; 36 | PInterfaceResultRTTI = ^TInterfaceResultRTTI; 37 | TInterfaceResultRTTI = packed record 38 | Name: TPackedShortString; 39 | TypeInfo: PPTypeInfo; 40 | end; 41 | PInterfaceMethodRTTI = ^TInterfaceMethodRTTI; 42 | TInterfaceMethodRTTI = packed record 43 | Name: TPackedShortString; 44 | Kind: TMethodKind; // mkProcedure or mkFunction 45 | CallConv: TCallConv; 46 | ParamCount: byte; // including Self 47 | Parameters: packed array[0..High(byte)-1] of TInterfaceParameterRTTI; 48 | case TMethodKind of 49 | mkFunction: 50 | (Result: TInterfaceResultRTTI); 51 | end; 52 | PExtraInterfaceData = ^TExtraInterfaceData; 53 | TExtraInterfaceData = packed record 54 | MethodCount: Word; // #methods 55 | HasMethodRTTI: Word; // $FFFF if no method RTTI, #methods again if has RTTI 56 | Methods: packed array[0..High(Word)-1] of TInterfaceMethodRTTI; 57 | end; 58 | { 59 | (MethodCount:1; HasMethodRTTI:1; 60 | Test:( 61 | Name: #3, 'F', 'o', 'o', 62 | Kind: #0, 63 | CallConv: #0, 64 | ParamCount: #3, 65 | Flags: #8, 66 | ParamName: #4, 'S', 'e', 'l', 'f', 67 | TypeName: #14, 'I', 'M', 'y', 'M', 'P', 'I', 'n', 't', 'e', 'r', 'f', 'a', 'c', 'e', 68 | TypeInfo: #24, 'T', 'O', #0, 69 | Flags: #0, 70 | Name: #1, 'A', 71 | TypeName: #7, 'I', 'n', 't', 'e', 'g', 'e', 'r', 72 | } 73 | 74 | procedure GetInterfaceInfo(InterfaceTypeInfo: PTypeInfo; var InterfaceInfo: TInterfaceInfo); 75 | // Converts from raw RTTI structures to user-friendly Info structures 76 | var 77 | TypeData: PTypeData; 78 | ExtraData: PExtraInterfaceData; 79 | i, j: integer; 80 | MethodInfo: PMethodSignature; 81 | MethodRTTI: PInterfaceMethodRTTI; 82 | ParameterInfo: PMethodParam; 83 | ParameterRTTI: PInterfaceParameterRTTI; 84 | InterfaceResultRTTI: PInterfaceResultRTTI; 85 | begin 86 | Assert(Assigned(InterfaceTypeInfo)); 87 | Assert(InterfaceTypeInfo.Kind = tkInterface); 88 | TypeData := GetTypeData(InterfaceTypeInfo); 89 | ExtraData := Skip(@TypeData.IntfUnit); 90 | 91 | // Interface 92 | InterfaceInfo.UnitName := TypeData.IntfUnit; 93 | InterfaceInfo.Name := InterfaceTypeInfo.Name; 94 | InterfaceInfo.Flags := TypeData.IntfFlags; 95 | InterfaceInfo.ParentInterface := Dereference(TypeData.IntfParent); 96 | InterfaceInfo.Guid := TypeData.Guid; 97 | InterfaceInfo.MethodCount := ExtraData.MethodCount; 98 | InterfaceInfo.HasMethodRTTI := (ExtraData.HasMethodRTTI = ExtraData.MethodCount); 99 | if InterfaceInfo.HasMethodRTTI 100 | then SetLength(InterfaceInfo.Methods, InterfaceInfo.MethodCount) 101 | else SetLength(InterfaceInfo.Methods, 0); 102 | 103 | // Methods 104 | MethodRTTI := @ExtraData.Methods[0]; 105 | for i := Low(InterfaceInfo.Methods) to High(InterfaceInfo.Methods) do 106 | begin 107 | MethodInfo := @InterfaceInfo.Methods[i]; 108 | MethodInfo.Name := Skip(@MethodRTTI.Name, MethodRTTI)^; 109 | MethodInfo.MethodKind := MethodRTTI.Kind; 110 | MethodInfo.CallConv := MethodRTTI.CallConv; 111 | MethodInfo.HasSignatureRTTI := True; 112 | MethodInfo.ParamCount := MethodRTTI.ParamCount; 113 | SetLength(MethodInfo.Parameters, MethodInfo.ParamCount); 114 | 115 | // Parameters 116 | ParameterRTTI := @MethodRTTI.Parameters; 117 | for j := Low(MethodInfo.Parameters) to High(MethodInfo.Parameters) do 118 | begin 119 | ParameterInfo := @MethodInfo.Parameters[j]; 120 | ParameterInfo.Flags := ParameterRTTI.Flags; 121 | ParameterInfo.ParamName := Skip(@ParameterRTTI.ParamName, ParameterRTTI)^; 122 | ParameterInfo.TypeName := Skip(@ParameterRTTI.TypeName, ParameterRTTI)^; 123 | ParameterInfo.TypeInfo := Dereference(ParameterRTTI.TypeInfo); 124 | ParameterInfo.Location := plUnknown; 125 | ParameterRTTI := Skip(@ParameterRTTI.TypeInfo, SizeOf(ParameterRTTI.TypeInfo)); 126 | end; 127 | 128 | // Function result 129 | if MethodInfo.MethodKind = mkFunction then 130 | begin 131 | InterfaceResultRTTI := Pointer(ParameterRTTI); 132 | MethodInfo.ResultTypeName := Skip(@InterfaceResultRTTI.Name, InterfaceResultRTTI)^; 133 | MethodInfo.ResultTypeInfo := Dereference(InterfaceResultRTTI.TypeInfo); 134 | MethodRTTI := Skip(@InterfaceResultRTTI.TypeInfo, SizeOf(InterfaceResultRTTI.TypeInfo)); 135 | end 136 | else 137 | MethodRTTI := Pointer(ParameterRTTI); 138 | end; 139 | end; 140 | 141 | end. 142 | -------------------------------------------------------------------------------- /RTTI/HVMethodInfoClasses.pas: -------------------------------------------------------------------------------- 1 | unit HVMethodInfoClasses; 2 | 3 | interface 4 | 5 | uses 6 | TypInfo, 7 | HVMethodSignature, 8 | HVVMT; 9 | 10 | type 11 | // Easy-to-use fixed size structure 12 | PClassInfo = ^TClassInfo; 13 | TClassInfo = record 14 | UnitName: string; 15 | Name: string; 16 | ClassType: TClass; 17 | ParentClass: TClass; 18 | MethodCount: Word; 19 | Methods: array of TMethodSignature; 20 | end; 21 | 22 | proc_rva = function (adr:Cardinal):Pointer of object; // convert RVA into VA 23 | 24 | procedure GetClassInfo(ClassTypeInfo: PTypeInfo; var ClassInfo: TClassInfo; conv:proc_rva); 25 | 26 | implementation 27 | 28 | type 29 | // compiler implementation-specific structures, subject to change in future Delphi versions 30 | // Derived from declarations in ObjAuto.pas 31 | PReturnInfo = ^TReturnInfo; 32 | TReturnInfo = packed record 33 | Version: Byte; 34 | CallingConvention: TCallConv; 35 | ReturnType: PPTypeInfo; 36 | ParamSize: Word; 37 | end; 38 | PParamInfo = ^TParamInfo; 39 | TParamInfo = packed record 40 | Flags: TParamFlags; 41 | ParamType: PPTypeInfo; 42 | Access: Word; 43 | Name: ShortString; 44 | end; 45 | 46 | function ClassOfTypeInfo(P: PPTypeInfo): TClass; 47 | begin 48 | Result := nil; 49 | if Assigned(P) and (P^.Kind = tkClass) then 50 | Result := GetTypeData(P^).ClassType; 51 | end; 52 | 53 | procedure GetClassInfo(ClassTypeInfo: PTypeInfo; var ClassInfo: TClassInfo; conv:proc_rva); 54 | // Converts from raw RTTI structures to user-friendly Info structures 55 | var 56 | TypeData: PTypeData; 57 | i, j: integer; 58 | MethodInfo: PMethodSignature; 59 | PublishedMethod: PPublishedMethod; 60 | MethodParam: PMethodParam; 61 | ReturnRTTI: PReturnInfo; 62 | ParameterRTTI: PParamInfo; 63 | SignatureEnd: Pointer; 64 | begin 65 | Assert(Assigned(ClassTypeInfo)); 66 | Assert(ClassTypeInfo.Kind = tkClass); 67 | // Class 68 | TypeData := GetTypeData(ClassTypeInfo); 69 | ClassInfo.UnitName := TypeData.UnitName; 70 | ClassInfo.ClassType := conv(Cardinal(TypeData.ClassType)); 71 | ClassInfo.Name := ClassInfo.ClassType.ClassName; 72 | ClassInfo.ParentClass := ClassOfTypeInfo(conv(Cardinal(TypeData.ParentInfo))); 73 | ClassInfo.MethodCount := GetPublishedMethodCount(ClassInfo.ClassType); 74 | SetLength(ClassInfo.Methods, ClassInfo.MethodCount); 75 | // Methods 76 | PublishedMethod := GetFirstPublishedMethod(ClassInfo.ClassType); 77 | for i := Low(ClassInfo.Methods) to High(ClassInfo.Methods) do 78 | begin 79 | // Method 80 | MethodInfo := @ClassInfo.Methods[i]; 81 | MethodInfo.Name := PublishedMethod.Name; 82 | MethodInfo.Address := PublishedMethod.Address; 83 | MethodInfo.MethodKind := mkProcedure; // Assume procedure by default 84 | 85 | // Return info and calling convention 86 | ReturnRTTI := Skip(@PublishedMethod.Name); 87 | SignatureEnd := Pointer(Cardinal(PublishedMethod) 88 | + PublishedMethod.Size); 89 | if Cardinal(ReturnRTTI) >= Cardinal(SignatureEnd) then 90 | begin 91 | MethodInfo.CallConv := ccReg; // Assume register calling convention 92 | MethodInfo.HasSignatureRTTI := False; 93 | end 94 | else 95 | begin 96 | MethodInfo.ResultTypeInfo := Dereference(ReturnRTTI.ReturnType); 97 | if Assigned(MethodInfo.ResultTypeInfo) then 98 | begin 99 | MethodInfo.MethodKind := mkFunction; 100 | MethodInfo.ResultTypeName := MethodInfo.ResultTypeInfo.Name; 101 | end 102 | else 103 | MethodInfo.MethodKind := mkProcedure; 104 | MethodInfo.CallConv := ReturnRTTI.CallingConvention; 105 | MethodInfo.HasSignatureRTTI := True; 106 | // Count parameters 107 | ParameterRTTI := Pointer(Cardinal(ReturnRTTI) + SizeOf(ReturnRTTI^)); 108 | MethodInfo.ParamCount := 0; 109 | while Cardinal(ParameterRTTI) < Cardinal(SignatureEnd) do 110 | begin 111 | Inc(MethodInfo.ParamCount); // Assume less than 255 parameters ;)! 112 | ParameterRTTI := Skip(@ParameterRTTI.Name); 113 | end; 114 | // Read parameter info 115 | ParameterRTTI := Pointer(Cardinal(ReturnRTTI) + SizeOf(ReturnRTTI^)); 116 | SetLength(MethodInfo.Parameters, MethodInfo.ParamCount); 117 | for j := Low(MethodInfo.Parameters) to High(MethodInfo.Parameters) do 118 | begin 119 | MethodParam := @MethodInfo.Parameters[j]; 120 | MethodParam.Flags := ParameterRTTI.Flags; 121 | if pfResult in MethodParam.Flags 122 | then MethodParam.ParamName := 'Result' 123 | else MethodParam.ParamName := ParameterRTTI.Name; 124 | MethodParam.TypeInfo := Dereference(ParameterRTTI.ParamType); 125 | if Assigned(MethodParam.TypeInfo) then 126 | MethodParam.TypeName := MethodParam.TypeInfo.Name; 127 | MethodParam.Location := TParamLocation(ParameterRTTI.Access); 128 | ParameterRTTI := Skip(@ParameterRTTI.Name); 129 | end; 130 | end; 131 | PublishedMethod := GetNextPublishedMethod(ClassInfo.ClassType, 132 | PublishedMethod); 133 | end; 134 | end; 135 | 136 | end. 137 | 138 | 139 | -------------------------------------------------------------------------------- /RTTI/HVMethodSignature.pas: -------------------------------------------------------------------------------- 1 | unit HVMethodSignature; 2 | 3 | interface 4 | 5 | uses Classes, SysUtils, TypInfo, HVVMT; 6 | 7 | type 8 | TParamLocation = (plUnknown=-1, plEAX=0, plEDX=1, plECX=2, plStack1=3, plStackN=$FFFF); 9 | TCallConv = (ccReg, ccCdecl, ccPascal, ccStdCall, ccSafeCall); 10 | TParamFlag = (pfVar, pfConst, pfArray, pfAddress, pfReference, pfOut, pfResult); 11 | TParamFlags = set of TParamFlag; 12 | PMethodParam = ^TMethodParam; 13 | TMethodParam = record 14 | Flags: TParamFlags; 15 | ParamName: string; 16 | TypeName: string; 17 | TypeInfo: PTypeInfo; 18 | Location: TParamLocation; 19 | end; 20 | TMethodParamList = array of TMethodParam; 21 | PMethodSignature = ^TMethodSignature; 22 | TMethodSignature = record 23 | Name: string; 24 | MethodKind: TMethodKind; 25 | CallConv: TCallConv; 26 | HasSignatureRTTI: boolean; 27 | Address: Pointer; 28 | ParamCount: Byte; 29 | Parameters: TMethodParamList; 30 | ResultTypeName: string; 31 | ResultTypeInfo: PTypeInfo; 32 | end; 33 | PPackedShortString = ^TPackedShortString; 34 | TPackedShortString = string[1]; 35 | 36 | function Skip(Value: PShortstring): pointer; overload; 37 | function Skip(Value: PPackedShortString; var NextField{: Pointer}): PShortString; overload; 38 | function Skip(CurrField: pointer; FieldSize: integer): pointer; overload; 39 | 40 | function Dereference(P: PPTypeInfo): PTypeInfo; 41 | 42 | function MethodKindString(MethodKind: TMethodKind): string; 43 | 44 | function MethodParamString(const MethodParam: TMethodParam; ExcoticFlags: boolean = False): string; 45 | 46 | function MethodParametesString(const MethodSignature: TMethodSignature; SkipSelf: boolean = True): string; 47 | 48 | function MethodSignatureToString(const Name: string; const MethodSignature: TMethodSignature): string; overload; 49 | 50 | function MethodSignatureToString(const MethodSignature: TMethodSignature): string; overload; 51 | 52 | implementation 53 | 54 | function Skip(Value: PShortstring): pointer; overload; 55 | begin 56 | Result := Value; 57 | Inc(PChar(Result), SizeOf(Value^[0]) + Length(Value^)); 58 | end; 59 | 60 | function Skip(Value: PPackedShortString; var NextField{: Pointer}): PShortString; overload; 61 | begin 62 | Result := PShortString(Value); 63 | Inc(PChar(NextField), SizeOf(Char) + Length(Result^) - SizeOf(TPackedShortString)); 64 | end; 65 | 66 | function Skip(CurrField: pointer; FieldSize: integer): pointer; overload; 67 | begin 68 | Result := PChar(Currfield) + FieldSize; 69 | end; 70 | 71 | function Dereference(P: PPTypeInfo): PTypeInfo; 72 | begin 73 | if Assigned(P) 74 | then Result := P^ 75 | else Result := nil; 76 | end; 77 | 78 | function MethodKindString(MethodKind: TMethodKind): string; 79 | begin 80 | case MethodKind of 81 | mkSafeProcedure, 82 | mkProcedure : Result := 'procedure'; 83 | mkSafeFunction, 84 | mkFunction : Result := 'function'; 85 | mkConstructor : Result := 'constructor'; 86 | mkDestructor : Result := 'destructor'; 87 | mkClassProcedure: Result := 'class procedure'; 88 | mkClassFunction : Result := 'class function'; 89 | end; 90 | end; 91 | 92 | function MethodParamString(const MethodParam: TMethodParam; ExcoticFlags: boolean = False): string; 93 | begin 94 | if pfVar in MethodParam.Flags then Result := 'var ' 95 | else if pfConst in MethodParam.Flags then Result := 'const ' 96 | else if pfOut in MethodParam.Flags then Result := 'out ' 97 | else Result := ''; 98 | if ExcoticFlags then 99 | begin 100 | if pfAddress in MethodParam.Flags then Result := '{addr} ' + Result; 101 | if pfReference in MethodParam.Flags then Result := '{ref} ' + Result; 102 | if pfResult in MethodParam.Flags then Result := '{result} ' + Result; 103 | end; 104 | 105 | Result := Result + MethodParam.ParamName + ': '; 106 | if pfArray in MethodParam.Flags then 107 | Result := Result + 'array of '; 108 | Result := Result + MethodParam.TypeName; 109 | end; 110 | 111 | function MethodParametesString(const MethodSignature: TMethodSignature; SkipSelf: boolean = True): string; 112 | var 113 | i: integer; 114 | MethodParam: PMethodParam; 115 | ParamIndex: integer; 116 | begin 117 | Result := ''; 118 | ParamIndex := 0; 119 | if MethodSignature.HasSignatureRTTI then 120 | for i := 0 to MethodSignature.ParamCount-1 do 121 | begin 122 | MethodParam := @MethodSignature.Parameters[i]; 123 | // Skip the implicit Self parameter for class and interface methods 124 | // Note that Self is not included in event types 125 | if SkipSelf and 126 | (i = 0) and 127 | (MethodParam.ParamName = 'Self') and 128 | (MethodParam.TypeInfo.Kind in [tkInterface, tkClass]) then 129 | Continue; 130 | if pfResult in MethodParam.Flags then 131 | Continue; 132 | if ParamIndex > 0 then 133 | Result := Result + '; '; 134 | Result := Result + MethodParamString(MethodParam^); 135 | Inc(ParamIndex); 136 | end 137 | else 138 | Result := '{??}'; 139 | end; 140 | 141 | function CallingConventionToString(CallConv: TCallConv): string; 142 | begin 143 | case CallConv of 144 | ccReg : Result := 'register'; 145 | ccCdecl : Result := 'cdecl'; 146 | ccPascal : Result := 'pascal'; 147 | ccStdCall : Result := 'stdcall'; 148 | ccSafeCall: Result := 'safecall'; 149 | else Result := 'TCallConv('+IntToStr(Ord(CallConv))+')'; 150 | end; 151 | end; 152 | 153 | function MethodSignatureToString(const Name: string; const MethodSignature: TMethodSignature): string; overload; 154 | begin 155 | Result := Format('%s %s(%s)', 156 | [MethodKindString(MethodSignature.MethodKind), 157 | Name, 158 | MethodParametesString(MethodSignature)]); 159 | if MethodSignature.HasSignatureRTTI and (MethodSignature.MethodKind = mkFunction) then 160 | Result := Result + ': ' + MethodSignature.ResultTypeName; 161 | Result := Result + ';' ; 162 | if MethodSignature.CallConv <> ccReg then 163 | Result := Result + ' ' + CallingConventionToString(MethodSignature.CallConv) + ';'; 164 | end; 165 | 166 | function MethodSignatureToString(const MethodSignature: TMethodSignature): string; overload; 167 | begin 168 | Result := MethodSignatureToString(MethodSignature.Name, MethodSignature); 169 | end; 170 | 171 | end. 172 | -------------------------------------------------------------------------------- /RTTI/HVPublishedMethodParams.pas: -------------------------------------------------------------------------------- 1 | unit HVPublishedMethodParams; 2 | 3 | interface 4 | 5 | uses Classes, SysUtils, TypInfo, HVVMT, HVMethodSignature; 6 | 7 | function SkipPackedShortString(Value: PShortstring): pointer; 8 | 9 | function GetMethodSignature(Event: PPropInfo): TMethodSignature; 10 | 11 | function FindEventProperty(Instance: TObject; Code: Pointer): PPropInfo; 12 | 13 | function FindEventFor(Instance: TObject; Code: Pointer): PPropInfo; 14 | 15 | function FindPublishedMethodSignature(Instance: TObject; Code: Pointer; var MethodSignature: TMethodSignature): boolean; 16 | 17 | function PublishedMethodToString(Instance: TObject; Method: PPublishedMethod): string; 18 | 19 | procedure GetPublishedMethodsWithParameters(Instance: TObject; List: TStrings); 20 | 21 | implementation 22 | 23 | function SkipPackedShortString(Value: PShortstring): pointer; 24 | begin 25 | Result := Value; 26 | Inc(PChar(Result), SizeOf(Value^[0]) + Length(Value^)); 27 | end; 28 | 29 | function PackedShortString(Value: PShortstring; var NextField{: Pointer}): PShortString; overload; 30 | begin 31 | Result := Value; 32 | PShortString(NextField) := Value; 33 | Inc(PChar(NextField), SizeOf(Result^[0]) + Length(Result^)); 34 | end; 35 | 36 | function PackedShortString(var NextField{: Pointer}): PShortString; overload; 37 | begin 38 | Result := PShortString(NextField); 39 | Inc(PChar(NextField), SizeOf(Result^[0]) + Length(Result^)); 40 | end; 41 | 42 | function GetMethodSignature(Event: PPropInfo): TMethodSignature; 43 | (* From TypInfo 44 | TTypeData = packed record 45 | case TTypeKind of 46 | ... 47 | tkMethod: ( 48 | MethodKind: TMethodKind; 49 | ParamCount: Byte; 50 | Parameters: array[0..1023] of Char 51 | {Parameters: array[1..ParamCount] of 52 | record 53 | Flags: TParamFlags; 54 | ParamName: ShortString; 55 | TypeName: ShortString; 56 | end; 57 | ResultTypeName: ShortString);*) 58 | type 59 | PParamListRecord = ^TParamListRecord; 60 | TParamListRecord = packed record 61 | Flags: TParamFlags; 62 | ParamName: {packed} ShortString; // Really string[Length(ParamName)] 63 | TypeName: {packed} ShortString; // Really string[Length(TypeName)] 64 | end; 65 | var 66 | EventData: PTypeData; 67 | i: integer; 68 | MethodParam: PMethodParam; 69 | ParamListRecord: PParamListRecord; 70 | begin 71 | Assert(Assigned(Event) and Assigned(Event.PropType)); 72 | Assert(Event.PropType^.Kind = tkMethod); 73 | EventData := GetTypeData(Event.PropType^); 74 | Result.MethodKind := EventData.MethodKind; 75 | Result.ParamCount := EventData.ParamCount; 76 | SetLength(Result.Parameters, Result.ParamCount); 77 | ParamListRecord := @EventData.ParamList; 78 | for i := 0 to Result.ParamCount-1 do 79 | begin 80 | MethodParam := @Result.Parameters[i]; 81 | MethodParam.Flags := ParamListRecord.Flags; 82 | MethodParam.ParamName := PackedShortString(@ParamListRecord.ParamName, ParamListRecord)^; 83 | MethodParam.TypeName := PackedShortString(ParamListRecord)^; 84 | end; 85 | Result.ResultTypeName := PackedShortString(ParamListRecord)^; 86 | end; 87 | 88 | function FindEventProperty(Instance: TObject; Code: Pointer): PPropInfo; 89 | // Tries to find an event property that is assigned to a specific code address 90 | var 91 | Count: integer; 92 | PropList: PPropList; 93 | i: integer; 94 | Method: TMethod; 95 | begin 96 | Assert(Assigned(Instance)); 97 | Count := GetPropList(Instance, PropList); 98 | if Count > 0 then 99 | try 100 | for i := 0 to Count-1 do 101 | begin 102 | Result := PropList^[i]; 103 | if Result.PropType^.Kind = tkMethod then 104 | begin 105 | Method := GetMethodProp(Instance, Result); 106 | if Method.Code = Code then 107 | Exit; 108 | end; 109 | end; 110 | finally 111 | FreeMem(PropList); 112 | end; 113 | Result := nil; 114 | end; 115 | 116 | function FindEventFor(Instance: TObject; Code: Pointer): PPropInfo; 117 | // Tries to find an event property that is assigned to a specific code address 118 | // In this instance or in one if its owned components (if the instance is a component) 119 | var 120 | i: integer; 121 | Component: TComponent; 122 | begin 123 | Result := FindEventProperty(Instance, Code); 124 | if Assigned(Result) then Exit; 125 | if Instance is TComponent then 126 | begin 127 | Component := TComponent(Instance); 128 | for i:= 0 to Component.ComponentCount-1 do 129 | begin 130 | Result := FindEventFor(Component.Components[i], Code); 131 | if Assigned(Result) then Exit; 132 | end; 133 | end; 134 | Result := nil; 135 | // TODO: Check published fields system 136 | end; 137 | 138 | function FindPublishedMethodSignature(Instance: TObject; Code: Pointer; var MethodSignature: TMethodSignature): boolean; 139 | var 140 | Event: PPropInfo; 141 | begin 142 | Assert(Assigned(Code)); 143 | Event := FindEventFor(Instance, Code); 144 | Result := Assigned(Event); 145 | if Result then 146 | MethodSignature := GetMethodSignature(Event); 147 | end; 148 | 149 | function PublishedMethodToString(Instance: TObject; Method: PPublishedMethod): string; 150 | var 151 | MethodSignature: TMethodSignature; 152 | begin 153 | if FindPublishedMethodSignature(Instance, Method.Address, MethodSignature) then 154 | Result := MethodSignatureToString(Method.Name, MethodSignature) 155 | else 156 | Result := Format('procedure %s(???);', [Method.Name]); 157 | end; 158 | 159 | procedure GetPublishedMethodsWithParameters(Instance: TObject; List: TStrings); 160 | var 161 | i : integer; 162 | Method: PPublishedMethod; 163 | AClass: TClass; 164 | Count: integer; 165 | begin 166 | List.BeginUpdate; 167 | try 168 | List.Clear; 169 | AClass := Instance.ClassType; 170 | while Assigned(AClass) do 171 | begin 172 | Count := GetPublishedMethodCount(AClass); 173 | if Count > 0 then 174 | begin 175 | List.Add(Format('Published methods in %s', [AClass.ClassName])); 176 | Method := GetFirstPublishedMethod(AClass); 177 | for i := 0 to Count-1 do 178 | begin 179 | List.Add(PublishedMethodToString(Instance, Method)); 180 | Method := GetNextPublishedMethod(AClass, Method); 181 | end; 182 | end; 183 | AClass := AClass.ClassParent; 184 | end; 185 | finally 186 | List.EndUpdate; 187 | end; 188 | end; 189 | 190 | end. 191 | 192 | -------------------------------------------------------------------------------- /RTTI/HVVMT.pas: -------------------------------------------------------------------------------- 1 | unit HVVMT; 2 | // Written by Hallvard Vassbotn, 2006 - http://hallvards.blogspot.com/ 3 | // Currently assumes D7-D2006 (*probably* works in D5 and D6) 4 | interface 5 | 6 | type 7 | PObject = ^TObject; 8 | PClass = ^TClass; 9 | 10 | // TObject virtual methods' signatures 11 | PSafeCallException = function (Self: TObject; ExceptObject: TObject; 12 | ExceptAddr: Pointer): HResult; 13 | PAfterConstruction = procedure (Self: TObject); 14 | PBeforeDestruction = procedure (Self: TObject); 15 | PDispatch = procedure (Self: TObject; var Message); 16 | PDefaultHandler = procedure (Self: TObject; var Message); 17 | PNewInstance = function (Self: TClass) : TObject; 18 | PFreeInstance = procedure (Self: TObject); 19 | PDestroy = procedure (Self: TObject; OuterMost: ShortInt); 20 | 21 | // Dynamic methods table 22 | TDMTIndex = Smallint; 23 | PDmtIndices = ^TDmtIndices; 24 | TDmtIndices = array[0..High(Word)-1] of TDMTIndex; 25 | PDmtMethods = ^TDmtMethods; 26 | TDmtMethods = array[0..High(Word)-1] of Pointer; 27 | PDmt = ^TDmt; 28 | TDmt = packed record 29 | Count: word; 30 | Indicies: TDmtIndices; // really [0..Count-1] 31 | Methods : TDmtMethods; // really [0..Count-1] 32 | end; 33 | 34 | // Published methods table 35 | PPublishedMethod = ^TPublishedMethod; 36 | TPublishedMethod = packed record 37 | Size: word; 38 | Address: Pointer; 39 | Name: {packed} Shortstring; 40 | end; 41 | TPublishedMethods = packed array[0..High(Word)-1] of TPublishedMethod; 42 | PPmt = ^TPmt; 43 | TPmt = packed record 44 | Count: Word; 45 | Methods: TPublishedMethods; // really [0..Count-1] 46 | end; 47 | 48 | // Published fields table 49 | PPublishedField = ^TPublishedField; 50 | TPublishedField = packed record 51 | Offset: Integer; 52 | TypeIndex: word; // Index into the FieldTypes array below 53 | Name: {packed} Shortstring; // really string[Length(Name)] 54 | end; 55 | PPublishedFieldTypes = ^TPublishedFieldTypes; 56 | TPublishedFieldTypes = packed record 57 | TypeCount: word; 58 | Types: array[0..High(Word)-1] of PClass; // really [0..TypeCount-1] 59 | end; 60 | TPublishedFields = packed array[0..High(Word)-1] of TPublishedField; 61 | PPft = ^TPft; 62 | TPft = packed record 63 | Count: Word; 64 | FieldTypes: PPublishedFieldTypes; 65 | Fields: TPublishedFields; // really [0..Count-1] 66 | end; 67 | 68 | // Virtual method table 69 | PVmt = ^TVmt; 70 | TVmt = packed record 71 | SelfPtr : TClass; 72 | IntfTable : Pointer; 73 | AutoTable : Pointer; 74 | InitTable : Pointer; 75 | TypeInfo : Pointer; 76 | FieldTable : PPft; 77 | MethodTable : PPmt; 78 | DynamicTable : PDmt; 79 | ClassName : PShortString; 80 | InstanceSize : PLongint; 81 | Parent : PClass; 82 | SafeCallException : PSafeCallException; 83 | AfterConstruction : PAfterConstruction; 84 | BeforeDestruction : PBeforeDestruction; 85 | Dispatch : PDispatch; 86 | DefaultHandler : PDefaultHandler; 87 | NewInstance : PNewInstance; 88 | FreeInstance : PFreeInstance; 89 | Destroy : PDestroy; 90 | {UserDefinedVirtuals: array[0..999] of procedure;} 91 | end; 92 | 93 | // Virtual method table 94 | function GetVmt(AClass: TClass): PVmt; 95 | 96 | // Published methods 97 | function GetPmt(AClass: TClass): PPmt; 98 | function GetPublishedMethodCount(AClass: TClass): integer; 99 | function GetPublishedMethod(AClass: TClass; Index: integer): PPublishedMethod; 100 | function GetFirstPublishedMethod(AClass: TClass): PPublishedMethod; 101 | function GetNextPublishedMethod(AClass: TClass; PublishedMethod: PPublishedMethod): PPublishedMethod; 102 | function FindPublishedMethodByName(AClass: TClass; const AName: ShortString): PPublishedMethod; 103 | function FindPublishedMethodByAddr(AClass: TClass; AAddr: Pointer): PPublishedMethod; 104 | function FindPublishedMethodAddr(AClass: TClass; const AName: ShortString): Pointer; 105 | function FindPublishedMethodName(AClass: TClass; AAddr: Pointer): Shortstring; 106 | 107 | // Published fields 108 | function GetPft(AClass: TClass): PPft; 109 | function GetPublishedFieldCount(AClass: TClass): integer; 110 | function GetNextPublishedField(AClass: TClass; 111 | PublishedField: PPublishedField): PPublishedField; 112 | function GetPublishedField(AClass: TClass; TypeIndex: integer): PPublishedField; 113 | function GetFirstPublishedField(AClass: TClass): PPublishedField; 114 | function FindPublishedFieldByName(AClass: TClass; const AName: ShortString): PPublishedField; 115 | function FindPublishedFieldByOffset(AClass: TClass; AOffset: Integer): PPublishedField; 116 | function FindPublishedFieldByAddr(Instance: TObject; AAddr: Pointer): PPublishedField; 117 | function FindPublishedFieldOffset(AClass: TClass; const AName: ShortString): integer; 118 | function FindPublishedFieldAddr(Instance: TObject; const AName: ShortString): PObject; 119 | function FindPublishedFieldName(AClass: TClass; AOffset: integer): Shortstring; overload; 120 | function FindPublishedFieldName(Instance: TObject; AAddr: Pointer): Shortstring; overload; 121 | function GetPublishedFieldType(AClass: TClass; Field: PPublishedField): TClass; 122 | function GetPublishedFieldAddr(Instance: TObject; Field: PPublishedField): PObject; 123 | function GetPublishedFieldValue(Instance: TObject; Field: PPublishedField): TObject; 124 | 125 | implementation 126 | 127 | uses 128 | Classes, 129 | SysUtils, 130 | TypInfo; 131 | 132 | // Virtual method table 133 | 134 | function GetVmt(AClass: TClass): PVmt; 135 | begin 136 | Result := PVmt(AClass); 137 | Dec(Result); 138 | end; 139 | 140 | // Published methods 141 | 142 | function GetPmt(AClass: TClass): PPmt; 143 | var 144 | Vmt: PVmt; 145 | begin 146 | Vmt := GetVmt(AClass); 147 | if Assigned(Vmt) 148 | then Result := Vmt.MethodTable 149 | else Result := nil; 150 | end; 151 | 152 | function GetPublishedMethodCount(AClass: TClass): integer; 153 | var 154 | Pmt: PPmt; 155 | begin 156 | Pmt := GetPmt(AClass); 157 | if Assigned(Pmt) 158 | then Result := Pmt.Count 159 | else Result := 0; 160 | end; 161 | 162 | function GetPublishedMethod(AClass: TClass; Index: integer): PPublishedMethod; 163 | var 164 | Pmt: PPmt; 165 | begin 166 | Pmt := GetPmt(AClass); 167 | if Assigned(Pmt) and (Index < Pmt.Count) then 168 | begin 169 | Result := @Pmt.Methods[0]; 170 | while Index > 0 do 171 | begin 172 | Inc(PChar(Result), Result.Size); 173 | Dec(Index); 174 | end; 175 | end 176 | else 177 | Result := nil; 178 | end; 179 | 180 | function GetFirstPublishedMethod(AClass: TClass): PPublishedMethod; 181 | begin 182 | Result := GetPublishedMethod(AClass, 0); 183 | end; 184 | {.$DEFINE DEBUG} 185 | function GetNextPublishedMethod(AClass: TClass; 186 | PublishedMethod: PPublishedMethod): PPublishedMethod; 187 | // Note: Caller is responsible for calling this the 188 | // correct number of times (using GetPublishedMethodCount) 189 | {$IFDEF DEBUG} 190 | var 191 | ExpectedSize: integer; 192 | {$ENDIF} 193 | begin 194 | Result := PublishedMethod; 195 | {$IFDEF DEBUG} 196 | ExpectedSize := SizeOf(Result.Size) 197 | + SizeOf(Result.Address) 198 | + SizeOf(Result.Name[0]) 199 | + Length(Result.Name); 200 | if Result.Size <> ExpectedSize then 201 | raise Exception.CreateFmt( 202 | 'RTTI for the published method "%s" of class "%s" has %d extra bytes of unknown data!', 203 | [Result.Name, AClass.ClassName, Result.Size-ExpectedSize]); 204 | {$ENDIF} 205 | if Assigned(Result) then 206 | Inc(PChar(Result), Result.Size); 207 | end; 208 | 209 | function FindPublishedMethodByName(AClass: TClass; const AName: ShortString): PPublishedMethod; 210 | var 211 | i : integer; 212 | begin 213 | while Assigned(AClass) do 214 | begin 215 | Result := GetFirstPublishedMethod(AClass); 216 | for i := 0 to GetPublishedMethodCount(AClass)-1 do 217 | begin 218 | // Note: Length(ShortString) expands to efficient inline code 219 | if (Length(Result.Name) = Length(AName)) and 220 | (StrLIComp(@Result.Name[1], @AName[1], Length(AName)) = 0) then 221 | Exit; 222 | Result := GetNextPublishedMethod(AClass, Result); 223 | end; 224 | AClass := AClass.ClassParent; 225 | end; 226 | Result := nil; 227 | end; 228 | 229 | function FindPublishedMethodByAddr(AClass: TClass; AAddr: Pointer): PPublishedMethod; 230 | var 231 | i : integer; 232 | begin 233 | while Assigned(AClass) do 234 | begin 235 | Result := GetFirstPublishedMethod(AClass); 236 | for i := 0 to GetPublishedMethodCount(AClass)-1 do 237 | begin 238 | if Result.Address = AAddr then 239 | Exit; 240 | Result := GetNextPublishedMethod(AClass, Result); 241 | end; 242 | AClass := AClass.ClassParent; 243 | end; 244 | Result := nil; 245 | end; 246 | 247 | function FindPublishedMethodAddr(AClass: TClass; const AName: ShortString): Pointer; 248 | var 249 | Method: PPublishedMethod; 250 | begin 251 | Method := FindPublishedMethodByName(AClass, AName); 252 | if Assigned(Method) 253 | then Result := Method.Address 254 | else Result := nil; 255 | end; 256 | 257 | function FindPublishedMethodName(AClass: TClass; AAddr: Pointer): Shortstring; 258 | var 259 | Method: PPublishedMethod; 260 | begin 261 | Method := FindPublishedMethodByAddr(AClass, AAddr); 262 | if Assigned(Method) 263 | then Result := Method.Name 264 | else Result := ''; 265 | end; 266 | 267 | // Published fields 268 | 269 | function GetPft(AClass: TClass): PPft; 270 | var 271 | Vmt: PVmt; 272 | begin 273 | Vmt := GetVmt(AClass); 274 | if Assigned(Vmt) 275 | then Result := Vmt.FieldTable 276 | else Result := nil; 277 | end; 278 | 279 | function GetPublishedFieldCount(AClass: TClass): integer; 280 | var 281 | Pft: PPft; 282 | begin 283 | Pft := GetPft(AClass); 284 | if Assigned(Pft) 285 | then Result := Pft.Count 286 | else Result := 0; 287 | end; 288 | 289 | function GetNextPublishedField(AClass: TClass; 290 | PublishedField: PPublishedField): PPublishedField; 291 | // Note: Caller is responsible for calling this the 292 | // correct number of times (using GetPublishedFieldCount) 293 | begin 294 | Result := PublishedField; 295 | if Assigned(Result) then 296 | Inc(PChar(Result), SizeOf(Result.Offset) 297 | + SizeOf(Result.TypeIndex) 298 | + SizeOf(Result.Name[0]) 299 | + Length(Result.Name)); 300 | end; 301 | 302 | function GetPublishedField(AClass: TClass; TypeIndex: integer): PPublishedField; 303 | var 304 | Pft: PPft; 305 | begin 306 | Pft := GetPft(AClass); 307 | if Assigned(Pft) and (TypeIndex < Pft.Count) then 308 | begin 309 | Result := @Pft.Fields[0]; 310 | while TypeIndex > 0 do 311 | begin 312 | Result := GetNextPublishedField(AClass, Result); 313 | Dec(TypeIndex); 314 | end; 315 | end 316 | else 317 | Result := nil; 318 | end; 319 | 320 | function GetFirstPublishedField(AClass: TClass): PPublishedField; 321 | begin 322 | Result := GetPublishedField(AClass, 0); 323 | end; 324 | 325 | function FindPublishedFieldByName(AClass: TClass; const AName: ShortString): PPublishedField; 326 | var 327 | i : integer; 328 | begin 329 | while Assigned(AClass) do 330 | begin 331 | Result := GetFirstPublishedField(AClass); 332 | for i := 0 to GetPublishedFieldCount(AClass)-1 do 333 | begin 334 | // Note: Length(ShortString) expands to efficient inline code 335 | if (Length(Result.Name) = Length(AName)) and 336 | (StrLIComp(@Result.Name[1], @AName[1], Length(AName)) = 0) then 337 | Exit; 338 | Result := GetNextPublishedField(AClass, Result); 339 | end; 340 | AClass := AClass.ClassParent; 341 | end; 342 | Result := nil; 343 | end; 344 | 345 | function FindPublishedFieldByOffset(AClass: TClass; AOffset: Integer): PPublishedField; 346 | var 347 | i : integer; 348 | begin 349 | while Assigned(AClass) do 350 | begin 351 | Result := GetFirstPublishedField(AClass); 352 | for i := 0 to GetPublishedFieldCount(AClass)-1 do 353 | begin 354 | if Result.Offset = AOffset then 355 | Exit; 356 | Result := GetNextPublishedField(AClass, Result); 357 | end; 358 | AClass := AClass.ClassParent; 359 | end; 360 | Result := nil; 361 | end; 362 | 363 | function FindPublishedFieldByAddr(Instance: TObject; AAddr: Pointer): PPublishedField; 364 | begin 365 | Result := FindPublishedFieldByOffset(Instance.ClassType, PChar(AAddr) - PChar(Instance)); 366 | end; 367 | 368 | function FindPublishedFieldOffset(AClass: TClass; const AName: ShortString): integer; 369 | var 370 | Field: PPublishedField; 371 | begin 372 | Field := FindPublishedFieldByName(AClass, AName); 373 | if Assigned(Field) 374 | then Result := Field.Offset 375 | else Result := -1; 376 | end; 377 | 378 | function FindPublishedFieldAddr(Instance: TObject; const AName: ShortString): PObject; 379 | var 380 | Offset: integer; 381 | begin 382 | Offset := FindPublishedFieldOffset(Instance.ClassType, AName); 383 | if Offset >= 0 384 | then Result := PObject(PChar(Instance) + Offset) 385 | else Result := nil; 386 | end; 387 | 388 | function FindPublishedFieldName(AClass: TClass; AOffset: integer): Shortstring; overload; 389 | var 390 | Field: PPublishedField; 391 | begin 392 | Field := FindPublishedFieldByOffset(AClass, AOffset); 393 | if Assigned(Field) 394 | then Result := Field.Name 395 | else Result := ''; 396 | end; 397 | 398 | function FindPublishedFieldName(Instance: TObject; AAddr: Pointer): Shortstring; overload; 399 | var 400 | Field: PPublishedField; 401 | begin 402 | Field := FindPublishedFieldByAddr(Instance, AAddr); 403 | if Assigned(Field) 404 | then Result := Field.Name 405 | else Result := ''; 406 | end; 407 | 408 | function GetPublishedFieldType(AClass: TClass; Field: PPublishedField): TClass; 409 | var 410 | Pft: PPft; 411 | begin 412 | Pft := GetPft(AClass); 413 | if Assigned(Pft) and Assigned(Field) and (Field.TypeIndex < Pft.FieldTypes.TypeCount) 414 | then Result := Pft.FieldTypes.Types[Field.TypeIndex]^ 415 | else Result := nil; 416 | end; 417 | 418 | function GetPublishedFieldAddr(Instance: TObject; Field: PPublishedField): PObject; 419 | begin 420 | if Assigned(Field) 421 | then Result := PObject(PChar(Instance) + Field.Offset) 422 | else Result := nil; 423 | end; 424 | 425 | function GetPublishedFieldValue(Instance: TObject; Field: PPublishedField): TObject; 426 | var 427 | FieldAddr: PObject; 428 | begin 429 | FieldAddr := GetPublishedFieldAddr(Instance, Field); 430 | if Assigned(FieldAddr) 431 | then Result := FieldAddr^ 432 | else Result := nil; 433 | end; 434 | 435 | end. 436 | 437 | -------------------------------------------------------------------------------- /vclexp.cfg: -------------------------------------------------------------------------------- 1 | -$A8 2 | -$B- 3 | -$C- 4 | -$D+ 5 | -$E- 6 | -$F- 7 | -$G+ 8 | -$H+ 9 | -$I+ 10 | -$J+ 11 | -$K- 12 | -$L+ 13 | -$M- 14 | -$N+ 15 | -$O+ 16 | -$P+ 17 | -$Q- 18 | -$R- 19 | -$S- 20 | -$T- 21 | -$U- 22 | -$V+ 23 | -$W- 24 | -$X+ 25 | -$YD 26 | -$Z1 27 | -cg 28 | -AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; 29 | -H+ 30 | -W+ 31 | -M 32 | -$M16384,1048576 33 | -K$00400000 34 | -LE"c:\program files (x86)\borland\delphi7\..\Bpl" 35 | -LN"c:\program files (x86)\borland\delphi7\..\Bpl" 36 | -U".\JCL;.\RTTI;D:\SOURCE\Package\ExtListView;D:\SOURCE\Package\Unicode\Source" 37 | -O".\JCL;.\RTTI;D:\SOURCE\Package\ExtListView;D:\SOURCE\Package\Unicode\Source" 38 | -I".\JCL;.\RTTI;D:\SOURCE\Package\ExtListView;D:\SOURCE\Package\Unicode\Source" 39 | -R".\JCL;.\RTTI;D:\SOURCE\Package\ExtListView;D:\SOURCE\Package\Unicode\Source" 40 | -w-UNSAFE_TYPE 41 | -w-UNSAFE_CODE 42 | -w-UNSAFE_CAST 43 | -------------------------------------------------------------------------------- /vclexp.dof: -------------------------------------------------------------------------------- 1 | [FileVersion] 2 | Version=7.0 3 | [Compiler] 4 | A=8 5 | B=0 6 | C=0 7 | D=1 8 | E=0 9 | F=0 10 | G=1 11 | H=1 12 | I=1 13 | J=1 14 | K=0 15 | L=1 16 | M=0 17 | N=1 18 | O=1 19 | P=1 20 | Q=0 21 | R=0 22 | S=0 23 | T=0 24 | U=0 25 | V=1 26 | W=0 27 | X=1 28 | Y=1 29 | Z=1 30 | ShowHints=1 31 | ShowWarnings=1 32 | UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; 33 | NamespacePrefix= 34 | SymbolDeprecated=1 35 | SymbolLibrary=1 36 | SymbolPlatform=1 37 | UnitLibrary=1 38 | UnitPlatform=1 39 | UnitDeprecated=1 40 | HResultCompat=1 41 | HidingMember=1 42 | HiddenVirtual=1 43 | Garbage=1 44 | BoundsError=1 45 | ZeroNilCompat=1 46 | StringConstTruncated=1 47 | ForLoopVarVarPar=1 48 | TypedConstVarPar=1 49 | AsgToTypedConst=1 50 | CaseLabelRange=1 51 | ForVariable=1 52 | ConstructingAbstract=1 53 | ComparisonFalse=1 54 | ComparisonTrue=1 55 | ComparingSignedUnsigned=1 56 | CombiningSignedUnsigned=1 57 | UnsupportedConstruct=1 58 | FileOpen=1 59 | FileOpenUnitSrc=1 60 | BadGlobalSymbol=1 61 | DuplicateConstructorDestructor=1 62 | InvalidDirective=1 63 | PackageNoLink=1 64 | PackageThreadVar=1 65 | ImplicitImport=1 66 | HPPEMITIgnored=1 67 | NoRetVal=1 68 | UseBeforeDef=1 69 | ForLoopVarUndef=1 70 | UnitNameMismatch=1 71 | NoCFGFileFound=1 72 | MessageDirective=1 73 | ImplicitVariants=1 74 | UnicodeToLocale=1 75 | LocaleToUnicode=1 76 | ImagebaseMultiple=1 77 | SuspiciousTypecast=1 78 | PrivatePropAccessor=1 79 | UnsafeType=0 80 | UnsafeCode=0 81 | UnsafeCast=0 82 | [Linker] 83 | MapFile=0 84 | OutputObjs=0 85 | ConsoleApp=1 86 | DebugInfo=0 87 | RemoteSymbols=0 88 | MinStackSize=16384 89 | MaxStackSize=1048576 90 | ImageBase=4194304 91 | ExeDescription= 92 | [Directories] 93 | OutputDir= 94 | UnitOutputDir= 95 | PackageDLLOutputDir= 96 | PackageDCPOutputDir= 97 | SearchPath=.\JCL;.\RTTI;D:\SOURCE\Package\ExtListView;D:\SOURCE\Package\Unicode\Source 98 | Packages=vcl;rtl;vclx;vclactnband;TSiLang_D7r;IcsDel70;KZ;dbrtl;EasyListviewD7;TMSUnicodeD7;ELV;GLvis;ShellCtrl;VclSmp;frx7;vcldb;dclusr;Misc;NiceGridD7;SpTBXLib_d7;tb2k_d7;VirtualShellToolsD7;VirtualTreesD7;zDesign7;fs7;frxe7;vclie;llPDFLibD7;RVword 99 | Conditionals= 100 | DebugSourceDirs= 101 | UsePackages=0 102 | [Parameters] 103 | RunParams= 104 | HostApplication= 105 | Launcher= 106 | UseLauncher=0 107 | DebugCWD= 108 | [Language] 109 | ActiveLang= 110 | ProjectLang= 111 | RootDir= 112 | [Version Info] 113 | IncludeVerInfo=0 114 | AutoIncBuild=0 115 | MajorVer=1 116 | MinorVer=0 117 | Release=0 118 | Build=0 119 | Debug=0 120 | PreRelease=0 121 | Special=0 122 | Private=0 123 | DLL=0 124 | Locale=1026 125 | CodePage=1251 126 | [Version Info Keys] 127 | CompanyName= 128 | FileDescription= 129 | FileVersion=1.0.0.0 130 | InternalName= 131 | LegalCopyright= 132 | LegalTrademarks= 133 | OriginalFilename= 134 | ProductName= 135 | ProductVersion=1.0.0.0 136 | Comments= 137 | [Excluded Packages] 138 | c:\Program Files (x86)\Borland\Bpl\lwizard7.bpl=Korzh Localizer 139 | c:\Program Files (x86)\Borland\Bpl\kctrls6.bpl=KStringGrid component 140 | [HistoryLists\hlUnitAliases] 141 | Count=1 142 | Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; 143 | [HistoryLists\hlSearchPath] 144 | Count=5 145 | Item0=.\JCL;.\RTTI;D:\SOURCE\Package\ExtListView;D:\SOURCE\Package\Unicode\Source 146 | Item1=D:\SOURCE\VCL explorer\JCL;D:\SOURCE\VCL explorer\RTTI;D:\Program Files\Borland\Projects\Bpl\ExtListView;D:\Program Files\Borland\Projects\Bpl\Unicode\Source 147 | Item2=D:\SOURCE\VCL explorer\JCL;D:\SOURCE\VCL explorer\RTTI;D:\Program Files\Borland\Projects\Bpl\ExtListView 148 | Item3=D:\SOURCE\VCL explorer\JCL;D:\SOURCE\VCL explorer\RTTI 149 | Item4=D:\SOURCE\VCL explorer\JCL 150 | [Exception Log] 151 | EurekaLog Version=6105 152 | Activate=0 153 | Activate Handle=1 154 | Save Log File=1 155 | Foreground Tab=0 156 | Freeze Activate=0 157 | Freeze Timeout=60 158 | SMTP From=eurekalog@email.com 159 | SMTP Host= 160 | SMTP Port=25 161 | SMTP UserID= 162 | SMTP Password= 163 | Append to Log=0 164 | TerminateBtn Operation=2 165 | Errors Number=32 166 | Errors Terminate=3 167 | Email Address= 168 | Email Object= 169 | Email Send Options=0 170 | Output Path= 171 | Encrypt Password= 172 | AutoCloseDialogSecs=0 173 | WebSendMode=0 174 | SupportULR= 175 | HTMLLayout Count=15 176 | HTMLLine0="%3Chtml%3E" 177 | HTMLLine1=" %3Chead%3E" 178 | HTMLLine2=" %3C/head%3E" 179 | HTMLLine3=" %3Cbody TopMargin=10 LeftMargin=10%3E" 180 | HTMLLine4=" %3Ctable width="100%%" border="0"%3E" 181 | HTMLLine5=" %3Ctr%3E" 182 | HTMLLine6=" %3Ctd nowrap%3E" 183 | HTMLLine7=" %3Cfont face="Lucida Console, Courier" size="2"%3E" 184 | HTMLLine8=" %3C%%HTML_TAG%%%3E" 185 | HTMLLine9=" %3C/font%3E" 186 | HTMLLine10=" %3C/td%3E" 187 | HTMLLine11=" %3C/tr%3E" 188 | HTMLLine12=" %3C/table%3E" 189 | HTMLLine13=" %3C/body%3E" 190 | HTMLLine14="%3C/html%3E" 191 | AutoCrashOperation=2 192 | AutoCrashNumber=10 193 | AutoCrashMinutes=1 194 | WebURL= 195 | WebUserID= 196 | WebPassword= 197 | WebPort=0 198 | AttachedFiles= 199 | ProxyURL= 200 | ProxyUser= 201 | ProxyPassword= 202 | ProxyPort=8080 203 | TrakerUser= 204 | TrakerPassword= 205 | TrakerAssignTo= 206 | TrakerProject= 207 | TrakerCategory= 208 | TrakerTrialID= 209 | ZipPassword= 210 | PreBuildEvent= 211 | PostSuccessfulBuildEvent= 212 | PostFailureBuildEvent= 213 | ExceptionDialogType=2 214 | Count=0 215 | EMail Message Line Count=0 216 | loNoDuplicateErrors=0 217 | loAppendReproduceText=0 218 | loDeleteLogAtVersionChange=0 219 | loAddComputerNameInLogFileName=0 220 | loSaveModulesAndProcessesSections=1 221 | loSaveAssemblerAndCPUSections=1 222 | soAppStartDate=1 223 | soAppName=1 224 | soAppVersionNumber=1 225 | soAppParameters=1 226 | soAppCompilationDate=1 227 | soAppUpTime=1 228 | soExcDate=1 229 | soExcAddress=1 230 | soExcModuleName=1 231 | soExcModuleVersion=1 232 | soExcType=1 233 | soExcMessage=1 234 | soExcID=1 235 | soExcCount=1 236 | soExcStatus=1 237 | soExcNote=1 238 | soUserID=1 239 | soUserName=1 240 | soUserEmail=1 241 | soUserPrivileges=1 242 | soUserCompany=1 243 | soActCtlsFormClass=1 244 | soActCtlsFormText=1 245 | soActCtlsControlClass=1 246 | soActCtlsControlText=1 247 | soCmpName=1 248 | soCmpTotalMemory=1 249 | soCmpFreeMemory=1 250 | soCmpTotalDisk=1 251 | soCmpFreeDisk=1 252 | soCmpSysUpTime=1 253 | soCmpProcessor=1 254 | soCmpDisplayMode=1 255 | soCmpDisplayDPI=1 256 | soCmpVideoCard=1 257 | soCmpPrinter=1 258 | soOSType=1 259 | soOSBuildN=1 260 | soOSUpdate=1 261 | soOSLanguage=1 262 | soOSCharset=1 263 | soNetIP=1 264 | soNetSubmask=1 265 | soNetGateway=1 266 | soNetDNS1=1 267 | soNetDNS2=1 268 | soNetDHCP=1 269 | soCustomData=1 270 | sndShowSendDialog=1 271 | sndShowSuccessFailureMsg=0 272 | sndSendEntireLog=0 273 | sndSendXMLLogCopy=0 274 | sndSendScreenshot=1 275 | sndUseOnlyActiveWindow=0 276 | sndSendLastHTMLPage=1 277 | sndSendInSeparatedThread=0 278 | sndAddDateInFileName=0 279 | sndAddComputerNameInFileName=0 280 | edoSendErrorReportChecked=1 281 | edoAttachScreenshotChecked=1 282 | edoShowCopyToClipOption=1 283 | edoShowDetailsButton=1 284 | edoShowInDetailedMode=0 285 | edoShowInTopMostMode=0 286 | edoUseEurekaLogLookAndFeel=0 287 | edoShowSendErrorReportOption=1 288 | edoShowAttachScreenshotOption=1 289 | edoShowCustomButton=0 290 | csoShowDLLs=1 291 | csoShowBPLs=1 292 | csoShowBorlandThreads=1 293 | csoShowWindowsThreads=1 294 | csoDoNotStoreProcNames=0 295 | boPauseBorlandThreads=0 296 | boDoNotPauseMainThread=0 297 | boPauseWindowsThreads=0 298 | boUseMainModuleOptions=1 299 | boCopyLogInCaseOfError=1 300 | boSaveCompressedCopyInCaseOfError=0 301 | boHandleSafeCallExceptions=1 302 | boCallRTLExceptionEvent=0 303 | boCatchHandledExceptions=0 304 | loCatchLeaks=0 305 | loGroupsSonLeaks=1 306 | loHideBorlandLeaks=1 307 | loFreeAllLeaks=1 308 | loCatchLeaksExceptions=1 309 | cfoReduceFileSize=1 310 | cfoCheckFileCorruption=0 311 | cfoUseEL7=0 312 | Count mtInformationMsgCaption=1 313 | mtInformationMsgCaption0="Information." 314 | Count mtQuestionMsgCaption=1 315 | mtQuestionMsgCaption0="Question." 316 | Count mtErrorMsgCaption=1 317 | mtErrorMsgCaption0="Error." 318 | Count mtDialog_Caption=1 319 | mtDialog_Caption0="Error occurred" 320 | Count mtDialog_ErrorMsgCaption=2 321 | mtDialog_ErrorMsgCaption0="An error has occurred during program execution." 322 | mtDialog_ErrorMsgCaption1="Please read the following information for further details." 323 | Count mtDialog_GeneralCaption=1 324 | mtDialog_GeneralCaption0="General" 325 | Count mtDialog_GeneralHeader=1 326 | mtDialog_GeneralHeader0="General Information" 327 | Count mtDialog_CallStackCaption=1 328 | mtDialog_CallStackCaption0="Call Stack" 329 | Count mtDialog_CallStackHeader=1 330 | mtDialog_CallStackHeader0="Call Stack Information" 331 | Count mtDialog_ModulesCaption=1 332 | mtDialog_ModulesCaption0="Modules" 333 | Count mtDialog_ModulesHeader=1 334 | mtDialog_ModulesHeader0="Modules Information" 335 | Count mtDialog_ProcessesCaption=1 336 | mtDialog_ProcessesCaption0="Processes" 337 | Count mtDialog_ProcessesHeader=1 338 | mtDialog_ProcessesHeader0="Processes Information" 339 | Count mtDialog_AsmCaption=1 340 | mtDialog_AsmCaption0="Assembler" 341 | Count mtDialog_AsmHeader=1 342 | mtDialog_AsmHeader0="Assembler Information" 343 | Count mtDialog_CPUCaption=1 344 | mtDialog_CPUCaption0="CPU" 345 | Count mtDialog_CPUHeader=1 346 | mtDialog_CPUHeader0="CPU Information" 347 | Count mtDialog_OKButtonCaption=1 348 | mtDialog_OKButtonCaption0="%26OK" 349 | Count mtDialog_TerminateButtonCaption=1 350 | mtDialog_TerminateButtonCaption0="%26Terminate" 351 | Count mtDialog_RestartButtonCaption=1 352 | mtDialog_RestartButtonCaption0="%26Restart" 353 | Count mtDialog_DetailsButtonCaption=1 354 | mtDialog_DetailsButtonCaption0="%26Details" 355 | Count mtDialog_CustomButtonCaption=1 356 | mtDialog_CustomButtonCaption0="%26Help" 357 | Count mtDialog_SendMessage=1 358 | mtDialog_SendMessage0="%26Send this error via Internet" 359 | Count mtDialog_ScreenshotMessage=1 360 | mtDialog_ScreenshotMessage0="%26Attach a Screenshot image" 361 | Count mtDialog_CopyMessage=1 362 | mtDialog_CopyMessage0="%26Copy to Clipboard" 363 | Count mtDialog_SupportMessage=1 364 | mtDialog_SupportMessage0="Go to the Support Page" 365 | Count mtMSDialog_ErrorMsgCaption=1 366 | mtMSDialog_ErrorMsgCaption0="The application has encountered a problem. We are sorry for the inconvenience." 367 | Count mtMSDialog_RestartCaption=1 368 | mtMSDialog_RestartCaption0="Restart application." 369 | Count mtMSDialog_TerminateCaption=1 370 | mtMSDialog_TerminateCaption0="Terminate application." 371 | Count mtMSDialog_PleaseCaption=1 372 | mtMSDialog_PleaseCaption0="Please tell us about this problem." 373 | Count mtMSDialog_DescriptionCaption=1 374 | mtMSDialog_DescriptionCaption0="We have created an error report that you can send to us. We will treat this report as confidential and anonymous." 375 | Count mtMSDialog_SeeDetailsCaption=1 376 | mtMSDialog_SeeDetailsCaption0="To see what data the error report contains," 377 | Count mtMSDialog_SeeClickCaption=1 378 | mtMSDialog_SeeClickCaption0="click here." 379 | Count mtMSDialog_HowToReproduceCaption=1 380 | mtMSDialog_HowToReproduceCaption0="What were you doing when the problem happened (optional)?" 381 | Count mtMSDialog_EmailCaption=1 382 | mtMSDialog_EmailCaption0="Email address (optional):" 383 | Count mtMSDialog_SendButtonCaption=1 384 | mtMSDialog_SendButtonCaption0="%26Send Error Report" 385 | Count mtMSDialog_NoSendButtonCaption=1 386 | mtMSDialog_NoSendButtonCaption0="%26Don't Send" 387 | Count mtLog_AppHeader=1 388 | mtLog_AppHeader0="Application" 389 | Count mtLog_AppStartDate=1 390 | mtLog_AppStartDate0="Start Date" 391 | Count mtLog_AppName=1 392 | mtLog_AppName0="Name/Description" 393 | Count mtLog_AppVersionNumber=1 394 | mtLog_AppVersionNumber0="Version Number" 395 | Count mtLog_AppParameters=1 396 | mtLog_AppParameters0="Parameters" 397 | Count mtLog_AppCompilationDate=1 398 | mtLog_AppCompilationDate0="Compilation Date" 399 | Count mtLog_AppUpTime=1 400 | mtLog_AppUpTime0="Up Time" 401 | Count mtLog_ExcHeader=1 402 | mtLog_ExcHeader0="Exception" 403 | Count mtLog_ExcDate=1 404 | mtLog_ExcDate0="Date" 405 | Count mtLog_ExcAddress=1 406 | mtLog_ExcAddress0="Address" 407 | Count mtLog_ExcModuleName=1 408 | mtLog_ExcModuleName0="Module Name" 409 | Count mtLog_ExcModuleVersion=1 410 | mtLog_ExcModuleVersion0="Module Version" 411 | Count mtLog_ExcType=1 412 | mtLog_ExcType0="Type" 413 | Count mtLog_ExcMessage=1 414 | mtLog_ExcMessage0="Message" 415 | Count mtLog_ExcID=1 416 | mtLog_ExcID0="ID" 417 | Count mtLog_ExcCount=1 418 | mtLog_ExcCount0="Count" 419 | Count mtLog_ExcStatus=1 420 | mtLog_ExcStatus0="Status" 421 | Count mtLog_ExcNote=1 422 | mtLog_ExcNote0="Note" 423 | Count mtLog_UserHeader=1 424 | mtLog_UserHeader0="User" 425 | Count mtLog_UserID=1 426 | mtLog_UserID0="ID" 427 | Count mtLog_UserName=1 428 | mtLog_UserName0="Name" 429 | Count mtLog_UserEmail=1 430 | mtLog_UserEmail0="Email" 431 | Count mtLog_UserCompany=1 432 | mtLog_UserCompany0="Company" 433 | Count mtLog_UserPrivileges=1 434 | mtLog_UserPrivileges0="Privileges" 435 | Count mtLog_ActCtrlsHeader=1 436 | mtLog_ActCtrlsHeader0="Active Controls" 437 | Count mtLog_ActCtrlsFormClass=1 438 | mtLog_ActCtrlsFormClass0="Form Class" 439 | Count mtLog_ActCtrlsFormText=1 440 | mtLog_ActCtrlsFormText0="Form Text" 441 | Count mtLog_ActCtrlsControlClass=1 442 | mtLog_ActCtrlsControlClass0="Control Class" 443 | Count mtLog_ActCtrlsControlText=1 444 | mtLog_ActCtrlsControlText0="Control Text" 445 | Count mtLog_CmpHeader=1 446 | mtLog_CmpHeader0="Computer" 447 | Count mtLog_CmpName=1 448 | mtLog_CmpName0="Name" 449 | Count mtLog_CmpTotalMemory=1 450 | mtLog_CmpTotalMemory0="Total Memory" 451 | Count mtLog_CmpFreeMemory=1 452 | mtLog_CmpFreeMemory0="Free Memory" 453 | Count mtLog_CmpTotalDisk=1 454 | mtLog_CmpTotalDisk0="Total Disk" 455 | Count mtLog_CmpFreeDisk=1 456 | mtLog_CmpFreeDisk0="Free Disk" 457 | Count mtLog_CmpSystemUpTime=1 458 | mtLog_CmpSystemUpTime0="System Up Time" 459 | Count mtLog_CmpProcessor=1 460 | mtLog_CmpProcessor0="Processor" 461 | Count mtLog_CmpDisplayMode=1 462 | mtLog_CmpDisplayMode0="Display Mode" 463 | Count mtLog_CmpDisplayDPI=1 464 | mtLog_CmpDisplayDPI0="Display DPI" 465 | Count mtLog_CmpVideoCard=1 466 | mtLog_CmpVideoCard0="Video Card" 467 | Count mtLog_CmpPrinter=1 468 | mtLog_CmpPrinter0="Printer" 469 | Count mtLog_OSHeader=1 470 | mtLog_OSHeader0="Operating System" 471 | Count mtLog_OSType=1 472 | mtLog_OSType0="Type" 473 | Count mtLog_OSBuildN=1 474 | mtLog_OSBuildN0="Build #" 475 | Count mtLog_OSUpdate=1 476 | mtLog_OSUpdate0="Update" 477 | Count mtLog_OSLanguage=1 478 | mtLog_OSLanguage0="Language" 479 | Count mtLog_OSCharset=1 480 | mtLog_OSCharset0="Charset" 481 | Count mtLog_NetHeader=1 482 | mtLog_NetHeader0="Network" 483 | Count mtLog_NetIP=1 484 | mtLog_NetIP0="IP Address" 485 | Count mtLog_NetSubmask=1 486 | mtLog_NetSubmask0="Submask" 487 | Count mtLog_NetGateway=1 488 | mtLog_NetGateway0="Gateway" 489 | Count mtLog_NetDNS1=1 490 | mtLog_NetDNS10="DNS 1" 491 | Count mtLog_NetDNS2=1 492 | mtLog_NetDNS20="DNS 2" 493 | Count mtLog_NetDHCP=1 494 | mtLog_NetDHCP0="DHCP" 495 | Count mtLog_CustInfoHeader=1 496 | mtLog_CustInfoHeader0="Custom Information" 497 | Count mtCallStack_Address=1 498 | mtCallStack_Address0="Address" 499 | Count mtCallStack_Name=1 500 | mtCallStack_Name0="Module" 501 | Count mtCallStack_Unit=1 502 | mtCallStack_Unit0="Unit" 503 | Count mtCallStack_Class=1 504 | mtCallStack_Class0="Class" 505 | Count mtCallStack_Procedure=1 506 | mtCallStack_Procedure0="Procedure/Method" 507 | Count mtCallStack_Line=1 508 | mtCallStack_Line0="Line" 509 | Count mtCallStack_MainThread=1 510 | mtCallStack_MainThread0="Main" 511 | Count mtCallStack_ExceptionThread=1 512 | mtCallStack_ExceptionThread0="Exception Thread" 513 | Count mtCallStack_RunningThread=1 514 | mtCallStack_RunningThread0="Running Thread" 515 | Count mtCallStack_CallingThread=1 516 | mtCallStack_CallingThread0="Calling Thread" 517 | Count mtCallStack_ThreadID=1 518 | mtCallStack_ThreadID0="ID" 519 | Count mtCallStack_ThreadPriority=1 520 | mtCallStack_ThreadPriority0="Priority" 521 | Count mtCallStack_ThreadClass=1 522 | mtCallStack_ThreadClass0="Class" 523 | Count mtCallStack_LeakCaption=1 524 | mtCallStack_LeakCaption0="Memory Leak" 525 | Count mtCallStack_LeakData=1 526 | mtCallStack_LeakData0="Data" 527 | Count mtCallStack_LeakType=1 528 | mtCallStack_LeakType0="Type" 529 | Count mtCallStack_LeakSize=1 530 | mtCallStack_LeakSize0="Total size" 531 | Count mtCallStack_LeakCount=1 532 | mtCallStack_LeakCount0="Count" 533 | Count mtSendDialog_Caption=1 534 | mtSendDialog_Caption0="Send." 535 | Count mtSendDialog_Message=1 536 | mtSendDialog_Message0="Message" 537 | Count mtSendDialog_Resolving=1 538 | mtSendDialog_Resolving0="Resolving DNS..." 539 | Count mtSendDialog_Login=1 540 | mtSendDialog_Login0="Login..." 541 | Count mtSendDialog_Connecting=1 542 | mtSendDialog_Connecting0="Connecting with server..." 543 | Count mtSendDialog_Connected=1 544 | mtSendDialog_Connected0="Connected with server." 545 | Count mtSendDialog_Sending=1 546 | mtSendDialog_Sending0="Sending message..." 547 | Count mtSendDialog_Sent=1 548 | mtSendDialog_Sent0="Message sent." 549 | Count mtSendDialog_SelectProject=1 550 | mtSendDialog_SelectProject0="Select project..." 551 | Count mtSendDialog_Searching=1 552 | mtSendDialog_Searching0="Searching..." 553 | Count mtSendDialog_Modifying=1 554 | mtSendDialog_Modifying0="Modifying..." 555 | Count mtSendDialog_Disconnecting=1 556 | mtSendDialog_Disconnecting0="Disconnecting..." 557 | Count mtSendDialog_Disconnected=1 558 | mtSendDialog_Disconnected0="Disconnected." 559 | Count mtReproduceDialog_Caption=1 560 | mtReproduceDialog_Caption0="Request" 561 | Count mtReproduceDialog_Request=1 562 | mtReproduceDialog_Request0="Please describe the steps to reproduce the error:" 563 | Count mtReproduceDialog_OKButtonCaption=1 564 | mtReproduceDialog_OKButtonCaption0="%26OK" 565 | Count mtModules_Handle=1 566 | mtModules_Handle0="Handle" 567 | Count mtModules_Name=1 568 | mtModules_Name0="Name" 569 | Count mtModules_Description=1 570 | mtModules_Description0="Description" 571 | Count mtModules_Version=1 572 | mtModules_Version0="Version" 573 | Count mtModules_Size=1 574 | mtModules_Size0="Size" 575 | Count mtModules_LastModified=1 576 | mtModules_LastModified0="Modified" 577 | Count mtModules_Path=1 578 | mtModules_Path0="Path" 579 | Count mtProcesses_ID=1 580 | mtProcesses_ID0="ID" 581 | Count mtProcesses_Name=1 582 | mtProcesses_Name0="Name" 583 | Count mtProcesses_Description=1 584 | mtProcesses_Description0="Description" 585 | Count mtProcesses_Version=1 586 | mtProcesses_Version0="Version" 587 | Count mtProcesses_Memory=1 588 | mtProcesses_Memory0="Memory" 589 | Count mtProcesses_Priority=1 590 | mtProcesses_Priority0="Priority" 591 | Count mtProcesses_Threads=1 592 | mtProcesses_Threads0="Threads" 593 | Count mtProcesses_Path=1 594 | mtProcesses_Path0="Path" 595 | Count mtCPU_Registers=1 596 | mtCPU_Registers0="Registers" 597 | Count mtCPU_Stack=1 598 | mtCPU_Stack0="Stack" 599 | Count mtCPU_MemoryDump=1 600 | mtCPU_MemoryDump0="Memory Dump" 601 | Count mtSend_SuccessMsg=1 602 | mtSend_SuccessMsg0="The message was sent successfully." 603 | Count mtSend_FailureMsg=1 604 | mtSend_FailureMsg0="Sorry, sending the message didn't work." 605 | Count mtSend_BugClosedMsg=2 606 | mtSend_BugClosedMsg0="These BUG is just closed." 607 | mtSend_BugClosedMsg1="Contact the program support to obtain an update." 608 | Count mtSend_UnknownErrorMsg=1 609 | mtSend_UnknownErrorMsg0="Unknown error." 610 | Count mtSend_InvalidLoginMsg=1 611 | mtSend_InvalidLoginMsg0="Invalid login request." 612 | Count mtSend_InvalidSearchMsg=1 613 | mtSend_InvalidSearchMsg0="Invalid search request." 614 | Count mtSend_InvalidSelectionMsg=1 615 | mtSend_InvalidSelectionMsg0="Invalid selection request." 616 | Count mtSend_InvalidInsertMsg=1 617 | mtSend_InvalidInsertMsg0="Invalid insert request." 618 | Count mtSend_InvalidModifyMsg=1 619 | mtSend_InvalidModifyMsg0="Invalid modify request." 620 | Count mtFileCrackedMsg=2 621 | mtFileCrackedMsg0="This file is cracked." 622 | mtFileCrackedMsg1="The application will be closed." 623 | Count mtException_LeakMultiFree=1 624 | mtException_LeakMultiFree0="Multi Free memory leak." 625 | Count mtException_LeakMemoryOverrun=1 626 | mtException_LeakMemoryOverrun0="Memory Overrun leak." 627 | Count mtException_AntiFreeze=1 628 | mtException_AntiFreeze0="The application seems to be frozen." 629 | Count mtInvalidEmailMsg=1 630 | mtInvalidEmailMsg0="Invalid email." 631 | TextsCollection=English 632 | 633 | 634 | -------------------------------------------------------------------------------- /vclexp.dpr: -------------------------------------------------------------------------------- 1 | program vclexp; 2 | 3 | uses 4 | Forms, 5 | Main in 'Main.pas' {Form1}, 6 | Dump in 'Dump.pas'; 7 | 8 | {$R *.res} 9 | 10 | begin 11 | Application.Initialize; 12 | Application.CreateForm(TForm1, Form1); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /vclexp.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tmcdos/VCL-explorer/60e3774c4bfd14c833d79eb67051b6d52069d6c7/vclexp.res --------------------------------------------------------------------------------