├── .gitignore ├── .travis.install.py ├── .travis.yml ├── CustomLineInfo.pas ├── ExceptionLogger.lpk ├── ExceptionLogger.pas ├── README.md ├── UExceptionForm.lfm ├── UExceptionForm.pas ├── UExceptionLogger.pas ├── UStackTrace.pas ├── assets └── icons │ └── no.png ├── demo ├── Demo.lpi ├── Demo.lpr ├── IncodeUsage.lpi ├── IncodeUsage.lpr ├── UMainForm.lfm ├── UMainForm.pas ├── revision.inc ├── utestincode.lfm └── utestincode.pas ├── doc └── images │ └── error_report.jpg ├── languages ├── UExceptionLogger.po └── UExceptionLogger.ru.po ├── leldcconvertencoding.inc ├── leldcconvertencoding.pas ├── leldcwindows.pas ├── lelversionsupport.pas ├── uappinfo.pas └── usysinfo.pas /.gitignore: -------------------------------------------------------------------------------- 1 | # Lazarus compiler-generated binaries (safe to delete) 2 | *.exe 3 | *.dll 4 | *.so 5 | *.dylib 6 | *.lrs 7 | *.res 8 | *.compiled 9 | *.dbg 10 | *.ppu 11 | *.o 12 | *.or 13 | *.a 14 | 15 | # Lazarus autogenerated files (duplicated info) 16 | *.rst 17 | *.rsj 18 | *.lrt 19 | 20 | # Lazarus local files (user-specific info) 21 | *.lps 22 | 23 | # Lazarus backups and unit output folders. 24 | # These can be changed by user in Lazarus/project options. 25 | backup/ 26 | *.bak 27 | lib/ 28 | 29 | # Application bundle for Mac OS 30 | *.app/ 31 | /demo/bugreport.txt 32 | -------------------------------------------------------------------------------- /.travis.install.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | # Part of `travis-lazarus` (https://github.com/nielsAD/travis-lazarus) 3 | # License: MIT 4 | 5 | import sys 6 | import os 7 | import subprocess 8 | 9 | OS_NAME=os.environ.get('TRAVIS_OS_NAME') or 'linux' 10 | OS_PMAN={'linux': 'sudo apt-get', 'osx': 'brew'}[OS_NAME] 11 | 12 | LAZ_TMP_DIR=os.environ.get('LAZ_TMP_DIR') or 'lazarus_tmp' 13 | LAZ_REL_DEF=os.environ.get('LAZ_REL_DEF') or {'linux':'amd64', 'qemu-arm':'amd64', 'qemu-arm-static':'amd64', 'osx':'i386', 'wine':'32'} 14 | LAZ_BIN_SRC=os.environ.get('LAZ_BIN_SRC') or 'https://sourceforge.net/projects/lazarus/files/%(target)s/Lazarus%%20%(version)s/' 15 | LAZ_BIN_TGT=os.environ.get('LAZ_BIN_TGT') or { 16 | 'linux': 'Lazarus%%20Linux%%20%(release)s%%20DEB', 17 | 'qemu-arm': 'Lazarus%%20Linux%%20%(release)s%%20DEB', 18 | 'qemu-arm-static': 'Lazarus%%20Linux%%20%(release)s%%20DEB', 19 | 'osx': 'Lazarus%%20Mac%%20OS%%20X%%20%(release)s', 20 | 'wine': 'Lazarus%%20Windows%%20%(release)s%%20bits' 21 | } 22 | 23 | def install_osx_dmg(dmg): 24 | try: 25 | # Mount .dmg file and parse (automatically determined) target volumes 26 | res = subprocess.check_output('sudo hdiutil attach %s | grep /Volumes/' % (dmg), shell=True) 27 | vol = ('/Volumes/' + l.strip().split('/Volumes/')[-1] for l in res.splitlines() if '/Volumes/' in l) 28 | except: 29 | return False 30 | 31 | # Install .pkg files with installer 32 | install_pkg = lambda v, f: os.system('sudo installer -pkg %s/%s -target /' % (v, f)) == 0 33 | 34 | for v in vol: 35 | try: 36 | if not all(map(lambda f: (not f.endswith('.pkg')) or install_pkg(v, f), os.listdir(v))): 37 | return False 38 | finally: 39 | # Unmount after installation 40 | os.system('hdiutil detach %s' % (v)) 41 | 42 | return True 43 | 44 | def install_lazarus_default(): 45 | if OS_NAME == 'linux': 46 | # Make sure nogui is installed for headless runs 47 | pkg = 'lazarus lcl-nogui' 48 | elif OS_NAME == 'osx': 49 | # Install brew cask first 50 | pkg = 'fpc caskroom/cask/brew-cask && %s cask install fpcsrc lazarus' % (OS_PMAN) 51 | else: 52 | # Default to lazarus 53 | pkg = 'lazarus' 54 | return os.system('%s install %s' % (OS_PMAN, pkg)) == 0 55 | 56 | def install_lazarus_version(ver,rel,env): 57 | # Download all files in directory for specified Lazarus version 58 | osn = env or OS_NAME 59 | tgt = LAZ_BIN_TGT[osn] % {'release': rel or LAZ_REL_DEF[osn]} 60 | src = LAZ_BIN_SRC % {'target': tgt, 'version': ver} 61 | if os.system('echo wget -w 1 -np -m -A download %s' % (src)) != 0: 62 | return False 63 | 64 | if os.system('wget -w 1 -np -m -A download %s' % (src)) != 0: 65 | return False 66 | 67 | if os.system('grep -Rh refresh sourceforge.net/ | grep -o "https://[^\\?]*" > urllist') != 0: 68 | return False 69 | 70 | if os.system('while read url; do wget --content-disposition "${url}" -A .deb,.dmg,.exe -P %s; done < urllist' % (LAZ_TMP_DIR)) != 0: 71 | return False 72 | 73 | if osn == 'wine': 74 | PKG_WINE={'bionic': 'wine32 wine-stable'}.get(os.environ.get('TRAVIS_DIST'), 'wine') 75 | 76 | # Install wine and Xvfb 77 | if os.system('sudo dpkg --add-architecture i386 && %s update && %s install xvfb %s' % (OS_PMAN, OS_PMAN, PKG_WINE)) != 0: 78 | return False 79 | 80 | # Initialize virtual display and wine directory 81 | if os.system('Xvfb %s & sleep 3 && (wineboot -i || wineboot-stable -i)' % (os.environ.get('DISPLAY') or '')) != 0: 82 | return False 83 | 84 | # Install basic Wine prerequisites, ignore failure 85 | os.system('winetricks -q corefonts') 86 | 87 | # Install all .exe files with wine 88 | process_file = lambda f: (not f.endswith('.exe')) or os.system('wine %s /VERYSILENT /DIR="c:\\lazarus"' % (f)) == 0 89 | elif osn == 'qemu-arm' or osn == 'qemu-arm-static': 90 | # Install qemu and arm cross compiling utilities 91 | if os.system('%s install libgtk2.0-dev qemu-user qemu-user-static binutils-arm-linux-gnueabi gcc-arm-linux-gnueabi libc-dev-armel-cross' % (OS_PMAN)) != 0: 92 | return False 93 | 94 | # Install all .deb files (for linux) and cross compile later 95 | process_file = lambda f: (not f.endswith('.deb')) or os.system('sudo dpkg --force-overwrite -i %s' % (f)) == 0 96 | elif osn == 'linux': 97 | # Install dependencies 98 | if os.system('%s install libgtk2.0-dev' % (OS_PMAN)) != 0: 99 | return False 100 | 101 | # Install all .deb files 102 | process_file = lambda f: (not f.endswith('.deb')) or os.system('sudo dpkg --force-overwrite -i %s' % (f)) == 0 103 | elif osn == 'osx': 104 | # Install all .dmg files 105 | process_file = lambda f: (not f.endswith('.dmg')) or install_osx_dmg(f) 106 | else: 107 | return False 108 | 109 | # Process all downloaded files 110 | if not all(map(lambda f: process_file(os.path.join(LAZ_TMP_DIR, f)), sorted(os.listdir(LAZ_TMP_DIR)))): 111 | return False 112 | 113 | if osn == 'wine': 114 | # Set wine Path (persistently) to include Lazarus binary directory 115 | if os.system('wine cmd /C reg add HKEY_CURRENT_USER\\\\Environment /v PATH /t REG_SZ /d "%PATH%\\;c:\\\\lazarus"') != 0: 116 | return False 117 | 118 | # Redirect listed executables so they execute in wine 119 | for alias in ('fpc', 'lazbuild', 'lazarus'): 120 | os.system('echo "#!/usr/bin/env bash \nwine %(target)s \$@" | sudo tee %(name)s > /dev/null && sudo chmod +x %(name)s' % { 121 | 'target': subprocess.check_output("find $WINEPREFIX -iname '%s.exe' | head -1 " % (alias), shell=True).strip(), 122 | 'name': '/usr/bin/%s' % (alias) 123 | }) 124 | elif osn == 'qemu-arm' or osn == 'qemu-arm-static': 125 | fpcv = subprocess.check_output('fpc -iV', shell=True).strip() 126 | gccv = subprocess.check_output('arm-linux-gnueabi-gcc -dumpversion', shell=True).strip() 127 | opts = ' '.join([ 128 | 'CPU_TARGET=arm', 129 | 'OS_TARGET=linux', 130 | 'BINUTILSPREFIX=arm-linux-gnueabi-', 131 | # 'CROSSOPT="-CpARMV7A -CfVFPV3_D16"', 132 | 'OPT=-dFPC_ARMEL', 133 | 'INSTALL_PREFIX=/usr' 134 | ]) 135 | 136 | # Compile ARM cross compiler 137 | if os.system('cd /usr/share/fpcsrc/%s && sudo make clean crossall crossinstall %s' % (fpcv, opts)) != 0: 138 | return False 139 | 140 | # Symbolic link to update default FPC cross compiler for ARM 141 | if os.system('sudo ln -sf /usr/lib/fpc/%s/ppcrossarm /usr/bin/ppcarm' % (fpcv)) != 0: 142 | return False 143 | 144 | # Update config file with paths to ARM libraries 145 | config = '\n'.join([ 146 | '#INCLUDE /etc/fpc.cfg', 147 | '#IFDEF CPUARM', 148 | '-Xd','-Xt', 149 | '-XParm-linux-gnueabi-', 150 | '-Fl/usr/arm-linux-gnueabi/lib', 151 | '-Fl/usr/lib/gcc/arm-linux-gnueabi/%s' % (gccv), 152 | '-Fl/usr/lib/gcc-cross/arm-linux-gnueabi/%s' % (gccv), 153 | # '-CpARMV7A', '-CfVFPV3_D16', 154 | '#ENDIF', 155 | '' 156 | ]) 157 | with open(os.path.expanduser('~/.fpc.cfg'),'w') as f: 158 | f.write(config) 159 | 160 | return True 161 | 162 | def install_lazarus(ver=None,rel=None,env=None): 163 | return install_lazarus_version(ver,rel,env) if ver else install_lazarus_default() 164 | 165 | def main(): 166 | os.system('%s update' % (OS_PMAN)) 167 | return install_lazarus(os.environ.get('LAZ_VER'),os.environ.get('LAZ_REL'),os.environ.get('LAZ_ENV')) 168 | 169 | if __name__ == '__main__': 170 | sys.exit(int(not main())) 171 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # See `travis-lazarus` (https://github.com/r3code/travis-lazarus) 2 | 3 | language: generic 4 | sudo: required 5 | dist: bionic 6 | services: 7 | - xvfb 8 | 9 | os: 10 | - linux 11 | - osx 12 | 13 | env: 14 | global: 15 | - WINEPREFIX=~/.winelaz 16 | - DISPLAY=:99.0 17 | matrix: 18 | - LAZ_PKG=true # Use the latest version from the default package manager 19 | - LAZ_VER=2.0.6 # Use specific (binary) release 20 | 21 | matrix: 22 | include: 23 | - os: linux 24 | env: LAZ_VER=2.0.6 LAZ_ENV=wine WINEARCH=win32 LAZ_OPT="--os=win32 --cpu=i386" 25 | - os: linux 26 | env: LAZ_VER=2.0.6 LAZ_ENV=wine WINEARCH=win64 LAZ_OPT="--os=win64 --cpu=x86_64" 27 | - os: linux 28 | env: LAZ_VER=2.0.6 LAZ_ENV=qemu-arm LAZ_OPT="--os=linux --cpu=arm" 29 | 30 | before_install: 31 | - chmod +x ./.travis.install.py 32 | 33 | install: 34 | # Install prerequisites (fpc/lazarus/wine/qemu) 35 | - ./.travis.install.py 36 | 37 | script: 38 | - lazbuild $LAZ_OPT ExceptionLogger.lpk # Check for build errors, build ExceptionLogger.lpk package 39 | # Run Tests 40 | # - lazbuild $LAZ_OPT my_lazarus_tests.lpi # Build my_lazarus_test project 41 | # - $LAZ_ENV ./bin/my_lazarus_tests --all --format=plain # Run my_lazarus_test testsuite 42 | 43 | notifications: 44 | email: 45 | on_success: false 46 | on_failure: change 47 | -------------------------------------------------------------------------------- /CustomLineInfo.pas: -------------------------------------------------------------------------------- 1 | { 2 | This file is part of the Free Pascal run time library. 3 | Copyright (c) 2000 by Peter Vreman 4 | 5 | Stabs Line Info Retriever 6 | 7 | See the file COPYING.FPC, included in this distribution, 8 | for details about the copyright. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | 14 | **********************************************************************} 15 | { 16 | This unit should not be compiled in objfpc mode, since this would make it 17 | dependent on objpas unit. 18 | } 19 | unit CustomLineInfo; 20 | interface 21 | 22 | {$S-} 23 | {$Q-} 24 | 25 | function GetLineInfo(addr:ptruint;var func,source:shortstring;var line:longint) : boolean; 26 | function StabBackTraceStr(addr:Pointer):shortstring; 27 | 28 | implementation 29 | 30 | uses 31 | exeinfo,strings; 32 | 33 | const 34 | N_Function = $24; 35 | N_TextLine = $44; 36 | N_DataLine = $46; 37 | N_BssLine = $48; 38 | N_SourceFile = $64; 39 | N_IncludeFile = $84; 40 | 41 | maxstabs = 40; { size of the stabs buffer } 42 | 43 | var 44 | { GDB after 4.18 uses offset to function begin 45 | in text section but OS/2 version still uses 4.16 PM } 46 | StabsFunctionRelative: boolean; 47 | 48 | type 49 | pstab=^tstab; 50 | tstab=packed record 51 | strpos : longint; 52 | ntype : byte; 53 | nother : byte; 54 | ndesc : word; 55 | nvalue : dword; 56 | end; 57 | 58 | { We use static variable so almost no stack is required, and is thus 59 | more safe when an error has occured in the program } 60 | var 61 | e : TExeFile; 62 | stabcnt, { amount of stabs } 63 | stablen, 64 | stabofs, { absolute stab section offset in executable } 65 | stabstrlen, 66 | stabstrofs : longint; { absolute stabstr section offset in executable } 67 | dirlength : longint; { length of the dirctory part of the source file } 68 | stabs : array[0..maxstabs-1] of tstab; { buffer } 69 | funcstab, { stab with current function info } 70 | linestab, { stab with current line info } 71 | dirstab, { stab with current directory info } 72 | filestab : tstab; { stab with current file info } 73 | filename: shortstring; 74 | dbgfn : string; 75 | 76 | 77 | var 78 | Crc32Tbl : array[0..255] of cardinal; 79 | 80 | procedure MakeCRC32Tbl; 81 | var 82 | crc : cardinal; 83 | i,n : integer; 84 | begin 85 | for i:=0 to 255 do 86 | begin 87 | crc:=i; 88 | for n:=1 to 8 do 89 | if (crc and 1)<>0 then 90 | crc:=(crc shr 1) xor cardinal($edb88320) 91 | else 92 | crc:=crc shr 1; 93 | Crc32Tbl[i]:=crc; 94 | end; 95 | end; 96 | 97 | Function UpdateCrc32(InitCrc:cardinal;const InBuf;InLen:LongInt):cardinal; 98 | var 99 | i : LongInt; 100 | p : pchar; 101 | begin 102 | 103 | if Crc32Tbl[1]=0 then 104 | MakeCrc32Tbl; 105 | p:=@InBuf; 106 | Result:=not InitCrc; 107 | for i:=1 to InLen do 108 | begin 109 | UpdateCrc32:=Crc32Tbl[byte(Result) xor byte(p^)] xor (Result shr 8); 110 | inc(p); 111 | end; 112 | Result:=not Result; 113 | end; 114 | 115 | function CheckDbgFile(var e:TExeFile;const fn:string;dbgcrc:cardinal):boolean; 116 | var 117 | c : cardinal; 118 | ofm : word; 119 | g : file; 120 | begin 121 | CheckDbgFile:=false; 122 | assign(g,fn); 123 | {$I-} 124 | ofm:=filemode; 125 | filemode:=$40; 126 | reset(g,1); 127 | filemode:=ofm; 128 | {$I+} 129 | if ioresult<>0 then 130 | exit; 131 | { We reuse the buffer from e here to prevent too much stack allocation } 132 | c:=0; 133 | repeat 134 | blockread(g,e.buf,e.bufsize,e.bufcnt); 135 | c:=UpdateCrc32(c,e.buf,e.bufcnt); 136 | until e.bufcntsizeof(dbglink)-1 then 156 | exit; 157 | fillchar(dbglink,sizeof(dbglink),0); 158 | seek(e.f,dbglinkofs); 159 | blockread(e.f,dbglink,dbglinklen); 160 | dbgfn:=strpas(dbglink); 161 | if length(dbgfn)=0 then 162 | exit; 163 | i:=align(length(dbgfn)+1,4); 164 | if (i+4)>dbglinklen then 165 | exit; 166 | move(dbglink[i],dbgcrc,4); 167 | { current dir } 168 | if CheckDbgFile(e,dbgfn,dbgcrc) then 169 | begin 170 | ReadDebugLink:=true; 171 | exit; 172 | end; 173 | { executable dir } 174 | i:=length(e.filename); 175 | while (i>0) and not(e.filename[i] in AllowDirectorySeparators) do 176 | dec(i); 177 | if i>0 then 178 | begin 179 | dbgfn:=copy(e.filename,1,i)+dbgfn; 180 | if CheckDbgFile(e,dbgfn,dbgcrc) then 181 | begin 182 | ReadDebugLink:=true; 183 | exit; 184 | end; 185 | end; 186 | end; 187 | 188 | function OpenStabs(addr : pointer) : boolean; 189 | var 190 | baseaddr : pointer; 191 | begin 192 | OpenStabs:=false; 193 | baseaddr := nil; 194 | GetModuleByAddr(addr,baseaddr,filename); 195 | {$ifdef DEBUG_LINEINFO} 196 | writeln(stderr,filename,' Baseaddr: ',hexstr(ptruint(baseaddr),sizeof(baseaddr)*2)); 197 | {$endif DEBUG_LINEINFO} 198 | 199 | if not OpenExeFile(e,filename) then 200 | exit; 201 | if ReadDebugLink(e,dbgfn) then 202 | begin 203 | CloseExeFile(e); 204 | if not OpenExeFile(e,dbgfn) then 205 | exit; 206 | end; 207 | if ptruint(BaseAddr) < e.processaddress then Exit; 208 | 209 | e.processaddress := ptruint(baseaddr) - e.processaddress; 210 | StabsFunctionRelative := E.FunctionRelative; 211 | if FindExeSection(e,'.stab',stabofs,stablen) and 212 | FindExeSection(e,'.stabstr',stabstrofs,stabstrlen) then 213 | begin 214 | stabcnt:=stablen div sizeof(tstab); 215 | OpenStabs:=true; 216 | end 217 | else 218 | begin 219 | CloseExeFile(e); 220 | exit; 221 | end; 222 | end; 223 | 224 | procedure CloseStabs; 225 | begin 226 | CloseExeFile(e); 227 | end; 228 | 229 | function GetLineInfo(addr:ptruint;var func,source:shortstring;var line:longint) : boolean; 230 | var 231 | res, 232 | stabsleft, 233 | stabscnt,i : longint; 234 | found : boolean; 235 | lastfunc : tstab; 236 | begin 237 | GetLineInfo:=false; 238 | {$ifdef DEBUG_LINEINFO} 239 | writeln(stderr,'GetLineInfo called'); 240 | {$endif DEBUG_LINEINFO} 241 | fillchar(func,high(func)+1,0); 242 | fillchar(source,high(source)+1,0); 243 | line:=0; 244 | if not e.isopen then 245 | begin 246 | if not OpenStabs(pointer(addr)) then 247 | exit; 248 | end; 249 | 250 | { correct the value to the correct address in the file } 251 | { processaddress is set in OpenStabs } 252 | addr := dword(addr - e.processaddress); 253 | 254 | {$ifdef DEBUG_LINEINFO} 255 | writeln(stderr,'Addr: ',hexstr(addr,sizeof(addr)*2)); 256 | {$endif DEBUG_LINEINFO} 257 | 258 | fillchar(funcstab,sizeof(tstab),0); 259 | fillchar(filestab,sizeof(tstab),0); 260 | fillchar(dirstab,sizeof(tstab),0); 261 | fillchar(linestab,sizeof(tstab),0); 262 | fillchar(lastfunc,sizeof(tstab),0); 263 | found:=false; 264 | seek(e.f,stabofs); 265 | stabsleft:=stabcnt; 266 | repeat 267 | if stabsleft>maxstabs then 268 | stabscnt:=maxstabs 269 | else 270 | stabscnt:=stabsleft; 271 | blockread(e.f,stabs,stabscnt*sizeof(tstab),res); 272 | stabscnt:=res div sizeof(tstab); 273 | for i:=0 to stabscnt-1 do 274 | begin 275 | case stabs[i].ntype of 276 | N_BssLine, 277 | N_DataLine, 278 | N_TextLine : 279 | begin 280 | if (stabs[i].ntype=N_TextLine) and StabsFunctionRelative then 281 | inc(stabs[i].nvalue,lastfunc.nvalue); 282 | if (stabs[i].nvalue<=addr) and 283 | (stabs[i].nvalue>linestab.nvalue) then 284 | begin 285 | { if it's equal we can stop and take the last info } 286 | if stabs[i].nvalue=addr then 287 | found:=true 288 | else 289 | linestab:=stabs[i]; 290 | end; 291 | end; 292 | N_Function : 293 | begin 294 | lastfunc:=stabs[i]; 295 | if (stabs[i].nvalue<=addr) and 296 | (stabs[i].nvalue>funcstab.nvalue) then 297 | begin 298 | funcstab:=stabs[i]; 299 | fillchar(linestab,sizeof(tstab),0); 300 | end; 301 | end; 302 | N_SourceFile, 303 | N_IncludeFile : 304 | begin 305 | if (stabs[i].nvalue<=addr) and 306 | (stabs[i].nvalue>=filestab.nvalue) then 307 | begin 308 | { if same value and type then the first one 309 | contained the directory PM } 310 | if (stabs[i].nvalue=filestab.nvalue) and 311 | (stabs[i].ntype=filestab.ntype) then 312 | dirstab:=filestab 313 | else 314 | fillchar(dirstab,sizeof(tstab),0); 315 | filestab:=stabs[i]; 316 | fillchar(linestab,sizeof(tstab),0); 317 | { if new file then func is not valid anymore PM } 318 | if stabs[i].ntype=N_SourceFile then 319 | begin 320 | fillchar(funcstab,sizeof(tstab),0); 321 | fillchar(lastfunc,sizeof(tstab),0); 322 | end; 323 | end; 324 | end; 325 | end; 326 | end; 327 | dec(stabsleft,stabscnt); 328 | until found or (stabsleft=0); 329 | 330 | { get the line,source,function info } 331 | line:=linestab.ndesc; 332 | if dirstab.ntype<>0 then 333 | begin 334 | seek(e.f,stabstrofs+dirstab.strpos); 335 | blockread(e.f,source[1],high(source)-1,res); 336 | dirlength:=strlen(@source[1]); 337 | source[0]:=chr(dirlength); 338 | end 339 | else 340 | dirlength:=0; 341 | if filestab.ntype<>0 then 342 | begin 343 | seek(e.f,stabstrofs+filestab.strpos); 344 | blockread(e.f,source[dirlength+1],high(source)-(dirlength+1),res); 345 | source[0]:=chr(strlen(@source[1])); 346 | end; 347 | if funcstab.ntype<>0 then 348 | begin 349 | seek(e.f,stabstrofs+funcstab.strpos); 350 | blockread(e.f,func[1],high(func)-1,res); 351 | func[0]:=chr(strlen(@func[1])); 352 | i:=pos(':',func); 353 | if i>0 then 354 | Delete(func,i,255); 355 | end; 356 | // if e.isopen then 357 | // CloseStabs; 358 | GetLineInfo:=true; 359 | end; 360 | 361 | function StabBackTraceStr(addr:Pointer):shortstring; 362 | var 363 | func, 364 | source : shortstring; 365 | hs : string[32]; 366 | line : longint; 367 | Store : TBackTraceStrFunc; 368 | Success : boolean; 369 | begin 370 | {$ifdef DEBUG_LINEINFO} 371 | writeln(stderr,'StabBackTraceStr called'); 372 | {$endif DEBUG_LINEINFO} 373 | { reset to prevent infinite recursion if problems inside the code PM } 374 | Success:=false; 375 | Store:=BackTraceStrFunc; 376 | BackTraceStrFunc:=@SysBackTraceStr; 377 | Success:=GetLineInfo(ptruint(addr),func,source,line); 378 | { create string } 379 | {$ifdef netware} 380 | { we need addr relative to code start on netware } 381 | dec(addr,ptruint(system.NWGetCodeStart)); 382 | StabBackTraceStr:=' CodeStart + $'+HexStr(ptruint(addr),sizeof(ptruint)*2); 383 | {$else} 384 | StabBackTraceStr:=' $'+HexStr(ptruint(addr),sizeof(ptruint)*2); 385 | {$endif} 386 | if func<>'' then 387 | Result := Result +' '+func; 388 | if source<>'' then 389 | begin 390 | if func<>'' then 391 | Result := Result + ', '; 392 | if line<>0 then 393 | begin 394 | str(line,hs); 395 | Result := Result + ' line ' + hs; 396 | end; 397 | Result := Result + ' of ' + source; 398 | end; 399 | if Success then 400 | BackTraceStrFunc:=Store; 401 | end; 402 | 403 | initialization 404 | BackTraceStrFunc := @StabBackTraceStr; 405 | 406 | finalization 407 | if e.isopen then 408 | CloseStabs; 409 | end. 410 | -------------------------------------------------------------------------------- /ExceptionLogger.lpk: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | <_ExternHelp Items="Count"/> 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /ExceptionLogger.pas: -------------------------------------------------------------------------------- 1 | { This file was automatically created by Lazarus. Do not edit! 2 | This source is only used to compile and install the package. 3 | } 4 | 5 | unit ExceptionLogger; 6 | 7 | {$warn 5023 off : no warning about unused units} 8 | interface 9 | 10 | uses 11 | UStackTrace, UExceptionForm, UExceptionLogger, CustomLineInfo, 12 | LazarusPackageIntf; 13 | 14 | implementation 15 | 16 | procedure Register; 17 | begin 18 | RegisterUnit('UExceptionLogger', @UExceptionLogger.Register); 19 | end; 20 | 21 | initialization 22 | RegisterPackage('ExceptionLogger', @Register); 23 | end. 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lazarus-exception-logger 2 | 3 | Extended version of ExceptionLogger (https://github.com/beNative/lazarus). 4 | At the moment of unhanled exception in the application shows basic application 5 | information and exception stack trace report. 6 | 7 | Also the error report can be saved to a file. New error report record will be 8 | added to the end of the existing report file. 9 | 10 | Repository: https://github.com/r3code/lazarus-exception-logger 11 | 12 | **Example of app info**: 13 | 14 | Class: Exception 15 | Message: Simple exception 16 | Application: Demo 17 | Version: Demo 18 | Time: 29.11.2017 13:58:57 19 | Process ID: 6412 20 | Thread ID: 6240 21 | 22 | **Example of error report file** 23 | 24 | Date/time : 2017-12-01 17:53:48.110 25 | Operating system : Windows 7 SP1 i386 26 | user name : Дмитрий 27 | program up time : 0days 0hours 0min 2sec 356ms 28 | free disk space : 296 GB 29 | Process ID : 15860 30 | Thread ID : 16152 31 | Executable : IncodeUsage.exe 32 | App. title : IncodeUsage Exaple of ExceptionLogger 33 | Version : 1.1.0.0 34 | Compiled date : 2017/12/01 at 17:52:03 35 | Build target : i386 - Win32 36 | LCL version : LCL 1.6.4.0 37 | Widget set : Win32/Win64 widget set 38 | Exception class : EMyException 39 | Exception message : Woo! 40 | code revision : 43594 41 | 42 | 01: 00426B2D TFRMTESTINCODE.BUTTON1CLICK in utestincode.pas (62) 43 | 02: 004FCB98 TCONTROL.CLICK in ./include/control.inc (2736) 44 | 03: 0051194D TBUTTONCONTROL.CLICK in ./include/buttoncontrol.inc (54) 45 | 04: 00511F6D TCUSTOMBUTTON.CLICK in ./include/buttons.inc (169) 46 | 05: 0051187B TBUTTONCONTROL.WMDEFAULTCLICKED in ./include/buttoncontrol.inc (20) 47 | 06: 0040D188 (754) 48 | 07: 004F2CA0 TWINCONTROL.WNDPROC in ./include/wincontrol.inc (5384) 49 | 08: 0053BAE9 DELIVERMESSAGE in lclmessageglue.pas (112) 50 | 09: 004CFB8F TWINDOWPROCHELPER.DOWINDOWPROC in ./win32/win32callback.inc (2441) 51 | 10: 004D021B WINDOWPROC in ./win32/win32callback.inc (2604) 52 | 11: 00540F27 CUSTOMFORMWNDPROC in ./win32/win32wsforms.pp (382) 53 | 12: 76CBC4B7 54 | 13: 76CBC5B7 55 | 14: 76CB5264 56 | 15: 76CB5552 57 | 16: 738445A1 58 | 17: 73844603 59 | 60 | 61 | **Example of exception stack trace dialog**: 62 | 63 | see doc/images/error_report.jpg 64 | ![Exception Report Example](https://raw.githubusercontent.com/r3code/lazarus-exception-logger/master/doc/images/error_report.jpg) 65 | 66 | ## Install 67 | 68 | * Download and install lpk file as Lazarus package. 69 | * Or copy source file to your project to use it standalone, include the files in a project or set the source path, init it directly in your code. 70 | 71 | ## Usage 72 | 73 | ### Common 74 | 75 | Set *Project Options - Debugging* 76 | *Checks and assertions* 77 | 78 | * I/O (-Ci) 79 | * Range (-Cr) 80 | * Overflow(-Co) 81 | * Stack (-Ct) 82 | * other by your needs. 83 | 84 | *Generate debugging info...*: Yes 85 | 86 | *Type of debug info*: Stabs (-gs) 87 | 88 | *Display line numbers...*: Yes 89 | 90 | ### Standalone usage 91 | 92 | See demo/IncodeUsage.lpr 93 | 94 | ### As Component 95 | 96 | Put component TExceptionLogger (tab Samples) to your form and set properties you want. 97 | 98 | ### TExceptionLogger Properties 99 | 100 | **LogFileName** - filepath to write report to. 101 | 102 | **MaxCallStackDepth** - maximum count of lines listed in the report, default 20. 103 | 104 | ## Demo 105 | 106 | See *demo* folder. 107 | 108 | 109 | 110 | -------------------------------------------------------------------------------- /UExceptionForm.lfm: -------------------------------------------------------------------------------- 1 | object ExceptionForm: TExceptionForm 2 | Left = 235 3 | Height = 320 4 | Top = 182 5 | Width = 480 6 | Caption = 'Exception info' 7 | ClientHeight = 320 8 | ClientWidth = 480 9 | OnClose = FormClose 10 | OnCreate = FormCreate 11 | OnDestroy = FormDestroy 12 | OnShow = FormShow 13 | Position = poScreenCenter 14 | LCLVersion = '1.6.4.0' 15 | object PanelBasic: TPanel 16 | Left = 0 17 | Height = 100 18 | Top = 0 19 | Width = 480 20 | Align = alTop 21 | BevelOuter = bvNone 22 | ClientHeight = 100 23 | ClientWidth = 480 24 | TabOrder = 0 25 | object Image1: TImage 26 | Left = 8 27 | Height = 48 28 | Top = 8 29 | Width = 48 30 | OnClick = Image1Click 31 | Picture.Data = { 32 | 1754506F727461626C654E6574776F726B477261706869639C0C000089504E47 33 | 0D0A1A0A0000000D49484452000000300000003008060000005702F987000000 34 | 0473424954080808087C0864880000000970485973000005310000053101B7ED 35 | 28520000001974455874536F667477617265007777772E696E6B73636170652E 36 | 6F72679BEE3C1A00000C194944415468819D997B8C15D51DC73F67662EE82A25 37 | 48C1A5202A015C0571450BCBC3DAB89644DBC20AD18DA08B0FDA8A6F946AFA07 38 | 58FF6AB4A90D88CA233654C568A5B12D52A5B0605B828DC6B0AB1850D816581E 39 | AE2F28ECE3DE3B73CEE91F73CEDC33B37797DD4EF2CB9C393373E6FBFDBD6746 40 | 68ADE9EF562F84FFF873CFEDBE78DAB431684D6A859ED6B30F1222B9464B09A0 41 | BFDCB7EFC4B3CB97573F77E8D089FE6211FD25502F84D7B070E1CECBC78E9DD2 42 | 75F0A08F10699CC9CAA2DBBDC29E0F437418264472E79DC7D7E79E7BF0A5575F 43 | 9DDC5F12FD22502F84B760C1827F4CA8ACAC291C39E277BB5308CAAE26045A29 44 | 741425C08521288CE4860DE3E4F0E1075FDAB0A15F24FA4CA05E08EFE6B973DF 45 | BD7CE8D069D1891381EE01B09D4F8EB5464B890E43B4520968173C42208060C8 46 | 10DA2FBCF0E086D75E9BBC62FFFE3E91E813817A21BC1FD7D6365E397CF84C55 47 | 28040950D22E935D494919838FA2546CB8DACF1209060D227FE9A5875E7EE595 48 | 2BFB42E28C04EA85F06A274DDA523366CCF7D13AD006B43080DDBB13AB688D8A 49 | A2127833EF824E80675C0920A8A8209A32E5F0FA75EBAE58D9D272F2FF26502F 50 | 843F63F4E8CDDF9B38B1567B5ED01368EDBA8C523178A56C96C93C51A4345F8E 51 | 889FCB911B3408396DDAD11757AE9CD81B891E09D40BE14F1F3D7AF335975D56 52 | 8B10817B4E1B229110F84E1A554AC5C04DC0BAA0BB3DD821A300DF1CFB030712 53 | E47231A920405C7BEDD1F5CF3F7FF9337BF7967527AF47F0A3466DBE66FCF85A 54 | 2D65A0A20825254A4AA494A828E2447535A2A181BCE7A195220A43A491A85040 55 | 2985520AA914D2DC27A54CCD2B29F9AABA9A13757584410041009E57BABE5844 56 | 35368EBC7DD1A28F1EB9F4D2217DB240BD10FEB41123365F535555AB3D2F28E7 57 | 32A7A74CA17AC9123CDFA765C70EDAD7AE25572CA2011586E960EE45FBFFBDFA 58 | 6A2E5AB8103F0838F2CF7F72F6A64D0CD43AE55A1EB17B45353587376EDC58FD 59 | 747373CA12290216FCCCF1E36B112250388169C65D35354C32E0214E932DDBB7 60 | 737ACD1ABCCE4ED03A89897275C26EED53A732F6EEBB1142A04C7AFDFCBDF718 61 | F0E69BE4A20861DCCB95AE89130F6EDAB66DB24B2221502F8437BDB272D38C71 62 | E3666908B4035A998BF335354CFAF9CFF10D7877DBB7650B2757AD221786C99C 63 | CE685F1B209D336650F5D39F26E0A513ECC777ED22F7C73F124451CA0296C437 64 | 2346EC6F6C6E9E6A4908AD35F54278332A2BFF347DCC981BB41081056D338C06 65 | C2E9D399B874691C6065DC426BCDDEB7DFE6EB679F4D489473A5FCCC994CBCF7 66 | DEE41E4B406B9DB44B9FEFDA45B0716342221143E4B8EF7FB2BDA565E6CA9696 67 | 931E40F5B0612BA68F1E7D839232D04EC06A13B0F9C99399F0E8A3E4060C8817 68 | 31E2795EEAF8B21B6F64C8FDF793F7BC2458DD40CECF9C49F5830F92CBE5F07D 69 | 1FCFF312719552397D3A85BA3A2229E360B7627055168B13AE1E3E7C134000F0 70 | AD8A8A315AA924601331DA97070E70F2F061CE1F3F3E05D8D5BEDD5FFEA31FF1 71 | 91D67CB9620541B198685F5E771D572F59D2ED7A571900524AA230A473CF1E72 72 | 26366CE1B496F080C11515833063B4D65A3B39DC32D686F180B6360E2C5BC617 73 | FBF7A70894B384E7795C317B36C31E7A887C10C4DABFEE3AA62E5D4A1004DD34 74 | 9FB5828C22FEBD762DE7EEDE5DB25E2615CB18A74C2C80751921509482D61DE7 75 | 8E1E65EF2F7E81FFD453545655F51807D6AFAF983D1B0D7CD5D4C4CCC71E4B02 76 | 56299510752DA14C2D39B07A35E7ECDE8D048494B1C69D2A6DC7CA8F9BE1004A 77 | 15D44D9B16BCD63AF63D60C0B1637CBC7429E2996718515565BC43A4DCC25A42 78 | 29C59573E6A067CF4E0A984B5A299590F03C8F62B1C8DE55AB38EBC30F898488 79 | B38F7111E58CAD5B2B93B93CF374A5A5041BB84E17A9C2B044504A8263C7685A 80 | B284B6FDFBBBB980750FAB6177ECFB3E4288D435F65C582CB267C50A721F7C90 81 | 0AFCC848E246C65226A0753A06A208DB32104509786DC7969494F8478FF2C17D 82 | F7717CDFBE14109788056AC716BCBDDE8EA330E4C35FFF1AB56B5702389232C9 83 | 402E09E5C48034BD564CC009601B0F320C636B38016DADA3A4C46B6DE55F8B17 84 | 73FCD34F7B0C4A57D316B06B0D1945ECFAD5AF503B77A2A22806EE808E6CFF64 85 | 70446E3A554ABB2EA4B594605D258A1277D25296CD4E3A8AF05A5BD9F9939FD0 86 | FAC927F1BC498BBD59C3CECB28E2EF4F3E49F8EEBB4452528C22A2282A3585C6 87 | 236414C55AB7C725523A65014C0B9CB88D03B81B196B1929E1D021FEB16811C7 88 | 5A5A92AA6A03B61C702B7F7BE2090A3B76C479DF00B4BE1E3969D3ED826D276C 89 | 89940838019B803780712BA1012FA328D5FB9F3B793243478E4CB7CB666CDD28 90 | 4BE6E26BAF25F4FD52809A349AF57D4BC6BA9174949AA451194528DB0E0B91A4 91 | 2A5B059396DA36784A254DDE5975755CFFD45371B595B25B81039274E976BE57 92 | CE9983528A3D4F3E895728942AAD52E079C927188BC577F000844294EA802C16 93 | 9504B4E741109472AD5B0FDCB191B3EAEAA87DFAE9B86E285BF248152A2B3616 94 | ECA6B566725D1D4A293EFAE52F93B6C3339F603CCF8BF37E69513044545C479C 95 | 4216865A866102500981F63C94EFA33D0FEDFBB1785E426EE0DCB95CFF9BDF24 96 | E05DEDDA42E6565BA02C89AB6EBA090D342F5B865F2CA28C5F7B42E01B12AEE6 97 | 2D19690825EFBAA9C6C07ECB911249A9A550C64A036EBD951FFCF6B7B1950C78 98 | 2BC9CBB9F93AE1B60B5A6B82204888593257D5D521A5E4A3E5CB5324B4947842 99 | 101857745B6B2D84D30B3924B21D4E766E607D3D3F5CB70EA5359109E6245B39 100 | 16F03C8F7C6727DF1C3FCEE84B2E4911CC5AC1F77DBE3B772E52299A972F2757 101 | 28A4DFEAA44CDA08EB4ACAB580CBAC3722B9FA7A66AF5F1F9BB0584C9AB02443 102 | 39EE12160AFCF9673FA3B8772FD76FD8C0459326A580FBBE9F6AFE7CDF67EABC 103 | 792829695EB62C2641ECF36E105B5C61189662C03D518E8800F4BC79CC5AB306 104 | CFF7136DBB005C572AE6F3BCB57831C5AD5B51C0DF162C609621612D642D612D 105 | 60AD3365DE3C8AF93C4D8F3FCE804201DF80F48D48B3CFC7C338461408D50BF8 106 | FCAC597C6FE54A8479D372DFA05C02524ABA3A3A78EB9E7B905BB726F7CBC387 107 | 7967FE7CFED3DC9CEAEB2DF86CD59E317F3E973CF1442AE3653F656A03D50338 108 | 0C2F1F80B628033C71A3A6268E998767DB62D70A5D1D1DBC73EFBDB06D5B37F7 109 | 93ADADBCBD604137126E7F648914BABA38EEACE18297401B9C3A047F4F08ACD1 110 | FACD2678E03368CB672CE001155F7CC1DE3BEFE4E0FBEFA71EEA92C87776B2ED 111 | FEFBF11A1BCB2A4100AAB595CD652C9105FFFADD77736AFBF66EE023E0389C6E 112 | 81D56BB55E9E103024DED8030F7F065FB6537A89B052D1D6C6C70D0DB4BCF71E 113 | 52CA941B15BABA68BCEF3E7C07BC0765C7FAC811DECA90B02F355D1D1DBCD4D0 114 | C0C96DDBBA7D3F2D00C7A0FD28AC5EAFF5E31677EAD3E23AAD5FFB141E38005F 115 | 9D328C5D00156D6D34DD761B9FEEDC9968AC98CFD3B87831B9C6C6B800F500DC 116 | 3DA75A5BD974EBADFCBBA92921D1D5D1C14BB7DFCEC9AD5B536F63009DB1E6DB 117 | DB60F5EFB57ECCC55CF6E3EE2221EA2F805517C2B7071367015BC824D0515949 118 | CD1B6F30ACAA8ABFDC761B62CB96E49CCA5CAB7A11316A14735E7F9DF3C78E65 119 | 434303DF6CD99200F7CDBE03F81ADA4FC19A0D5A2FCD62EDF1EBF45D42DC3212 120 | 9E1F0D4387664828E0746525FE8409F88D8D3D023E13016D489C3D6E1CA777EC 121 | 8801399A6F07BE80F64E58FBAAD68F96C3D9EBFF81BB84B8F97C7861140C3D1F 122 | 1870066067029C05EFA6C90490D99F043E87CE3CAC7D4DEB253D613CE31F9ABB 123 | 84B87908BC70010C1D090C3C03D09ECEE932E36C7EB7FF0ABE068E416711D6BC 124 | AEF523BDE1EBD33FB23B84B865704CE2BC0B80B3CF40A22F04CA152805B40147 125 | A13384757FD0FAE13361EBF35FCA3B84B8E51C43E26243C26ADC16982CD0DE5C 126 | 264B40C6C039029D511FC1F78B00C042216E390B568F8221E3808A1EC0F6E632 127 | E55C27020E0387A053C1BA37FA08BEDF0420B6440ED67E07068FA37B76B202DD 128 | 5DA6A7DEA61538085D1AD66DD4FAA1FEE0E93701803B8598AFE0F94130D8CEB9 129 | C05499B972BFAAEC760ABA04BCB851EB07FA8BA52C0111F7086E176BC5D618FF 130 | 06985501B38D5695E90E85B6EB6680965153C24943F35FE17794C2CA8A7B1C01 131 | 5267000BD387FB40CE80CB19F0FF8FF899B1ED0AAC612C10572410F6636FEF2B 132 | 0251CA02A639B30FB56012AD3B73D97DD65A760D1C0256EB298D668864CF9513 133 | ED5AE17F98412D151886AE050000000049454E44AE426082 134 | } 135 | end 136 | object lblErrorHeader: TLabel 137 | Left = 69 138 | Height = 15 139 | Top = 8 140 | Width = 215 141 | Caption = 'Error occured during program execution:' 142 | ParentColor = False 143 | end 144 | object lblErrorText: TLabel 145 | Left = 80 146 | Height = 56 147 | Top = 24 148 | Width = 393 149 | Anchors = [akTop, akLeft, akRight, akBottom] 150 | AutoSize = False 151 | Caption = ' ' 152 | ParentColor = False 153 | WordWrap = True 154 | end 155 | object lblLoggerInternalError: TLabel 156 | Left = 10 157 | Height = 14 158 | Top = 80 159 | Width = 242 160 | Caption = 'Logger Internal Error Text Here (hidden by default)' 161 | Font.Color = clMaroon 162 | Font.Height = -11 163 | Font.Name = 'Sans' 164 | ParentColor = False 165 | ParentFont = False 166 | Visible = False 167 | end 168 | end 169 | object PanelDescription: TPanel 170 | Left = 0 171 | Height = 188 172 | Top = 100 173 | Width = 480 174 | Align = alClient 175 | BevelOuter = bvNone 176 | ClientHeight = 188 177 | ClientWidth = 480 178 | TabOrder = 1 179 | object PageControl1: TPageControl 180 | Left = 8 181 | Height = 186 182 | Top = 0 183 | Width = 467 184 | ActivePage = TabSheet1 185 | Anchors = [akTop, akLeft, akRight, akBottom] 186 | TabIndex = 0 187 | TabOrder = 0 188 | object TabSheet1: TTabSheet 189 | Caption = 'General' 190 | ClientHeight = 158 191 | ClientWidth = 459 192 | object MemoExceptionInfo: TMemo 193 | Left = 3 194 | Height = 152 195 | Top = 3 196 | Width = 453 197 | Align = alClient 198 | Anchors = [] 199 | BorderSpacing.Around = 3 200 | Font.Height = -13 201 | Font.Name = 'Monospace' 202 | ParentFont = False 203 | ReadOnly = True 204 | ScrollBars = ssAutoBoth 205 | TabOrder = 0 206 | WordWrap = False 207 | end 208 | end 209 | object TabSheet2: TTabSheet 210 | Caption = 'Call stack' 211 | ClientHeight = 155 212 | ClientWidth = 463 213 | object ListView1: TListView 214 | Left = 3 215 | Height = 151 216 | Top = 3 217 | Width = 430 218 | Align = alClient 219 | BorderSpacing.Around = 3 220 | Columns = < 221 | item 222 | Caption = 'Index' 223 | Width = 40 224 | end 225 | item 226 | Caption = 'Address' 227 | Width = 75 228 | end 229 | item 230 | Caption = 'Line' 231 | Width = 71 232 | end 233 | item 234 | Caption = 'Class' 235 | Width = 150 236 | end 237 | item 238 | Caption = 'Procedure/method' 239 | Width = 150 240 | end 241 | item 242 | Caption = 'Unit' 243 | Width = 150 244 | end> 245 | ReadOnly = True 246 | RowSelect = True 247 | TabOrder = 0 248 | ViewStyle = vsReport 249 | end 250 | end 251 | end 252 | end 253 | object PanelButtons: TPanel 254 | Left = 0 255 | Height = 32 256 | Top = 288 257 | Width = 480 258 | Align = alBottom 259 | BevelOuter = bvNone 260 | ClientHeight = 32 261 | ClientWidth = 480 262 | TabOrder = 2 263 | object ButtonKill: TButton 264 | Left = 303 265 | Height = 25 266 | Top = 3 267 | Width = 91 268 | Anchors = [akRight, akBottom] 269 | Caption = 'Exit program' 270 | OnClick = ButtonKillClick 271 | TabOrder = 0 272 | end 273 | object ButtonClose: TButton 274 | Left = 399 275 | Height = 25 276 | Top = 3 277 | Width = 74 278 | Anchors = [akRight, akBottom] 279 | Caption = 'Continue' 280 | OnClick = ButtonCloseClick 281 | TabOrder = 1 282 | end 283 | object CheckBoxIgnore: TCheckBox 284 | Left = 10 285 | Height = 19 286 | Top = 6 287 | Width = 133 288 | Anchors = [akLeft, akBottom] 289 | Caption = 'ignore this exception ' 290 | TabOrder = 2 291 | end 292 | object ButtonDetails: TButton 293 | Left = 223 294 | Height = 25 295 | Top = 3 296 | Width = 75 297 | Anchors = [akRight, akBottom] 298 | Caption = 'Details' 299 | OnClick = ButtonDetailsClick 300 | TabOrder = 3 301 | end 302 | end 303 | end 304 | -------------------------------------------------------------------------------- /UExceptionForm.pas: -------------------------------------------------------------------------------- 1 | unit UExceptionForm; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, 9 | CustomLineInfo, ComCtrls, ExtCtrls, UStackTrace, UExceptionLogger; 10 | 11 | type 12 | 13 | { TExceptionForm } 14 | 15 | TExceptionForm = class(TForm) 16 | ButtonDetails: TButton; 17 | ButtonClose: TButton; 18 | ButtonKill: TButton; 19 | CheckBoxIgnore: TCheckBox; 20 | Image1: TImage; 21 | lblErrorHeader: TLabel; 22 | lblLoggerInternalError: TLabel; 23 | lblErrorText: TLabel; 24 | ListView1: TListView; 25 | MemoExceptionInfo: TMemo; 26 | PageControl1: TPageControl; 27 | PanelBasic: TPanel; 28 | PanelDescription: TPanel; 29 | PanelButtons: TPanel; 30 | TabSheet1: TTabSheet; 31 | TabSheet2: TTabSheet; 32 | procedure ButtonCloseClick(Sender: TObject); 33 | procedure ButtonDetailsClick(Sender: TObject); 34 | procedure ButtonKillClick(Sender: TObject); 35 | procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 36 | procedure FormCreate(Sender: TObject); 37 | procedure FormDestroy(Sender: TObject); 38 | procedure FormShow(Sender: TObject); 39 | procedure Image1Click(Sender: TObject); 40 | public 41 | Logger: TExceptionLogger; 42 | procedure SetBasicInfo(ADataList: TStringList); 43 | procedure LoadStackTraceToListView(StackTrace: TStackTrace); 44 | procedure SetLoggerError(const AMsg: String); 45 | end; 46 | 47 | 48 | implementation 49 | 50 | {$R *.lfm} 51 | 52 | procedure TExceptionForm.FormShow(Sender: TObject); 53 | begin 54 | Caption := SExceptionInfo; 55 | PageControl1.Pages[0].Caption := SGeneral; 56 | PageControl1.Pages[1].Caption := SCallStack; 57 | lblErrorHeader.Caption := SErrorOccured; 58 | ButtonClose.Caption := SClose; 59 | ButtonDetails.Caption := SDetails; 60 | ButtonKill.Caption := STerminate; 61 | CheckBoxIgnore.Caption := SIgnoreNextTime; 62 | ListView1.Column[0].Caption := SIndex; 63 | ListView1.Column[1].Caption := SAddress; 64 | ListView1.Column[2].Caption := SLine; 65 | ListView1.Column[3].Caption := SClass; 66 | ListView1.Column[4].Caption := SProcedureMethod; 67 | ListView1.Column[5].Caption := SUnit; 68 | 69 | Height := PanelBasic.Height + PanelButtons.Height; 70 | PageControl1.ActivePageIndex := 0; 71 | CheckBoxIgnore.Checked := False; 72 | end; 73 | 74 | procedure TExceptionForm.Image1Click(Sender: TObject); 75 | begin 76 | 77 | end; 78 | 79 | procedure TExceptionForm.SetBasicInfo(ADataList: TStringList); 80 | begin 81 | MemoExceptionInfo.Lines.Assign(ADataList); 82 | end; 83 | 84 | procedure TExceptionForm.FormCreate(Sender: TObject); 85 | begin 86 | {$IFDEF MSWINDOWS} 87 | MemoExceptionInfo.Font.Name:='Courier New'; 88 | MemoExceptionInfo.Font.Size:=9; 89 | {$ENDIF} 90 | end; 91 | 92 | procedure TExceptionForm.ButtonCloseClick(Sender: TObject); 93 | begin 94 | if CheckBoxIgnore.Checked then 95 | Logger.SkipExceptionNextTime(); 96 | Close; 97 | end; 98 | 99 | procedure TExceptionForm.ButtonDetailsClick(Sender: TObject); 100 | begin 101 | if PanelDescription.Height <= 1 then 102 | Height := PanelBasic.Height + PanelButtons.Height + 200 103 | else Height := PanelBasic.Height + PanelButtons.Height; 104 | Application.ProcessMessages; 105 | end; 106 | 107 | procedure TExceptionForm.ButtonKillClick(Sender: TObject); 108 | begin 109 | //Halt; 110 | Application.Terminate; 111 | end; 112 | 113 | procedure TExceptionForm.FormClose(Sender: TObject; 114 | var CloseAction: TCloseAction); 115 | begin 116 | CloseAction:=caFree; 117 | end; 118 | 119 | 120 | procedure TExceptionForm.FormDestroy(Sender: TObject); 121 | begin 122 | end; 123 | 124 | procedure TExceptionForm.LoadStackTraceToListView(StackTrace: TStackTrace); 125 | var 126 | I: Integer; 127 | NewItem: TListItem; 128 | begin 129 | with ListView1, Items do 130 | try 131 | BeginUpdate; 132 | Clear; 133 | for I := 0 to StackTrace.Count - 1 do 134 | with TStackFrameInfo(StackTrace[I]) do begin 135 | NewItem := Add; 136 | with NewItem do begin 137 | Caption := IntToStr(Index); 138 | SubItems.Add(IntToHex(Address, 8)); 139 | SubItems.Add(IntToStr(LineNumber)); 140 | SubItems.Add(FunctionClassName); 141 | SubItems.Add(FunctionName); 142 | SubItems.Add(Source); 143 | end; 144 | end; 145 | finally 146 | EndUpdate; 147 | end; 148 | end; 149 | 150 | procedure TExceptionForm.SetLoggerError(const AMsg: String); 151 | begin 152 | if AMsg = EmptyStr then 153 | Exit; 154 | lblLoggerInternalError.Caption:=AMsg; 155 | lblLoggerInternalError.Show; 156 | end; 157 | 158 | 159 | end. 160 | 161 | -------------------------------------------------------------------------------- /UExceptionLogger.pas: -------------------------------------------------------------------------------- 1 | unit UExceptionLogger; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes 9 | , SysUtils 10 | , UStackTrace 11 | , CustomLineInfo 12 | , Forms 13 | {$if FPC_FULlVERSION>=30002} 14 | {$ifopt D+} 15 | , lineinfo 16 | {$ENDIF} 17 | // enable Debugging - Display line info... (-gl) 18 | {$endif} 19 | ; 20 | 21 | type 22 | TThreadSynchronizeEvent = procedure (AObject: TObject; Method: TThreadMethod) of object; 23 | 24 | { TExceptionLogger } 25 | 26 | TExceptionLogger = class(TComponent) 27 | private 28 | FStartTime: Cardinal; 29 | FExtraInfo: TStringList; 30 | FMaxCallStackDepth: Integer; 31 | FLogFileName: string; 32 | FIgnoreList: TStringList; 33 | FBasicData: TStringList; 34 | FStackTrace: TStackTrace; 35 | FLastException: Exception; 36 | FExceptionSender: TObject; 37 | FLoggerLastError: string; 38 | FOnThreadSynchronize: TThreadSynchronizeEvent; 39 | procedure ThreadSynchronize(AObject: TObject; Method: TThreadMethod); 40 | function GetProgramUpTime: string; 41 | procedure SetMaxCallStackDepth(const AValue: Integer); 42 | function FormatBasicDataReport(ABasicData: TStringList): TStringList; 43 | procedure PrepareReport; 44 | procedure ShowForm; 45 | procedure SaveBugReportToFile; 46 | procedure CollectReportBasicData(AStore: TStringList); 47 | public 48 | constructor Create(AOwner: TComponent); override; 49 | destructor Destroy; override; 50 | procedure HandleException(Sender: TObject; E: Exception); 51 | 52 | function StackTraceAsStringList: TStringList; 53 | procedure LogToFile(ADataList: TStringList); 54 | procedure AddExtraInfo(const AFieldName, AValue: string); 55 | procedure SkipExceptionNextTime; 56 | published 57 | property LogFileName: string read FLogFileName write FLogFileName; 58 | property MaxCallStackDepth: Integer read FMaxCallStackDepth write SetMaxCallStackDepth; 59 | property OnThreadSynchronize: TThreadSynchronizeEvent read FOnThreadSynchronize 60 | write FOnThreadSynchronize; 61 | end; 62 | 63 | procedure Register; 64 | 65 | resourcestring 66 | // Log titles 67 | SExceptionClass = 'Exception class'; 68 | SExceptionMessage = 'Exception message'; 69 | SExeName = 'Executable'; 70 | SApplicationTitle = 'App. title'; 71 | SReportTime = 'Date/time'; 72 | // Operating system info 73 | SOperatingSystem = 'Operating system'; 74 | SUserName = 'user name'; 75 | SCurrentDiskFreeSpaceSize = 'free disk space'; 76 | // Time info 77 | SProgramUpTime = 'program up time'; 78 | // Process Info 79 | SProcessID = 'Process ID'; 80 | SThreadID = 'Thread ID'; 81 | SVersion = 'Version'; 82 | SCompiledDate = 'Compiled date'; 83 | SBuildTarget = 'Build target'; 84 | SLCLVersion = 'LCL version'; 85 | SWidgetSet = 'Widget set'; 86 | // Form Titles 87 | SExceptionInfo = 'Exception info'; 88 | SCallStack = 'Call stack'; 89 | SGeneral = 'General'; 90 | SErrorOccured = 'Error occured during program execution:'; 91 | STerminate = 'Exit program'; 92 | SClose = 'Continue'; 93 | SDetails = 'Details'; 94 | SIgnoreNextTime = 'Skip this exception next'; 95 | 96 | // Stack 97 | SIndex = 'Index'; 98 | SAddress = 'Address'; 99 | SLine = 'Line'; 100 | SClass = 'Class'; 101 | SProcedureMethod = 'Procedure/method'; 102 | SUnit = 'Unit'; 103 | SExceptionHandlerCannotBeSynchronized = 'Exception handler cannot be synchronized with main thread.'; 104 | 105 | SErrorReportFileNotCrearted = 'Report file not created'; 106 | 107 | var 108 | exceptionLogger: TExceptionLogger; 109 | 110 | implementation 111 | 112 | uses 113 | UExceptionForm 114 | , lelVersionSupport 115 | , usysinfo 116 | , uappinfo 117 | ; 118 | 119 | 120 | procedure Register; 121 | begin 122 | RegisterComponents('Samples', [TExceptionLogger]); 123 | end; 124 | 125 | { TExceptionLogger } 126 | 127 | constructor TExceptionLogger.Create(AOwner: TComponent); 128 | begin 129 | inherited Create(AOwner); 130 | FIgnoreList := TStringList.Create; 131 | FBasicData := TStringList.Create; 132 | FStackTrace := TStackTrace.Create; 133 | FExtraInfo := TStringList.Create; 134 | FStartTime := SysUtils.GetTickCount64; 135 | MaxCallStackDepth := 20; 136 | Application.OnException := @HandleException; 137 | Application.Flags := Application.Flags - [AppNoExceptionMessages]; 138 | OnThreadSynchronize := @ThreadSynchronize; 139 | end; 140 | 141 | destructor TExceptionLogger.Destroy; 142 | begin 143 | if Assigned(FBasicData) then 144 | FreeAndNil(FBasicData); 145 | FreeAndNil(FExtraInfo); 146 | FreeAndNil(FStackTrace); 147 | FreeAndNil(FIgnoreList); 148 | inherited Destroy; 149 | end; 150 | 151 | procedure TExceptionLogger.CollectReportBasicData(AStore: TStringList); 152 | procedure SubAddLine(const AName, AValue: string); 153 | begin 154 | AStore.Add(Format('%s=%s',[AName, AValue])); 155 | end; 156 | procedure SubAddExtraInfo; 157 | var 158 | i: integer; 159 | begin 160 | for i := 0 to FExtraInfo.Count - 1 do 161 | begin 162 | SubAddLine(FExtraInfo.Names[i], FExtraInfo.ValueFromIndex[i]); 163 | end; 164 | end; 165 | begin 166 | SubAddLine(SReportTime,FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', Now)); 167 | // OS Info 168 | SubAddLine(SOperatingSystem, GetOsVersionInfo); 169 | SubAddLine(SUserName, GetCurrentUserName); 170 | SubAddLine(SProgramUpTime, GetProgramUpTime); 171 | SubAddLine(SCurrentDiskFreeSpaceSize, GetCurrentDiskFreeSpaceSize); 172 | // Process Info 173 | SubAddLine(SProcessID,IntToStr(GetProcessID)); 174 | {$IFNDEF DARWIN} 175 | SubAddLine(SThreadID,IntToStr(GetThreadID)); 176 | {$ENDIF} 177 | // App Info 178 | SubAddLine(SExeName, ExtractFileName(Application.ExeName)); 179 | SubAddLine(SApplicationTitle, Application.Title); 180 | SubAddLine(SVersion, GetAppVersion); 181 | // Compile time info 182 | SubAddLine(SCompiledDate, lelVersionSupport.GetCompiledDate); 183 | SubAddLine(SBuildTarget, lelVersionSupport.GetTargetInfo); 184 | SubAddLine(SLCLVersion, lelVersionSupport.GetLCLVersion); 185 | SubAddLine(SWidgetSet, lelVersionSupport.GetWidgetSet); 186 | // Exception Info 187 | SubAddLine(SExceptionClass, FLastException.ClassName); 188 | SubAddLine(SExceptionMessage, FLastException.Message); 189 | // Custom Extra Info 190 | SubAddExtraInfo; 191 | AStore.Add(EmptyStr); 192 | end; 193 | 194 | function TExceptionLogger.StackTraceAsStringList: TStringList; 195 | var 196 | i: integer; 197 | stackFrame: TStackFrameInfo; 198 | Line: string; 199 | rowNo, address, method, source, lineNo: string; 200 | begin 201 | Result := TStringList.Create; 202 | for I := 0 to FStackTrace.Count - 1 do 203 | begin 204 | stackFrame := TStackFrameInfo(FStackTrace[I]); 205 | method := stackFrame.FunctionName; 206 | if stackFrame.FunctionClassName <> EmptyStr then 207 | method := stackFrame.FunctionClassName + '.' + stackFrame.FunctionName; 208 | source := EmptyStr; 209 | if stackFrame.Source <> EmptyStr then 210 | source := 'in ' + stackFrame.Source; 211 | if stackFrame.LineNumber = 0 then 212 | source := EmptyStr; 213 | rowNo := Format('%0.2d', [stackFrame.Index]); 214 | address := IntToHex(stackFrame.Address, 8); 215 | lineNo := EmptyStr; 216 | if stackFrame.LineNumber > 0 then 217 | lineNo := Format('(%d)', [stackFrame.LineNumber]); 218 | Line := Format('%s: %s %s %s %s',[rowNo, address, method, source, lineNo]); 219 | Result.Add(Line); 220 | end; 221 | Result.Add(EmptyStr); 222 | Result.Add(EmptyStr); 223 | end; 224 | 225 | procedure TExceptionLogger.LogToFile(ADataList: TStringList); 226 | var 227 | LogFile: TFileStream; 228 | Buffer: string; 229 | begin 230 | Buffer := ADataList.Text; 231 | 232 | if FileExists(FLogFileName) then 233 | LogFile := TFileStream.Create(UTF8Decode(FLogFileName), fmOpenReadWrite) 234 | else 235 | LogFile := TFileStream.Create(UTF8Decode(FLogFileName), fmCreate); 236 | with LogFile do 237 | try 238 | Seek(0, soFromEnd); 239 | if Length(Buffer) > 0 then 240 | Write(Buffer[1], Length(Buffer)); 241 | finally 242 | LogFile.Free; 243 | end; 244 | end; 245 | 246 | procedure TExceptionLogger.AddExtraInfo(const AFieldName, AValue: string); 247 | begin 248 | FExtraInfo.Add(Format('%s=%s', [AFieldName, AValue])); 249 | end; 250 | 251 | procedure TExceptionLogger.SkipExceptionNextTime; 252 | begin 253 | if not Assigned(FLastException) then 254 | Exit; 255 | FIgnoreList.Add(FLastException.ClassName); 256 | end; 257 | 258 | procedure TExceptionLogger.HandleException(Sender: TObject; E: Exception); 259 | begin 260 | BackTraceStrFunc := @StabBackTraceStr; 261 | FStackTrace.GetExceptionBackTrace; 262 | FLastException := E; 263 | FExceptionSender := Sender; 264 | if (MainThreadID <> ThreadID) then 265 | begin 266 | if Assigned(FOnThreadSynchronize) then 267 | FOnThreadSynchronize(Sender, @ShowForm) 268 | else 269 | raise Exception.Create(SExceptionHandlerCannotBeSynchronized); 270 | end 271 | else 272 | ShowForm; 273 | end; 274 | 275 | procedure TExceptionLogger.PrepareReport; 276 | begin 277 | FBasicData.Clear; 278 | CollectReportBasicData(FBasicData); 279 | FStackTrace.GetInfo; 280 | end; 281 | 282 | procedure TExceptionLogger.ShowForm; 283 | var 284 | biFormatted: TStringList; 285 | begin 286 | if FIgnoreList.IndexOf(FLastException.ClassName) <> -1 then 287 | Exit; 288 | 289 | if FExceptionSender is TThread then 290 | TThread.Synchronize(TThread(FExceptionSender), @PrepareReport) 291 | else 292 | PrepareReport; 293 | 294 | SaveBugReportToFile; 295 | 296 | with TExceptionForm.Create(Application) do 297 | try 298 | Logger := Self; 299 | try 300 | biFormatted := FormatBasicDataReport(FBasicData); 301 | SetBasicInfo(biFormatted); 302 | finally 303 | biFormatted.free; 304 | end; 305 | LoadStackTraceToListView(FStackTrace); 306 | SetLoggerError(FLoggerLastError); 307 | lblErrorText.Caption := FLastException.Message; 308 | ShowModal; 309 | finally 310 | Free; 311 | end;; 312 | end; 313 | 314 | procedure TExceptionLogger.SaveBugReportToFile; 315 | var 316 | basicDataReport, stackTraces: TStringList; 317 | begin 318 | basicDataReport := FormatBasicDataReport(FBasicData); 319 | stackTraces := StackTraceAsStringList; 320 | try 321 | if FLogFileName <> EmptyStr then 322 | try 323 | LogToFile(basicDataReport); 324 | LogToFile(stackTraces); 325 | except 326 | on E: Exception do 327 | FLoggerLastError := SErrorReportFileNotCrearted 328 | + '. ' + E.Message; 329 | end; 330 | finally 331 | basicDataReport.Free; 332 | stackTraces.Free; 333 | end; 334 | end; 335 | 336 | procedure TExceptionLogger.SetMaxCallStackDepth(const AValue: Integer); 337 | begin 338 | FMaxCallStackDepth := AValue; 339 | FStackTrace.MaxDepth := AValue; 340 | end; 341 | 342 | function TExceptionLogger.FormatBasicDataReport(ABasicData: TStringList 343 | ): TStringList; 344 | var 345 | fieldName, fieldValue: string; 346 | i: Integer; 347 | begin 348 | Result := TStringList.Create; 349 | if not Assigned(ABasicData) then 350 | Exit; 351 | if ABasicData.Count = 0 then 352 | Exit; 353 | for i := 0 to ABasicData.Count - 1 do 354 | begin 355 | if ABasicData.Names[i] <> EmptyStr then 356 | begin 357 | fieldName:=ABasicData.Names[i]; 358 | fieldValue:=ABasicData.ValueFromIndex[i]; 359 | Result.Add(Format('%-19s: %s', [fieldName, fieldValue])); 360 | end 361 | else 362 | Result.Add(ABasicData[i]); 363 | end; 364 | end; 365 | 366 | 367 | procedure TExceptionLogger.ThreadSynchronize(AObject: TObject; 368 | Method: TThreadMethod); 369 | begin 370 | if AObject is TThread then TThread.Synchronize(TThread(AObject), Method) 371 | else raise Exception.Create(SExceptionHandlerCannotBeSynchronized); 372 | end; 373 | 374 | function TExceptionLogger.GetProgramUpTime: string; 375 | const 376 | SECOND = 1000; 377 | MINUTE = 60 * SECOND; 378 | HOUR = 60 * MINUTE; 379 | DAY = 24 * HOUR; 380 | var 381 | delta: Cardinal; 382 | days, hours, minutes, seconds, ms: int64; 383 | begin 384 | delta := SysUtils.GetTickCount64 - FStartTime; 385 | days := delta div DAY; 386 | hours := (delta - days*DAY) div HOUR; 387 | minutes := (delta - days*DAY - hours * HOUR) div MINUTE; 388 | seconds:= (delta - days*DAY - hours * HOUR - minutes*MINUTE) div SECOND; 389 | ms := delta - days*DAY - hours * HOUR - minutes*MINUTE - seconds*SECOND; 390 | Result := Format('%ddays %dhours %dmin %dsec %dms',[days, hours, minutes, 391 | seconds, ms]); 392 | end; 393 | 394 | 395 | initialization 396 | 397 | exceptionLogger := TExceptionLogger.Create(Application); 398 | 399 | {$IFOPT D+} 400 | //disables "optimizations" when converting stack to string (in unit lineinfo) 401 | AllowReuseOfLineInfoData:=false; 402 | {$endif} 403 | 404 | 405 | end. 406 | 407 | -------------------------------------------------------------------------------- /UStackTrace.pas: -------------------------------------------------------------------------------- 1 | unit UStackTrace; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, Contnrs, CustomLineInfo; 9 | 10 | type 11 | TStackFrameInfo = class 12 | Index: Integer; 13 | LineNumber: Integer; 14 | Address: Integer; 15 | FunctionClassName: string; 16 | FunctionName: string; 17 | Source: string; 18 | procedure GetFrameInfo(Addr: Pointer); 19 | end; 20 | 21 | { TStackTrace } 22 | 23 | TStackTrace = class(TObjectList) 24 | Frames: array of Pointer; 25 | MaxDepth: Integer; 26 | procedure GetExceptionBackTrace; 27 | procedure GetCallStack(BP: Pointer); 28 | procedure GetCurrentCallStack; 29 | procedure GetInfo; 30 | constructor Create; 31 | end; 32 | 33 | 34 | implementation 35 | 36 | procedure TStackFrameInfo.GetFrameInfo(Addr: Pointer); 37 | var 38 | Func: shortstring; 39 | SourceStr: shortstring; 40 | Line: LongInt; 41 | Store: TBackTraceStrFunc; 42 | Success: Boolean; 43 | begin 44 | // Reset to prevent infinite recursion if problems inside the code PM 45 | Store := BackTraceStrFunc; 46 | BackTraceStrFunc := @SysBackTraceStr; 47 | Line := 0; 48 | SourceStr := EmptyStr; 49 | Func := EmptyStr; 50 | Success := GetLineInfo(ptruint(Addr), Func, SourceStr, Line); 51 | Address := Integer(Addr); 52 | FunctionName := Func; 53 | if Pos('__', FunctionName) > 0 then begin 54 | FunctionClassName := Copy(FunctionName, 1, Pos('__', FunctionName) - 1); 55 | Delete(FunctionName, 1, Length(FunctionClassName) + 2); 56 | end else FunctionClassName := ''; 57 | LineNumber := Line; 58 | Source := SourceStr; 59 | BackTraceStrFunc := Store; 60 | end; 61 | 62 | procedure TStackTrace.GetCallStack(BP: Pointer); 63 | var 64 | I: Longint; 65 | prevbp: Pointer; 66 | CallerFrame: Pointer; 67 | CallerAddress: Pointer; 68 | StackFrameInfo: TStackFrameInfo; 69 | begin 70 | Clear; 71 | try 72 | I := 0; 73 | SetLength(Frames, 0); 74 | while (BP <> nil) and (I < MaxDepth) do begin 75 | SetLength(Frames, Length(Frames) + 1); 76 | Frames[I] := TStackFrameInfo(get_caller_addr(BP)); 77 | Inc(I); 78 | BP := TStackFrameInfo(get_caller_frame(BP)); 79 | end; 80 | except 81 | { prevent endless dump if an exception occured } 82 | end; 83 | end; 84 | 85 | constructor TStackTrace.Create; 86 | begin 87 | inherited; 88 | MaxDepth := 20; 89 | end; 90 | 91 | procedure TStackTrace.GetExceptionBackTrace; 92 | var 93 | FrameCount: Integer; 94 | FramesList: PPointer; 95 | FrameNumber: Integer; 96 | begin 97 | SetLength(Frames, 1); 98 | Frames[0] := ExceptAddr; 99 | FrameCount := ExceptFrameCount; 100 | FramesList := ExceptFrames; 101 | if FrameCount > MaxDepth then FrameCount := MaxDepth; 102 | SetLength(Frames, FrameCount + 1); 103 | for FrameNumber := 0 to FrameCount - 1 do begin 104 | Frames[FrameNumber + 1] := FramesList[FrameNumber] 105 | end; 106 | end; 107 | 108 | procedure TStackTrace.GetCurrentCallStack; 109 | begin 110 | GetCallStack(get_frame); 111 | end; 112 | 113 | procedure TStackTrace.GetInfo; 114 | var 115 | I: Integer; 116 | StackFrameInfo: TStackFrameInfo; 117 | begin 118 | Clear; 119 | for I := 0 to High(Frames) do begin 120 | StackFrameInfo := TStackFrameInfo.Create; 121 | StackFrameInfo.GetFrameInfo(Frames[I]); 122 | StackFrameInfo.Index := I + 1; 123 | Add(StackFrameInfo); 124 | end; 125 | end; 126 | 127 | end. 128 | 129 | -------------------------------------------------------------------------------- /assets/icons/no.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r3code/lazarus-exception-logger/32a072483cbdf6de13c9d7357ba4b64c3ca15940/assets/icons/no.png -------------------------------------------------------------------------------- /demo/Demo.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | <ResourceType Value="res"/> 9 | <UseXPManifest Value="True"/> 10 | </General> 11 | <i18n> 12 | <EnableI18N LFM="False"/> 13 | </i18n> 14 | <VersionInfo> 15 | <UseVersionInfo Value="True"/> 16 | <MajorVersionNr Value="1"/> 17 | <MinorVersionNr Value="1"/> 18 | <RevisionNr Value="1"/> 19 | <BuildNr Value="2"/> 20 | </VersionInfo> 21 | <BuildModes Count="1" Active="Default"> 22 | <Item1 Name="Default" Default="True"/> 23 | </BuildModes> 24 | <PublishOptions> 25 | <Version Value="2"/> 26 | </PublishOptions> 27 | <RunParams> 28 | <FormatVersion Value="2"/> 29 | <Modes Count="1"> 30 | <Mode0 Name="default"/> 31 | </Modes> 32 | </RunParams> 33 | <RequiredPackages Count="2"> 34 | <Item1> 35 | <PackageName Value="ExceptionLogger"/> 36 | </Item1> 37 | <Item2> 38 | <PackageName Value="LCL"/> 39 | </Item2> 40 | </RequiredPackages> 41 | <Units Count="10"> 42 | <Unit0> 43 | <Filename Value="Demo.lpr"/> 44 | <IsPartOfProject Value="True"/> 45 | <EditorIndex Value="1"/> 46 | <CursorPos X="63" Y="11"/> 47 | <UsageCount Value="21"/> 48 | <Loaded Value="True"/> 49 | </Unit0> 50 | <Unit1> 51 | <Filename Value="UMainForm.pas"/> 52 | <IsPartOfProject Value="True"/> 53 | <ComponentName Value="MainForm"/> 54 | <HasResources Value="True"/> 55 | <ResourceBaseClass Value="Form"/> 56 | <TopLine Value="32"/> 57 | <CursorPos X="48" Y="47"/> 58 | <UsageCount Value="21"/> 59 | <Loaded Value="True"/> 60 | <LoadedDesigner Value="True"/> 61 | </Unit1> 62 | <Unit2> 63 | <Filename Value="/usr/lib64/lazarus/components/codetools/codetools.pas"/> 64 | <UnitName Value="CodeTools"/> 65 | <TopLine Value="4"/> 66 | <CursorPos X="32" Y="15"/> 67 | <UsageCount Value="10"/> 68 | </Unit2> 69 | <Unit3> 70 | <Filename Value="../UExceptionForm.lfm"/> 71 | <UsageCount Value="10"/> 72 | <DefaultSyntaxHighlighter Value="LFM"/> 73 | </Unit3> 74 | <Unit4> 75 | <Filename Value="../UExceptionForm.pas"/> 76 | <ComponentName Value="ExceptionForm"/> 77 | <HasResources Value="True"/> 78 | <ResourceBaseClass Value="Form"/> 79 | <EditorIndex Value="-1"/> 80 | <TopLine Value="42"/> 81 | <CursorPos X="33" Y="85"/> 82 | <UsageCount Value="10"/> 83 | <DefaultSyntaxHighlighter Value="Delphi"/> 84 | </Unit4> 85 | <Unit5> 86 | <Filename Value="../ReadMe.txt"/> 87 | <EditorIndex Value="-1"/> 88 | <CursorPos X="39" Y="3"/> 89 | <UsageCount Value="10"/> 90 | <DefaultSyntaxHighlighter Value="None"/> 91 | </Unit5> 92 | <Unit6> 93 | <Filename Value="/usr/share/fpcsrc/rtl/inc/objpash.inc"/> 94 | <TopLine Value="171"/> 95 | <CursorPos X="23" Y="185"/> 96 | <UsageCount Value="10"/> 97 | </Unit6> 98 | <Unit7> 99 | <Filename Value="../UExceptionLogger.pas"/> 100 | <IsVisibleTab Value="True"/> 101 | <EditorIndex Value="2"/> 102 | <TopLine Value="260"/> 103 | <CursorPos X="38" Y="278"/> 104 | <UsageCount Value="10"/> 105 | <Loaded Value="True"/> 106 | <DefaultSyntaxHighlighter Value="Delphi"/> 107 | </Unit7> 108 | <Unit8> 109 | <Filename Value="../leldcconvertencoding.inc"/> 110 | <EditorIndex Value="-1"/> 111 | <CursorPos X="2" Y="3"/> 112 | <UsageCount Value="10"/> 113 | <DefaultSyntaxHighlighter Value="Delphi"/> 114 | </Unit8> 115 | <Unit9> 116 | <Filename Value="../UStackTrace.pas"/> 117 | <EditorIndex Value="3"/> 118 | <CursorPos X="15" Y="29"/> 119 | <UsageCount Value="10"/> 120 | <Loaded Value="True"/> 121 | <DefaultSyntaxHighlighter Value="Delphi"/> 122 | </Unit9> 123 | </Units> 124 | <JumpHistory Count="29" HistoryIndex="28"> 125 | <Position1> 126 | <Filename Value="../UExceptionLogger.pas"/> 127 | <Caret Line="45" Column="34" TopLine="29"/> 128 | </Position1> 129 | <Position2> 130 | <Filename Value="../UExceptionLogger.pas"/> 131 | <Caret Line="302" Column="22" TopLine="272"/> 132 | </Position2> 133 | <Position3> 134 | <Filename Value="../UExceptionLogger.pas"/> 135 | <Caret Line="322" Column="47" TopLine="292"/> 136 | </Position3> 137 | <Position4> 138 | <Filename Value="../UExceptionLogger.pas"/> 139 | <Caret Line="45" Column="39" TopLine="26"/> 140 | </Position4> 141 | <Position5> 142 | <Filename Value="../UExceptionLogger.pas"/> 143 | <Caret Line="322" Column="58" TopLine="308"/> 144 | </Position5> 145 | <Position6> 146 | <Filename Value="../UExceptionLogger.pas"/> 147 | <Caret Line="45" Column="45" TopLine="45"/> 148 | </Position6> 149 | <Position7> 150 | <Filename Value="../UExceptionLogger.pas"/> 151 | <Caret Line="326" Column="54" TopLine="320"/> 152 | </Position7> 153 | <Position8> 154 | <Filename Value="../UExceptionLogger.pas"/> 155 | <Caret Line="33" Column="15" TopLine="15"/> 156 | </Position8> 157 | <Position9> 158 | <Filename Value="../UExceptionLogger.pas"/> 159 | <Caret Line="131" Column="13" TopLine="101"/> 160 | </Position9> 161 | <Position10> 162 | <Filename Value="../UExceptionLogger.pas"/> 163 | <Caret Line="143" Column="25" TopLine="113"/> 164 | </Position10> 165 | <Position11> 166 | <Filename Value="../UExceptionLogger.pas"/> 167 | <Caret Line="144" Column="26" TopLine="114"/> 168 | </Position11> 169 | <Position12> 170 | <Filename Value="../UExceptionLogger.pas"/> 171 | <Caret Line="281" Column="15" TopLine="251"/> 172 | </Position12> 173 | <Position13> 174 | <Filename Value="../UExceptionLogger.pas"/> 175 | <Caret Line="282" Column="15" TopLine="252"/> 176 | </Position13> 177 | <Position14> 178 | <Filename Value="../UExceptionLogger.pas"/> 179 | <Caret Line="308" Column="54" TopLine="278"/> 180 | </Position14> 181 | <Position15> 182 | <Filename Value="../UExceptionLogger.pas"/> 183 | <Caret Line="327" Column="14" TopLine="320"/> 184 | </Position15> 185 | <Position16> 186 | <Filename Value="../UExceptionLogger.pas"/> 187 | <Caret Line="324" Column="31" TopLine="317"/> 188 | </Position16> 189 | <Position17> 190 | <Filename Value="../UExceptionLogger.pas"/> 191 | <Caret Line="327" Column="14" TopLine="317"/> 192 | </Position17> 193 | <Position18> 194 | <Filename Value="../UExceptionLogger.pas"/> 195 | <Caret Line="332" Column="28" TopLine="317"/> 196 | </Position18> 197 | <Position19> 198 | <Filename Value="../UExceptionLogger.pas"/> 199 | <Caret Line="340" Column="16" TopLine="317"/> 200 | </Position19> 201 | <Position20> 202 | <Filename Value="../UExceptionLogger.pas"/> 203 | <Caret Line="322" Column="47" TopLine="317"/> 204 | </Position20> 205 | <Position21> 206 | <Filename Value="../UExceptionLogger.pas"/> 207 | <Caret Line="45" Column="34" TopLine="29"/> 208 | </Position21> 209 | <Position22> 210 | <Filename Value="../UExceptionLogger.pas"/> 211 | <Caret Line="302" Column="22" TopLine="272"/> 212 | </Position22> 213 | <Position23> 214 | <Filename Value="../UExceptionLogger.pas"/> 215 | <Caret Line="322" Column="47" TopLine="292"/> 216 | </Position23> 217 | <Position24> 218 | <Filename Value="../UExceptionLogger.pas"/> 219 | <Caret Line="45" Column="34" TopLine="29"/> 220 | </Position24> 221 | <Position25> 222 | <Filename Value="../UExceptionLogger.pas"/> 223 | <Caret Line="302" Column="22" TopLine="287"/> 224 | </Position25> 225 | <Position26> 226 | <Filename Value="../UExceptionLogger.pas"/> 227 | <Caret Line="45" Column="15" TopLine="29"/> 228 | </Position26> 229 | <Position27> 230 | <Filename Value="../UExceptionLogger.pas"/> 231 | <Caret Line="151" Column="50" TopLine="144"/> 232 | </Position27> 233 | <Position28> 234 | <Filename Value="../UExceptionLogger.pas"/> 235 | <Caret Line="46" Column="36" TopLine="30"/> 236 | </Position28> 237 | <Position29> 238 | <Filename Value="../UExceptionLogger.pas"/> 239 | <Caret Line="151" Column="50" TopLine="121"/> 240 | </Position29> 241 | </JumpHistory> 242 | </ProjectOptions> 243 | <CompilerOptions> 244 | <Version Value="11"/> 245 | <Target> 246 | <Filename Value="Demo"/> 247 | </Target> 248 | <SearchPaths> 249 | <IncludeFiles Value="$(ProjOutDir)"/> 250 | <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> 251 | </SearchPaths> 252 | <CodeGeneration> 253 | <Checks> 254 | <IOChecks Value="True"/> 255 | <RangeChecks Value="True"/> 256 | <OverflowChecks Value="True"/> 257 | <StackChecks Value="True"/> 258 | </Checks> 259 | </CodeGeneration> 260 | <Linking> 261 | <Debugging> 262 | <DebugInfoType Value="dsStabs"/> 263 | </Debugging> 264 | <Options> 265 | <Win32> 266 | <GraphicApplication Value="True"/> 267 | </Win32> 268 | </Options> 269 | </Linking> 270 | <Other> 271 | <Verbosity> 272 | <ShoLineNum Value="True"/> 273 | </Verbosity> 274 | </Other> 275 | </CompilerOptions> 276 | <Debugging> 277 | <Exceptions Count="3"> 278 | <Item1> 279 | <Name Value="EAbort"/> 280 | </Item1> 281 | <Item2> 282 | <Name Value="ECodetoolError"/> 283 | </Item2> 284 | <Item3> 285 | <Name Value="EFOpenError"/> 286 | </Item3> 287 | </Exceptions> 288 | </Debugging> 289 | </CONFIG> 290 | -------------------------------------------------------------------------------- /demo/Demo.lpr: -------------------------------------------------------------------------------- 1 | program Demo; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX} //{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF} //{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, UMainForm 11 | { you can add units after this }; 12 | 13 | {$R *.res} 14 | 15 | begin 16 | Application.Title:='ExceptionLogger Commponent demo'; 17 | Application.Initialize; 18 | Application.CreateForm(TMainForm, MainForm); 19 | Application.Run; 20 | end. 21 | 22 | -------------------------------------------------------------------------------- /demo/IncodeUsage.lpi: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="11"/> 5 | <PathDelim Value="\"/> 6 | <General> 7 | <SessionStorage Value="InProjectDir"/> 8 | <MainUnit Value="0"/> 9 | <Title Value="IncodeUsage Example of ExceptionLogger"/> 10 | <ResourceType Value="res"/> 11 | <UseXPManifest Value="True"/> 12 | <XPManifest> 13 | <DpiAware Value="True/PM"/> 14 | </XPManifest> 15 | </General> 16 | <i18n> 17 | <OutDir Value="..\languages"/> 18 | </i18n> 19 | <VersionInfo> 20 | <UseVersionInfo Value="True"/> 21 | <MajorVersionNr Value="1"/> 22 | <MinorVersionNr Value="1"/> 23 | <Language Value="0419"/> 24 | </VersionInfo> 25 | <BuildModes Count="1"> 26 | <Item1 Name="Default" Default="True"/> 27 | </BuildModes> 28 | <PublishOptions> 29 | <Version Value="2"/> 30 | </PublishOptions> 31 | <RunParams> 32 | <FormatVersion Value="2"/> 33 | <Modes Count="1"> 34 | <Mode0 Name="default"/> 35 | </Modes> 36 | </RunParams> 37 | <RequiredPackages Count="1"> 38 | <Item1> 39 | <PackageName Value="LCL"/> 40 | </Item1> 41 | </RequiredPackages> 42 | <Units Count="8"> 43 | <Unit0> 44 | <Filename Value="IncodeUsage.lpr"/> 45 | <IsPartOfProject Value="True"/> 46 | </Unit0> 47 | <Unit1> 48 | <Filename Value="utestincode.pas"/> 49 | <IsPartOfProject Value="True"/> 50 | <ComponentName Value="frmTestIncode"/> 51 | <HasResources Value="True"/> 52 | <ResourceBaseClass Value="Form"/> 53 | <UnitName Value="uTestIncode"/> 54 | </Unit1> 55 | <Unit2> 56 | <Filename Value="..\CustomLineInfo.pas"/> 57 | <IsPartOfProject Value="True"/> 58 | </Unit2> 59 | <Unit3> 60 | <Filename Value="..\UExceptionForm.pas"/> 61 | <IsPartOfProject Value="True"/> 62 | <ComponentName Value="ExceptionForm"/> 63 | <HasResources Value="True"/> 64 | <ResourceBaseClass Value="Form"/> 65 | </Unit3> 66 | <Unit4> 67 | <Filename Value="..\UExceptionLogger.pas"/> 68 | <IsPartOfProject Value="True"/> 69 | </Unit4> 70 | <Unit5> 71 | <Filename Value="..\UStackTrace.pas"/> 72 | <IsPartOfProject Value="True"/> 73 | </Unit5> 74 | <Unit6> 75 | <Filename Value="..\usysinfo.pas"/> 76 | <IsPartOfProject Value="True"/> 77 | </Unit6> 78 | <Unit7> 79 | <Filename Value="..\uappinfo.pas"/> 80 | <IsPartOfProject Value="True"/> 81 | </Unit7> 82 | </Units> 83 | </ProjectOptions> 84 | <CompilerOptions> 85 | <Version Value="11"/> 86 | <PathDelim Value="\"/> 87 | <Target> 88 | <Filename Value="IncodeUsage"/> 89 | </Target> 90 | <SearchPaths> 91 | <IncludeFiles Value="$(ProjOutDir)"/> 92 | <OtherUnitFiles Value=".."/> 93 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 94 | </SearchPaths> 95 | <CodeGeneration> 96 | <Checks> 97 | <IOChecks Value="True"/> 98 | <RangeChecks Value="True"/> 99 | <OverflowChecks Value="True"/> 100 | <StackChecks Value="True"/> 101 | </Checks> 102 | <Optimizations> 103 | <OptimizationLevel Value="0"/> 104 | </Optimizations> 105 | </CodeGeneration> 106 | <Linking> 107 | <Debugging> 108 | <DebugInfoType Value="dsStabs"/> 109 | </Debugging> 110 | <Options> 111 | <Win32> 112 | <GraphicApplication Value="True"/> 113 | </Win32> 114 | </Options> 115 | </Linking> 116 | </CompilerOptions> 117 | <Debugging> 118 | <Exceptions Count="3"> 119 | <Item1> 120 | <Name Value="EAbort"/> 121 | </Item1> 122 | <Item2> 123 | <Name Value="ECodetoolError"/> 124 | </Item2> 125 | <Item3> 126 | <Name Value="EFOpenError"/> 127 | </Item3> 128 | </Exceptions> 129 | </Debugging> 130 | </CONFIG> 131 | -------------------------------------------------------------------------------- /demo/IncodeUsage.lpr: -------------------------------------------------------------------------------- 1 | program IncodeUsage; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX}{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF}{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, uTestIncode, UExceptionLogger, sysutils, usysinfo, uappinfo; 11 | 12 | {$R *.res} 13 | {$I 'revision.inc'} 14 | 15 | 16 | begin 17 | Application.Title:='IncodeUsage Example of ExceptionLogger'; 18 | RequireDerivedFormResource:=True; 19 | Application.Initialize; 20 | exceptionLogger := TExceptionLogger.Create(Application); 21 | exceptionLogger.LogFileName:= 'bugreport.txt'; 22 | exceptionLogger.AddExtraInfo('code revision', RevisionStr); 23 | Application.CreateForm(TfrmTestIncode, frmTestIncode); 24 | Application.Run; 25 | end. 26 | 27 | -------------------------------------------------------------------------------- /demo/UMainForm.lfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 297 3 | Height = 147 4 | Top = 221 5 | Width = 251 6 | Caption = 'ExceptionLogger Commponent demo' 7 | ClientHeight = 147 8 | ClientWidth = 251 9 | LCLVersion = '1.6.4.0' 10 | object btnMakeException: TButton 11 | Left = 17 12 | Height = 25 13 | Top = 18 14 | Width = 191 15 | Caption = 'Simple exception' 16 | OnClick = btnMakeExceptionClick 17 | TabOrder = 0 18 | end 19 | object btnMakeThreadException: TButton 20 | Left = 17 21 | Height = 25 22 | Top = 59 23 | Width = 191 24 | Caption = 'Exception inside thread' 25 | OnClick = btnMakeThreadExceptionClick 26 | TabOrder = 1 27 | end 28 | object ExceptionLogger1: TExceptionLogger 29 | MaxCallStackDepth = 20 30 | left = 96 31 | top = 88 32 | end 33 | end 34 | -------------------------------------------------------------------------------- /demo/UMainForm.pas: -------------------------------------------------------------------------------- 1 | unit UMainForm; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, 9 | UExceptionLogger; 10 | 11 | type 12 | 13 | { TSampleThread } 14 | 15 | TSampleThread = class(TThread) 16 | procedure Execute; override; 17 | end; 18 | 19 | { TMainForm } 20 | 21 | TMainForm = class(TForm) 22 | btnMakeException: TButton; 23 | btnMakeThreadException: TButton; 24 | ExceptionLogger1: TExceptionLogger; 25 | procedure btnMakeExceptionClick(Sender: TObject); 26 | procedure btnMakeThreadExceptionClick(Sender: TObject); 27 | private 28 | { private declarations } 29 | public 30 | Thread: TSampleThread; 31 | end; 32 | 33 | var 34 | MainForm: TMainForm; 35 | 36 | implementation 37 | 38 | { TSampleThread } 39 | 40 | procedure TSampleThread.Execute; 41 | begin 42 | try 43 | raise Exception.Create('Exception inside thread'); 44 | 45 | except 46 | on E: Exception do 47 | MainForm.ExceptionLogger1.HandleException(Self, E); 48 | end; 49 | end; 50 | 51 | {$R *.lfm} 52 | 53 | { TMainForm } 54 | 55 | procedure TMainForm.btnMakeExceptionClick(Sender: TObject); 56 | begin 57 | raise Exception.Create('Simple exception'); 58 | end; 59 | 60 | procedure TMainForm.btnMakeThreadExceptionClick(Sender: TObject); 61 | begin 62 | Thread := TSampleThread.Create(True); 63 | Thread.FreeOnTerminate := True; 64 | Thread.Start; 65 | end; 66 | 67 | end. 68 | 69 | -------------------------------------------------------------------------------- /demo/revision.inc: -------------------------------------------------------------------------------- 1 | // see http://wiki.freepascal.org/Show_Application_Title,_Version,_and_Company 2 | const RevisionStr = '43594'; -------------------------------------------------------------------------------- /demo/utestincode.lfm: -------------------------------------------------------------------------------- 1 | object frmTestIncode: TfrmTestIncode 2 | Left = 370 3 | Height = 240 4 | Top = 205 5 | Width = 320 6 | Caption = 'frmTestIncode' 7 | ClientHeight = 240 8 | ClientWidth = 320 9 | LCLVersion = '1.6.4.0' 10 | object Button1: TButton 11 | Left = 64 12 | Height = 65 13 | Top = 48 14 | Width = 191 15 | Caption = 'MyException' 16 | OnClick = Button1Click 17 | TabOrder = 0 18 | end 19 | object Button2: TButton 20 | Left = 64 21 | Height = 65 22 | Top = 144 23 | Width = 191 24 | Caption = 'Thread Exception' 25 | OnClick = Button2Click 26 | TabOrder = 1 27 | end 28 | end 29 | -------------------------------------------------------------------------------- /demo/utestincode.pas: -------------------------------------------------------------------------------- 1 | unit uTestIncode; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls; 9 | 10 | type 11 | 12 | EMyException = class(Exception); 13 | 14 | { TSampleThread } 15 | 16 | TSampleThread = class(TThread) 17 | procedure Execute; override; 18 | end; 19 | 20 | { TfrmTestIncode } 21 | 22 | TfrmTestIncode = class(TForm) 23 | Button1: TButton; 24 | Button2: TButton; 25 | procedure Button1Click(Sender: TObject); 26 | procedure Button2Click(Sender: TObject); 27 | public 28 | Thread: TSampleThread; 29 | end; 30 | 31 | var 32 | frmTestIncode: TfrmTestIncode; 33 | 34 | implementation 35 | 36 | uses 37 | UExceptionLogger; 38 | 39 | { TSampleThread } 40 | 41 | procedure TSampleThread.Execute; 42 | var 43 | k: string; 44 | begin 45 | try 46 | k := 'a'; 47 | Sleep(1000); 48 | k := 'b'; 49 | raise Exception.Create('Exception inside thread. K=' + K); 50 | 51 | except 52 | on E: Exception do 53 | UExceptionLogger.exceptionLogger.HandleException(Self, E); 54 | end; 55 | end; 56 | 57 | {$R *.lfm} 58 | 59 | { TfrmTestIncode } 60 | 61 | procedure TfrmTestIncode.Button1Click(Sender: TObject); 62 | begin 63 | raise EMyException.Create('Woo!'); 64 | end; 65 | 66 | procedure TfrmTestIncode.Button2Click(Sender: TObject); 67 | begin 68 | Thread := TSampleThread.Create(True); 69 | Thread.FreeOnTerminate := True; 70 | Thread.Start; 71 | end; 72 | 73 | end. 74 | 75 | -------------------------------------------------------------------------------- /doc/images/error_report.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r3code/lazarus-exception-logger/32a072483cbdf6de13c9d7357ba4b64c3ca15940/doc/images/error_report.jpg -------------------------------------------------------------------------------- /languages/UExceptionLogger.po: -------------------------------------------------------------------------------- 1 | msgid "" 2 | msgstr "Content-Type: text/plain; charset=UTF-8" 3 | 4 | #: uexceptionlogger.saddress 5 | msgid "Address" 6 | msgstr "" 7 | 8 | #: uexceptionlogger.sapplicationtitle 9 | msgid "App. title" 10 | msgstr "" 11 | 12 | #: uexceptionlogger.sbuildtarget 13 | msgid "Build target" 14 | msgstr "" 15 | 16 | #: uexceptionlogger.scallstack 17 | msgid "Call stack" 18 | msgstr "" 19 | 20 | #: uexceptionlogger.sclass 21 | msgid "Class" 22 | msgstr "" 23 | 24 | #: uexceptionlogger.sclose 25 | msgid "Continue" 26 | msgstr "" 27 | 28 | #: uexceptionlogger.scompileddate 29 | msgid "Compiled date" 30 | msgstr "" 31 | 32 | #: uexceptionlogger.scurrentdiskfreespacesize 33 | msgid "free disk space" 34 | msgstr "" 35 | 36 | #: uexceptionlogger.sdetails 37 | msgid "Details" 38 | msgstr "" 39 | 40 | #: uexceptionlogger.serroroccured 41 | msgid "Error occured during program execution:" 42 | msgstr "" 43 | 44 | #: uexceptionlogger.serrorreportfilenotcrearted 45 | msgid "Report file not created" 46 | msgstr "" 47 | 48 | #: uexceptionlogger.sexceptionclass 49 | msgid "Exception class" 50 | msgstr "" 51 | 52 | #: uexceptionlogger.sexceptionhandlercannotbesynchronized 53 | msgid "Exception handler cannot be synchronized with main thread." 54 | msgstr "" 55 | 56 | #: uexceptionlogger.sexceptioninfo 57 | msgid "Exception info" 58 | msgstr "" 59 | 60 | #: uexceptionlogger.sexceptionmessage 61 | msgid "Exception message" 62 | msgstr "" 63 | 64 | #: uexceptionlogger.sexename 65 | msgid "Executable" 66 | msgstr "" 67 | 68 | #: uexceptionlogger.sgeneral 69 | msgid "General" 70 | msgstr "" 71 | 72 | #: uexceptionlogger.signorenexttime 73 | msgid "Skip this exception next" 74 | msgstr "" 75 | 76 | #: uexceptionlogger.sindex 77 | msgid "Index" 78 | msgstr "" 79 | 80 | #: uexceptionlogger.slclversion 81 | msgid "LCL version" 82 | msgstr "" 83 | 84 | #: uexceptionlogger.sline 85 | msgid "Line" 86 | msgstr "" 87 | 88 | #: uexceptionlogger.soperatingsystem 89 | msgid "Operating system" 90 | msgstr "" 91 | 92 | #: uexceptionlogger.sproceduremethod 93 | msgid "Procedure/method" 94 | msgstr "" 95 | 96 | #: uexceptionlogger.sprocessid 97 | msgid "Process ID" 98 | msgstr "" 99 | 100 | #: uexceptionlogger.sprogramuptime 101 | msgid "program up time" 102 | msgstr "" 103 | 104 | #: uexceptionlogger.sreporttime 105 | msgid "Date/time" 106 | msgstr "" 107 | 108 | #: uexceptionlogger.sterminate 109 | msgid "Exit program" 110 | msgstr "" 111 | 112 | #: uexceptionlogger.sthreadid 113 | msgid "Thread ID" 114 | msgstr "" 115 | 116 | #: uexceptionlogger.sunit 117 | msgid "Unit" 118 | msgstr "" 119 | 120 | #: uexceptionlogger.susername 121 | msgid "user name" 122 | msgstr "" 123 | 124 | #: uexceptionlogger.sversion 125 | msgid "Version" 126 | msgstr "" 127 | 128 | #: uexceptionlogger.swidgetset 129 | msgid "Widget set" 130 | msgstr "" 131 | 132 | -------------------------------------------------------------------------------- /languages/UExceptionLogger.ru.po: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r3code/lazarus-exception-logger/32a072483cbdf6de13c9d7357ba4b64c3ca15940/languages/UExceptionLogger.ru.po -------------------------------------------------------------------------------- /leldcconvertencoding.inc: -------------------------------------------------------------------------------- 1 | // unit renamed dcconvertencoding to leldcconvertencoding. Fixes #9 Units conflicting with KASToolbar from OPM 2 | { Do not edit this file! It is autogenerated from C program natspec.c } 3 | 4 | const 5 | charset_relation: array[0..253, 0..3] of String = 6 | ( 7 | ('C' , 'C' , 'CP1252' , 'IBM437' ), 8 | ('POSIX' , 'POSIX' , 'CP1252' , 'IBM437' ), 9 | ('aa' , 'aa_DJ' , 'CP1252' , 'IBM437' ), 10 | ('aa' , 'aa_ER' , 'CP1252' , 'IBM437' ), 11 | ('aa' , 'aa_ER@saaho' , 'CP1252' , 'IBM437' ), 12 | ('aa' , 'aa_ET' , 'CP1252' , 'IBM437' ), 13 | ('af' , 'af_ZA' , 'CP1252' , 'IBM850' ), 14 | ('am' , 'am_ET' , 'CP1252' , 'IBM437' ), 15 | ('an' , 'an_ES' , 'CP1252' , 'IBM437' ), 16 | ('ar' , 'ar_AE' , 'CP1256' , '' ), 17 | ('ar' , 'ar_BH' , 'CP1256' , '' ), 18 | ('ar' , 'ar_DZ' , 'CP1256' , '' ), 19 | ('ar' , 'ar_EG' , 'CP1256' , '' ), 20 | ('ar' , 'ar_IN' , 'CP1256' , '' ), 21 | ('ar' , 'ar_IQ' , 'CP1256' , '' ), 22 | ('ar' , 'ar_JO' , 'CP1256' , '' ), 23 | ('ar' , 'ar_KW' , 'CP1256' , '' ), 24 | ('ar' , 'ar_LB' , 'CP1256' , '' ), 25 | ('ar' , 'ar_LY' , 'CP1256' , '' ), 26 | ('ar' , 'ar_MA' , 'CP1256' , '' ), 27 | ('ar' , 'ar_OM' , 'CP1256' , '' ), 28 | ('ar' , 'ar_QA' , 'CP1256' , '' ), 29 | ('ar' , 'ar_SA' , 'CP1256' , '' ), 30 | ('ar' , 'ar_SD' , 'CP1256' , '' ), 31 | ('ar' , 'ar_SY' , 'CP1256' , '' ), 32 | ('ar' , 'ar_TN' , 'CP1256' , '' ), 33 | ('ar' , 'ar_YE' , 'CP1256' , '' ), 34 | ('as' , 'as_IN' , 'CP1252' , 'IBM437' ), 35 | ('ast' , 'ast_ES' , 'CP1252' , 'IBM437' ), 36 | ('az' , 'az_AZ' , 'CP1254' , 'IBM857' ), 37 | ('be' , 'be_BY' , 'CP1251' , 'IBM849' ), 38 | ('be' , 'be_BY@latin' , 'CP1251' , 'IBM849' ), 39 | ('ber' , 'ber_DZ' , 'CP1252' , 'IBM437' ), 40 | ('ber' , 'ber_MA' , 'CP1252' , 'IBM437' ), 41 | ('bg' , 'bg_BG' , 'CP1251' , 'IBM866' ), 42 | ('bn' , 'bn_BD' , 'CP1252' , 'IBM437' ), 43 | ('bn' , 'bn_IN' , 'CP1252' , 'IBM437' ), 44 | ('bo' , 'bo_CN' , 'CP1252' , 'IBM437' ), 45 | ('bo' , 'bo_IN' , 'CP1252' , 'IBM437' ), 46 | ('br' , 'br_FR' , 'CP1252' , 'IBM850' ), 47 | ('br' , 'br_FR@euro' , 'CP1252' , 'IBM850' ), 48 | ('bs' , 'bs_BA' , 'CP1252' , 'IBM437' ), 49 | ('byn' , 'byn_ER' , 'CP1252' , 'IBM437' ), 50 | ('ca' , 'ca_AD' , 'CP1252' , 'IBM850' ), 51 | ('ca' , 'ca_ES' , 'CP1252' , 'IBM850' ), 52 | ('ca' , 'ca_ES@euro' , 'CP1252' , 'IBM850' ), 53 | ('ca' , 'ca_FR' , 'CP1252' , 'IBM850' ), 54 | ('ca' , 'ca_IT' , 'CP1252' , 'IBM850' ), 55 | ('crh' , 'crh_UA' , 'CP1252' , 'IBM437' ), 56 | ('cs' , 'cs_CZ' , 'CP1250' , 'IBM852' ), 57 | ('csb' , 'csb_PL' , 'CP1252' , 'IBM437' ), 58 | ('cy' , 'cy_GB' , 'ISO885914' , 'IBM850' ), 59 | ('da' , 'da_DK' , 'CP1252' , 'IBM850' ), 60 | ('de' , 'de_AT' , 'CP1252' , 'IBM850' ), 61 | ('de' , 'de_AT@euro' , 'CP1252' , 'IBM850' ), 62 | ('de' , 'de_BE' , 'CP1252' , 'IBM850' ), 63 | ('de' , 'de_BE@euro' , 'CP1252' , 'IBM850' ), 64 | ('de' , 'de_CH' , 'CP1252' , 'IBM850' ), 65 | ('de' , 'de_DE' , 'CP1252' , 'IBM850' ), 66 | ('de' , 'de_DE@euro' , 'CP1252' , 'IBM850' ), 67 | ('de' , 'de_LU' , 'CP1252' , 'IBM850' ), 68 | ('de' , 'de_LU@euro' , 'CP1252' , 'IBM850' ), 69 | ('dz' , 'dz_BT' , 'CP1252' , 'IBM437' ), 70 | ('el' , 'el_CY' , 'CP1253' , '' ), 71 | ('el' , 'el_GR' , 'CP1253' , '' ), 72 | ('en' , 'en_AG' , 'CP1252' , 'IBM437' ), 73 | ('en' , 'en_AU' , 'CP1252' , 'IBM850' ), 74 | ('en' , 'en_BW' , 'CP1252' , 'IBM437' ), 75 | ('en' , 'en_CA' , 'CP1252' , 'IBM850' ), 76 | ('en' , 'en_DK' , 'CP1252' , 'IBM437' ), 77 | ('en' , 'en_GB' , 'CP1252' , 'IBM850' ), 78 | ('en' , 'en_HK' , 'CP1252' , 'IBM437' ), 79 | ('en' , 'en_IE' , 'CP1252' , 'IBM850' ), 80 | ('en' , 'en_IE@euro' , 'CP1252' , 'IBM850' ), 81 | ('en' , 'en_IN' , 'CP1252' , 'IBM437' ), 82 | ('en' , 'en_NG' , 'CP1252' , 'IBM437' ), 83 | ('en' , 'en_NZ' , 'CP1252' , 'IBM850' ), 84 | ('en' , 'en_PH' , 'CP1252' , 'IBM437' ), 85 | ('en' , 'en_SG' , 'CP1252' , 'IBM437' ), 86 | ('en' , 'en_US' , 'CP1252' , 'IBM437' ), 87 | ('en' , 'en_ZA' , 'CP1252' , 'IBM437' ), 88 | ('en' , 'en_ZW' , 'CP1252' , 'IBM437' ), 89 | ('es' , 'es_AR' , 'CP1252' , 'IBM850' ), 90 | ('es' , 'es_BO' , 'CP1252' , 'IBM850' ), 91 | ('es' , 'es_CL' , 'CP1252' , 'IBM850' ), 92 | ('es' , 'es_CO' , 'CP1252' , 'IBM850' ), 93 | ('es' , 'es_CR' , 'CP1252' , 'IBM850' ), 94 | ('es' , 'es_DO' , 'CP1252' , 'IBM850' ), 95 | ('es' , 'es_EC' , 'CP1252' , 'IBM850' ), 96 | ('es' , 'es_ES' , 'CP1252' , 'IBM850' ), 97 | ('es' , 'es_ES@euro' , 'CP1252' , 'IBM850' ), 98 | ('es' , 'es_GT' , 'CP1252' , 'IBM850' ), 99 | ('es' , 'es_HN' , 'CP1252' , 'IBM850' ), 100 | ('es' , 'es_MX' , 'CP1252' , 'IBM850' ), 101 | ('es' , 'es_NI' , 'CP1252' , 'IBM850' ), 102 | ('es' , 'es_PA' , 'CP1252' , 'IBM850' ), 103 | ('es' , 'es_PE' , 'CP1252' , 'IBM850' ), 104 | ('es' , 'es_PR' , 'CP1252' , 'IBM850' ), 105 | ('es' , 'es_PY' , 'CP1252' , 'IBM850' ), 106 | ('es' , 'es_SV' , 'CP1252' , 'IBM850' ), 107 | ('es' , 'es_US' , 'CP1252' , 'IBM850' ), 108 | ('es' , 'es_UY' , 'CP1252' , 'IBM850' ), 109 | ('es' , 'es_VE' , 'CP1252' , 'IBM850' ), 110 | ('et' , 'et_EE' , 'CP1257' , '' ), 111 | ('eu' , 'eu_ES' , 'CP1252' , 'IBM850' ), 112 | ('eu' , 'eu_ES@euro' , 'CP1252' , 'IBM850' ), 113 | ('fa' , 'fa_IR' , 'CP1256' , '' ), 114 | ('fi' , 'fi_FI' , 'CP1252' , 'IBM850' ), 115 | ('fi' , 'fi_FI@euro' , 'CP1252' , 'IBM850' ), 116 | ('fil' , 'fil_PH' , 'CP1252' , 'IBM437' ), 117 | ('fo' , 'fo_FO' , 'CP1252' , 'IBM850' ), 118 | ('fr' , 'fr_BE' , 'CP1252' , 'IBM850' ), 119 | ('fr' , 'fr_BE@euro' , 'CP1252' , 'IBM850' ), 120 | ('fr' , 'fr_CA' , 'CP1252' , 'IBM850' ), 121 | ('fr' , 'fr_CH' , 'CP1252' , 'IBM850' ), 122 | ('fr' , 'fr_FR' , 'CP1252' , 'IBM850' ), 123 | ('fr' , 'fr_FR@euro' , 'CP1252' , 'IBM850' ), 124 | ('fr' , 'fr_LU' , 'CP1252' , 'IBM850' ), 125 | ('fr' , 'fr_LU@euro' , 'CP1252' , 'IBM850' ), 126 | ('fur' , 'fur_IT' , 'CP1252' , 'IBM437' ), 127 | ('fy' , 'fy_DE' , 'CP1252' , 'IBM437' ), 128 | ('fy' , 'fy_NL' , 'CP1252' , 'IBM437' ), 129 | ('ga' , 'ga_IE' , 'CP1252' , 'IBM437' ), 130 | ('ga' , 'ga_IE@euro' , 'CP1252' , 'IBM437' ), 131 | ('gd' , 'gd_GB' , 'CP1252' , 'IBM850' ), 132 | ('gez' , 'gez_ER' , 'CP1252' , 'IBM437' ), 133 | ('gez' , 'gez_ER@abegede' , 'CP1252' , 'IBM437' ), 134 | ('gez' , 'gez_ET' , 'CP1252' , 'IBM437' ), 135 | ('gez' , 'gez_ET@abegede' , 'CP1252' , 'IBM437' ), 136 | ('gl' , 'gl_ES' , 'CP1252' , 'IBM850' ), 137 | ('gl' , 'gl_ES@euro' , 'CP1252' , 'IBM850' ), 138 | ('gv' , 'gv_GB' , 'CP1252' , 'IBM850' ), 139 | ('ha' , 'ha_NG' , 'CP1252' , 'IBM437' ), 140 | ('he' , 'he_IL' , 'CP1255' , 'IBM862' ), 141 | ('hne' , 'hne_IN' , 'CP1252' , 'IBM437' ), 142 | ('hr' , 'hr_HR' , 'CP1250' , 'IBM852' ), 143 | ('hsb' , 'hsb_DE' , 'CP1252' , 'IBM437' ), 144 | ('ht' , 'ht_HT' , 'CP1252' , 'IBM437' ), 145 | ('hu' , 'hu_HU' , 'CP1250' , 'IBM852' ), 146 | ('hy' , 'hy_AM' , 'CP1252' , 'IBM437' ), 147 | ('id' , 'id_ID' , 'CP1252' , 'IBM850' ), 148 | ('ig' , 'ig_NG' , 'CP1252' , 'IBM437' ), 149 | ('ik' , 'ik_CA' , 'CP1252' , 'IBM437' ), 150 | ('is' , 'is_IS' , 'CP1252' , 'IBM850' ), 151 | ('it' , 'it_CH' , 'CP1252' , 'IBM850' ), 152 | ('it' , 'it_IT' , 'CP1252' , 'IBM850' ), 153 | ('it' , 'it_IT@euro' , 'CP1252' , 'IBM850' ), 154 | ('iu' , 'iu_CA' , 'CP1252' , 'IBM437' ), 155 | ('iw' , 'iw_IL' , 'CP1252' , 'IBM437' ), 156 | ('ja' , 'ja_JP' , 'CP932' , 'CP932' ), 157 | ('kk' , 'kk_KZ' , 'CP1251' , 'IBM866' ), 158 | ('kl' , 'kl_GL' , 'CP1252' , 'IBM437' ), 159 | ('km' , 'km_KH' , 'CP1252' , 'IBM437' ), 160 | ('ko' , 'ko_KR' , 'CP949' , 'CP949' ), 161 | ('ks' , 'ks_IN' , 'CP1252' , 'IBM437' ), 162 | ('ks' , 'ks_IN@devanagari' , 'CP1252' , 'IBM437' ), 163 | ('ku' , 'ku_TR' , 'CP1252' , 'IBM437' ), 164 | ('kw' , 'kw_GB' , 'CP1252' , 'IBM850' ), 165 | ('ky' , 'ky_KG' , 'CP1251' , 'IBM866' ), 166 | ('lg' , 'lg_UG' , 'CP1252' , 'IBM437' ), 167 | ('li' , 'li_BE' , 'CP1252' , 'IBM437' ), 168 | ('li' , 'li_NL' , 'CP1252' , 'IBM437' ), 169 | ('lo' , 'lo_LA' , 'CP1252' , 'IBM437' ), 170 | ('lt' , 'lt_LT' , 'CP1257' , '' ), 171 | ('lv' , 'lv_LV' , 'CP1257' , '' ), 172 | ('mai' , 'mai_IN' , 'CP1252' , 'IBM437' ), 173 | ('mg' , 'mg_MG' , 'CP1252' , 'IBM437' ), 174 | ('mi' , 'mi_NZ' , 'CP1252' , 'IBM437' ), 175 | ('mk' , 'mk_MK' , 'CP1251' , 'IBM866' ), 176 | ('ml' , 'ml_IN' , 'CP1252' , 'IBM437' ), 177 | ('mn' , 'mn_MN' , 'CP1251' , 'IBM866' ), 178 | ('ms' , 'ms_MY' , 'CP1252' , 'IBM850' ), 179 | ('mt' , 'mt_MT' , 'CP1252' , 'IBM437' ), 180 | ('nan' , 'nan_TW@latin' , 'CP1252' , 'IBM437' ), 181 | ('nb' , 'nb_NO' , 'CP1252' , 'IBM850' ), 182 | ('nds' , 'nds_DE' , 'CP1252' , 'IBM437' ), 183 | ('nds' , 'nds_NL' , 'CP1252' , 'IBM437' ), 184 | ('ne' , 'ne_NP' , 'CP1252' , 'IBM437' ), 185 | ('nl' , 'nl_AW' , 'CP1252' , 'IBM850' ), 186 | ('nl' , 'nl_BE' , 'CP1252' , 'IBM850' ), 187 | ('nl' , 'nl_BE@euro' , 'CP1252' , 'IBM850' ), 188 | ('nl' , 'nl_NL' , 'CP1252' , 'IBM850' ), 189 | ('nl' , 'nl_NL@euro' , 'CP1252' , 'IBM850' ), 190 | ('nn' , 'nn_NO' , 'CP1252' , 'IBM850' ), 191 | ('no' , 'no_NO' , 'CP1252' , 'IBM437' ), 192 | ('nr' , 'nr_ZA' , 'CP1252' , 'IBM437' ), 193 | ('nso' , 'nso_ZA' , 'CP1252' , 'IBM437' ), 194 | ('oc' , 'oc_FR' , 'CP1252' , 'IBM437' ), 195 | ('om' , 'om_ET' , 'CP1252' , 'IBM437' ), 196 | ('om' , 'om_KE' , 'CP1252' , 'IBM437' ), 197 | ('or' , 'or_IN' , 'CP1252' , 'IBM437' ), 198 | ('pap' , 'pap_AN' , 'CP1252' , 'IBM437' ), 199 | ('pl' , 'pl_PL' , 'CP1250' , 'IBM852' ), 200 | ('pt' , 'pt_BR' , 'CP1252' , 'IBM850' ), 201 | ('pt' , 'pt_PT' , 'CP1252' , 'IBM850' ), 202 | ('pt' , 'pt_PT@euro' , 'CP1252' , 'IBM850' ), 203 | ('ro' , 'ro_RO' , 'CP1250' , 'IBM852' ), 204 | ('ru' , 'ru_RU' , 'CP1251' , 'IBM866' ), 205 | ('ru' , 'ru_UA' , 'CP1251' , 'IBM866' ), 206 | ('rw' , 'rw_RW' , 'CP1252' , 'IBM437' ), 207 | ('sc' , 'sc_IT' , 'CP1252' , 'IBM437' ), 208 | ('sd' , 'sd_IN' , 'CP1252' , 'IBM437' ), 209 | ('sd' , 'sd_IN@devanagari' , 'CP1252' , 'IBM437' ), 210 | ('se' , 'se_NO' , 'CP1252' , 'IBM437' ), 211 | ('shs' , 'shs_CA' , 'CP1252' , 'IBM437' ), 212 | ('si' , 'si_LK' , 'CP1252' , 'IBM437' ), 213 | ('sid' , 'sid_ET' , 'CP1252' , 'IBM437' ), 214 | ('sk' , 'sk_SK' , 'CP1250' , 'IBM852' ), 215 | ('sl' , 'sl_SI' , 'CP1250' , 'IBM852' ), 216 | ('so' , 'so_DJ' , 'CP1252' , 'IBM437' ), 217 | ('so' , 'so_ET' , 'CP1252' , 'IBM437' ), 218 | ('so' , 'so_KE' , 'CP1252' , 'IBM437' ), 219 | ('so' , 'so_SO' , 'CP1252' , 'IBM437' ), 220 | ('sq' , 'sq_AL' , 'CP1250' , 'IBM852' ), 221 | ('sr' , 'sr_ME' , 'CP1250' , 'IBM852' ), 222 | ('sr' , 'sr_RS' , 'CP1250' , 'IBM852' ), 223 | ('sr' , 'sr_RS@latin' , 'CP1250' , 'IBM852' ), 224 | ('ss' , 'ss_ZA' , 'CP1252' , 'IBM437' ), 225 | ('st' , 'st_ZA' , 'CP1252' , 'IBM437' ), 226 | ('sv' , 'sv_FI' , 'CP1252' , 'IBM850' ), 227 | ('sv' , 'sv_FI@euro' , 'CP1252' , 'IBM850' ), 228 | ('sv' , 'sv_SE' , 'CP1252' , 'IBM850' ), 229 | ('tg' , 'tg_TJ' , 'CP1252' , 'IBM437' ), 230 | ('th' , 'th_TH' , 'IBM874' , 'IBM874' ), 231 | ('ti' , 'ti_ER' , 'CP1252' , 'IBM437' ), 232 | ('ti' , 'ti_ET' , 'CP1252' , 'IBM437' ), 233 | ('tig' , 'tig_ER' , 'CP1252' , 'IBM437' ), 234 | ('tk' , 'tk_TM' , 'CP1252' , 'IBM437' ), 235 | ('tl' , 'tl_PH' , 'CP1252' , 'IBM437' ), 236 | ('tn' , 'tn_ZA' , 'CP1252' , 'IBM437' ), 237 | ('tr' , 'tr_CY' , 'CP1254' , 'IBM857' ), 238 | ('tr' , 'tr_TR' , 'CP1254' , 'IBM857' ), 239 | ('ts' , 'ts_ZA' , 'CP1252' , 'IBM437' ), 240 | ('tt' , 'tt_RU' , 'CP1251' , 'IBM866' ), 241 | ('tt' , 'tt_RU@iqtelif' , 'CP1251' , 'IBM866' ), 242 | ('ug' , 'ug_CN' , 'CP1252' , 'IBM437' ), 243 | ('uk' , 'uk_UA' , 'CP1251' , 'CP1125' ), 244 | ('ur' , 'ur_PK' , 'CP1256' , '' ), 245 | ('uz' , 'uz_UZ' , 'CP1251' , 'IBM866' ), 246 | ('uz' , 'uz_UZ@cyrillic' , 'CP1254' , 'IBM857' ), 247 | ('ve' , 've_ZA' , 'CP1252' , 'IBM437' ), 248 | ('vi' , 'vi_VN' , 'CP1258' , 'CP1258' ), 249 | ('wa' , 'wa_BE' , 'CP1252' , 'IBM850' ), 250 | ('wa' , 'wa_BE@euro' , 'CP1252' , 'IBM850' ), 251 | ('wo' , 'wo_SN' , 'CP1252' , 'IBM437' ), 252 | ('xh' , 'xh_ZA' , 'CP1252' , 'IBM437' ), 253 | ('yi' , 'yi_US' , 'CP1252' , 'IBM437' ), 254 | ('yo' , 'yo_NG' , 'CP1252' , 'IBM437' ), 255 | ('zh' , 'zh_CN' , 'CP936' , 'CP936' ), 256 | ('zh' , 'zh_HK' , 'BIG5' , 'BIG5' ), 257 | ('zh' , 'zh_SG' , 'CP936' , 'CP936' ), 258 | ('zh' , 'zh_TW' , 'BIG5' , 'BIG5' ), 259 | ('zu' , 'zu_ZA' , 'CP1252' , 'IBM437' ), 260 | ('POSIX' , 'POSIX' , 'CP1252' , 'IBM437' ) 261 | ); 262 | -------------------------------------------------------------------------------- /leldcconvertencoding.pas: -------------------------------------------------------------------------------- 1 | // unit renamed DCConvertEncoding to lelDCConvertEncoding. Fixes #9 Units conflicting with KASToolbar from OPM 2 | unit lelDCConvertEncoding; 3 | 4 | {$mode objfpc}{$H+} 5 | 6 | {$IF DEFINED(DARWIN)} 7 | {$modeswitch objectivec1} 8 | {$ENDIF} 9 | 10 | interface 11 | 12 | uses 13 | Classes, SysUtils; 14 | 15 | {$IF NOT DECLARED(RawByteString)} 16 | type 17 | RawByteString = AnsiString; 18 | {$IFEND} 19 | 20 | var 21 | 22 | {en 23 | Convert from OEM to System encoding, if needed 24 | } 25 | CeOemToSys: function (const Source: String): RawByteString; 26 | CeSysToOem: function (const Source: String): RawByteString; 27 | 28 | {en 29 | Convert from OEM to UTF-8 encoding, if needed 30 | } 31 | CeOemToUtf8: function (const Source: String): RawByteString; 32 | CeUtf8ToOem: function (const Source: String): RawByteString; 33 | 34 | {en 35 | Convert from Ansi to System encoding, if needed 36 | } 37 | CeAnsiToSys: function (const Source: String): RawByteString; 38 | CeSysToAnsi: function (const Source: String): RawByteString; 39 | 40 | {en 41 | Convert from ANSI to UTF-8 encoding, if needed 42 | } 43 | CeAnsiToUtf8: function (const Source: String): RawByteString; 44 | CeUtf8ToAnsi: function (const Source: String): RawByteString; 45 | 46 | {en 47 | Convert from Utf8 to System encoding, if needed 48 | } 49 | CeUtf8ToSys: function (const Source: String): RawByteString; 50 | CeSysToUtf8: function (const Source: String): RawByteString; 51 | 52 | function CeRawToUtf8(const Source: String): RawByteString; 53 | 54 | {$IF DEFINED(MSWINDOWS)} 55 | function CeTryEncode(const aValue: UnicodeString; aCodePage: Cardinal; 56 | aAllowBestFit: Boolean; out aResult: AnsiString): Boolean; 57 | function CeTryDecode(const aValue: AnsiString; aCodePage: Cardinal; 58 | out aResult: UnicodeString): Boolean; 59 | {$ELSEIF DEFINED(UNIX)} 60 | var 61 | SystemEncodingUtf8: Boolean = False; 62 | SystemLanguage, SystemEncoding, SystemLocale: String; 63 | {$ENDIF} 64 | 65 | implementation 66 | 67 | uses 68 | {$IF DEFINED(UNIX)} 69 | iconvenc_dyn 70 | {$IF DEFINED(DARWIN)} 71 | , MacOSAll, CocoaAll 72 | {$ENDIF} 73 | {$ELSEIF DEFINED(MSWINDOWS)} 74 | Windows 75 | {$ENDIF} 76 | ; 77 | 78 | {$IF DEFINED(FPC_HAS_CPSTRING)} 79 | var 80 | FileSystemCodePage: TSystemCodePage; 81 | {$ENDIF} 82 | 83 | function UTF8CharacterStrictLength(P: PAnsiChar): integer; 84 | begin 85 | if p=nil then exit(0); 86 | if ord(p^)<%10000000 then begin 87 | // regular single byte character 88 | exit(1); 89 | end 90 | else if ord(p^)<%11000000 then begin 91 | // invalid single byte character 92 | exit(0); 93 | end 94 | else if ((ord(p^) and %11100000) = %11000000) then begin 95 | // should be 2 byte character 96 | if (ord(p[1]) and %11000000) = %10000000 then 97 | exit(2) 98 | else 99 | exit(0); 100 | end 101 | else if ((ord(p^) and %11110000) = %11100000) then begin 102 | // should be 3 byte character 103 | if ((ord(p[1]) and %11000000) = %10000000) 104 | and ((ord(p[2]) and %11000000) = %10000000) then 105 | exit(3) 106 | else 107 | exit(0); 108 | end 109 | else if ((ord(p^) and %11111000) = %11110000) then begin 110 | // should be 4 byte character 111 | if ((ord(p[1]) and %11000000) = %10000000) 112 | and ((ord(p[2]) and %11000000) = %10000000) 113 | and ((ord(p[3]) and %11000000) = %10000000) then 114 | exit(4) 115 | else 116 | exit(0); 117 | end else 118 | exit(0); 119 | end; 120 | 121 | function CeRawToUtf8(const Source: String): RawByteString; 122 | var 123 | P: PAnsiChar; 124 | I, L: LongInt; 125 | begin 126 | L:= Length(Source); 127 | // Try UTF-8 (this includes ASCII) 128 | P:= PAnsiChar(Source); 129 | repeat 130 | if Ord(P^) < 128 then begin 131 | // ASCII 132 | if (P^ = #0) and (P - PAnsiChar(Source) >= L) then begin 133 | Result:= Source; 134 | Exit; 135 | end; 136 | Inc(P); 137 | end else begin 138 | I:= UTF8CharacterStrictLength(P); 139 | if I = 0 then Break; 140 | Inc(P, I); 141 | end; 142 | until False; 143 | Result:= CeSysToUtf8(Source); 144 | end; 145 | 146 | function Dummy(const Source: String): RawByteString; 147 | begin 148 | Result:= Source; 149 | end; 150 | 151 | {$IF DEFINED(FPC_HAS_CPSTRING)} 152 | 153 | function Sys2UTF8(const Source: String): RawByteString; 154 | begin 155 | Result:= Source; 156 | SetCodePage(Result, FileSystemCodePage, False); 157 | SetCodePage(Result, CP_UTF8, True); 158 | // Prevent another codepage appear in the strings 159 | // we don't need codepage conversion magic in our code 160 | SetCodePage(Result, DefaultSystemCodePage, False); 161 | end; 162 | 163 | function UTF82Sys(const Source: String): RawByteString; 164 | begin 165 | Result:= Source; 166 | SetCodePage(Result, CP_UTF8, False); 167 | SetCodePage(Result, FileSystemCodePage, True); 168 | // Prevent another codepage appear in the strings 169 | // we don't need codepage conversion magic in our code 170 | SetCodePage(Result, DefaultSystemCodePage, False); 171 | end; 172 | 173 | {$ELSE} 174 | 175 | function Sys2UTF8(const Source: String): RawByteString; 176 | begin 177 | Result:= UTF8Encode(Source); 178 | end; 179 | 180 | function UTF82Sys(const Source: String): RawByteString; 181 | begin 182 | Result:= UTF8Decode(Source); 183 | end; 184 | 185 | {$ENDIF} 186 | 187 | {$IF DEFINED(MSWINDOWS)} 188 | 189 | function CeTryEncode(const aValue: UnicodeString; aCodePage: Cardinal; 190 | aAllowBestFit: Boolean; out aResult: AnsiString): Boolean; 191 | // Try to encode the given Unicode string as the requested codepage 192 | const 193 | WC_NO_BEST_FIT_CHARS = $00000400; 194 | Flags: array[Boolean] of DWORD = (WC_NO_BEST_FIT_CHARS, 0); 195 | var 196 | UsedDefault: BOOL; 197 | begin 198 | if not aAllowBestFit and not CheckWin32Version(4, 1) then 199 | Result := False 200 | else begin 201 | SetLength(aResult, WideCharToMultiByte(aCodePage, Flags[aAllowBestFit], 202 | PWideChar(aValue), Length(aValue), nil, 0, nil, @UsedDefault)); 203 | SetLength(aResult, WideCharToMultiByte(aCodePage, Flags[aAllowBestFit], 204 | PWideChar(aValue), Length(aValue), PAnsiChar(aResult), 205 | Length(aResult), nil, @UsedDefault)); 206 | Result := not UsedDefault; 207 | end; 208 | end; 209 | 210 | function CeTryDecode(const aValue: AnsiString; aCodePage: Cardinal; 211 | out aResult: UnicodeString): Boolean; 212 | begin 213 | SetLength(aResult, MultiByteToWideChar(aCodePage, MB_ERR_INVALID_CHARS, 214 | LPCSTR(aValue), Length(aValue), nil, 0) * SizeOf(UnicodeChar)); 215 | SetLength(aResult, MultiByteToWideChar(aCodePage, MB_ERR_INVALID_CHARS, 216 | LPCSTR(aValue), Length(aValue), PWideChar(aResult), Length(aResult))); 217 | Result := Length(aResult) > 0; 218 | end; 219 | 220 | function Oem2Utf8(const Source: String): RawByteString; 221 | var 222 | UnicodeResult: UnicodeString; 223 | begin 224 | if CeTryDecode(Source, CP_OEMCP, UnicodeResult) then 225 | Result:= UTF8Encode(UnicodeResult) 226 | else 227 | Result:= Source; 228 | end; 229 | 230 | function Utf82Oem(const Source: String): RawByteString; 231 | var 232 | AnsiResult: AnsiString; 233 | begin 234 | if CeTryEncode(UTF8Decode(Source), CP_OEMCP, False, AnsiResult) then 235 | Result:= AnsiResult 236 | else 237 | Result:= Source; 238 | end; 239 | 240 | function OEM2Ansi(const Source: String): RawByteString; 241 | var 242 | Dst: PAnsiChar; 243 | begin 244 | Result:= Source; 245 | Dst:= AllocMem((Length(Result) + 1) * SizeOf(AnsiChar)); 246 | if OEMToChar(PAnsiChar(Result), Dst) then 247 | Result:= StrPas(Dst); 248 | FreeMem(Dst); 249 | end; 250 | 251 | function Ansi2OEM(const Source: String): RawByteString; 252 | var 253 | Dst: PAnsiChar; 254 | begin 255 | Result := Source; 256 | Dst := AllocMem((Length(Result) + 1) * SizeOf(AnsiChar)); 257 | if CharToOEM(PAnsiChar(Result), Dst) then 258 | Result := StrPas(Dst); 259 | FreeMem(Dst); 260 | end; 261 | 262 | procedure Initialize; 263 | begin 264 | CeOemToSys:= @OEM2Ansi; 265 | CeSysToOem:= @Ansi2OEM; 266 | CeOemToUtf8:= @Oem2Utf8; 267 | CeUtf8ToOem:= @Utf82Oem; 268 | CeAnsiToSys:= @Dummy; 269 | CeSysToAnsi:= @Dummy; 270 | CeAnsiToUtf8:= @Sys2UTF8; 271 | CeUtf8ToAnsi:= @UTF82Sys; 272 | CeSysToUtf8:= @Sys2UTF8; 273 | CeUtf8ToSys:= @UTF82Sys; 274 | end; 275 | 276 | {$ELSEIF DEFINED(UNIX)} 277 | 278 | {$I leldcconvertencoding.inc} 279 | 280 | const 281 | EncodingUTF8 = 'UTF-8'; // UTF-8 Encoding 282 | 283 | var 284 | EncodingOEM, // OEM Encoding 285 | EncodingANSI: String; // ANSI Encoding 286 | 287 | function GetSystemEncoding: Boolean; 288 | {$IF DEFINED(DARWIN)} 289 | var 290 | Country: String; 291 | CurrentLocale: NSLocale; 292 | LanguageCFRef: CFStringRef = nil; 293 | LanguageCFArray: CFArrayRef = nil; 294 | begin 295 | // System encoding 296 | SystemEncoding:= EncodingUTF8; 297 | // Get system language 298 | LanguageCFArray:= CFLocaleCopyPreferredLanguages; 299 | try 300 | Result:= CFArrayGetCount(LanguageCFArray) > 0; 301 | if Result then 302 | begin 303 | LanguageCFRef:= CFArrayGetValueAtIndex(LanguageCFArray, 0); 304 | SetLength(SystemLanguage, MAX_PATH); 305 | Result:= CFStringGetCString(LanguageCFRef, 306 | PAnsiChar(SystemLanguage), 307 | MAX_PATH, 308 | kCFStringEncodingUTF8 309 | ); 310 | end; 311 | finally 312 | CFRelease(LanguageCFArray); 313 | end; 314 | if Result then 315 | begin 316 | // Crop to terminating zero 317 | SystemLanguage:= PAnsiChar(SystemLanguage); 318 | // Get system country 319 | CurrentLocale:= NSLocale.currentLocale(); 320 | Country:= NSString(CurrentLocale.objectForKey(NSLocaleCountryCode)).UTF8String; 321 | // Combine system locale 322 | if (Length(SystemLanguage) > 0) and (Length(Country) > 0) then 323 | begin 324 | SystemLocale:= SystemLanguage + '_' + Country; 325 | end; 326 | end; 327 | end; 328 | {$ELSE} 329 | var 330 | I: Integer; 331 | Lang: String; 332 | begin 333 | Result:= True; 334 | Lang:= SysUtils.GetEnvironmentVariable('LC_ALL'); 335 | if Length(Lang) = 0 then 336 | begin 337 | Lang:= SysUtils.GetEnvironmentVariable('LC_MESSAGES'); 338 | if Length(Lang) = 0 then 339 | begin 340 | Lang:= SysUtils.GetEnvironmentVariable('LANG'); 341 | if Length(Lang) = 0 then 342 | Exit(False); 343 | end; 344 | end; 345 | I:= Pos('_', Lang); 346 | if (I = 0) then 347 | SystemLanguage:= Lang 348 | else begin 349 | SystemLanguage:= Copy(Lang, 1, I - 1); 350 | end; 351 | I:= System.Pos('.', Lang); 352 | if (I > 0) then 353 | begin 354 | SystemLocale:= Copy(Lang, 1, I - 1); 355 | SystemEncoding:= Copy(Lang, I + 1, Length(Lang) - I); 356 | end 357 | else begin 358 | SystemLocale:= Lang; 359 | SystemEncoding:= EncodingUTF8; 360 | end; 361 | end; 362 | {$ENDIF} 363 | 364 | {$IF DEFINED(DARWIN)} 365 | function InitIconv(var Error: String): Boolean; 366 | begin 367 | Error:= EmptyStr; 368 | Result:= TryLoadLib('libiconv.dylib', Error); 369 | IconvLibFound:= IconvLibFound or Result; 370 | end; 371 | {$ENDIF} 372 | 373 | function FindEncoding: Boolean; 374 | var 375 | Index: Integer; 376 | begin 377 | // Try to find by language and country 378 | for Index:= Low(charset_relation) to High(charset_relation) do 379 | begin 380 | if CompareStr(charset_relation[Index, 1], SystemLocale) = 0 then 381 | begin 382 | EncodingANSI:= charset_relation[Index, 2]; 383 | EncodingOEM:= charset_relation[Index, 3]; 384 | Exit(True); 385 | end; 386 | end; 387 | // Try to find by language only 388 | for Index:= Low(charset_relation) to High(charset_relation) do 389 | begin 390 | if CompareStr(charset_relation[Index, 0], SystemLanguage) = 0 then 391 | begin 392 | EncodingANSI:= charset_relation[Index, 2]; 393 | EncodingOEM:= charset_relation[Index, 3]; 394 | Exit(True); 395 | end; 396 | end; 397 | Result:= False; 398 | end; 399 | 400 | function Oem2Utf8(const Source: String): RawByteString; 401 | begin 402 | Result:= Source; 403 | Iconvert(Source, String(Result), EncodingOEM, EncodingUTF8); 404 | end; 405 | 406 | function Utf82Oem(const Source: String): RawByteString; 407 | begin 408 | Result:= Source; 409 | Iconvert(Source, String(Result), EncodingUTF8, EncodingOEM); 410 | end; 411 | 412 | function OEM2Sys(const Source: String): RawByteString; 413 | begin 414 | Result:= Source; 415 | Iconvert(Source, String(Result), EncodingOEM, SystemEncoding); 416 | end; 417 | 418 | function Sys2OEM(const Source: String): RawByteString; 419 | begin 420 | Result:= Source; 421 | Iconvert(Source, String(Result), SystemEncoding, EncodingOEM); 422 | end; 423 | 424 | function Ansi2Sys(const Source: String): RawByteString; 425 | begin 426 | Result:= Source; 427 | Iconvert(Source, String(Result), EncodingANSI, SystemEncoding); 428 | end; 429 | 430 | function Sys2Ansi(const Source: String): RawByteString; 431 | begin 432 | Result:= Source; 433 | Iconvert(Source, String(Result), SystemEncoding, EncodingANSI); 434 | end; 435 | 436 | function Ansi2Utf8(const Source: String): RawByteString; 437 | begin 438 | Result:= Source; 439 | Iconvert(Source, String(Result), EncodingANSI, EncodingUTF8); 440 | end; 441 | 442 | function Utf82Ansi(const Source: String): RawByteString; 443 | begin 444 | Result:= Source; 445 | Iconvert(Source, String(Result), EncodingUTF8, EncodingANSI); 446 | end; 447 | 448 | procedure Initialize; 449 | var 450 | Error: String = ''; 451 | begin 452 | CeOemToSys:= @Dummy; 453 | CeSysToOem:= @Dummy; 454 | CeOemToUtf8:= @Dummy; 455 | CeUtf8ToOem:= @Dummy; 456 | CeAnsiToSys:= @Dummy; 457 | CeSysToAnsi:= @Dummy; 458 | CeUtf8ToSys:= @Dummy; 459 | CeSysToUtf8:= @Dummy; 460 | CeAnsiToUtf8:= @Dummy; 461 | CeUtf8ToAnsi:= @Dummy; 462 | 463 | // Try to get system encoding and initialize Iconv library 464 | if not (GetSystemEncoding and InitIconv(Error)) then 465 | WriteLn(Error) 466 | else 467 | begin 468 | SystemEncodingUtf8:= (SysUtils.CompareText(SystemEncoding, 'UTF-8') = 0) or 469 | (SysUtils.CompareText(SystemEncoding, 'UTF8') = 0); 470 | if FindEncoding then 471 | begin 472 | if (Length(EncodingOEM) > 0) then 473 | begin 474 | CeOemToSys:= @OEM2Sys; 475 | CeSysToOem:= @Sys2OEM; 476 | CeOemToUtf8:= @Oem2Utf8; 477 | CeUtf8ToOem:= @Utf82Oem; 478 | end; 479 | if (Length(EncodingANSI) > 0) then 480 | begin 481 | CeAnsiToSys:= @Ansi2Sys; 482 | CeSysToAnsi:= @Sys2Ansi; 483 | CeAnsiToUtf8:= @Ansi2Utf8; 484 | CeUtf8ToAnsi:= @Utf82Ansi; 485 | end; 486 | end; 487 | if not SystemEncodingUtf8 then 488 | begin 489 | CeUtf8ToSys:= @UTF82Sys; 490 | CeSysToUtf8:= @Sys2UTF8; 491 | end; 492 | end; 493 | end; 494 | 495 | {$ELSE} 496 | 497 | procedure Initialize; 498 | begin 499 | CeOemToSys:= @Dummy; 500 | CeSysToOem:= @Dummy; 501 | CeOemToUtf8:= @Dummy; 502 | CeUtf8ToOem:= @Dummy; 503 | CeAnsiToSys:= @Dummy; 504 | CeSysToAnsi:= @Dummy; 505 | CeUtf8ToSys:= @Dummy; 506 | CeSysToUtf8:= @Dummy; 507 | CeAnsiToUtf8:= @Dummy; 508 | CeUtf8ToAnsi:= @Dummy; 509 | end; 510 | 511 | {$ENDIF} 512 | 513 | initialization 514 | {$IF DEFINED(FPC_HAS_CPSTRING)} 515 | FileSystemCodePage:= WideStringManager.GetStandardCodePageProc(scpFileSystemSingleByte); 516 | {$ENDIF} 517 | Initialize; 518 | 519 | end. 520 | -------------------------------------------------------------------------------- /leldcwindows.pas: -------------------------------------------------------------------------------- 1 | { 2 | Double commander 3 | ------------------------------------------------------------------------- 4 | This unit contains Windows specific functions 5 | 6 | Copyright (C) 2015 Alexander Koblov (alexx2000@mail.ru) 7 | 8 | This library is free software; you can redistribute it and/or 9 | modify it under the terms of the GNU Lesser General Public 10 | License as published by the Free Software Foundation; either 11 | version 2.1 of the License, or (at your option) any later version. 12 | 13 | This library is distributed in the hope that it will be useful, 14 | but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | Lesser General Public License for more details. 17 | 18 | You should have received a copy of the GNU Lesser General Public 19 | License along with this library; if not, write to the Free Software 20 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 21 | } 22 | // unit renamed DCWindows to lelDCWindows. Fixes #9 Units conflicting with KASToolbar from OPM 23 | unit lelDCWindows; 24 | 25 | {$mode objfpc}{$H+} 26 | 27 | interface 28 | 29 | uses 30 | Windows; 31 | 32 | {en 33 | Converts file name in UTF-8 encoding to file name 34 | with UTF-16 encoding with extended-length path prefix 35 | } 36 | function UTF16LongName(const FileName: String): UnicodeString; 37 | 38 | {en 39 | Enable a privilege 40 | @param(hToken Access token handle) 41 | @param(lpszPrivilege Name of privilege to enable) 42 | @returns(The function returns @true if successful, @false otherwise) 43 | } 44 | function EnablePrivilege(hToken: HANDLE; lpszPrivilege: LPCTSTR): Boolean; 45 | {en 46 | Copy permissions specific to the NTFS file system, 47 | like read and write permissions, and the file owner 48 | } 49 | function CopyNtfsPermissions(const Source, Target: String): Boolean; 50 | 51 | implementation 52 | 53 | uses 54 | JwaAclApi, JwaWinNT, JwaAccCtrl, JwaWinBase, JwaWinType; 55 | 56 | function UTF16LongName(const FileName: String): UnicodeString; 57 | var 58 | Temp: PWideChar; 59 | begin 60 | if Pos('\\', FileName) = 0 then 61 | Result := '\\?\' + UTF8Decode(FileName) 62 | else begin 63 | Result := '\\?\UNC\' + UTF8Decode(Copy(FileName, 3, MaxInt)); 64 | end; 65 | Temp := Pointer(Result) + 4; 66 | while Temp^ <> #0 do 67 | begin 68 | if Temp^ = '/' then Temp^:= '\'; 69 | Inc(Temp); 70 | end; 71 | if ((Temp - 1)^ = DriveSeparator) then Result:= Result + '\'; 72 | end; 73 | 74 | function EnablePrivilege(hToken: HANDLE; lpszPrivilege: LPCTSTR): Boolean; 75 | var 76 | tp: TTokenPrivileges; 77 | luid: TLuid = (LowPart: 0; HighPart: 0); 78 | begin 79 | if (not LookupPrivilegeValue(nil, lpszPrivilege, luid)) then 80 | Exit(False); 81 | 82 | tp.PrivilegeCount:= 1; 83 | tp.Privileges[0].Luid:= luid; 84 | tp.Privileges[0].Attributes:= SE_PRIVILEGE_ENABLED; 85 | 86 | // Enable privilege in the specified access token 87 | if (not AdjustTokenPrivileges(hToken, False, @tp, SizeOf(TTokenPrivileges), nil, nil)) then 88 | Exit(False); 89 | 90 | // Not all privileges or groups referenced are assigned to the caller 91 | Result:= not (GetLastError() = ERROR_NOT_ALL_ASSIGNED); 92 | end; 93 | 94 | function CopyNtfsPermissions(const Source, Target: String): Boolean; 95 | const 96 | DisabledPrivilege: Boolean = True; 97 | var 98 | Dacl, Sacl: PACL; 99 | lpdwRevision: DWORD = 0; 100 | ProcessToken: HANDLE = 0; 101 | SidOwner, SidGroup: PSID; 102 | SecDescPtr: PSECURITY_DESCRIPTOR = nil; 103 | SecDescCtl: SECURITY_DESCRIPTOR_CONTROL = 0; 104 | SecurityInfo: SECURITY_INFORMATION = DACL_SECURITY_INFORMATION or SACL_SECURITY_INFORMATION or 105 | OWNER_SECURITY_INFORMATION or GROUP_SECURITY_INFORMATION; 106 | begin 107 | if DisabledPrivilege then 108 | begin 109 | DisabledPrivilege:= False; 110 | Result:= OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, ProcessToken); 111 | if not Result then 112 | Exit(False) 113 | else begin 114 | EnablePrivilege(ProcessToken, SE_BACKUP_NAME); 115 | EnablePrivilege(ProcessToken, SE_RESTORE_NAME); 116 | EnablePrivilege(ProcessToken, SE_SECURITY_NAME); 117 | CloseHandle(ProcessToken); 118 | end; 119 | end; 120 | Result:= GetNamedSecurityInfoW(PWideChar(UTF8Decode(Source)), SE_FILE_OBJECT, SecurityInfo, 121 | @SidOwner, @SidGroup, @Dacl, @Sacl, SecDescPtr) = ERROR_SUCCESS; 122 | if Result then 123 | begin 124 | if GetSecurityDescriptorControl(SecDescPtr, SecDescCtl, lpdwRevision) then 125 | begin 126 | // Need to copy DACL inheritance 127 | if (SecDescCtl and SE_DACL_PROTECTED <> 0) then 128 | SecurityInfo:= SecurityInfo or PROTECTED_DACL_SECURITY_INFORMATION 129 | else begin 130 | SecurityInfo:= SecurityInfo or UNPROTECTED_DACL_SECURITY_INFORMATION; 131 | end; 132 | // Need to copy SACL inheritance 133 | if (SecDescCtl and SE_SACL_PROTECTED <> 0) then 134 | SecurityInfo:= SecurityInfo or PROTECTED_SACL_SECURITY_INFORMATION 135 | else begin 136 | SecurityInfo:= SecurityInfo or UNPROTECTED_SACL_SECURITY_INFORMATION; 137 | end; 138 | Result:= SetNamedSecurityInfoW(PWideChar(UTF8Decode(Target)), SE_FILE_OBJECT, 139 | SecurityInfo, SidOwner, SidGroup, Dacl, Sacl) = ERROR_SUCCESS; 140 | end; 141 | {$PUSH}{$HINTS OFF}{$WARNINGS OFF} 142 | LocalFree(HLOCAL(SecDescPtr)); 143 | {$POP} 144 | end; 145 | end; 146 | 147 | end. 148 | 149 | -------------------------------------------------------------------------------- /lelversionsupport.pas: -------------------------------------------------------------------------------- 1 | Unit lelVersionSupport; 2 | 3 | {$mode objfpc} 4 | 5 | Interface 6 | 7 | (* 8 | Building on the excellent vinfo.pas supplied by Paul Ishenin and available elsewhere on the Lazarus 9 | Forums 10 | - I hid the TVersionInfo class from the end user to simplify their (mine) number of required Uses... 11 | - Added defensive code to TVersionInfo if no build info is compiled into the exe 12 | - Deduced GetResourceStrings - works under Linux 64/GTK2 with Lazarus 0.9.30, but fails under 13 | Win XP 32bit/Lazarus 0.9.29 - suspecting my install as the lazresexplorer example also fails 14 | for me under Lazarus 0.9.29, but works with Lazarus 0.9.30 15 | 16 | Trawled through IDE source code, FPC source code and Lazarus supplied example program lasresexplorer 17 | to find the other defines and lookups... 18 | 19 | End user only needs to use VersionSupport - no other units necessary for their project. 20 | 21 | Jedi CodeFormatter seems to fail on the {$I %VARIABLE%} references, so sticking them all in here 22 | means end user code can be neatly formatted using Jedi CodeFormatter 23 | 24 | Other interesting includes I picked up in my travels are... 25 | // {$I %HOME%} = User Home Directory 26 | // {$I %FILE%} = Current pas file 27 | // {$I %LINE%} = current line number 28 | 29 | Mike Thompson - mike.cornflake@gmail.com 30 | Origin: July 24 2011 31 | 32 | Changes: 33 | January 2017: Updated code to cope with refactored LCL Platform Definitions 34 | *) 35 | 36 | Uses 37 | Classes, SysUtils; 38 | 39 | // Surfacing general defines and lookups 40 | Function GetCompiledDate: String; 41 | Function GetCompilerInfo: String; 42 | Function GetTargetInfo: String; 43 | Function GetOS: String; 44 | Function GetCPU: String; 45 | Function GetLCLVersion: String; 46 | Function GetWidgetSet: String; 47 | 48 | // Exposing resource and version info compiled into exe 49 | Function GetResourceStrings(oStringList : TStringList) : Boolean; 50 | Function GetFileVersion: String; 51 | Function GetProductVersion: String; 52 | 53 | Implementation 54 | 55 | Uses 56 | resource, versiontypes, versionresource, LCLVersion, InterfaceBase, LCLPlatformDef; 57 | 58 | Function GetWidgetSet: String; 59 | Begin 60 | Result := LCLPlatformDisplayNames[WidgetSet.LCLPlatform]; 61 | End; 62 | 63 | Function GetCompilerInfo: String; 64 | begin 65 | Result := 'FPC '+{$I %FPCVERSION%}; 66 | end; 67 | 68 | Function GetTargetInfo: String; 69 | Begin 70 | Result := {$I %FPCTARGETCPU%}+' - '+{$I %FPCTARGETOS%}; 71 | End; 72 | 73 | Function GetOS: String; 74 | Begin 75 | Result := {$I %FPCTARGETOS%}; 76 | End; 77 | 78 | function GetCPU: String; 79 | begin 80 | Result := {$I %FPCTARGETCPU%}; 81 | end; 82 | 83 | Function GetLCLVersion: String; 84 | Begin 85 | Result := 'LCL '+lcl_version; 86 | End; 87 | 88 | Function GetCompiledDate: String; 89 | Var 90 | sDate, sTime: String; 91 | Begin 92 | sDate := {$I %DATE%}; 93 | sTime := {$I %TIME%}; 94 | 95 | Result := sDate + ' at ' + sTime; 96 | End; 97 | 98 | { Routines to expose TVersionInfo data } 99 | 100 | Type 101 | TVersionInfo = Class 102 | private 103 | FBuildInfoAvailable: Boolean; 104 | FVersResource: TVersionResource; 105 | Function GetFixedInfo: TVersionFixedInfo; 106 | Function GetStringFileInfo: TVersionStringFileInfo; 107 | Function GetVarFileInfo: TVersionVarFileInfo; 108 | public 109 | Constructor Create; 110 | Destructor Destroy; override; 111 | 112 | Procedure Load(Instance: THandle); 113 | 114 | Property BuildInfoAvailable: Boolean Read FBuildInfoAvailable; 115 | 116 | Property FixedInfo: TVersionFixedInfo Read GetFixedInfo; 117 | Property StringFileInfo: TVersionStringFileInfo Read GetStringFileInfo; 118 | Property VarFileInfo: TVersionVarFileInfo Read GetVarFileInfo; 119 | End; 120 | 121 | Var 122 | FInfo: TVersionInfo; 123 | 124 | Procedure CreateInfo; 125 | Begin 126 | If Not Assigned(FInfo) Then 127 | Begin 128 | FInfo := TVersionInfo.Create; 129 | FInfo.Load(HINSTANCE); 130 | End; 131 | End; 132 | 133 | Function GetResourceStrings(oStringList: TStringList): Boolean; 134 | Var 135 | i, j : Integer; 136 | oTable : TVersionStringTable; 137 | begin 138 | CreateInfo; 139 | 140 | oStringList.Clear; 141 | Result := False; 142 | 143 | If FInfo.BuildInfoAvailable Then 144 | Begin 145 | Result := True; 146 | For i := 0 To FInfo.StringFileInfo.Count-1 Do 147 | Begin 148 | oTable := FInfo.StringFileInfo.Items[i]; 149 | 150 | For j := 0 To oTable.Count-1 Do 151 | If Trim(oTable.ValuesByIndex[j])<>'' Then 152 | oStringList.Values[oTable.Keys[j]] := oTable.ValuesByIndex[j]; 153 | end; 154 | end; 155 | end; 156 | 157 | Function ProductVersionToString(PV: TFileProductVersion): String; 158 | Begin 159 | Result := Format('%d.%d.%d.%d', [PV[0], PV[1], PV[2], PV[3]]); 160 | End; 161 | 162 | Function GetProductVersion: String; 163 | Begin 164 | CreateInfo; 165 | 166 | If FInfo.BuildInfoAvailable Then 167 | Result := ProductVersionToString(FInfo.FixedInfo.ProductVersion) 168 | Else 169 | Result := 'No build information available'; 170 | End; 171 | 172 | Function GetFileVersion: String; 173 | Begin 174 | CreateInfo; 175 | 176 | If FInfo.BuildInfoAvailable Then 177 | Result := ProductVersionToString(FInfo.FixedInfo.FileVersion) 178 | Else 179 | Result := 'No build information available'; 180 | End; 181 | 182 | { TVersionInfo } 183 | 184 | Function TVersionInfo.GetFixedInfo: TVersionFixedInfo; 185 | Begin 186 | Result := FVersResource.FixedInfo; 187 | End; 188 | 189 | Function TVersionInfo.GetStringFileInfo: TVersionStringFileInfo; 190 | Begin 191 | Result := FVersResource.StringFileInfo; 192 | End; 193 | 194 | Function TVersionInfo.GetVarFileInfo: TVersionVarFileInfo; 195 | Begin 196 | Result := FVersResource.VarFileInfo; 197 | End; 198 | 199 | Constructor TVersionInfo.Create; 200 | Begin 201 | Inherited Create; 202 | 203 | FVersResource := TVersionResource.Create; 204 | FBuildInfoAvailable := False; 205 | End; 206 | 207 | Destructor TVersionInfo.Destroy; 208 | Begin 209 | FVersResource.Free; 210 | 211 | Inherited Destroy; 212 | End; 213 | 214 | Procedure TVersionInfo.Load(Instance: THandle); 215 | Var 216 | Stream: TResourceStream; 217 | ResID: Integer; 218 | Res: TFPResourceHandle; 219 | Begin 220 | FBuildInfoAvailable := False; 221 | ResID := 1; 222 | 223 | // Defensive code to prevent failure if no resource available... 224 | Res := FindResource(Instance, PChar(PtrInt(ResID)), PChar(RT_VERSION)); 225 | If Res = 0 Then 226 | Exit; 227 | 228 | Stream := TResourceStream.CreateFromID(Instance, ResID, PChar(RT_VERSION)); 229 | Try 230 | FVersResource.SetCustomRawDataStream(Stream); 231 | 232 | // access some property to load from the stream 233 | FVersResource.FixedInfo; 234 | 235 | // clear the stream 236 | FVersResource.SetCustomRawDataStream(nil); 237 | 238 | FBuildInfoAvailable := True; 239 | Finally 240 | Stream.Free; 241 | End; 242 | End; 243 | 244 | Initialization 245 | FInfo := nil; 246 | 247 | Finalization 248 | If Assigned(FInfo) Then 249 | FInfo.Free; 250 | End. 251 | 252 | -------------------------------------------------------------------------------- /uappinfo.pas: -------------------------------------------------------------------------------- 1 | unit uappinfo; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes 9 | , SysUtils 10 | // http://wiki.lazarus.freepascal.org/Show_Application_Title,_Version,_and_Company 11 | // FPC 3.0 fileinfo reads exe resources as long as you register the appropriate units 12 | , fileinfo 13 | , winpeimagereader {need this for reading exe info} 14 | , elfreader {needed for reading ELF executables} 15 | , machoreader {needed for reading MACH-O executables} 16 | ; 17 | 18 | function GetAppVersion: string; 19 | 20 | implementation 21 | 22 | function GetAppVersion: string; 23 | var 24 | FileVerInfo: TFileVersionInfo; 25 | begin 26 | Result := ''; 27 | FileVerInfo:=TFileVersionInfo.Create(nil); 28 | try 29 | try 30 | FileVerInfo.ReadFileInfo; 31 | Result := FileVerInfo.VersionStrings.Values['FileVersion']; 32 | Exit; 33 | except 34 | on E: EResNotFound do 35 | Exit; 36 | end; 37 | finally 38 | FileVerInfo.Free; 39 | end; 40 | end; 41 | 42 | end. 43 | 44 | -------------------------------------------------------------------------------- /usysinfo.pas: -------------------------------------------------------------------------------- 1 | unit usysinfo; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | function GetOsVersionInfo: string; 8 | function GetCurrentDiskFreeSpaceSize: string; 9 | function GetCurrentUserName: string; 10 | 11 | implementation 12 | 13 | uses 14 | Classes 15 | , SysUtils 16 | , strutils 17 | , lelDCConvertEncoding 18 | , LazUTF8 19 | {$IF DEFINED(UNIX)} 20 | , BaseUnix 21 | , users 22 | {$IFDEF DARWIN} 23 | , MacOSAll 24 | {$ENDIF} 25 | {$ENDIF} 26 | {$IFDEF LCLQT} 27 | , qt4 28 | {$ENDIF} 29 | {$IFDEF LCLQT5} 30 | , qt5 31 | {$ENDIF} 32 | {$IFDEF LCLGTK2} 33 | , gtk2 34 | {$ENDIF} 35 | {$IFDEF WINDOWS} 36 | , Windows 37 | , JwaNative 38 | , JwaNtStatus 39 | , JwaWinType 40 | , lelDCWindows 41 | {$ENDIF} 42 | 43 | ; 44 | 45 | {$IF DEFINED(WINDOWS)} 46 | const 47 | AccessModes: array[0..2] of DWORD = ( 48 | GENERIC_READ, 49 | GENERIC_WRITE, 50 | GENERIC_READ or GENERIC_WRITE); 51 | ShareModes: array[0..4] of DWORD = ( 52 | 0, 53 | 0, 54 | FILE_SHARE_READ, 55 | FILE_SHARE_WRITE, 56 | FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE); 57 | OpenFlags: array[0..3] of DWORD = ( 58 | 0, 59 | FILE_FLAG_WRITE_THROUGH, 60 | FILE_FLAG_NO_BUFFERING, 61 | FILE_FLAG_WRITE_THROUGH or FILE_FLAG_NO_BUFFERING); 62 | 63 | var 64 | CurrentDirectory: String; 65 | {$ELSEIF DEFINED(UNIX)} 66 | const 67 | 68 | {$IF NOT DECLARED(O_SYNC)} 69 | O_SYNC = 0; 70 | {$ENDIF} 71 | 72 | {$IF NOT DECLARED(O_DIRECT)} 73 | O_DIRECT = 0; 74 | {$ENDIF} 75 | 76 | AccessModes: array[0..2] of cInt = ( 77 | O_RdOnly, 78 | O_WrOnly, 79 | O_RdWr); 80 | OpenFlags: array[0..3] of cInt = ( 81 | 0, 82 | O_SYNC, 83 | O_DIRECT, 84 | O_SYNC or O_DIRECT); 85 | {$ENDIF} 86 | 87 | // from https://sourceforge.net/p/doublecmd/code/HEAD/tree/trunk/src/platform/udcversion.pas 88 | function mbFileAccess(const FileName: String; Mode: Word): Boolean; 89 | {$IFDEF WINDOWS} 90 | const 91 | AccessMode: array[0..2] of DWORD = ( 92 | GENERIC_READ, 93 | GENERIC_WRITE, 94 | GENERIC_READ or GENERIC_WRITE); 95 | var 96 | hFile: System.THandle; 97 | dwDesiredAccess: DWORD; 98 | dwShareMode: DWORD = 0; 99 | begin 100 | dwDesiredAccess := AccessMode[Mode and 3]; 101 | if Mode = fmOpenRead then // If checking Read mode no sharing mode given 102 | Mode := Mode or fmShareDenyNone; 103 | dwShareMode := ShareModes[(Mode and $F0) shr 4]; 104 | hFile:= CreateFileW(PWideChar(UTF16LongName(FileName)), dwDesiredAccess, dwShareMode, 105 | nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0); 106 | Result := hFile <> INVALID_HANDLE_VALUE; 107 | if Result then 108 | FileClose(hFile); 109 | end; 110 | {$ELSE} 111 | const 112 | AccessMode: array[0..2] of LongInt = ( 113 | R_OK, 114 | W_OK, 115 | R_OK or W_OK); 116 | begin 117 | Result:= fpAccess(CeUtf8ToSys(FileName), AccessMode[Mode and 3]) = 0; 118 | end; 119 | {$ENDIF} 120 | 121 | // from https://sourceforge.net/p/doublecmd/code/HEAD/tree/trunk/src/platform/udcversion.pas 122 | {$IF DEFINED(UNIX)} 123 | {en 124 | Reads file into strings. 125 | Returns @false if file not found or cannot be read. 126 | } 127 | function GetStringsFromFile(FileName: String; out sl: TStringList): Boolean; 128 | begin 129 | Result := False; 130 | sl := nil; 131 | if mbFileAccess(FileName, fmOpenRead) then 132 | begin 133 | sl := TStringList.Create; 134 | try 135 | sl.LoadFromFile(FileName); 136 | Result := True; 137 | except 138 | on EFilerError do 139 | Exit; // Bypass 140 | end; 141 | end; 142 | end; 143 | 144 | {en 145 | Reads first line of file into a string. 146 | Returns @false if file not found or cannot be read. 147 | } 148 | function GetStringFromFile(FileName: String; out str: String): Boolean; 149 | var 150 | sl: TStringList; 151 | begin 152 | str := EmptyStr; 153 | Result := GetStringsFromFile(FileName, sl); 154 | if Result then 155 | try 156 | if sl.Count > 0 then 157 | str := sl.Strings[0]; 158 | finally 159 | sl.Free; 160 | end; 161 | end; 162 | 163 | function GetOsFromLsbRelease: String; 164 | function TrimQuotes(const Str: String): String; 165 | begin 166 | Result:= TrimSet(Str, ['"', '''']); 167 | end; 168 | var 169 | sl: TStringList; 170 | begin 171 | Result := EmptyStr; 172 | 173 | if GetStringsFromFile('/etc/lsb-release', sl) then 174 | try 175 | if sl.Count > 0 then 176 | begin 177 | Result := sl.Values['DISTRIB_DESCRIPTION']; 178 | 179 | if Result <> EmptyStr then 180 | Result := TrimQuotes(Result) 181 | else 182 | Result := sl.Values['DISTRIB_ID'] + 183 | sl.Values['DISTRIB_RELEASE'] + 184 | sl.Values['DISTRIB_CODENAME']; 185 | end; 186 | finally 187 | sl.Free; 188 | end; 189 | end; 190 | 191 | function GetOsFromProcVersion: String; 192 | var 193 | i: Integer; 194 | s: String; 195 | begin 196 | Result := EmptyStr; 197 | 198 | if GetStringFromFile('/proc/version', s) then 199 | begin 200 | // Get first three strings separated by space. 201 | 202 | i := Pos(' ', s); 203 | if i > 0 then 204 | Result := Result + Copy(s, 1, i); 205 | Delete(s, 1, i); 206 | 207 | i := Pos(' ', s); 208 | if i > 0 then 209 | Result := Result + Copy(s, 1, i); 210 | Delete(s, 1, i); 211 | 212 | i := Pos(' ', s); 213 | if i > 0 then 214 | Result := Result + Copy(s, 1, i - 1); 215 | Delete(s, 1, i); 216 | end; 217 | end; 218 | 219 | function GetOsFromIssue: String; 220 | begin 221 | if not GetStringFromFile('/etc/issue', Result) then 222 | Result := EmptyStr; 223 | end; 224 | 225 | function GetDebianVersion: String; 226 | var 227 | s: String; 228 | begin 229 | if GetStringFromFile('/etc/debian_version', s) then 230 | begin 231 | Result := 'Debian'; 232 | if s <> EmptyStr then 233 | Result := Result + ' ' + s; 234 | end 235 | else 236 | Result := EmptyStr; 237 | end; 238 | 239 | function GetSuseVersion: String; 240 | begin 241 | if GetStringFromFile('/etc/SuSE-release', Result) or 242 | GetStringFromFile('/etc/suse-release', Result) then 243 | begin 244 | if Result = EmptyStr then 245 | Result := 'Suse'; 246 | end 247 | else 248 | Result := EmptyStr; 249 | end; 250 | 251 | function GetRedHatVersion: String; 252 | begin 253 | if GetStringFromFile('/etc/redhat-release', Result) then 254 | begin 255 | if Result = EmptyStr then 256 | Result := 'RedHat'; 257 | end 258 | else 259 | Result := EmptyStr; 260 | end; 261 | 262 | function GetMandrakeVersion: String; 263 | begin 264 | if GetStringFromFile('/etc/mandrake-release', Result) then 265 | begin 266 | if Result = EmptyStr then 267 | Result := 'Mandrake'; 268 | end 269 | else 270 | Result := EmptyStr; 271 | end; 272 | 273 | function GetVersionNumber: String; 274 | var 275 | Info: utsname; 276 | I: Integer = 1; 277 | begin 278 | FillChar(Info, SizeOf(Info), 0); 279 | fpUname(Info); 280 | Result := Info.release; 281 | while (I <= Length(Result)) and (Result[I] in ['0'..'9', '.']) do 282 | Inc(I); 283 | Result := Copy(Result, 1, I - 1); 284 | end; 285 | 286 | {$IFDEF DARWIN} 287 | function GetMacOSXVersion: String; 288 | var 289 | versionMajor, 290 | versionMinor, versionBugFix: SInt32; 291 | begin 292 | Result:= EmptyStr; 293 | if (Gestalt(gestaltSystemVersionMajor, versionMajor) <> noErr) then Exit; 294 | if (Gestalt(gestaltSystemVersionMinor, versionMinor) <> noErr) then Exit; 295 | if (Gestalt(gestaltSystemVersionBugFix, versionBugFix) <> noErr) then Exit; 296 | Result:= Format('Mac OS X %d.%d.%d', [versionMajor, versionMinor, versionBugFix]); 297 | end; 298 | {$ENDIF} 299 | 300 | {$ENDIF} 301 | 302 | {$IF DEFINED(WINDOWS)} 303 | procedure TryGetNativeSystemInfo(var SystemInfo: TSystemInfo); 304 | type 305 | TGetNativeSystemInfo = procedure (var lpSystemInfo: TSystemInfo); stdcall; 306 | var 307 | hLib: HANDLE; 308 | GetNativeSystemInfoProc: TGetNativeSystemInfo; 309 | begin 310 | hLib := LoadLibrary(LPCTSTR('kernel32.dll')); 311 | if hLib <> 0 then 312 | begin 313 | try 314 | GetNativeSystemInfoProc := TGetNativeSystemInfo(GetProcAddress(hLib, 'GetNativeSystemInfo')); 315 | if Assigned(GetNativeSystemInfoProc) then 316 | GetNativeSystemInfoProc(SystemInfo) 317 | else 318 | GetSystemInfo(SystemInfo); 319 | finally 320 | FreeLibrary(hLib); 321 | end; 322 | end 323 | else 324 | GetSystemInfo(SystemInfo); 325 | end; 326 | {$ENDIF} 327 | 328 | function GetOsVersionInfo: string; 329 | {$IF DEFINED(WINDOWS)} 330 | const 331 | PROCESSOR_ARCHITECTURE_AMD64 = 9; 332 | var 333 | si: SYSTEM_INFO; 334 | osvi: TOsVersionInfoExW; 335 | {$ENDIF} 336 | begin 337 | {$IF DEFINED(WINDOWS)} 338 | Result := 'Windows'; 339 | 340 | ZeroMemory(@osvi, SizeOf(TOsVersionInfoExW)); 341 | osvi.dwOSVersionInfoSize := SizeOf(TOsVersionInfoExW); 342 | 343 | if (RtlGetVersion(@osvi) = STATUS_SUCCESS) or GetVersionExW(@osvi) then 344 | begin 345 | ZeroMemory(@si, SizeOf(si)); 346 | TryGetNativeSystemInfo(si); 347 | 348 | case osvi.dwPlatformId of 349 | VER_PLATFORM_WIN32_WINDOWS: 350 | case osvi.dwMajorVersion of 351 | 4: case osvi.dwMinorVersion of 352 | 0: Result := Result + ' 95'; 353 | 10: Result := Result + ' 98'; 354 | 90: Result := Result + ' ME'; 355 | end; 356 | end; 357 | 358 | VER_PLATFORM_WIN32_NT: 359 | begin 360 | case osvi.dwMajorVersion of 361 | 3: Result := Result + ' NT 3.5'; 362 | 4: Result := Result + ' NT 4'; 363 | 5: case osvi.dwMinorVersion of 364 | 0: Result := Result + ' 2000'; 365 | 1: begin 366 | Result := Result + ' XP'; 367 | if osvi.wSuiteMask = $0000 then 368 | Result := Result + ' Home' 369 | else if osvi.wSuiteMask = $0200 then 370 | Result := Result + ' Professional'; 371 | end; 372 | 2: if (osvi.wProductType = VER_NT_WORKSTATION) and 373 | (si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64) then 374 | begin 375 | Result := Result + ' XP Professional x64' 376 | end 377 | else if (osvi.wProductType = VER_NT_SERVER) then 378 | begin 379 | if osvi.wSuiteMask = $8000 then 380 | Result := Result + ' Home Server' 381 | else 382 | Result := Result + ' Server 2003'; 383 | end; 384 | end; 385 | 6: case osvi.dwMinorVersion of 386 | 0: if (osvi.wProductType = VER_NT_WORKSTATION) then 387 | begin 388 | Result := Result + ' Vista'; 389 | if osvi.wSuiteMask = $0000 then 390 | Result := Result + ' Ultimate' 391 | else if osvi.wSuiteMask = $0200 then 392 | Result := Result + ' Home'; 393 | end 394 | else if (osvi.wProductType = VER_NT_SERVER) then 395 | Result := Result + ' Server 2008'; 396 | 1: if (osvi.wProductType = VER_NT_WORKSTATION) then 397 | Result := Result + ' 7' 398 | else if (osvi.wProductType = VER_NT_SERVER) then 399 | Result := Result + ' Server 2008 R2'; 400 | 2: if (osvi.wProductType = VER_NT_WORKSTATION) then 401 | Result := Result + ' 8' 402 | else if (osvi.wProductType = VER_NT_SERVER) then 403 | Result := Result + ' Server 2012'; 404 | 3: if (osvi.wProductType = VER_NT_WORKSTATION) then 405 | Result := Result + ' 8.1' 406 | else if (osvi.wProductType = VER_NT_SERVER) then 407 | Result := Result + ' Server 2012 R2'; 408 | end; 409 | 10: case osvi.dwMinorVersion of 410 | 0: if (osvi.wProductType = VER_NT_WORKSTATION) then 411 | begin 412 | Result := Result + ' 10'; 413 | if (osvi.wSuiteMask and VER_SUITE_PERSONAL <> 0) then 414 | Result := Result + ' Home'; 415 | end 416 | end; 417 | end; 418 | end; 419 | end; 420 | 421 | // If something detected then add service pack number and architecture. 422 | if Result <> 'Windows' then 423 | begin 424 | if osvi.wServicePackMajor > 0 then 425 | begin 426 | Result := Result + ' SP' + IntToStr(osvi.wServicePackMajor); 427 | if osvi.wServicePackMinor > 0 then 428 | Result := Result + '.' + IntToStr(osvi.wServicePackMinor); 429 | end; 430 | 431 | if si.wProcessorArchitecture in [PROCESSOR_ARCHITECTURE_AMD64] then 432 | Result := Result + ' x86_64' 433 | else 434 | Result := Result + ' i386'; 435 | end 436 | else 437 | Result := Result + ' Build ' + IntToStr(osvi.dwBuildNumber); 438 | end; 439 | {$ELSEIF DEFINED(UNIX)} 440 | // Try using linux standard base. 441 | Result := GetOsFromLsbRelease; 442 | 443 | // Try some distribution-specific files. 444 | if Result = EmptyStr then 445 | Result := GetDebianVersion; 446 | if Result = EmptyStr then 447 | Result := GetRedHatVersion; 448 | if Result = EmptyStr then 449 | Result := GetSuseVersion; 450 | if Result = EmptyStr then 451 | Result := GetMandrakeVersion; 452 | 453 | {$IFDEF DARWIN} 454 | if Result = EmptyStr then 455 | Result := GetMacOSXVersion; 456 | {$ENDIF} 457 | 458 | // Other methods. 459 | if Result = EmptyStr then 460 | Result := GetOsFromIssue; 461 | if Result = EmptyStr then 462 | Result := GetOsFromProcVersion; 463 | 464 | // Set default names. 465 | if Result = EmptyStr then 466 | begin 467 | {$IF DEFINED(LINUX)} 468 | Result := 'Linux'; 469 | {$ELSEIF DEFINED(DARWIN)} 470 | Result := 'Darwin'; // MacOS 471 | {$ELSEIF DEFINED(FREEBSD)} 472 | Result := 'FreeBSD'; 473 | {$ELSEIF DEFINED(BSD)} 474 | Result := 'BSD'; 475 | {$ELSE} 476 | Result := 'Unix'; 477 | {$ENDIF} 478 | Result += ' ' + GetVersionNumber; 479 | end; 480 | {$ENDIF} 481 | end; 482 | 483 | function GetCurrentDiskFreeSpaceSize: string; 484 | const 485 | GB = 1024 * 1024 * 1024; 486 | begin 487 | Result := Format('%d GB',[DiskFree(0) div GB]); 488 | end; 489 | 490 | // from http://forum.lazarus.freepascal.org/index.php/topic,23171.msg138057.html#msg138057 491 | function GetCurrentUserName: string; 492 | {$IFDEF WINDOWS} 493 | const 494 | MaxLen = 256; 495 | var 496 | Len: DWORD; 497 | WS: WideString; 498 | Res: windows.BOOL; 499 | {$ENDIF} 500 | begin 501 | Result := ''; 502 | {$IFDEF UNIX} 503 | {$IF (DEFINED(LINUX)) OR (DEFINED(FREEBSD))} 504 | //GetUsername in unit Users, fpgetuid in unit BaseUnix 505 | Result := SysToUtf8(GetUserName(fpgetuid)); 506 | {$ELSE Linux/BSD} 507 | Result := GetEnvironmentVariableUtf8('USER'); 508 | {$ENDIF UNIX} 509 | {$ELSE} 510 | {$IFDEF WINDOWS} 511 | Len := MaxLen; 512 | {$IFnDEF WINCE} 513 | if Win32MajorVersion <= 4 then 514 | begin 515 | SetLength(Result,MaxLen); 516 | Res := Windows.GetuserName(@Result[1], Len); 517 | if Res then 518 | begin 519 | SetLength(Result,Len-1); 520 | Result := SysToUtf8(Result); 521 | end 522 | else SetLength(Result,0); 523 | end 524 | else 525 | {$ENDIF NOT WINCE} 526 | begin 527 | SetLength(WS, MaxLen-1); 528 | Res := Windows.GetUserNameW(@WS[1], Len); 529 | if Res then 530 | begin 531 | SetLength(WS, Len - 1); 532 | Result := Utf16ToUtf8(WS); 533 | end 534 | else SetLength(Result,0); 535 | end; 536 | {$ENDIF WINDOWS} 537 | {$ENDIF UNIX} 538 | end; 539 | 540 | end. 541 | 542 | --------------------------------------------------------------------------------