pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity

Global clean:

Browse Source 
* Refactoring
* Code formating
- Removed many old defines...

git-svn-id: https://svn.code.sf.net/p/kolmck/code@162 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
2017-08-15 04:00:14 +00:00
parent 9b54772921
commit 8eb8ee907d
6 changed files with 984 additions and 2497 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2425
KOL.pas
View File

File diff suppressed because it is too large Load Diff

6
KOLDEF.inc
View File

@@ -130,7 +130,6 @@
{$DEFINE PAS_VERSION}
{$DEFINE PAS_ONLY}
{.$DEFINE UNICODE_CTRLS}
{$DEFINE STREAM_LARGE64}
{$ENDIF}
{$WARN UNIT_DEPRECATED OFF}
{.$WARN SYMBOL_PLATFORM OFF}
@@ -155,7 +154,6 @@
{$DEFINE PAS_VERSION}
{$DEFINE PAS_ONLY}
{.$DEFINE UNICODE_CTRLS}
{$DEFINE STREAM_LARGE64}
{$ENDIF}
{$WARN UNIT_DEPRECATED OFF}
{.$WARN SYMBOL_PLATFORM OFF}
@@ -181,7 +179,6 @@
{$DEFINE PAS_VERSION}
{$DEFINE PAS_ONLY}
{.$DEFINE UNICODE_CTRLS}
{$DEFINE STREAM_LARGE64}
{$ENDIF}
{$WARN UNIT_DEPRECATED OFF}
{.$WARN SYMBOL_PLATFORM OFF}
@@ -209,7 +206,6 @@
{$DEFINE PAS_VERSION}
{$DEFINE PAS_ONLY}
{.$DEFINE UNICODE_CTRLS}
{$DEFINE STREAM_LARGE64}
{$ENDIF}
{$WARN UNIT_DEPRECATED OFF}
{.$WARN SYMBOL_PLATFORM OFF}
@@ -238,7 +234,6 @@
{$DEFINE PAS_VERSION}
{$DEFINE PAS_ONLY}
{.$DEFINE UNICODE_CTRLS}
{$DEFINE STREAM_LARGE64}
{$ENDIF}
{$WARN UNIT_DEPRECATED OFF}
{.$WARN SYMBOL_PLATFORM OFF}
@@ -268,7 +263,6 @@
{$DEFINE PAS_VERSION}
{$DEFINE PAS_ONLY}
{.$DEFINE UNICODE_CTRLS}
{$DEFINE STREAM_LARGE64}
{$ENDIF}
{$WARN UNIT_DEPRECATED OFF}
{.$WARN SYMBOL_PLATFORM OFF}

188
KOL_ASM.inc
View File

@@ -9765,43 +9765,27 @@ end;
destructor TStrList.Destroy;
asm
PUSH EAX
CALL Clear
POP EAX
CALL TObj.Destroy
PUSH EAX
CALL Clear
POP EAX
CALL TObj.Destroy
end;
function TStrList.Add(const S: Ansistring): integer;
asm
MOV ECX, EDX
MOV EDX, [EAX].fCount
PUSH EDX
CALL Insert
POP EAX
MOV ECX, EDX
MOV EDX, [EAX].fCount
PUSH EDX
CALL Insert
POP EAX
end;
//dufa
//procedure TStrList.AddStrings(Strings: PStrList);
//asm
// PUSH EAX
// XCHG EAX, EDX
// PUSH 0
// MOV EDX, ESP
// CALL GetTextStr
// POP EDX
// POP EAX
// MOV CL, 1
// PUSH EDX
// CALL SetText
// CALL RemoveStr
//end;
procedure TStrList.Assign(Strings: PStrList);
asm
PUSHAD
CALL Clear
POPAD
JMP AddStrings
PUSHAD
CALL Clear
POPAD
JMP AddStrings
end;
procedure TStrList.Clear;
@@ -9913,6 +9897,55 @@ asm
JMP Delete
end;
(* bugged dufa
procedure TStrList.AddStrings(Strings: PStrList);
asm
PUSH EAX
XCHG EAX, EDX
PUSH 0
MOV EDX, ESP
CALL GetTextStr
POP EDX
POP EAX
MOV CL, 1
PUSH EDX
CALL SetText
CALL RemoveStr
end;
procedure TStrList.MergeFromFile(const FileName: KOLString);
asm
PUSH EAX
XCHG EAX, EDX
CALL NewReadFileStream
XCHG EDX, EAX
POP EAX
MOV CL, 1
PUSH EDX
CALL LoadFromStream
POP EAX
JMP TObj.RefDec
end;
procedure TStrList.SaveToStream(Stream: PStream);
asm
PUSH EDX
PUSH 0
MOV EDX, ESP
CALL GetTextStr
POP EAX
PUSH EAX
CALL System.@LStrLen
XCHG ECX, EAX
POP EDX
POP EAX
PUSH EDX
JECXZ @@1
CALL TStream.Write
@@1:
CALL RemoveStr
end;*)
procedure LowerCaseStrFromPCharEDX;
asm
{ <- EDX = PChar string
@@ -9974,40 +10007,6 @@ asm
@@exit:
end;
{// bugged.dufa
procedure TStrList.MergeFromFile(const FileName: KOLString);
asm
PUSH EAX
XCHG EAX, EDX
CALL NewReadFileStream
XCHG EDX, EAX
POP EAX
MOV CL, 1
PUSH EDX
CALL LoadFromStream
POP EAX
JMP TObj.RefDec
end;}
procedure TStrList.SaveToStream(Stream: PStream);
asm
PUSH EDX
PUSH 0
MOV EDX, ESP
CALL GetTextStr
POP EAX
PUSH EAX
CALL System.@LStrLen
XCHG ECX, EAX
POP EDX
POP EAX
PUSH EDX
JECXZ @@1
CALL TStream.Write
@@1:
CALL RemoveStr
end;
procedure SortData( const Data: Pointer; const uNElem: Dword;
const CompareFun: TCompareEvent;
const SwapProc: TSwapEvent );
@@ -12948,68 +12947,6 @@ asm
CALL TObj.RefDec
end;
{$IFDEF USE_OLDCONVERT2MASK}
procedure TBitmap.Convert2Mask(TranspColor: TColor);
asm
PUSH EBX
PUSH ESI
MOV EBX, EAX
MOV ESI, EDX
CALL GetHandle
TEST EAX, EAX
JZ @@exit
PUSH 0
PUSH 1
PUSH 1
PUSH [EBX].fHeight
PUSH [EBX].fWidth
CALL CreateBitmap
PUSH EAX // MonoHandle
PUSH 0
CALL CreateCompatibleDC
POP EDX
PUSH EDX
PUSH EAX // MonoDC
PUSH EDX
PUSH EAX
CALL SelectObject
PUSH EAX // SaveMono
CALL StartDC // DCfrom, SaveFrom
XCHG EAX, ESI
CALL Color2RGB
PUSH EAX // Color2RGB(TranspColor)
PUSH dword ptr [ESP+8] //DCfrom
CALL Windows.SetBkColor
PUSH EAX // SaveBkColor
PUSH SRCCOPY
PUSH 0
PUSH 0
PUSH dword ptr [ESP+12+4+4] //DCfrom
PUSH [EBX].fHeight
PUSH [EBX].fWidth
PUSH 0
PUSH 0
PUSH dword ptr [ESP+32+16] //MonoDC
CALL BitBlt
PUSH dword ptr [ESP+8] //DCfrom
CALL Windows.SetBkColor // ESP-> SaveFrom
CALL FinishDC // ESP-> SaveMono
CALL FinishDC // ESP-> MonoHandle
MOV EAX, EBX
CALL ClearData
POP [EBX].fHandle
MOV [EBX].fHandleType, bmDDB
@@exit:
POP ESI
POP EBX
end;
{$ELSE USE_OLDCONVERT2MASK} //Pascal
procedure TBitmap.Convert2Mask(TranspColor: TColor);
asm
PUSH EBX
@@ -13248,7 +13185,6 @@ asm
POP ESI
POP EBX
end;
{$ENDIF USE_OLDCONVERT2MASK} //Pascal
procedure _PrepareBmp2Rotate;
const szBIH = sizeof(TBitmapInfoHeader);

18
KOL_ASM_NOUNICODE.inc
View File

@@ -3317,7 +3317,6 @@ asm
{$ENDIF}
JECXZ @@exit
{$IFNDEF NOT_FIX_CURINDEX}
PUSH ESI
PUSH EBP
@@ -3352,19 +3351,6 @@ asm
POP EBP
POP ESI
{$ELSE NOT_FIX_CURINDEX}
PUSH EDX
MOV EDX, EDI
MOV EAX, EBX
CALL Delete
XCHG EAX, EBX
XCHG EDX, EDI
POP ECX
CALL Insert
{$ENDIF NOT_FIX_CURINDEX}
@@exit:
POP EBX
@@ -3653,6 +3639,7 @@ asm
@@exit:
end;
(* bugged?! dufa
function TStrList.AppendToFile(const FileName: Ansistring): Boolean;
asm
PUSH EBX
@@ -3728,7 +3715,6 @@ asm
@@exit: POP EDX
end;
{ maybebugged.dufa
function TStrList.SaveToFile(const FileName: Ansistring): Boolean;
asm
PUSH EBX
@@ -3762,7 +3748,7 @@ asm
@@exit:
POP EDX
POP EBX
end;}
end; *)
procedure TControl.SetStatusText(Index: Integer; const Value: KOLString);
asm

543
KOL_Linux.inc
View File

@@ -1,543 +0,0 @@
{$IFDEF global_declare}
type DWORD = LongWord;
PDWORD = ^DWORD;
PPoint = ^TPoint;
TPoint = packed record
X: Longint;
Y: Longint;
end;
PRect = ^TRect;
TRect = packed record
case Integer of
0: (Left, Top, Right, Bottom: Longint);
1: (TopLeft, BottomRight: TPoint);
end;
const
INVALID_HANDLE_VALUE = Cardinal(-1);
MAX_PATH = 4095; // From /usr/include/linux/limits.h PATH_MAX
const
{ File attribute constants }
FILE_ATTRIBUTE_READONLY = $00000001;
FILE_ATTRIBUTE_HIDDEN = $00000002;
FILE_ATTRIBUTE_SYSTEM = $00000004;
FILE_ATTRIBUTE_VOLUME = $00000008;
FILE_ATTRIBUTE_DIRECTORY = $00000010;
FILE_ATTRIBUTE_ARCHIVE = $00000020;
FILE_ATTRIBUTE_SYMLINK = $00000040;
FILE_ATTRIBUTE_ANYFILE = $0000003F;
FILE_ATTRIBUTE_NORMAL = FILE_ATTRIBUTE_ARCHIVE;
type
TFilename = type string;
PFileTime = ^TFileTime;
TFileTime = __time_t;
PFindFileData = ^TFindFileData;
TFindFileData = packed record
// from TWin32FindData: -------------
dwFileAttributes: DWORD;
ftCreationTime: TFileTime;
ftLastAccessTime: TFileTime;
ftLastWriteTime: TFileTime;
nFileSizeHigh: DWORD;
nFileSizeLow: DWORD;
//dwReserved0: DWORD;
//dwReserved1: DWORD;
cFileName: array[0..MAX_PATH - 1] of Char;
//cAlternateFileName: array[0..13] of KOLChar; - no in Linux
//-------- + handle:
FindHandle: Pointer;
ExcludeAttr: Integer;
Mode: mode_t;
PathOnly: String;
Pattern: String;
end;
const
ExeBaseAddress = Pointer($8048000); // Kylix only?
function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer;
function DeleteFile(lpFileName: PChar): Boolean;
{$ENDIF global_declare}
{$IFDEF implementation}
//------------------ Unicode strings
function WAnsiUpperCase(const S: WideString): WideString;
var
I: Integer;
P: PWideChar;
begin
SetLength(Result, Length(S));
P := @Result[1];
for I := 1 to Length(S) do
P[I-1] := WideChar(towupper(UCS4Char(S[I])));
end;
function WAnsiLowerCase(const S: WideString): WideString;
var
I: Integer;
P: PWideChar;
begin
SetLength(Result, Length(S));
P := @Result[1];
for I := 1 to Length(S) do
P[I-1] := WideChar(towlower(UCS4Char(S[I])));
end;
//------------------ Ansi strings
function AnsiUpperCase(const S: string): string;
begin
Result := WAnsiUpperCase( S );
end;
function AnsiLowerCase(const S: string): string;
begin
Result := WAnsiLowerCase( S );
end;
function AnsiCompareStr(const S1, S2: string): Integer;
begin
// glibc 2.1.2 / 2.1.3 implementations of strcoll() and strxfrm()
// have severe capacity limits. Comparing two 100k strings may
// exhaust the stack and kill the process.
// Fixed in glibc 2.1.91 and later.
Result := strcoll(PChar(S1), PChar(S2));
end;
function _AnsiCompareStr(S1, S2: PChar): Integer;
begin
// glibc 2.1.2 / 2.1.3 implementations of strcoll() and strxfrm()
// have severe capacity limits. Comparing two 100k strings may
// exhaust the stack and kill the process.
// Fixed in glibc 2.1.91 and later.
Result := strcoll(S1, S2);
end;
function AnsiCompareStrNoCase(const S1, S2: string): Integer;
begin
// glibc 2.1.2 / 2.1.3 implementations of strcoll() and strxfrm()
// have severe capacity limits. Comparing two 100k strings may
// exhaust the stack and kill the process.
// Fixed in glibc 2.1.91 and later.
Result := AnsiCompareStr( AnsiUpperCase( S1 ), AnsiUpperCase( S2 ) );
end;
function _AnsiCompareStrNoCase(S1, S2: PChar): Integer;
begin
// glibc 2.1.2 / 2.1.3 implementations of strcoll() and strxfrm()
// have severe capacity limits. Comparing two 100k strings may
// exhaust the stack and kill the process.
// Fixed in glibc 2.1.91 and later.
Result := AnsiCompareStrNoCase( S1, S2 );
end;
//--------------- File functions
function FileCreate(const FileName: string; OpenFlags: DWord): THandle;
begin
Result := open64( PChar( FileName ), OpenFlags );
end;
function FileClose(Handle: THandle): boolean;
begin
Result := FALSE;
if Handle = INVALID_HANDLE_VALUE then Exit;
__close( Handle );
Result := TRUE;
end;
function FileExists( const FileName : String ) : Boolean;
var st: TStatBuf;
begin
Result := FALSE;
if stat(PChar(FileName), st) = 0 then
Result := st.st_mtime <> -1;
end;
function FileSeek( Handle: THandle; MoveTo: integer; MoveMethod: TMoveMethod): DWord;
var Temp: Int64;
begin
Temp := MoveTo;
Result := lseek64(Handle, Temp, Integer( MoveMethod ));
end;
function FileFarSeek(Handle: THandle; MoveTo: Int64; MoveMethod: TMoveMethod): DWord;
var Temp: Int64;
begin
Temp := MoveTo;
Result := lseek64(Handle, Temp, Integer( MoveMethod ));
end;
function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;
begin
Result := __read(Handle, Buffer, Count);
end;
function GetFileSize( Handle: THandle; HiSize: PDWORD ): DWORD;
var Pos: Int64;
Len: Int64;
begin
Pos := FileSeek( Handle, 0, spCurrent );
Len := FileSeek( Handle, 0, spEnd );
FileSeek( Handle, Pos, spBegin );
Result := I64( Len ).Lo;
if HiSize <> nil then HiSize^ := I64( Len ).Hi;
end;
function FileWrite( Handle: THandle; const Buffer; Count: DWord): DWord;
begin
Result := __write(Handle, Buffer, Count);
end;
// the only way for a file name to be not complete in Unix:
// it is located in current working directory (CWD) ??????
function FileFullPath( const FileName: String ) : String;
var wd: String;
buffer: array[ 0.._POSIX_PATH_MAX+1 ] of Char;
begin
Result := FileName;
wd := '';
if getwd( buffer ) <> nil then
wd := buffer;
if StrIsStartingFrom( PChar( FileName ), PChar( wd ) ) then Exit;
Result := IncludeTrailingPathDelimiter( wd ) + Filename;
if not FileExists( Result ) then Result := FileName;
end;
function Find_Next(var F: TFindFileData): Boolean;
var
PtrDirEnt: PDirEnt;
Scratch: TDirEnt;
StatBuf: TStatBuf;
LinkStatBuf: TStatBuf;
FName: string;
Attr: Integer;
Mode: mode_t;
Sz: Int64;
begin
Result := FALSE;
PtrDirEnt := nil;
if readdir_r(F.FindHandle, @Scratch, PtrDirEnt) <> 0 then
Exit;
while PtrDirEnt <> nil do
begin
if fnmatch(PChar(F.Pattern), PtrDirEnt.d_name, 0) = 0 then
begin // F.PathOnly must include trailing backslash
FName := F.PathOnly + string(PtrDirEnt.d_name);
if lstat(PChar(FName), StatBuf) = 0 then
begin
Attr := 0;
Mode := StatBuf.st_mode;
if S_ISDIR(Mode) then
Attr := Attr or FILE_ATTRIBUTE_DIRECTORY
else
if not S_ISREG(Mode) then // directories shouldn't be treated as system files
begin
if S_ISLNK(Mode) then
begin
Attr := Attr or FILE_ATTRIBUTE_SYMLINK;
if (stat(PChar(FName), LinkStatBuf) = 0) and
S_ISDIR(LinkStatBuf.st_mode) then
Attr := Attr or FILE_ATTRIBUTE_DIRECTORY
end;
Attr := Attr or FILE_ATTRIBUTE_SYSTEM;
end;
if (PtrDirEnt.d_name[0] = '.') and (PtrDirEnt.d_name[1] <> #0) then
begin
if not ((PtrDirEnt.d_name[1] = '.') and (PtrDirEnt.d_name[2] = #0)) then
Attr := Attr or FILE_ATTRIBUTE_HIDDEN;
end;
if euidaccess(PChar(FName), W_OK) <> 0 then
Attr := Attr or FILE_ATTRIBUTE_READONLY;
if Attr and F.ExcludeAttr = 0 then
begin
Sz := StatBuf.st_size;
F.nFileSizeLow := I64(Sz).Lo;
F.nFileSizeHigh := I64(Sz).Hi;
F.dwFileAttributes := Attr;
F.Mode := StatBuf.st_mode;
StrCopy( F.cFileName, PtrDirEnt.d_name );
F.ftCreationTime := StatBuf.st_mtime;
F.ftLastWriteTime := StatBuf.st_mtime;
F.ftLastAccessTime := StatBuf.st_atime;
Result := TRUE;
Break;
end;
end;
end;
Result := FALSE;
if readdir_r(F.FindHandle, @Scratch, PtrDirEnt) <> 0 then
Break;
end // End of While
end;
procedure Find_Close(var F: TFindFileData);
begin
if F.FindHandle <> nil then
begin
closedir(F.FindHandle);
F.FindHandle := nil;
end;
F.PathOnly := ''; // in Kylix this is not done (memory leak bug?)
F.Pattern := '';
end;
function Find_First( const FilePathName: String; var F: TFindFileData ): Boolean;
begin
FillChar( F, Sizeof( F ), 0 );
F.ExcludeAttr := FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_SYSTEM or
FILE_ATTRIBUTE_VOLUME; // or FILE_ATTRIBUTE_DIRECTORY;
F.PathOnly := ExtractFilePath(FilePathName);
F.Pattern := ExtractFileName(FilePathName);
if F.PathOnly = '' then
F.PathOnly := GetWorkDir;
F.FindHandle := opendir(PChar(F.PathOnly));
if F.FindHandle <> nil then
begin
if not Find_Next(F) then
begin
Find_Close(F);
Result := FALSE;
Exit;
end;
end;
Result:= TRUE;
end;
function FileSize( const Path : String ) : Int64;
var F: TFindFileData;
begin
Result := 0;
if Find_First( Path, F ) then
begin
Result := PInt64( @ F.nFileSizeLow )^;
Find_Close( F );
end;
end;
function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;
begin
Result := Sgn( FT1 - FT2 );
end;
function DirectoryExists(const Name: string): Boolean;
var st: TStatBuf;
begin
if stat(PChar(Name), st) = 0 then
Result := S_ISDIR(st.st_mode)
else
Result := False;
end;
function GetWorkDir : string;
var
DirBuf: array[0..MAX_PATH] of Char;
begin
getcwd(DirBuf, sizeof(DirBuf));
Result := string(DirBuf);
end;
//[function GetModuleFileName] // grabbed form Kylix/system.pas
function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer;
var
Addr: Pointer;
Info: TDLInfo;
FoundInModule: HMODULE;
Temp: Integer;
begin
Result := 0;
if BufLen <= 0 then Exit;
if (Module = MainInstance) or (Module = 0) then
begin
// First, try the dlsym approach.
// dladdr fails to return the name of the main executable
// in glibc prior to 2.1.91
{ Look for a dynamic symbol exported from this program.
_DYNAMIC is not required in a main program file.
If the main program is compiled with Delphi, it will always
have a resource section, named @Sysinit@ResSym.
If the main program is not compiled with Delphi, dlsym
will search the global name space, potentially returning
the address of a symbol in some other shared object library
loaded by the program. To guard against that, we check
that the address of the symbol found is within the
main program address range. }
dlerror; // clear error state; dlsym doesn't
Addr := dlsym(Pointer( Module ), '@Sysinit@ResSym');
if (Addr <> nil) and (dlerror = nil)
and (dladdr(Addr, Info) <> 0)
and (Info.{FileName}dli_fname <> nil)
and (Info.{BaseAddress}dli_fbase = ExeBaseAddress) then
begin
Result := StrLen(Info.{FileName}dli_fname);
if Result >= BufLen then Result := BufLen-1;
// dlinfo may not give a full path. Compare to /proc/self/exe,
// take longest result.
Temp := readlink('/proc/self/exe', Buffer, BufLen);
if Temp >= BufLen then Temp := BufLen-1;
if Temp > Result then
Result := Temp
else
Move(Info.{FileName}dli_fname^, Buffer^, Result);
Buffer[Result] := #0;
Exit;
end;
// Try inspecting the /proc/ virtual file system
// to find the program filename in the process info
Result := readlink('/proc/self/exe', Buffer, BufLen);
if Result <> -1 then
begin
if Result >= BufLen then Result := BufLen-1;
Buffer[Result] := #0;
end;
{$IFDEF AllowParamStrModuleName}
{ Using ParamStr(0) to obtain a module name presents a potential
security hole. Resource modules are loaded based upon the filename
of a given module. We use dlopen() to load resource modules, which
means the .init code of the resource module will be executed.
Normally, resource modules contain no code at all - they're just
carriers of resource data.
An unpriviledged user program could launch our trusted,
priviledged program with a bogus parameter list, tricking us
into loading a module that contains malicious code in its
.init section.
Without this ParamStr(0) section, GetModuleFilename cannot be
misdirected by unpriviledged code (unless the system program loader
or the /proc file system or system root directory has been compromised).
Resource modules are always loaded from the same directory as the
given module. Trusted code (programs, packages, and libraries)
should reside in directories that unpriviledged code cannot alter.
If you need GetModuleFilename to have a chance of working on systems
where glibc < 2.1.91 and /proc is not available, and your
program will not run as a priviledged user (or you don't care),
you can define AllowParamStrModuleNames and rebuild the System unit
and baseCLX package. Note that even with ParamStr(0) support
enabled, GetModuleFilename can still fail to find the name of
a module. C'est la Unix. }
if Result = -1 then // couldn't access the /proc filesystem
begin // return less accurate ParamStr(0)
{ ParamStr(0) returns the name of the link used
to launch the app, not the name of the app itself.
Also, if this app was launched by some other program,
there is no guarantee that the launching program has set
up our environment at all. (example: Apache CGI) }
if (ArgValues = nil) or (ArgValues^ = nil) or
(PCharArray(ArgValues^)[0] = nil) then
begin
Result := 0;
Exit;
end;
Result := _strlen(PCharArray(ArgValues^)[0]);
if Result >= BufLen then Result := BufLen-1;
Move(PCharArray(ArgValues^)[0]^, Buffer^, Result);
Buffer[Result] := #0;
end;
{$ENDIF}
end
else
begin
{ For shared object libraries, we can rely on the dlsym technique.
Look for a dynamic symbol in the requested module.
Don't assume the module was compiled with Delphi.
We look for a dynamic symbol with the name _DYNAMIC. This
exists in all ELF shared object libraries that export
or import symbols; If someone has a shared object library that
contains no imports or exports of any kind, this will probably fail.
If dlsym can't find the requested symbol in the given module, it
will search the global namespace and could return the address
of a symbol from some other module that happens to be loaded
into this process. That would be bad, so we double check
that the module handle of the symbol found matches the
module handle we asked about.}
dlerror; // clear error state; dlsym doesn't
Addr := dlsym(Pointer( Module ), '_DYNAMIC');
if (Addr <> nil) and (dlerror = nil)
and (dladdr(Addr, Info) <> 0) then
begin
if Info.{BaseAddress}dli_fbase = ExeBaseAddress then
Info.{FileName}dli_fname := nil;
FoundInModule := HMODULE(dlopen(Info.{FileName}dli_fname, RTLD_LAZY));
if FoundInModule <> 0 then
dlclose(Pointer( FoundInModule ));
if Module = FoundInModule then
begin
if Assigned(Info.{FileName}dli_fname) then
begin
Result := StrLen(Info.{FileName}dli_fname);
if Result >= BufLen then Result := BufLen-1;
Move(Info.{FileName}dli_fname^, Buffer^, Result);
end
else
Result := 0;
Buffer[Result] := #0;
end;
end;
end;
if Result < 0 then Result := 0;
end;
//[END GetModuleFileName]
function CreateTempFile( const DirPath, Prefix: String ): String;
var i: Integer;
begin
i := 0;
REPEAT
Result := DirPath + Prefix + Int2Str( i );
inc( i );
UNTIL not FileExists( Result );
end;
function DeleteFile(lpFileName: PChar): Boolean;
begin
Result := remove( lpFileName ) = 0;
end;
{--- TTimer ---}
(*)
procedure TTimer.SetEnabled(const Value: Boolean);
begin
if FEnabled = Value then Exit;
fEnabled := Value;
if Value then
begin
fTV.it_interval.tv_sec := fInterval div 1000;
fTV.it_interval.tv_usec := (fInterval mod 1000) * 1000;
setitimer( fTimerKind, )
fHandle := SetTimer( {$IFDEF TIMER_APPLETWND} Applet.GetWindowHandle
{$ELSE} TimerOwnerWnd.GetWindowHandle
{$ENDIF}, Integer( @Self ),
fInterval, @TimerProc );
end
else
begin
if fHandle <> 0 then
begin
KillTimer( TimerOwnerWnd.fHandle, fHandle );
fHandle := 0;
end;
end;
end;
(*)
{$ENDIF implementation}

301
KOL_deprecated.inc
View File

@@ -1,301 +0,0 @@
{*******************************************************************************
KOL_deprecated.inc
-- declarations and code deprecated in KOL.pas
********************************************************************************}
{$IFDEF interface_1} ///////////////////////////////////////////////////////////
{$IFNDEF _FPC}
TOnLVDataW = procedure( Sender: PControl; Idx, SubItem: Integer;
var Txt: WideString; var ImgIdx: Integer; var State: DWORD;
var Store: Boolean ) of object;
{* Event type for OnLVDataW event (the same as OnLVData, but for unicode verion
of the control OnLVDataW allows to return WideString text in the event
handler). Used to provide virtual list view control
(i.e. having lvoOwnerData style) with actual data on request. Use parameter
Store as a flag if control should store obtained data by itself or not. }
{$ENDIF _FPC}
{$ENDIF interface_1} ///////////////////////////////////////////////////////////
{$IFDEF interface_2} ///////////////////////////////////////////////////////////
{$IFNDEF _FPC}
protected
fOnLVDataW: TOnLVDataW;
function GetLVColTextW(Idx: Integer): WideString;
procedure SetLVColTextW(Idx: Integer; const Value: WideString);
function LVGetItemTextW(Idx, Col: Integer): WideString;
procedure LVSetItemTextW(Idx, Col: Integer; const Value: WideString);
function TVGetItemTextW(Item: THandle): WideString;
procedure TVSetItemTextW(Item: THandle; const Value: WideString);
procedure SetOnLVDataW(const Value: TOnLVDataW);
public
procedure LVColAddW( const aText: WideString; aalign: TTextAlign; aWidth: Integer );
{* |<#listview>
Adds new column (unicode version). }
procedure LVColInsertW( ColIdx: Integer; const aText: WideString; aAlign: TTextAlign; aWidth: Integer );
{* |<#listview>
Inserts new column at the Idx position (1-based column index). }
property LVColTextW[ Idx: Integer ]: WideString read GetLVColTextW write SetLVColTextW;
{* |<#listview>
Allows to get/change column header text at run time. }
function LVItemAddW( const aText: WideString ): Integer;
{* |<#listview>
Adds an item to the end of list view. Returns an index of the item added. }
function LVItemInsertW( Idx: Integer; const aText: WideString ): Integer;
{* |<#listview>
Inserts an item to Idx position. This method is deprecated, use
TVItemInsert (adding symbol UNICODE_CTRLS to options) }
property LVItemsW[ Idx, Col: Integer ]: WideString read LVGetItemTextW write LVSetItemTextW;
{* |<#listview>
Access to List View item text. }
function LVIndexOfW( const S: WideString ): Integer;
{* Returns first list view item index with caption matching S.
The same as LVSearchForW( S, -1, FALSE ). }
function LVSearchForW( const S: WideString; StartAfter: Integer; Partial: Boolean ): Integer;
{* Searches an item with Caption equal to S (or starting from S, if Partial = TRUE).
Searching is started after an item specified by StartAfter parameter. }
property OnLVDataW: TOnLVDataW read fOnLVDataW write SetOnLVDataW;
{* |<#listview>
The same as OnLVData, but for unicode version of the list view allows
to return WideString text in the event handler. Though for unicode list
view it is still possible to use ordinary event OnLVData, it is
very recommended to use this event istead. }
function TVInsertW( nParent, nAfter: THandle; const Txt: WideString ): THandle;
{* |<#treeview>
Inserts item to a tree view. If nParent is 0 or TVI_ROOT, the item is
inserted at the root of tree view. It is possible to pass following special
values as nAfter parameter:
|<pre>
TVI_FIRST Inserts the item at the beginning of the list.
TVI_LAST Inserts the item at the end of the list.
TVI_SORT Inserts the item into the list in alphabetical order.
|</pre><br>
This version of the method is Unicode. The tree view control should be
set up as unicode control calling Perform( TVM_SETUNICODEFORMAT, 1, 0 ),
and conditional symbol UNICODE_CTRLS must be defined to provide event
handling for such kind of tree view (and other Unicode) controls. }
property TVItemTextW[ Item: THandle ]: WideString read TVGetItemTextW write TVSetItemTextW;
{* |<#treeview>
Text of tree view item. }
function TVItemPathW( Item: THandle; Delimiter: WideChar ): WideString;
{* |<#treeview>
Returns full path from the root item to given item. Path is calculated
as a concatenation of all parent nodes text strings, separated by
given delimiter character. If Item is not specified ( =0 ), path is returned
for Selected item. }
{$ENDIF _FPC}
{$ENDIF interface_2} ///////////////////////////////////////////////////////////
{$IFDEF implementation} ////////////////////////////////////////////////////////
{$IFNDEF _FPC}
//[procedure LVGetItemW]
procedure LVGetItemW( Sender: PControl; Idx, Col: Integer; var LVI: TLVItemW;
TextBuf: PWideChar; TextBufSize: Integer );
begin
LVI.mask := LVIF_STATE or LVIF_PARAM or LVIF_IMAGE;
if Col > 0 then
if not (lvoSubItemImages in Sender.fLVOptions) then
LVI.mask := LVIF_STATE or LVIF_PARAM;
LVI.iItem := Idx;
LVI.iSubItem := Col;
LVI.pszText := TextBuf;
LVI.cchTextMax := TextBufSize;
if TextBufSize <> 0 then
LVI.mask := LVI.mask or LVIF_TEXT;
Sender.Perform( LVM_GETITEMW, 0, Integer( @LVI ) );
end;
//[procedure TControl.LVColAddW]
procedure TControl.LVColAddW(const aText: WideString; aalign: TTextAlign;
aWidth: Integer);
begin
LVColInsertW( fLVColCount, aText, aalign, aWidth );
end;
//[procedure TControl.LVColInsertW]
procedure TControl.LVColInsertW(ColIdx: Integer; const aText: WideString;
aAlign: TTextAlign; aWidth: Integer);
var LVColData: TLVColumnW;
begin
LVColData.mask := LVCF_FMT or LVCF_TEXT;
if ImageListSmall <> nil then
LVColData.mask := LVColData.mask; // or LVCF_IMAGE ;
LVColData.iImage := -1;
LVColData.fmt := Ord( aAlign );
if aWidth < 0 then
begin
aWidth := -aWidth;
LVColData.fmt := LVColData.fmt or LVCFMT_BITMAP_ON_RIGHT;
end;
LVColData.cx := aWidth;
if aWidth > 0 then
LVColData.mask := LVColData.mask or LVCF_WIDTH;
LVColData.pszText := PWideChar( aText );
if Perform( LVM_INSERTCOLUMNW, ColIdx, Integer( @LVColData ) ) >= 0 then
Inc( fLVColCount );
end;
//[function TControl.GetLVColTextW]
function TControl.GetLVColTextW(Idx: Integer): WideString;
var Buf: array[ 0..4095 ] of WideChar;
LC: TLVColumnW;
begin
LC.mask := LVCF_TEXT;
LC.pszText := @ Buf[ 0 ];
LC.cchTextMax := High( Buf ) + 1;
Buf[ 0 ] := #0;
Perform( LVM_GETCOLUMNW, Idx, Integer( @ LC ) );
Result := Buf;
end;
//[procedure TControl.SetLVColTextW]
procedure TControl.SetLVColTextW(Idx: Integer; const Value: WideString);
var LC: TLVColumnW;
begin
FillChar( LC, Sizeof( LC ), 0 );
LC.mask := LVCF_TEXT;
LC.pszText := '';
if Value <> '' then
LC.pszText := @ Value[ 1 ];
Perform( LVM_SETCOLUMNW, Idx, Integer( @ LC ) );
end;
//[function TControl.LVGetItemTextW]
function TControl.LVGetItemTextW(Idx, Col: Integer): WideString;
var LVI: TLVItemW;
TextBuf: PWideChar;
BufSize: DWORD;
begin
BufSize := 0;
TextBuf := nil;
repeat
if TextBuf <> nil then
FreeMem( TextBuf );
BufSize := BufSize * 2 + 100; // to vary in asm version
GetMem( TextBuf, BufSize * 2 );
TextBuf[ 0 ] := #0;
LVGetItemW( @Self, Idx, Col, LVI, TextBuf, BufSize );
until DWORD( WStrLen( TextBuf ) ) < BufSize - 1;
Result := TextBuf;
FreeMem( TextBuf );
end;
//[procedure TControl.LVSetItemTextW]
procedure TControl.LVSetItemTextW(Idx, Col: Integer;
const Value: WideString);
var LVI: TLVItemW;
begin
LVI.iSubItem := Col;
LVI.pszText := PWideChar( Value );
Perform( LVM_SETITEMTEXTW, Idx, Integer( @LVI ) );
end;
//[function TControl.TVGetItemTextW]
function TControl.TVGetItemTextW(Item: THandle): WideString;
var TVI: TTVItemW;
Buffer: array[ 0..4095 ] of WideChar;
begin
TVI.mask := TVIF_HANDLE or TVIF_TEXT;
TVI.hItem := Item;
TVI.pszText := @Buffer[ 0 ];
Buffer[ 0 ] := #0;
TVI.cchTextMax := High( Buffer ) + 1;
Perform( TVM_GETITEMW, 0, Integer( @TVI ) );
Result := Buffer;
end;
//[procedure TControl.TVSetItemTextW]
procedure TControl.TVSetItemTextW(Item: THandle; const Value: WideString);
var TVI: TTVItemW;
begin
TVI.mask := TVIF_HANDLE or TVIF_TEXT;
TVI.hItem := Item;
TVI.pszText := PWideChar( Value );
Perform( TVM_SETITEMW, 0, Integer( @TVI ) );
end;
//[function TControl.TVItemPathW]
function TControl.TVItemPathW(Item: THandle;
Delimiter: WideChar): WideString;
begin
if Item = 0 then
Item := TVSelected;
Result := '';
while Item <> 0 do
begin
if Result <> '' then
Result := Delimiter + Result;
Result := TVItemTextW[ Item ] + Result;
Item := TVItemParent[ Item ];
end;
end;
type
TTVInsertStructW = packed Record
hParent: THandle;
hAfter : THandle;
item: TTVItemW;
end;
TTVInsertStructExW = packed Record
hParent: THandle;
hAfter : THandle;
item: TTVItemExW;
end;
//[function TControl.TVInsertW]
function TControl.TVInsertW(nParent, nAfter: THandle;
const Txt: WideString): THandle;
var TVIns: TTVInsertStructW;
begin
TVIns.hParent := nParent;
TVIns.hAfter := nAfter;
TVIns.item.mask := TVIF_TEXT;
if Txt = '' then TVIns.item.pszText := nil
else TVIns.item.pszText := PWideChar( @ Txt[ 1 ] );
Result := Perform( TVM_INSERTITEMW, 0, Integer( @ TVIns ) );
Invalidate;
end;
//[function TControl.LVItemInsertW]
function TControl.LVItemInsertW(Idx: Integer;
const aText: WideString): Integer;
var LVI: TLVItemW;
begin
LVI.mask := LVIF_TEXT or LVIF_DI_SETITEM;
LVI.iItem := Idx;
LVI.iSubItem := 0;
LVI.pszText := PWideChar( aText );
Result := Perform( LVM_INSERTITEMW, 0, Integer( @LVI ) );
end;
//[function TControl.LVItemAddW]
function TControl.LVItemAddW(const aText: WideString): Integer;
begin
Result := LVItemInsertW( Count, aText );
end;
procedure TControl.SetOnLVDataW(const Value: TOnLVDataW);
begin
fOnLVDataW := Value;
AttachProc( @WndProc_LVData );
Perform( LVM_SETCALLBACKMASK, LVIS_OVERLAYMASK or LVIS_STATEIMAGEMASK, 0 );
end;
function TControl.LVIndexOfW(const S: WideString): Integer;
begin
Result := LVSearchForW( S, -1, FALSE );
end;
//[function TControl.LVSearchForW]
function TControl.LVSearchForW(const S: WideString; StartAfter: Integer;
Partial: Boolean): Integer;
var f: TLVFindInfoW;
begin
f.lParam := 0;
f.flags := LVFI_STRING;
if Partial then
f.flags := LVFI_STRING or LVFI_PARTIAL;
f.psz := @s[1];
result := Perform(LVM_FINDITEMW,StartAfter,integer(@f));
end;
{$ENDIF _FPC}
{$ENDIF implementation} ////////////////////////////////////////////////////////