Remove old installer/launcher/uninstaller and libs

Change-Id: I4d415e36a46ac1977d40dc039d023947eb7bf502
Reviewed-on: http://gerrit.dmdirc.com/1727
Automatic-Compile: DMDirc Local Commits <dmdirc@googlemail.com>
Reviewed-by: Greg Holmes <greg@dmdirc.com>

installer/release.sh

@@ -196,15 +196,6 @@ if [ "windows" = "${BUILDTARGET}" -o "" = "${BUILDTARGET}" ]; then
 	cd ${THISDIR}
 fi;
 
-if [ "oldwindows" = "${BUILDTARGET}" ]; then
-	echo "================================================================"
-	echo "Building Old Windows installer"
-	echo "================================================================"
-	cd windows
-	./makeInstallerWindows.sh ${OPT}${JARFILE}${JRE}-k -s ${TAGGED}${BRANCH}${RELEASE} -p "${plugins_windows}"
-	cd ${THISDIR}
-fi;
-
 if [ "osx" = "${BUILDTARGET}" -o "" = "${BUILDTARGET}" ]; then
 	echo "================================================================"
 	echo "Building OSX Bundle"

installer/windows/Launcher.dpr

@@ -1,115 +0,0 @@
-{*
- * This application launches the dmdirc java-based installer.
- * 
- * DMDirc - Open Source IRC Client
- * Copyright (c) 2006-2011 Chris Smith, Shane Mc Cormack, Gregory Holmes
- * 
- * Permission is hereby granted, free of charge, to any person obtaining a copy
- * of this software and associated documentation files (the "Software"), to deal
- * in the Software without restriction, including without limitation the rights
- * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
- * copies of the Software, and to permit persons to whom the Software is
- * furnished to do so, subject to the following conditions:
- * 
- * The above copyright notice and this permission notice shall be included in
- * all copies or substantial portions of the Software.
- * 
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
- * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
- * SOFTWARE.
- *}
-program Launcher;
-{$MODE Delphi}
-{$APPTYPE GUI}
-
-uses Windows, SysUtils, classes, MD5;
-procedure InitCommonControls; stdcall; External 'comctl32.dll' name 'InitCommonControls';
-
-//{$R files.res}
-//{$R version.res}
-//{$R icon.res}
-{$R all.res}
-
-{$I consts.inc}
-
-function GetTempDirectory(): String;
-var
-	buf: array[0..MAX_PATH] of Char;
-	wintemp, temp: String;
-begin
-	GetTempPath(SizeOf(buf)-1, buf);
-	wintemp := StrPas(buf);
-	Randomize;
-	temp := '\DMDirc-installer-'+inttostr(1000 + Random(1000));
-	while (DirectoryExists(wintemp+temp+'\')) do begin
-		temp := temp+'-'+inttostr(1+Random(1000));
-	end;
-	MkDir(wintemp+temp+'\');
-	result := wintemp+temp+'\';
-end;
-
-procedure ExtractResource(name: string; filename: string; dir: string = '');
-var
-	rStream: TResourceStream;
-	fStream: TFileStream;
-	fname: string;
-begin
-	if (dir = '') or (not DirectoryExists(dir)) then dir := IncludeTrailingPathDelimiter(ExtractFileDir(paramstr(0)));
-	fname := dir+filename;
-	if FileExists(fname) then DeleteFile(fname);
-	
-	rStream := TResourceStream.Create(hInstance, name, RT_RCDATA);
-	try
-		fStream := TFileStream.Create(fname, fmCreate);
-		try
-			fStream.CopyFrom(rStream, 0);
-		finally
-			fStream.Free;
-		end;
-	finally
-		rStream.Free;
-	end;
-end;
-
-procedure Launch(sProgramToRun: String);
-var
-	StartupInfo: TStartupInfo;
-	ProcessInfo: TProcessInformation;
-begin
-	FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
-	with StartupInfo do begin
-		cb := SizeOf(TStartupInfo);
-		dwFlags := STARTF_USESHOWWINDOW;
-		wShowWindow := SW_SHOWNORMAL;
-	end;
-
-	CreateProcess(nil, PChar(sProgramToRun), nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
-end;
-
-function checkMD5(filename: String): boolean;
-var
-	hash: String;
-begin
-	hash := MD5Print(MD5File(filename));
-	result := (hash = MD5SUM);
-//	if not result then begin
-//		MessageBox(0, PChar('MD5Hash Result:'+#10+'Got: '+hash+#10+'Exp: '+MD5SUM+#10+'Res:'+booltostr(hash = MD5SUM)), 'Test', MB_OK + MB_ICONSTOP);
-//	end;
-
-// Uncomment this to disable MD5 Check
-//	result := true;
-end;
-
-var
-	ErrorMessage: String;
-	TempDir: String;
-begin
-        InitCommonControls;
-	TempDir := GetTempDirectory;
-	ErrorMessage := '';
-	{$I ExtractCode.inc}
-end.

installer/windows/MD5.pas

@@ -1,393 +0,0 @@
-                                                                              // tabs = 2
-// -----------------------------------------------------------------------------------------------
-//
-//                                 MD5 Message-Digest for Delphi 4
-//
-//                                 Delphi 4 Unit implementing the
-//                      RSA Data Security, Inc. MD5 Message-Digest Algorithm
-//
-//                          Implementation of Ronald L. Rivest's RFC 1321
-//
-//                      Copyright � 1997-1999 Medienagentur Fichtner & Meyer
-//                                  Written by Matthias Fichtner
-//
-// -----------------------------------------------------------------------------------------------
-//               See RFC 1321 for RSA Data Security's copyright and license notice!
-// -----------------------------------------------------------------------------------------------
-//
-//     14-Jun-97  mf  Implemented MD5 according to RFC 1321                           RFC 1321
-//     16-Jun-97  mf  Initial release of the compiled unit (no source code)           RFC 1321
-//     28-Feb-99  mf  Added MD5Match function for comparing two digests               RFC 1321
-//     13-Sep-99  mf  Reworked the entire unit                                        RFC 1321
-//     17-Sep-99  mf  Reworked the "Test Driver" project                              RFC 1321
-//     19-Sep-99  mf  Release of sources for MD5 unit and "Test Driver" project       RFC 1321
-//
-// -----------------------------------------------------------------------------------------------
-//                   The latest release of md5.pas will always be available from
-//                  the distribution site at: http://www.fichtner.net/delphi/md5/
-// -----------------------------------------------------------------------------------------------
-//                       Please send questions, bug reports and suggestions
-//                      regarding this code to: mfichtner@fichtner-meyer.com
-// -----------------------------------------------------------------------------------------------
-//                        This code is provided "as is" without express or
-//                     implied warranty of any kind. Use it at your own risk.
-// -----------------------------------------------------------------------------------------------
-
-unit md5;
-{$MODE Delphi}
-// -----------------------------------------------------------------------------------------------
-INTERFACE
-// -----------------------------------------------------------------------------------------------
-
-uses
-	Windows;
-
-type
-	MD5Count = array[0..1] of DWORD;
-	MD5State = array[0..3] of DWORD;
-	MD5Block = array[0..15] of DWORD;
-	MD5CBits = array[0..7] of byte;
-	MD5Digest = array[0..15] of byte;
-	MD5Buffer = array[0..63] of byte;
-	MD5Context = record
-		State: MD5State;
-		Count: MD5Count;
-		Buffer: MD5Buffer;
-	end;
-
-procedure MD5Init(var Context: MD5Context);
-procedure MD5Update(var Context: MD5Context; Input: pChar; Length: longword);
-procedure MD5Final(var Context: MD5Context; var Digest: MD5Digest);
-
-function MD5String(M: string): MD5Digest;
-function MD5File(N: string): MD5Digest;
-function MD5Print(D: MD5Digest): string;
-
-function MD5Match(D1, D2: MD5Digest): boolean;
-
-// -----------------------------------------------------------------------------------------------
-IMPLEMENTATION
-// -----------------------------------------------------------------------------------------------
-
-var
-	PADDING: MD5Buffer = (
-		$80, $00, $00, $00, $00, $00, $00, $00,
-		$00, $00, $00, $00, $00, $00, $00, $00,
-		$00, $00, $00, $00, $00, $00, $00, $00,
-		$00, $00, $00, $00, $00, $00, $00, $00,
-		$00, $00, $00, $00, $00, $00, $00, $00,
-		$00, $00, $00, $00, $00, $00, $00, $00,
-		$00, $00, $00, $00, $00, $00, $00, $00,
-		$00, $00, $00, $00, $00, $00, $00, $00
-	);
-
-function F(x, y, z: DWORD): DWORD;
-begin
-	Result := (x and y) or ((not x) and z);
-end;
-
-function G(x, y, z: DWORD): DWORD;
-begin
-	Result := (x and z) or (y and (not z));
-end;
-
-
-function H(x, y, z: DWORD): DWORD;
-begin
-	Result := x xor y xor z;
-end;
-
-function I(x, y, z: DWORD): DWORD;
-begin
-	Result := y xor (x or (not z));
-end;
-
-procedure rot(var x: DWORD; n: BYTE);
-begin
-	x := (x shl n) or (x shr (32 - n));
-end;
-
-procedure FF(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD);
-begin
-	inc(a, F(b, c, d) + x + ac);
-	rot(a, s);
-	inc(a, b);
-end;
-
-procedure GG(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD);
-begin
-	inc(a, G(b, c, d) + x + ac);
-	rot(a, s);
-	inc(a, b);
-end;
-
-procedure HH(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD);
-begin
-	inc(a, H(b, c, d) + x + ac);
-	rot(a, s);
-	inc(a, b);
-end;
-
-procedure II(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD);
-begin
-	inc(a, I(b, c, d) + x + ac);
-	rot(a, s);
-	inc(a, b);
-end;
-
-// -----------------------------------------------------------------------------------------------
-
-// Encode Count bytes at Source into (Count / 4) DWORDs at Target
-procedure Encode(Source, Target: pointer; Count: longword);
-var
-	S: PByte;
-	T: PDWORD;
-	I: longword;
-begin
-	S := Source;
-	T := Target;
-	for I := 1 to Count div 4 do begin
-		T^ := S^;
-		inc(S);
-		T^ := T^ or (S^ shl 8);
-		inc(S);
-		T^ := T^ or (S^ shl 16);
-		inc(S);
-		T^ := T^ or (S^ shl 24);
-		inc(S);
-		inc(T);
-	end;
-end;
-
-// Decode Count DWORDs at Source into (Count * 4) Bytes at Target
-procedure Decode(Source, Target: pointer; Count: longword);
-var
-	S: PDWORD;
-	T: PByte;
-	I: longword;
-begin
-	S := Source;
-	T := Target;
-	for I := 1 to Count do begin
-		T^ := S^ and $ff;
-		inc(T);
-		T^ := (S^ shr 8) and $ff;
-		inc(T);
-		T^ := (S^ shr 16) and $ff;
-		inc(T);
-		T^ := (S^ shr 24) and $ff;
-		inc(T);
-		inc(S);
-	end;
-end;
-
-// Transform State according to first 64 bytes at Buffer
-procedure Transform(Buffer: pointer; var State: MD5State);
-var
-	a, b, c, d: DWORD;
-	Block: MD5Block;
-begin
-	Encode(Buffer, @Block, 64);
-	a := State[0];
-	b := State[1];
-	c := State[2];
-	d := State[3];
-	FF (a, b, c, d, Block[ 0],  7, $d76aa478);
-	FF (d, a, b, c, Block[ 1], 12, $e8c7b756);
-	FF (c, d, a, b, Block[ 2], 17, $242070db);
-	FF (b, c, d, a, Block[ 3], 22, $c1bdceee);
-	FF (a, b, c, d, Block[ 4],  7, $f57c0faf);
-	FF (d, a, b, c, Block[ 5], 12, $4787c62a);
-	FF (c, d, a, b, Block[ 6], 17, $a8304613);
-	FF (b, c, d, a, Block[ 7], 22, $fd469501);
-	FF (a, b, c, d, Block[ 8],  7, $698098d8);
-	FF (d, a, b, c, Block[ 9], 12, $8b44f7af);
-	FF (c, d, a, b, Block[10], 17, $ffff5bb1);
-	FF (b, c, d, a, Block[11], 22, $895cd7be);
-	FF (a, b, c, d, Block[12],  7, $6b901122);
-	FF (d, a, b, c, Block[13], 12, $fd987193);
-	FF (c, d, a, b, Block[14], 17, $a679438e);
-	FF (b, c, d, a, Block[15], 22, $49b40821);
-	GG (a, b, c, d, Block[ 1],  5, $f61e2562);
-	GG (d, a, b, c, Block[ 6],  9, $c040b340);
-	GG (c, d, a, b, Block[11], 14, $265e5a51);
-	GG (b, c, d, a, Block[ 0], 20, $e9b6c7aa);
-	GG (a, b, c, d, Block[ 5],  5, $d62f105d);
-	GG (d, a, b, c, Block[10],  9,  $2441453);
-	GG (c, d, a, b, Block[15], 14, $d8a1e681);
-	GG (b, c, d, a, Block[ 4], 20, $e7d3fbc8);
-	GG (a, b, c, d, Block[ 9],  5, $21e1cde6);
-	GG (d, a, b, c, Block[14],  9, $c33707d6);
-	GG (c, d, a, b, Block[ 3], 14, $f4d50d87);
-	GG (b, c, d, a, Block[ 8], 20, $455a14ed);
-	GG (a, b, c, d, Block[13],  5, $a9e3e905);
-	GG (d, a, b, c, Block[ 2],  9, $fcefa3f8);
-	GG (c, d, a, b, Block[ 7], 14, $676f02d9);
-	GG (b, c, d, a, Block[12], 20, $8d2a4c8a);
-	HH (a, b, c, d, Block[ 5],  4, $fffa3942);
-	HH (d, a, b, c, Block[ 8], 11, $8771f681);
-	HH (c, d, a, b, Block[11], 16, $6d9d6122);
-	HH (b, c, d, a, Block[14], 23, $fde5380c);
-	HH (a, b, c, d, Block[ 1],  4, $a4beea44);
-	HH (d, a, b, c, Block[ 4], 11, $4bdecfa9);
-	HH (c, d, a, b, Block[ 7], 16, $f6bb4b60);
-	HH (b, c, d, a, Block[10], 23, $bebfbc70);
-	HH (a, b, c, d, Block[13],  4, $289b7ec6);
-	HH (d, a, b, c, Block[ 0], 11, $eaa127fa);
-	HH (c, d, a, b, Block[ 3], 16, $d4ef3085);
-	HH (b, c, d, a, Block[ 6], 23,  $4881d05);
-	HH (a, b, c, d, Block[ 9],  4, $d9d4d039);
-	HH (d, a, b, c, Block[12], 11, $e6db99e5);
-	HH (c, d, a, b, Block[15], 16, $1fa27cf8);
-	HH (b, c, d, a, Block[ 2], 23, $c4ac5665);
-	II (a, b, c, d, Block[ 0],  6, $f4292244);
-	II (d, a, b, c, Block[ 7], 10, $432aff97);
-	II (c, d, a, b, Block[14], 15, $ab9423a7);
-	II (b, c, d, a, Block[ 5], 21, $fc93a039);
-	II (a, b, c, d, Block[12],  6, $655b59c3);
-	II (d, a, b, c, Block[ 3], 10, $8f0ccc92);
-	II (c, d, a, b, Block[10], 15, $ffeff47d);
-	II (b, c, d, a, Block[ 1], 21, $85845dd1);
-	II (a, b, c, d, Block[ 8],  6, $6fa87e4f);
-	II (d, a, b, c, Block[15], 10, $fe2ce6e0);
-	II (c, d, a, b, Block[ 6], 15, $a3014314);
-	II (b, c, d, a, Block[13], 21, $4e0811a1);
-	II (a, b, c, d, Block[ 4],  6, $f7537e82);
-	II (d, a, b, c, Block[11], 10, $bd3af235);
-	II (c, d, a, b, Block[ 2], 15, $2ad7d2bb);
-	II (b, c, d, a, Block[ 9], 21, $eb86d391);
-	inc(State[0], a);
-	inc(State[1], b);
-	inc(State[2], c);
-	inc(State[3], d);
-end;
-
-// -----------------------------------------------------------------------------------------------
-
-// Initialize given Context
-procedure MD5Init(var Context: MD5Context);
-begin
-	with Context do begin
-		State[0] := $67452301;
-		State[1] := $efcdab89;
-		State[2] := $98badcfe;
-		State[3] := $10325476;
-		Count[0] := 0;
-		Count[1] := 0;
-		ZeroMemory(@Buffer, SizeOf(MD5Buffer));
-	end;
-end;
-
-// Update given Context to include Length bytes of Input
-procedure MD5Update(var Context: MD5Context; Input: pChar; Length: longword);
-var
-	Index: longword;
-	PartLen: longword;
-	I: longword;
-begin
-	with Context do begin
-		Index := (Count[0] shr 3) and $3f;
-		inc(Count[0], Length shl 3);
-		if Count[0] < (Length shl 3) then inc(Count[1]);
-		inc(Count[1], Length shr 29);
-	end;
-	PartLen := 64 - Index;
-	if Length >= PartLen then begin
-		CopyMemory(@Context.Buffer[Index], Input, PartLen);
-		Transform(@Context.Buffer, Context.State);
-		I := PartLen;
-		while I + 63 < Length do begin
-			Transform(@Input[I], Context.State);
-			inc(I, 64);
-		end;
-		Index := 0;
-	end else I := 0;
-	CopyMemory(@Context.Buffer[Index], @Input[I], Length - I);
-end;
-
-// Finalize given Context, create Digest and zeroize Context
-procedure MD5Final(var Context: MD5Context; var Digest: MD5Digest);
-var
-	Bits: MD5CBits;
-	Index: longword;
-	PadLen: longword;
-begin
-	Decode(@Context.Count, @Bits, 2);
-	Index := (Context.Count[0] shr 3) and $3f;
-	if Index < 56 then PadLen := 56 - Index else PadLen := 120 - Index;
-	MD5Update(Context, @PADDING, PadLen);
-	MD5Update(Context, @Bits, 8);
-	Decode(@Context.State, @Digest, 4);
-	ZeroMemory(@Context, SizeOf(MD5Context));
-end;
-
-// -----------------------------------------------------------------------------------------------
-
-// Create digest of given Message
-function MD5String(M: string): MD5Digest;
-var
-	Context: MD5Context;
-begin
-	MD5Init(Context);
-	MD5Update(Context, pChar(M), length(M));
-	MD5Final(Context, Result);
-end;
-
-// Create digest of file with given Name
-function MD5File(N: string): MD5Digest;
-var
-	FileHandle: THandle;
-	MapHandle: THandle;
-	ViewPointer: pointer;
-	Context: MD5Context;
-begin
-	MD5Init(Context);
-	FileHandle := CreateFile(pChar(N), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,
-		nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_SEQUENTIAL_SCAN, 0);
-	if FileHandle <> INVALID_HANDLE_VALUE then try
-		MapHandle := CreateFileMapping(FileHandle, nil, PAGE_READONLY, 0, 0, nil);
-		if MapHandle <> 0 then try
-			ViewPointer := MapViewOfFile(MapHandle, FILE_MAP_READ, 0, 0, 0);
-			if ViewPointer <> nil then try
-				MD5Update(Context, ViewPointer, GetFileSize(FileHandle, nil));
-			finally
-				UnmapViewOfFile(ViewPointer);
-			end;
-		finally
-			CloseHandle(MapHandle);
-		end;
-	finally
-		CloseHandle(FileHandle);
-	end;
-	MD5Final(Context, Result);
-end;
-
-// Create hex representation of given Digest
-function MD5Print(D: MD5Digest): string;
-var
-	I: byte;
-const
-	Digits: array[0..15] of char =
-		('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
-begin
-	Result := '';
-	for I := 0 to 15 do Result := Result + Digits[(D[I] shr 4) and $0f] + Digits[D[I] and $0f];
-end;
-
-// -----------------------------------------------------------------------------------------------
-
-// Compare two Digests
-function MD5Match(D1, D2: MD5Digest): boolean;
-var
-	I: byte;
-begin
-	I := 0;
-	Result := TRUE;
-	while Result and (I < 16) do begin
-		Result := D1[I] = D2[I];
-		inc(I);
-	end;
-end;
-
-end.
-

installer/windows/Setup.dpr

@@ -1,469 +0,0 @@
-{*
- * This application launches the dmdirc java-based installer.
- *
- * DMDirc - Open Source IRC Client
- * Copyright (c) 2006-2011 Chris Smith, Shane Mc Cormack, Gregory Holmes,
- * Michael Nixon
- *
- * Permission is hereby granted, free of charge, to any person obtaining a copy
- * of this software and associated documentation files (the "Software"), to deal
- * in the Software without restriction, including without limitation the rights
- * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
- * copies of the Software, and to permit persons to whom the Software is
- * furnished to do so, subject to the following conditions:
- *
- * The above copyright notice and this permission notice shall be included in
- * all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
- * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
- * SOFTWARE.
- *}
-
-(* Current DMDirc windows setup flow:
- *
- * 1) Outer wrapper EXE that extracts a 7zip SFX to windows temp dir
- * 2) 7zip SFX unpacks
- * 3) Wrapper EXE starts Setup.exe (this program)
- * 4) Setup checks for existence of the JRE and offers to download/install it
- * 5) Setup starts the java portion of the DMDirc installer
- *)
-program Setup;
-
-// Resource file - icon, versioninfo, manifest
-{$R most.res}
-
-{ ---------------------------------------------------------------------------- }
-{$IFDEF FPC}
-  {$MODE Delphi}
-{$ENDIF}
-
-// Use this instead of {$APPTYPE XXX}
-// APP_XXX is the same as {$APPTYPE XXX}
-// Defaults to console
-// This is a work-around for a bug in FPC Cross Compiling to windows in delphi
-// mode (IsConsole is always true)
-{$DEFINE APP_GUI}
-
-// This block actually does the work for the above work-around
-{$IFDEF APP_GUI}
-  {$APPTYPE GUI}
-{$ELSE}
-  {$IFDEF APP_FS}
-    {$APPTYPE FS}
-  {$ELSE}
-    {$IFDEF APP_TOOL}
-      {$DEFINE APP_CONSOLE}
-      {$APPTYPE TOOL}
-    {$ELSE}
-      {$DEFINE APP_CONSOLE}
-      {$APPTYPE CONSOLE}
-    {$ENDIF}
-  {$ENDIF}
-{$ENDIF}
-
-{ ----------------------------------------------------------------------------
-  Debugging specific compiler directives
-  ---------------------------------------------------------------------------- }
-
-// If defined the JRE will always be downloaded as if it didn't exist. Used for
-// testing the JRE download dialog.
-// {$DEFINE FORCEJREDOWNLOAD}
-
-uses
-  kol, shared, Vista, Windows, SysUtils, classes, registry;
-
-const
-  // SetupConsts holds build information for this release
-  {$I SetupConsts.inc}
-  // This is also part of the above IsConsole workaround.
-  {$IFDEF APP_CONSOLE}
-    IsConsole: boolean = true;
-  {$ELSE}
-    IsConsole: boolean = false;
-  {$ENDIF}
-
-var
-  { --------------------------------------------------------------------------
-    KOL form objects
-    -------------------------------------------------------------------------- }
-  frmmain: pcontrol;
-  progressbar, btncancel: pcontrol;
-  label1, label2, label3, label4, labelurl, labelspeed, labelprogress: pcontrol;
-
-  { --------------------------------------------------------------------------
-    Other globals
-    -------------------------------------------------------------------------- }
-  terminateDownload: boolean = false;
-
-procedure InitCommonControls; stdcall; External 'comctl32.dll' name 'InitCommonControls';
-
-{ ----------------------------------------------------------------------------
-  Main form: Cancel button clicked event
-  ---------------------------------------------------------------------------- }
-procedure btnCancel_Click(Dummy: Pointer; Sender: PControl);
-begin
-  terminateDownload := true;
-end;
-
-{ ----------------------------------------------------------------------------
-  Main form: Set progress percentage to <value> and display in label <msg>
-  ---------------------------------------------------------------------------- }
-procedure setProgress(value: integer; msg: string);
-begin
-  ProgressBar.progress := value;
-  labelprogress.Caption := msg;
-  applet.processmessages;
-end;
-
-{ ----------------------------------------------------------------------------
-  Initialise KOL and create the main window
-  ---------------------------------------------------------------------------- }
-procedure CreateMainWindow;
-var
-  screenw, screenh: longint;
-  iconhandle: thandle;
-begin
-  { This call is required for common control 6 DLL to be correctly imported.
-    Without it strange things happen on windows XP }
-  InitCommonControls;
-
-  { Load the icon to assign to our window }
-  iconhandle := LoadIcon(hInstance, 'icon.ico');
-
-  { We need the screen size to centre the window later }
-  screenw := GetSystemMetrics(SM_CXSCREEN);
-  screenh := GetSystemMetrics(SM_CYSCREEN);
-
-  { KOL programs ideally need an Applet created }
-  Applet := NewApplet('DMDirc Setup');
-  Applet.Visible := true;
-
-  Applet.Icon := iconhandle;
-
-  { Create main form and set sane defaults. If we don't set the font here then
-    all child objects will have a rubbish font as a holdover from Windows 3.1! }
-  frmmain := NewForm(Applet, 'DMDirc Setup').SetClientSize(400, 184);
-  frmmain.CreateVisible := True;
-  frmmain.CanResize := False;
-  frmmain.Style := frmmain.style and (not WS_MAXIMIZEBOX);
-  frmmain.Font.FontName := 'Ms Sans Serif';
-  frmmain.Font.FontHeight := 8;
-  frmmain.SetPosition((screenw div 2) - (frmmain.Width div 2), (screenh div 2) - (frmmain.height div 2));
-
-  frmmain.Icon := iconhandle;
-
-  progressbar := NewProgressBar(frmmain).SetPosition(16, 114);
-  progressbar.SetSize(frmmain.clientWidth - (progressbar.Left * 2), 16);
-  progressbar.MaxProgress := 100;
-  progressbar.Progress := 0;
-  progressbar.Visible := true;
-
-  btncancel := NewButton(frmmain, 'Cancel').SetPosition(progressbar.Left +
-  progressbar.width - 60, progressbar.Top + progressbar.Height + 14);
-  btncancel.SetSize(60, 24);
-
-  label1 := NewLabel(frmmain, 'Downloading Java Runtime Environment').SetPosition(16, 16);
-  label1.SetSize(frmmain.ClientWidth - 32, 16);
-  label1.Font.FontStyle := [fsBold];
-
-  label2 := NewLabel(frmmain, 'Address:').SetPosition(16, label1.top + 28);
-  label2.SetSize(frmmain.ClientWidth - 32, 16);
-
-  label3 := NewLabel(frmmain, 'Speed:').SetPosition(16, label2.top + 20);
-  label3.SetSize(frmmain.ClientWidth - 32, 16);
-
-  label4 := NewLabel(frmmain, 'Progress:').SetPosition(16, label3.top + 20);
-  label4.SetSize(frmmain.ClientWidth - 32, 16);
-
-  { BringToFront calls are needed on the following labels because the labels
-    created earlier are as wide as the form and cover them as they are not
-    transparent. It seems windows creates controls in a backwards order so newer
-    controls are behind older ones. I could rearrange this order in the code but
-    it would look messy. }
-
-  labelurl := NewLabel(frmmain, '').SetPosition(70, label1.top + 28);
-  labelurl.SetSize(frmmain.ClientWidth - 32, 16);
-  labelurl.BringToFront;
-
-  labelspeed := NewLabel(frmmain, '').SetPosition(70, label2.top + 20);
-  labelspeed.SetSize(frmmain.ClientWidth - 32, 16);
-  labelspeed.BringToFront;
-
-  labelprogress := NewLabel(frmmain, '').SetPosition(70, label3.top + 20);
-  labelprogress.SetSize(frmmain.ClientWidth - 32, 16);
-  labelprogress.BringToFront;
-
-  { Assign UI methods }
-  btncancel.OnClick := TOnEvent(MakeMethod(nil, @btnCancel_Click ));
-
-  { The window will not appear until the messageloop is started with Run() but
-    this means we must yield this thread to the UI. This is unacceptable for
-    such a simple program. Calling CreateWindow here will cause the window to
-    appear but the message loop does not run; consequently the app must service
-    messages by hand at a timely interval to avoid windows from marking the
-    program as unresponsive. This is a hack but acceptable here. }
-
-  { /!\ WARNING /!\ Run() can no longer be used to enter the message loop after
-    this call or a nasty crash will occur. }
-  applet.createwindow;
-end;
-
-{ ----------------------------------------------------------------------------
-  Return the size in bytes of the file specified by <name>
-  Returns -1 on error
-  ---------------------------------------------------------------------------- }
-function GetFileSizeByName(name: String): Integer;
-var
-  hand: THandle;
-begin
-  hand := 0;
-  Result := 0;
-  if FileExists(name) then begin
-    try
-      hand := CreateFile(PChar(name), GENERIC_READ, FILE_SHARE_WRITE or FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
-      Result := GetFileSize(hand, nil);
-    finally
-      try
-        if (hand <> 0) then CloseHandle(hand);
-      except
-        Result := -1;
-      end;
-    end;
-  end;
-end;
-
-{$IFNDEF VER150}
-{ ----------------------------------------------------------------------------
-  Return part of a string
-  ---------------------------------------------------------------------------- }
-function AnsiMidStr(Source: String; Start: Integer; Count: Integer): String;
-begin
-  // Not perfectly accurate, but does the job
-  { ^ What does that mean? // Zipplet }
-  Result := Copy(Source, Start, Count);
-end;
-{$ENDIF}
-
-{ ----------------------------------------------------------------------------
-  Downloads the JRE. Returns TRUE if the user installed it. False otherwise
-  ---------------------------------------------------------------------------- }
-function downloadJRE(message: String = 'Would you like to download the java JRE?'): boolean;
-var
-  ProcessInfo: TProcessInformation;
-  processResult: Longword;
-  url: String;
-  dir: String;
-  line: String;
-  f: TextFile;
-  bits: TStringList;
-  match: boolean;
-  wantedsize: double;
-  currentsize: double;
-   lastsize: double;
-   i: double;
-   c: longint;
-begin
-  dir := IncludeTrailingPathDelimiter(ExtractFileDir(paramstr(0)));
-  // TODO: We should probably download the 64bit version of java if we are
-  // 64bit.
-  url := 'http://www.dmdirc.com/getjava/windows/all';
-  Result := false;
-
-  { First we will determine the approximate size of the download.
-    In my opinion we should not do this until we have asked the user if they
-    would like to download the JRE. Might change this later.
-    We obtain the size by asking wget to find out. }
-  ExecAndWait('wget.exe -o "'+dir+'wgetoutput" --spider '+url, true);
-
-  { Just incase wget fails ... }
-  if not fileexists(dir+'wgetoutput') then begin
-    showerror('Internal error: wget returned no output.', 'DMDirc Setup');
-    result := false;
-    exit;
-  end;
-
-  { Parse the output and grab the approximate size }
-  AssignFile(f, dir+'wgetoutput');
-  Reset(f);
-  line := '';
-  match := false;
-  while not Eof(f) do begin
-    ReadLn(f, line);
-    if length(line) > 8 then begin
-      if copy(line, 1, 7) = 'Length:' then begin
-        match := true;
-        break;
-      end;
-    end;
-  end;
-  if match then begin
-    bits := TStringList.create;
-    try
-      bits.Clear;
-      bits.Delimiter := ' ';
-      bits.DelimitedText := line;
-      try
-        wantedsize := strtoint(StringReplace(bits[1], ',', '', [rfReplaceAll]))
-      except
-        wantedsize := 0;
-      end;
-
-      { We ask the user if they wish to download the JRE }
-      if askQuestion(message+' (Download Size: '+AnsiMidStr(bits[2], 2, length(bits[2])-2)+')', 'DMDirc Setup') then begin
-        { Create progress window and show it }
-        CreateMainWindow;
-        { Get wget to start the download }
-        ProcessInfo := Launch('wget.exe '+url+' -O jre.exe', true);
-        labelurl.caption := url;
-        labelspeed.caption := 'Connecting to site...';
-
-        { Why is this case needed ?! }
-        if wantedsize <= 0 then begin
-          progressbar.progress := 50;
-        end;
-        getExitCodeProcess(ProcessInfo.hProcess, processResult);
-
-        lastsize := 0;
-        c := 0;
-        i := 0;
-        while (processResult = STILL_ACTIVE) and (not terminateDownload) do begin
-          if wantedsize > 0 then begin
-            currentsize := GetFileSizeByName(dir + 'jre.exe');
-            inc(c);
-            if (c >= 5) then begin
-              i := (i + currentsize - lastsize) / 2;
-              labelspeed.caption := nicesize(round(i * 2)) + '/sec';
-              lastsize := currentsize;
-              c := 0;
-            end;
-            if (currentsize > 0) then setProgress(Round((currentsize/wantedsize)*100),
-              nicesize(currentsize) + ' of ' + nicesize(wantedsize) +
-              ' (' + inttostr(Round((currentsize/wantedsize)*100)) + '%)');
-          end;
-          { We must process the message loop or the window wont respond to the user }
-          applet.ProcessMessages;
-          { Sleep to prevent 100% CPU usage }
-          sleep(100);
-          GetExitCodeProcess(ProcessInfo.hProcess, processResult);
-        end;
-        frmmain.visible := false;
-        applet.visible := false;
-        if (terminateDownload) then begin
-          Result := false;
-          TerminateProcess(ProcessInfo.hProcess, 0);
-          showError('JRE Download was aborted', 'DMDirc Setup', false);
-        end
-        else Result := processResult = 0;
-        if not Result then begin
-          if not terminateDownload then begin
-            showError('JRE Download Failed', 'DMDirc Setup', false);
-          end
-          else begin
-            // If the download was cancelled by the form, this error will already
-            // have been given.
-            { No action needed here anymore }
-          end;
-        end;
-      end;
-    finally
-      bits.free;
-    end;
-  end;
-end;
-
-{ ----------------------------------------------------------------------------
-  Begin the JRE download/install.
-  ---------------------------------------------------------------------------- }
-function installJRE(isUpgrade: boolean): boolean;
-var
-  question: String;
-  needDownload: boolean;
-  canContinue: boolean;
-begin
-  Result := false;
-  needDownload := not FileExists(IncludeTrailingPathDelimiter(ExtractFileDir(paramstr(0)))+'jre.exe');
-  if needDownload then begin
-    if not isUpgrade then question := 'Java was not detected on your machine. Would you like to download and install it now?'
-    else question := 'The version of java detected on your machine is not compatible with DMDirc. Would you like to download and install a compatible version now?';
-  end
-  else begin
-    if not isUpgrade then question := 'Java was not detected on your machine. Would you like to install it now?'
-    else question := 'The version of java detected on your machine is not compatible with DMDirc. Would you like to install a compatible version now?';
-  end;
-
-  canContinue := true;
-  if (needDownload) then begin
-    canContinue := downloadJRE(question);
-  end;
-
-  if canContinue then begin
-    // Final result of this function is the return value of installing java.
-    if needDownload or askQuestion(question, 'DMDirc Setup') then begin
-      showmessage('The Java installer will now run. Please follow the instructions given. '+#13#10+'The DMDirc installation will continue afterwards.', 'DMDirc Setup');
-      Result := (ExecAndWait('jre.exe') = 0);
-    end;
-  end
-end;
-
-{ ----------------------------------------------------------------------------
-  MAIN PROGRAM
-  ---------------------------------------------------------------------------- }
-var
-  errorMessage: String;
-  params: String = '';
-  dir: String = '';
-  Reg: TRegistry;
-  result: Integer;
-begin
-
-  errorMessage := '';
-  if FileExists('DMDirc.jar') then begin
-    {$IFDEF FORCEJREDOWNLOAD}if (1 <> 0) then begin{$ELSE}if (RunJava('-version') <> 0) then begin{$ENDIF}
-      if not installJRE(false) then begin
-        showError('DMDirc setup can not continue without Java. Please install Java and try again.', 'DMDirc Setup', false, false);
-        exit;
-      end;
-    end;
-
-    Reg := TRegistry.Create;
-    Reg.RootKey := HKEY_LOCAL_MACHINE;
-    if Reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\DMDirc', false) then begin
-      dir := Reg.ReadString('InstallDir');
-      if (dir <> '') then begin
-        params := params+' --directory "'+dir+'"';
-      end;
-    end;
-    Reg.CloseKey;
-    Reg.Free;
-    if (ReleaseNumber <> '') then begin
-      params := params+' --release '+ReleaseNumber;
-    end;
-    // Check if the installer runs
-    if (RunJava('-cp DMDirc.jar com.dmdirc.installer.Main --help') <> 0) then begin
-      if not installJRE(true) then begin
-        showError('Sorry, DMDirc setup can not continue without an updated version of java.', 'DMDirc Setup', false, false);
-        exit;
-      end
-      else begin
-        // Try again now that java is installed.
-        result := RunJava('-cp DMDirc.jar com.dmdirc.installer.Main '+params);
-      end;
-    end
-    else begin
-      // Java is the right version, run the installer
-      result := RunJava('-cp DMDirc.jar com.dmdirc.installer.Main '+params);
-    end;
-  end
-  else begin
-    errorMessage := errorMessage+'DMDirc.jar was not found.';
-    errorMessage := errorMessage+#13#10;
-    errorMessage := errorMessage+#13#10+'This is likely because of a corrupt installer build.';
-    errorMessage := errorMessage+#13#10+'Please check http://www.dmdirc.com/ for an updated build.';
-    showError(errorMessage, 'DMDirc Setup');
-  end;
-end.

installer/windows/UAC.manifest

@@ -1,17 +0,0 @@
-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
-<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
-  <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="DMDirc Installer" type="win32"/>
-  <description>DMDirc Installer</description>
-  <dependency>
-    <dependentAssembly>
-      <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*"/>
-    </dependentAssembly>
-  </dependency>
-  <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
-    <security>
-      <requestedPrivileges>
-        <requestedExecutionLevel level="requireAdministrator"/>
-      </requestedPrivileges>
-    </security>
-  </trustInfo>
-</assembly>

installer/windows/UAC_uninstaller.manifest

@@ -1,17 +0,0 @@
-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
-<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
-  <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="DMDirc Uninstaller" type="win32"/>
-  <description>DMDirc Uninstaller</description>
-  <dependency>
-    <dependentAssembly>
-      <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*"/>
-    </dependentAssembly>
-  </dependency>
-  <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
-    <security>
-      <requestedPrivileges>
-        <requestedExecutionLevel level="requireAdministrator"/>
-      </requestedPrivileges>
-    </security>
-  </trustInfo>
-</assembly>

installer/windows/Uninstaller.dpr

@@ -1,199 +0,0 @@
-{*
- * DMDirc Uninstaller
- *
- * This application launches DMDirc on windows and passes control to the
- * update engine as necessary.
- *
- * DMDirc - Open Source IRC Client
- * Copyright (c) 2006-2011 Chris Smith, Shane Mc Cormack, Gregory Holmes,
- * Michael Nixon
- *
- * Permission is hereby granted, free of charge, to any person obtaining a copy
- * of this software and associated documentation files (the "Software"), to deal
- * in the Software without restriction, including without limitation the rights
- * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
- * copies of the Software, and to permit persons to whom the Software is
- * furnished to do so, subject to the following conditions:
- *
- * The above copyright notice and this permission notice shall be included in
- * all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
- * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
- * SOFTWARE.
- *}
-program Uninstaller;
-{$IFDEF FPC}
-	{$MODE Delphi}
-{$ENDIF}
-// Use this instead of {$APPTYPE XXX}
-// APP_XXX is the same as {$APPTYPE XXX}
-// Defaults to console
-// This is a work-around for a bug in FPC Cross Compiling to windows in delphi
-// mode (IsConsole is always true)
-{$DEFINE APP_GUI}
-
-// This block actually does the work for the above work-around
-{$IFDEF APP_GUI}
-	{$APPTYPE GUI}
-{$ELSE}
-	{$IFDEF APP_FS}
-		{$APPTYPE FS}
-	{$ELSE}
-		{$IFDEF APP_TOOL}
-			{$DEFINE APP_CONSOLE}
-			{$APPTYPE TOOL}
-		{$ELSE}
-			{$DEFINE APP_CONSOLE}
-			{$APPTYPE CONSOLE}
-		{$ENDIF}
-	{$ENDIF}
-{$ENDIF}
-
-uses shared, Windows, SysUtils, registry, Vista;
-procedure InitCommonControls; stdcall; External 'comctl32.dll' name 'InitCommonControls';
-
-{$R uninstall.res}
-{ ---------------------------------------------------------------------------- }
-
-{ ----------------------------------------------------------------------------
-  Create a temp directory and return the path to it
-  ---------------------------------------------------------------------------- }
-function GetTempDirectory(): String;
-var
-	buf: array[0..MAX_PATH] of Char;
-	wintemp, temp: String;
-begin
-	GetTempPath(SizeOf(buf)-1, buf);
-	wintemp := StrPas(buf);
-	Randomize;
-	temp := '\DMDirc-uninstaller-'+inttostr(1000 + Random(1000));
-	while (DirectoryExists(wintemp+temp+'\')) do begin
-		temp := temp+'-'+inttostr(1+Random(1000));
-	end;
-	MkDir(wintemp+temp+'\');
-	result := wintemp+temp+'\';
-end;
-
-{ ----------------------------------------------------------------------------
-  Delete a directory and all files it contains
-  ---------------------------------------------------------------------------- }
-function KillDir(Dir: string): Integer;
-var
-	searchResult: TSearchRec;
-begin
-	Result := 0;
-	if FindFirst(Dir+'\*', faDirectory + faHidden  + faReadOnly + faSysfile + faAnyFile, searchResult) = 0 then
-	begin
-		repeat
-			if (searchResult.attr and faDirectory) <> faDirectory then begin
-				Try
-					DeleteFile(Dir+'\'+searchResult.name);
-				Except
-					MessageBox(0, PChar('Unable to delete "'+Dir+'\'+searchResult.name+'" - is DMDirc still running?.'), 'DMDirc Uninstaller', MB_OK);
-				end;
-			end
-			else begin
-				if (searchResult.name <> '.') and (searchResult.name <> '..') then begin
-					KillDir(Dir+'\'+searchResult.name);
-				end;
-			end;
-		until FindNext(searchResult) <> 0;
-		FindClose(searchResult);
-	end;
-	Try
-		RmDir(Dir);
-	Except
-	end;
-end;
-
-{ ----------------------------------------------------------------------------
-  MAIN PROGRAM
-  ---------------------------------------------------------------------------- }
-var
-	TempDir: String;
-	InstallDir: String = '';
-	i: Integer;
-	Reg: TRegistry;
-	handlerInfo: String;
-	profileDir: String;
-	deleteProtocol: boolean;
-begin
-        InitCommonControls;
-	if (ParamCount > 0) then begin
-		for i := 1 to ParamCount do begin
-			InstallDir := InstallDir+' '+paramstr(i);
-		end;
-		InstallDir := trim(InstallDir);
-		KillDir(InstallDir);
-		profileDir := GetEnvironmentVariable('USERPROFILE');
-		
-		if IsWindowsVista then begin
-			// Vista
-			KillDir(GetEnvironmentVariable('APPDATA')+'\Microsoft\Windows\Start Menu\Programs\DMDirc');
-			DeleteFile(GetEnvironmentVariable('USERPROFILE')+'\AppData\Roaming\Microsoft\Internet Explorer\Quick Launch\DMDirc.lnk');
-			DeleteFile(GetEnvironmentVariable('USERPROFILE')+'\Desktop\DMDirc.lnk');
-			profileDir := profileDir+'\AppData\Roaming\DMDirc';
-		end
-		else begin
-			// Not Vista
-			KillDir(GetEnvironmentVariable('USERPROFILE')+'\Start Menu\Programs\DMDirc');
-			DeleteFile(GetEnvironmentVariable('USERPROFILE')+'\Application Data\Microsoft\Internet Explorer\Quick Launch\DMDirc.lnk');
-			DeleteFile(GetEnvironmentVariable('USERPROFILE')+'\Desktop\DMDirc.lnk');
-			profileDir := profileDir+'\Application Data\DMDirc';
-		end;
-		// Remove irc:// handler if it is us.
-		deleteProtocol := false;
-		Reg := TRegistry.Create;
-		Reg.RootKey := HKEY_CLASSES_ROOT;
-		if Reg.OpenKey('irc\Shell\open\command', false) then begin
-			handlerInfo := Reg.ReadString('');
-			if (handlerInfo = '"'+InstallDir+'DMDirc.exe" -c %1') then begin
-				deleteProtocol := true;
-			end
-		end;
-		Reg.CloseKey;
-		Reg.Free;
-		
-		if deleteProtocol then begin
-			Reg := TRegistry.Create;
-			Reg.RootKey := HKEY_CLASSES_ROOT;
-			Reg.DeleteKey('irc\Shell\open\command');
-			Reg.DeleteKey('irc\Shell\open');
-			Reg.DeleteKey('irc\Shell');
-			Reg.DeleteKey('irc\DefaultIcon');
-			Reg.DeleteKey('irc');
-			Reg.CloseKey;
-			Reg.Free;
-		end;
-			
-		Reg := TRegistry.Create;
-		Reg.RootKey := HKEY_LOCAL_MACHINE;
-		Reg.DeleteKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\DMDirc');
-		Reg.CloseKey;
-		Reg.Free;
-		
-		if (FileExists(profileDir+'\dmdirc.config')) then begin
-			if MessageBox(0, PChar('A dmdirc profile has been detected ('+profileDir+') '+#13#10+'Do you want to delete it as well?'), 'DMDirc Uninstaller', MB_YESNO) = IDYES then begin
-				KillDir(profileDir);
-			end;
-		end;
-		
-		showmessage('DMDirc has been uninstalled from "'+InstallDir+'".', 'DMDirc Uninstaller', 'Uninstall Successful');
-	end
-	else if askQuestion('This will uninstall DMDirc. '+#13#10+#13#10+'Do you want to continue?', 'DMDirc Uninstaller') then begin
-		if (ExecAndWait('java -jar "' + ExtractFileDir(paramstr(0)) + '\DMDirc.jar" -k', true) <> 0) then begin
-			TempDir := GetTempDirectory;
-			CopyFile(pchar(paramstr(0)), pchar(TempDir+'/uninstall.exe'), false);
-			Launch('"'+TempDir+'/uninstall.exe" '+ExtractFileDir(paramstr(0))+'\');
-		end else begin
-			showError('Uninstall Aborted - DMDirc is still running.' +
-                #13#10 + 'Please close DMDirc before continuing',
-                'DMDirc Uninstaller', False, False);
-		end;
-	end;
-end.

installer/windows/makeInstallerWindows.sh

@@ -1,661 +0,0 @@
-#!/bin/sh
-#
-# This script generates a .exe file that will install DMDirc
-#
-# DMDirc - Open Source IRC Client
-# Copyright (c) 2006-2011 Chris Smith, Shane Mc Cormack, Gregory Holmes
-#
-# Permission is hereby granted, free of charge, to any person obtaining a copy
-# of this software and associated documentation files (the "Software"), to deal
-# in the Software without restriction, including without limitation the rights
-# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-# copies of the Software, and to permit persons to whom the Software is
-# furnished to do so, subject to the following conditions:
-#
-# The above copyright notice and this permission notice shall be included in
-# all copies or substantial portions of the Software.
-#
-# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-# SOFTWARE.
-
-# Name of the extractor
-RUNNAME=extractor.exe
-# Name of the installer (without .exe)
-INSTALLNAME=DMDirc-Setup
-# Name of the internal file
-INTNAME=extractor.7z
-# full name of the files to output to
-RUNNAME="${PWD}/${RUNNAME}"
-INTNAME="${PWD}/${INTNAME}"
-# Get 7zip path
-ZIP=`which 7z`
-
-PWDIR="${PWD}"
-# Windows binaries need real paths not cygwin-y pathhs.
-if [ "${WINDIR}" != "" ]; then
-	PWDIR=`echo "${PWDIR}" | sed 's#^/c/#c:/#'`
-fi;
-
-if [ "" = "${ZIP}" ]; then
-	echo "7Zip not found, failing."
-	exit 1;
-fi
-
-# Compress stuff!
-compress() {
-	FLAGS="-y"
-	if [ "${WINDIR}" = "" ]; then
-		FLAGS="${FLAGS}l"
-	fi;
-	
-	"${ZIP}" a ${FLAGS} "${INTNAME}" $@ 2>/dev/null || {
-		echo "Compression failed."
-		kill -15 $$;
-	};
-}
-
-# Get signcode path
-SIGNCODE=`which signcode`
-
-if [ "" = "${SIGNCODE}" ]; then
-	echo "Signcode not found. EXE's will not be digitally signed."
-fi
-
-# Sign stuff!
-signexe() {
-return;
-	if [ "" != "${SIGNCODE}" ]; then
-		if [ -e "../signing/DMDirc.spc" -a -e "../signing/DMDirc.pvk" ]; then
-			echo "Digitally Signing EXE (${@})..."
-			${SIGNCODE} -spc "../signing/DMDirc.spc" -v "../signing/DMDirc.pvk" -i "http://www.dmdirc.com/" -n "DMDirc Installer" $@ 2>/dev/null || {
-				kill -15 $$;
-			};
-			rm ${@}.sig
-			rm ${@}.bak
-		fi
-	fi
-}
-
-WGET=`which wget`
-FETCH=`which fetch`
-CURL=`which curl`
-getFile() {
-	URL=${1}
-	OUTPUT=${2}
-
-	if [ "${WGET}" != "" ]; then
-		"${WGET}" -O "${OUTPUT}" ${URL}
-	elif [ "${FETCH}" != "" ]; then
-		"${FETCH}" -o "${OUTPUT}" ${URL}
-	elif [ "${CURL}" != "" ]; then
-		"${CURL}" -o "${OUTPUT}" ${URL}
-	fi;
-}
-
-# Check for some CLI params
-compileJar="false"
-compileSetup="false"
-useOldSetup="false"
-isRelease=""
-useUPX="false"
-finalTag=""
-signEXE="true"
-compilerFlags="-Xs -XX -O2 -Or -Op1"
-BRANCH="0"
-plugins=""
-location="../../"
-current="1"
-jarfile=""
-jre=""
-jrename="jre" # Filename for JRE without the .exe
-TAGGED=""
-
-showHelp() {
-	echo "This will generate a DMDirc installer for a windows based system."
-	echo "The following command line arguments are known:"
-	echo "---------------------"
-	echo "-h, --help                Help information"
-	echo "-b, --branch              Release in -r is a branch "
-	echo "-s, --setup               Recompile the .exe file"
-	echo "-o,                       If setup.exe compile fails, use old version"
-	echo "-p, --plugins <plugins>   What plugins to add to the jar file"
-	echo "-c, --compile             Recompile the .jar file"
-	echo "-u, --unsigned            Don't sign the exe"
-	echo "-e, --extra <tag>         Tag to add to final exe name to distinguish this build from a standard build"
-	echo "-f, --flags <flags>       Extra flags to pass to the compiler"
-	echo "    --jre                 Include the JRE in this installer"
-	echo "    --jar <file>          use <file> as DMDirc.jar"
-	echo "    --current             Use the current folder as the base for the build"
-# This is not in the help cos its crappy really, and makes little/no difference to the
-# exe size unless debugging information is added using --flags, in which case the person
-# probably is Dataforce and knows about this flag anyway
-#	echo "    --upx                 UPX binary if UPX is available on the path,"
-#	echo "                          (Compression Level: 4 for signed exe, 9 for unsigned)"
-	echo "---------------------"
-	exit 0;
-}
-
-while test -n "$1"; do
-	case "$1" in
-		--plugins|-p)
-			shift
-			plugins=${1}
-			;;
-		--jar)
-			shift
-			jarfile=${1}
-			;;
-		--jre)
-			jre="http://www.dmdirc.com/getjava/windows/all"
-			;;
-		--jre64)
-			# No specific jre64 for windows.
-			echo "No specific 64ibt JRE for windows, exiting"
-			exit 1;
-			;;
-		--current)
-			location="../../"
-			current="1"
-			;;
-		--compile|-c)
-			compileJar="true"
-			;;
-		--setup|-s)
-			compileSetup="true"
-			;;
-		-o)
-			useOldSetup="true"
-			;;
-		--release|-r)
-			shift
-			isRelease=${1}
-			;;
-		--extra|-e)
-			shift
-			finalTag="-${1}"
-			;;
-		--flags|-f)
-			shift
-			compilerFlags="${1} "
-			;;
-		--upx)
-			useUPX="true"
-			;;
-		--unsigned|-u)
-			signEXE="false"
-			;;
-		--help|-h)
-			showHelp;
-			;;
-		--branch|-b)
-			BRANCH="1"
-			;;
-		--tag|-t)
-			TAGGED=`git describe --tags`
-			TAGGED=${TAGGED%%-*}
-			;;
-	esac
-	shift
-done
-
-# Go!
-echo "-----------"
-if [ -e "${RUNNAME}" ]; then
-	echo "Removing existing .exe file"
-	rm -Rf "${RUNNAME}"
-fi
-if [ -e "${INTNAME}" ]; then
-	echo "Removing existing .7z file"
-	rm -Rf "${INTNAME}"
-fi
-echo "Creating .7z file"
-
-if [ "" = "${current}" ]; then
-	jarPath="${location}trunk"
-else
-	jarPath="${location}"
-fi
-
-if [ "" = "${jarfile}" ]; then
-	jarfile=${jarPath}"/dist/DMDirc.jar"
-	if [ ! -e ${jarPath}"/dist/DMDirc.jar" -o "${compileJar}" = "true" ]; then
-		echo "Creating jar.."
-		OLDPWD=${PWD}
-		cd ${jarPath}
-
-		rm -Rf build dist
-		ant jar
-		if [ ! -e "dist/DMDirc.jar" ]; then
-			echo "There was an error creating the .jar file. Aborting."
-			exit 1;
-		fi;
-		cd ${OLDPWD}
-	fi;
-elif [ ! -e "${jarfile}" ]; then
-	echo "Requested Jar file (${jarfile}) does not exist."
-	exit 1;
-fi;
-
-if [ "" = "${plugins}" ]; then
-	echo "Linking jar (${jarfile}).."
-	ln -sf ${jarfile} "./DMDirc.jar"
-else
-	echo "Copying jar (${jarfile}).."
-	cp ${jarfile} "./DMDirc.jar"
-
-	echo "Adding plugins to jar"
-	ln -sf ${jarPath}"/plugins"
-	pluginList=""
-	for plugin in ${plugins}; do
-		pluginList=${pluginList}" plugins/${plugin}"
-	done
-	jar -uvf "DMDirc.jar" ${pluginList}
-
-	../../updateBundledPlugins.sh "DMDirc.jar";
-	rm -Rf plugins;
-fi
-
-echo "	ReleaseNumber: String = '${TAGGED}';" > SetupConsts.inc
-
-FILES=""
-# Icon Res file
-if [ -e ${jarPath}"/src/com/dmdirc/res/icon.ico" ]; then
-	ln -sf ${jarPath}"/src/com/dmdirc/res/icon.ico" ./icon.ico
-	FILES="${FILES} ${PWDIR}/icon.ico"
-fi
-echo "icon.ico ICON icon.ico" > icon.rc
-
-# Other resources
-echo "extractor RCDATA extractor.exe" > files.rc
-
-COMPILER_IS_BROKEN="0";
-
-NUM="${TAGGED}"
-
-
-
-# Version Numbers
-if [ "" = "${NUM}" ]; then
-	MAJORVER="0"
-	MINORVER="0"
-	RELEASE="0"
-	EXTRAVER="0"
-	TEXTVER="${isRelease}"
-	PRIVATE="1"
-	USER=`whoami`
-	USER=`echo "${USER}" | sed 's#\\\\#\\\\\\\\#g'`
-	HOST=`hostname`
-	DATE=`date`
-else
-	MAJORVER=${NUM%%.*}
-	SUBVER=${NUM#*.}
-	EXTRAVER="0"
-	DOT=`expr index "${SUBVER}" .`
-	if [ "${DOT}" = "0" ]; then
-		MINORVER=${SUBVER}
-		RELEASE="0"
-	else
-		MINORVER=${SUBVER%%.*}
-		END=${SUBVER##*.}
-		RELEASE=${END##*[^0-9]}
-	fi
-	TEXTVER=$NUM
-	PRIVATE="0"
-fi;
-
-# Information for the below section:
-#
-# http://support.microsoft.com/kb/139491
-# http://msdn2.microsoft.com/en-us/library/aa381049.aspx
-# http://courses.cs.vt.edu/~cs3304/FreePascal/doc/prog/node14.html#SECTION001440000000000000000
-# http://tortoisesvn.tigris.org/svn/tortoisesvn/trunk/src/Resources/TortoiseShell.rc2
-
-echo "1 VERSIONINFO" > version.rc.1
-echo "FILEVERSION 1, 0, 0, 0" >> version.rc.1
-echo "PRODUCTVERSION ${MAJORVER}, ${MINORVER}, ${RELEASE}, ${EXTRAVER}" >> version.rc.1
-if [ "${PRIVATE}" = "1" ]; then
-	if [ "${COMPILER_IS_BROKEN}" = "0" ]; then
-		echo "FILEFLAGSMASK 0x000A" >> version.rc.1
-		echo "FILEFLAGS 0x3f" >> version.rc.1
-	else
-		echo "FILEFLAGS 0x000A" >> version.rc.1
-	fi;
-else
-	echo "FILEFLAGSMASK 0" >> version.rc.1
-fi;
-echo "FILEOS 0x40004" >> version.rc.1
-echo "FILETYPE 1" >> version.rc.1
-echo "BEGIN" >> version.rc.1
-echo "	BLOCK \"StringFileInfo\"" >> version.rc.1
-echo "	BEGIN" >> version.rc.1
-echo "		BLOCK \"040004E4\"" >> version.rc.1
-echo "		BEGIN" >> version.rc.1
-echo "			VALUE \"Comments\", \"http://www.dmdirc.com/\"" >> version.rc.1
-echo "			VALUE \"CompanyName\", \"DMDirc\"" >> version.rc.1
-cat version.rc.1 > version.rc
-cat version.rc.1 > uninstallversion.rc
-rm version.rc.1
-echo "			VALUE \"FileDescription\", \"Installer for DMDirc ${TEXTVER}\"" >> version.rc
-echo "			VALUE \"FileDescription\", \"Uninstaller for DMDirc\"" >> uninstallversion.rc
-
-echo "			VALUE \"FileVersion\", \"2.0\"" > version.rc.2
-echo "			VALUE \"InternalName\", \"DMDirc.jar\"" >> version.rc.2
-echo "			VALUE \"LegalCopyright\", \"Copyright (c) 2006-2011 Chris Smith, Shane Mc Cormack, Gregory Holmes\"" >> version.rc.2
-echo "			VALUE \"OriginalFilename\", \"$2\"" >> version.rc.2
-echo "			VALUE \"ProductName\", \"DMDirc\"" >> version.rc.2
-echo "			VALUE \"ProductVersion\", \"${TEXTVER}\"" >> version.rc.2
-if [ "${PRIVATE}" = "1" ]; then
-	echo "			VALUE \"PrivateBuild\", \"Build by ${USER}@${HOST} on ${DATE}\"" >> version.rc.2
-fi;
-echo "		END" >> version.rc.2
-echo "	END" >> version.rc.2
-echo "	BLOCK \"VarFileInfo\"" >> version.rc.2
-echo "	BEGIN" >> version.rc.2
-echo "		VALUE \"Translation\", 0x400, 1252" >> version.rc.2
-echo "	END" >> version.rc.2
-echo "END" >> version.rc.2
-
-
-cat version.rc.2 >> version.rc
-cat version.rc.2 >> uninstallversion.rc
-rm version.rc.2
-
-echo "1 24 \"UAC.manifest\"" > UAC.rc
-echo "1 24 \"UAC_uninstaller.manifest\"" > UAC_uninstaller.rc
-
-# Build res files
-#windres -F pe-i386 -i version.rc -o version.res
-#windres -F pe-i386 -i files.rc -o files.res
-#windres -F pe-i386 -i icon.rc -o icon.res
-
-# UAC really needs to match the product name / description properly
-# so we have a special one for the uninstaller
-cat UAC_uninstaller.rc > uninstall.rc
-# Next line seems to be silly because we add a version resource
-# later as all.rc is not for the uninstaller.
-# cat uninstallversion.rc >> all.rc
-cat uninstallversion.rc >> uninstall.rc
-cat icon.rc >> uninstall.rc
-
-windres -F pe-i386 -i uninstall.rc -o uninstall.res
-
-cat UAC.rc > all.rc
-cat version.rc >> all.rc
-cat files.rc >> all.rc
-cat icon.rc >> all.rc
-# Build later after extractor.exe exists
-
-cat UAC.rc > most.rc
-cat version.rc >> most.rc
-cat icon.rc >> most.rc
-
-windres -F pe-i386 -i most.rc -o most.res
-
-FILES="${FILES} ${PWDIR}/DMDirc.jar ${PWDIR}/Setup.exe";
-if [ "" != "${jre}" ]; then
-	if [ ! -e "../common/${jrename}.exe" ]; then
-		echo "Downloading JRE to include in installer"
-		getFile "${jre}" "../common/${jrename}.exe"
-	fi
-	ln -sf ../common/${jrename}.exe jre.exe
-	FILES="${FILES} ${PWDIR}/jre.exe"
-fi;
-DELETEFILES=${FILES}
-if [ "" != "${DMDIRC_FPC}" ]; then
-	FPC=${DMDIRC_FPC}
-else
-	FPC=`which fpc`
-fi;
-lazarusDir="/usr/share/lazarus"
-if [ ! -e "${lazarusDir}/lcl" ]; then
-	lazarusDir="/usr/lib/lazarus/"
-fi;
-
-
-compilerFlags="-Sd -Twin32 ${compilerFlags}";
-extraFlags=""
-if [ ! -e "Setup.exe"  -o "${compileSetup}" = "true" ]; then
-	echo "Setup.exe does not exist. Lets try and compile it."
-	if [ "${FPC}" = "" ]; then
-		echo "FPC Compiler not found, Setup.exe can not be built."
-		exit 1;
-	else
-		echo "Building Setup.exe..."
-		extraFlags="-dKOL -Fu${PWDIR}/../../libwin/kolfpc -Fu{$PWDIR}/../../libwin/lcore -Fu{$PWDIR} -Fu${PWDIR}/../../libwin"
-		echo ${FPC} ${compilerFlags} ${extraFlags} Setup.dpr
-		${FPC} ${compilerFlags} ${extraFlags} Setup.dpr
-		if [ $? -ne 0 ]; then
-			if [ -e "Setup.exe" -a "${useOldSetup}" = "true" ]; then
-				echo "Unable to compile Setup.exe, using existing version."
-			else
-				echo "Unable to compile Setup.exe, terminating."
-				exit 1;
-			fi
-		fi;
-	fi
-fi
-
-ls
-if [ ! -e "Setup.exe" ]; then
-	echo "Still can't find Setup.exe, terminating."
-	exit 1;
-fi
-
-echo "Compressing files.."
-
-# Shortcut.exe is from http://www.optimumx.com/download/#Shortcut
-if [ ! -e Shortcut.exe ]; then
-	getFile "http://binary.dmdirc.com/Shortcut.zip" "Shortcut.zip"
-	unzip -q Shortcut.zip Shortcut.exe
-	rm Shortcut.zip
-fi
-FILES="${FILES} ${PWDIR}/Shortcut.exe"
-DELETEFILES="${DELETEFILES} Shortcut.exe"
-
-if [ "${isRelease}" != "" ]; then
-	DOCSDIR=${jarPath}
-else
-	DOCSDIR="../common"
-fi
-
-if [ -e "${DOCSDIR}/README.TXT" ]; then
-	ln -sf "${DOCSDIR}/README.TXT" .
-	FILES="${FILES} ${PWDIR}/README.TXT"
-	DELETEFILES="${DELETEFILES} README.TXT"
-fi
-
-if [ -e "${DOCSDIR}/CHANGES.TXT" ]; then
-	ln -sf "${DOCSDIR}/CHANGES.TXT" .
-	FILES="${FILES} ${PWDIR}/CHANGES.TXT"
-	DELETEFILES="${DELETEFILES} CHANGES.TXT"
-elif [ -e "${DOCSDIR}/CHANGELOG.TXT" ]; then
-	ln -sf "${DOCSDIR}/CHANGELOG.TXT" .
-	FILES="${FILES} ${PWDIR}/CHANGELOG.TXT"
-	DELETEFILES="${DELETEFILES} CHANGELOG.TXT"
-fi
-
-if [ -e "${jarPath}/launcher/windows" ]; then
-	# Try to compile all
-	olddir=${PWD}
-	cd "${jarPath}/launcher/windows/"
-	sh compile.sh
-	cd ${olddir}
-	# Now add to file list.
-	for thisfile in `ls -1 ${jarPath}/launcher/windows/*.exe`; do
-		ln -sf ${thisfile} .
-		FILES="${FILES} ${PWDIR}/${thisfile}"
-	done
-fi
-
-extraFlags="-dKOL -Fu${PWDIR}/../../libwin/kolfpc -Fu{$PWDIR} -Fu${PWDIR}/../../libwin"
-echo ${FPC} ${compilerFlags} ${extraFlags} ${3}Uninstaller.dpr
-${FPC} ${compilerFlags} ${extraFlags} ${3}Uninstaller.dpr
-if [ -e "Uninstaller.exe" ]; then
-	FILES="${FILES} ${PWDIR}/Uninstaller.exe"
-#	DELETEFILES="${DELETEFILES} ${PWDIR}/Uninstaller.exe"
-fi
-
-# Add wget to allow downloading jre
-if [ ! -e "wget.exe" ]; then
-	getFile "http://binary.dmdirc.com/wget.exe" "wget.exe"
-fi;
-
-if [ ! -e "wget.exe" ]; then
-	echo "wget.exe not found, unable to continue."
-	exit 1;
-fi;
-
-FILES="${FILES} ${PWDIR}/wget.exe"
-
-compress $FILES
-
-echo "Creating config.."
-echo ";!@Install@!UTF-8!" > 7zip.conf
-if [ "${isRelease}" != "" ]; then
-	echo "Title=\"DMDirc Installation "${isRelease}"\"" >> 7zip.conf
-	echo "BeginPrompt=\"Do you want to install DMDirc "${isRelease}"?\"" >> 7zip.conf
-elif [ "${TAGGED}" != "" ]; then
-	echo "Title=\"DMDirc Installation "${TAGGED}"\"" >> 7zip.conf
-	echo "BeginPrompt=\"Do you want to install DMDirc "${TAGGED}"?\"" >> 7zip.conf
-else
-	echo "Title=\"DMDirc Installation\"" >> 7zip.conf
-	echo "BeginPrompt=\"Do you want to install DMDirc?\"" >> 7zip.conf
-fi;
-echo "ExecuteFile=\"Setup.exe\"" >> 7zip.conf
-echo ";!@InstallEnd@!" >> 7zip.conf
-
-if [ ! -e "7zS.sfx" ]; then
-	echo "Obtaining sfx stub.."
-	getFile "http://binary.dmdirc.com/7zS.sfx" "7zS.sfx"
-fi
-
-if [ ! -e "7zS.sfx" ]; then
-	echo "7zS.sfx not found, unable to continue."
-	exit 1;
-fi;
-
-echo "Creating .exe"
-cat 7zS.sfx 7zip.conf "${INTNAME}" > "${RUNNAME}"
-
-doRename=0
-if [ "${TAGGED}" != "" ]; then
-	doRename=1
-fi;
-
-if [ ${doRename} -eq 1 ]; then
-	if [ "${TAGGED}" = "" ]; then
-		releaseTag=branch-${isRelease}
-	else
-		releaseTag=${TAGGED}
-	fi;
-	ORIGNAME="DMDirc-${releaseTag}-Setup${finalTag}.exe"
-else
-	ORIGNAME="${INSTALLNAME}${finalTag}.exe"
-fi;
-
-echo "Building launcher";
-
-MD5BIN=`which md5sum`
-AWK=`which awk`
-MD5SUM=""
-if [ "${MD5BIN}" != "" -a "${AWK}" != "" ]; then
-	MD5SUM=`${MD5BIN} extractor.exe | ${AWK} '{print $1}'`
-fi
-echo "const" > consts.inc
-echo "	MD5SUM: String = '${MD5SUM}';" >> consts.inc
-
-# Code to extract and launch resource
-echo "ExtractResource('extractor', 'dmdirc_extractor.exe', TempDir);" > ExtractCode.inc
-if [ "${MD5SUM}" != "" ]; then
-	echo "if FindCmdLineSwitch('-nomd5') or FindCmdLineSwitch('nomd5') or checkMD5(TempDir+'dmdirc_extractor.exe') then begin" >> ExtractCode.inc
-	echo -n "	"; # Oh so important for code formatting!
-fi;
-echo "Launch(TempDir+'dmdirc_extractor.exe');" >> ExtractCode.inc
-if [ "${MD5SUM}" != "" ]; then
-	echo "end" >> ExtractCode.inc
-	echo "else begin" >> ExtractCode.inc
-	echo "	ErrorMessage := 'This copy of the DMDirc installer appears to be damaged and will now exit';" >> ExtractCode.inc
-	echo "	ErrorMessage := ErrorMessage+#13#10+'You may choose to skip this check and run it anyway by passing the /nomd5 parameter';" >> ExtractCode.inc
-	echo "	ErrorMessage := ErrorMessage+#13#10+'';" >> ExtractCode.inc
-	echo "	ErrorMessage := ErrorMessage+#13#10;" >> ExtractCode.inc
-	echo "	ErrorMessage := ErrorMessage+#13#10+'If you feel this is incorrect, or you require some further assistance,';" >> ExtractCode.inc
-	echo "	ErrorMessage := ErrorMessage+#13#10+'please feel free to contact us.';" >> ExtractCode.inc
-	echo "	" >> ExtractCode.inc
-	echo "	MessageBox(0, PChar(ErrorMessage), 'Sorry, setup is unable to continue', MB_OK + MB_ICONSTOP);" >> ExtractCode.inc
-	echo "end;" >> ExtractCode.inc
-fi
-
-windres -F pe-i386 -i all.rc -o all.res
-
-echo ${FPC} ${compilerFlags} ${3}Launcher.dpr
-${FPC} ${compilerFlags} ${3}Launcher.dpr
-if [ $? -ne 0 ]; then
-	if [ -e "Launcher.exe" ]; then
-		echo "Unable to compile Launcher.exe, using existing version."
-	else
-		echo "Unable to compile Launcher.exe, terminating."
-		exit 1;
-	fi
-fi
-
-rm -f *.res
-rm -f *.rc
-rm -f *.inc
-rm -f *.ppu
-
-FULLINSTALLER="${PWD}/${INSTALLNAME}${finalTag}.exe"
-mv Launcher.exe ${FULLINSTALLER}
-
-if [ "${useUPX}" = "true" ]; then
-	UPX=`which upx`
-	if [ "${UPX}" != "" ]; then
-		if [ "${signEXE}" = "true" ]; then
-			${UPX} -4 ${FULLINSTALLER}
-		else
-			${UPX} -9 ${FULLINSTALLER}
-		fi
-	fi
-fi
-
-echo "Chmodding.."
-chmod a+x ${FULLINSTALLER}
-if [ "${signEXE}" = "true" ]; then
-	echo "Signing.."
-	signexe ${FULLINSTALLER}
-else
-	echo "Not Signing.."
-fi;
-
-if [ "" != "${jre}" ]; then
-	ORIGNAME=`echo ${ORIGNAME} | sed "s/.exe$/.${jrename}.exe/"`
-fi;
-
-mv ${FULLINSTALLER} ../output/${ORIGNAME}
-
-# Quick hack to prevent deleting of 2 important files in ${FILES}
-mv Setup.exe Setup.exe.tmp
-mv Shortcut.exe Shortcut.exe.tmp
-
-rm -f ${DELETEFILES}
-rm -f ./7zip.conf
-rm -f ./*.o
-rm -f ./*.or
-rm -f ${RUNNAME}
-rm -f ${INTNAME}
-rm -f icon.ico
-
-# And un-hack
-mv Setup.exe.tmp Setup.exe
-mv Shortcut.exe.tmp Shortcut.exe
-
-echo "-----------"
-echo "Done."
-echo "-----------"
-
-# and Done \o
-exit 0;

libwin/Vista.pas

@@ -1,220 +0,0 @@
-{*
- * Vista image improvements from http://www.installationexcellence.com/articles/VistaWithDelphi/Original/Index.html
- * and http://www.installationexcellence.com/articles/VistaWithDelphi/Index.html
- *
- * This application launches DMDirc on windows and passes control to the
- * update engine as necessary.
- *
- * DMDirc - Open Source IRC Client
- * Copyright (c) 2006-2010 Chris Smith, Shane Mc Cormack, Gregory Holmes,
- * Michael Nixon
- *
- * Permission is hereby granted, free of charge, to any person obtaining a copy
- * of this software and associated documentation files (the "Software"), to deal
- * in the Software without restriction, including without limitation the rights
- * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
- * copies of the Software, and to permit persons to whom the Software is
- * furnished to do so, subject to the following conditions:
- *
- * The above copyright notice and this permission notice shall be included in
- * all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
- * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
- * SOFTWARE.
- *}
-{* NOTE: The version in the installer/ directory is the one to edit! *}
-unit Vista;
-
-interface
-
-uses Windows, SysUtils;
-
-function IsWindowsVista: Boolean;
-function TaskDialog(const AHandle: THandle; const ATitle, ADescription, AContent: WideString; const Icon, Buttons: integer; includeDescInXP: boolean = false; stripLineFeed: boolean = true): Integer;
-//procedure SetVistaFonts(const AForm: TCustomForm);
-
-const
-  VistaFont = 'Segoe UI'; 
-  VistaContentFont = 'Calibri';
-  XPContentFont = 'Verdana';
-  XPFont = 'Tahoma';
-
-  TD_ICON_BLANK = 0;
-  TD_ICON_WARNING = 84;
-  TD_ICON_QUESTION = 99;
-  TD_ICON_ERROR = 98;
-  TD_ICON_INFORMATION = 81;
-  TD_ICON_SHIELD_QUESTION = 104;
-  TD_ICON_SHIELD_ERROR = 105;
-  TD_ICON_SHIELD_OK = 106;
-  TD_ICON_SHIELD_WARNING = 107;
-
-  TD_BUTTON_OK = 1;
-  TD_BUTTON_YES = 2;
-  TD_BUTTON_NO = 4;
-  TD_BUTTON_CANCEL = 8;
-  TD_BUTTON_RETRY = 16;
-  TD_BUTTON_CLOSE = 32;
-
-  TD_RESULT_OK = 1;
-  TD_RESULT_CANCEL = 2;
-  TD_RESULT_RETRY = 4;
-  TD_RESULT_YES = 6;
-  TD_RESULT_NO = 7;
-  TD_RESULT_CLOSE = 8;
-  
-  mrNone = 0;
-  mrOK = mrNone + 1;
-  mrCancel = mrNone + 2;
-  mrAbort = mrNone + 3;
-  mrRetry = mrNone + 4;
-  mrYes = mrNone + 6;
-  mrNo = mrNone + 7;
-
-implementation
-
-{*
-procedure SetVistaFonts(const AForm: TCustomForm);
-begin
-  if IsWindowsVista and not SameText(AForm.Font.Name, VistaFont) and (Screen.Fonts.IndexOf(VistaFont) >= 0) then
-  begin
-    AForm.Font.Size := AForm.Font.Size + 1;
-    AForm.Font.Name := VistaFont;
-  end;
-end;
-*}
-
-function IsWindowsVista: Boolean;
-var
-  VerInfo: TOSVersioninfo;
-begin
-  VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
-  GetVersionEx(VerInfo);
-  Result := VerInfo.dwMajorVersion >= 6;
-end;
-
-// http://www.swissdelphicenter.ch/en/showcode.php?id=1692
-{:Converts Unicode string to Ansi string using specified code page.
-  @param   ws       Unicode string.
-  @param   codePage Code page to be used in conversion.
-  @returns Converted ansi string.
-}
-function WideStringToString(const ws: WideString; codePage: Word): AnsiString;
-var
-  l: integer;
-begin
-  if ws = '' then begin
-    Result := ''
-  end
-  else begin
-    l := WideCharToMultiByte(codePage, WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR, @ws[1], - 1, nil, 0, nil, nil);
-    SetLength(Result, l - 1);
-    if l > 1 then begin
-      WideCharToMultiByte(codePage, WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR, @ws[1], - 1, @Result[1], l - 1, nil, nil);
-    end;
-  end;
-end;
-
-
-//from http://www.tmssoftware.com/atbdev5.htm
-function TaskDialog(const AHandle: THandle; const ATitle, ADescription, AContent: WideString; const Icon, Buttons: integer; includeDescInXP: boolean = false; stripLineFeed: boolean = true): Integer;
-type
-        tTaskDialogProc = function(HWND: THandle; hInstance: THandle; cTitle, cDescription, cContent: pwidechar; Buttons: Integer; Icon: integer; ResButton: pinteger): integer; stdcall;
-var
-  DLLHandle: THandle;
-  res: integer;
-  wS: WideString;
-  S: String;
-  {$IFDEF MESSAGEDLG}
-  Btns: TMsgDlgButtons;
-  DlgType: TMsgDlgType;
-  {$ELSE}
-  Btns: Integer;
-  myIcon: Integer;
-  {$ENDIF}
-  TaskDialogFound: boolean;
-  TaskDialogProc: tTaskDialogProc;
-begin
-  TaskDialogFound := false;
-  Result := 0;
-  if IsWindowsVista then begin
-    DLLHandle := LoadLibrary('comctl32.dll');
-    if DLLHandle >= 32 then begin
-      TaskDialogProc := tTaskDialogProc(GetProcAddress(DLLHandle,'TaskDialog'));
-      
-      if Assigned(TaskDialogProc) then begin
-        
-        if stripLineFeed then begin
-          wS := StringReplace(AContent, #10, '', [rfReplaceAll]);
-          wS := StringReplace(wS, #13, '', [rfReplaceAll]);
-        end
-        else begin
-          wS := AContent;
-        end;
-
-        TaskDialogProc(AHandle, 0, PWideChar(ATitle), PWideChar(ADescription), PWideChar(wS), Buttons, Icon, @res);
-        TaskDialogFound := true;
-        Result := mrOK;
-        case res of
-          TD_RESULT_CANCEL : Result := mrCancel;
-          TD_RESULT_RETRY : Result := mrRetry;
-          TD_RESULT_YES : Result := mrYes;
-          TD_RESULT_NO : Result := mrNo;
-          TD_RESULT_CLOSE : Result := mrAbort;
-        end;
-      end;
-      FreeLibrary(DLLHandle);
-    end;
-  end;
-  
-  if not TaskDialogFound then begin
-    S := '';
-    if includeDescInXP then S := ADescription + #10#13 + #10#13 + AContent else S := AContent;
-    
-    {$IFDEF MESSAGEDLG}
-      Btns := [];
-      if Buttons and TD_BUTTON_OK = TD_BUTTON_OK then Btns := Btns + [MBOK];
-      if Buttons and TD_BUTTON_YES = TD_BUTTON_YES then Btns := Btns + [MBYES];
-      if Buttons and TD_BUTTON_NO = TD_BUTTON_NO then Btns := Btns + [MBNO];
-      if Buttons and TD_BUTTON_CANCEL = TD_BUTTON_CANCEL then Btns := Btns + [MBCANCEL];
-      if Buttons and TD_BUTTON_RETRY = TD_BUTTON_RETRY then Btns := Btns + [MBRETRY];
-  
-      if Buttons and TD_BUTTON_CLOSE = TD_BUTTON_CLOSE then Btns := Btns + [MBABORT];
-  
-      DlgType := mtCustom;
-  
-      case Icon of
-        TD_ICON_WARNING : DlgType := mtWarning;
-        TD_ICON_QUESTION : DlgType := mtConfirmation;
-        TD_ICON_ERROR : DlgType := mtError;
-        TD_ICON_INFORMATION: DlgType := mtInformation;
-      end;
-  
-      Result := MessageDlg(S, DlgType, Btns, 0);
-    {$ELSE}
-      Btns := 0;
-      if Buttons and TD_BUTTON_OK = TD_BUTTON_OK then Btns := MB_OK;
-      if (Buttons and TD_BUTTON_YES = TD_BUTTON_YES) and (Buttons and TD_BUTTON_NO = TD_BUTTON_NO) then Btns := MB_YESNO;
-      if (Buttons and TD_BUTTON_CANCEL = TD_BUTTON_CANCEL) and (Buttons and TD_BUTTON_YES = TD_BUTTON_YES) and (Buttons and TD_BUTTON_NO = TD_BUTTON_NO) then Btns := MB_YESNOCANCEL;
-      if (Buttons and TD_BUTTON_CANCEL = TD_BUTTON_CANCEL) and (Buttons and TD_BUTTON_OK = TD_BUTTON_OK) then Btns := MB_OKCANCEL;
-      if (Buttons and TD_BUTTON_CANCEL = TD_BUTTON_CANCEL) and (Buttons and TD_BUTTON_RETRY = TD_BUTTON_RETRY) then Btns := MB_RETRYCANCEL;
-      
-      myIcon := 0;
-      case Icon of
-        TD_ICON_QUESTION : myIcon := MB_ICONQUESTION;
-        TD_ICON_ERROR : myIcon := MB_ICONSTOP;
-        TD_ICON_INFORMATION: myIcon := MB_ICONINFORMATION;
-      end;
-
-                        Result := MessageBox(0, pchar(S), pchar(String(ATitle)), Btns + myIcon);
-    {$ENDIF}
-  end;
-end;
-
-end.
-

libwin/kolfpc/COPYING

@@ -1 +0,0 @@
-See files COPYING.LIB and LICENCE.TXT in top directory

libwin/kolfpc/COPYING.LIB

@@ -1,517 +0,0 @@
-
-	  GNU LIBRARY GENERAL PUBLIC LICENSE
-	  ==================================
-                Version 2, June 1991
-
- Copyright (C) 1991 Free Software Foundation, Inc.
-                    675 Mass Ave, Cambridge, MA 02139, USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-[This is the first released version of the library GPL.  It is
- numbered 2 because it goes with version 2 of the ordinary GPL.]
-
-                        Preamble
-
-The licenses for most software are designed to take away your
-freedom to share and change it.  By contrast, the GNU General
-Public Licenses are intended to guarantee your freedom to share
-and change free software--to make sure the software is free for
-all its users.
-
-This license, the Library General Public License, applies to
-some specially designated Free Software Foundation software, and
-to any other libraries whose authors decide to use it.  You can
-use it for your libraries, too.
-
-When we speak of free software, we are referring to freedom, not
-price.  Our General Public Licenses are designed to make sure
-that you have the freedom to distribute copies of free software
-(and charge for this service if you wish), that you receive
-source code or can get it if you want it, that you can change
-the software or use pieces of it in new free programs; and that
-you know you can do these things.
-
-To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the
-rights. These restrictions translate to certain responsibilities
-for you if you distribute copies of the library, or if you
-modify it.
-
-For example, if you distribute copies of the library, whether
-gratis or for a fee, you must give the recipients all the rights
-that we gave you.  You must make sure that they, too, receive or
-can get the source code.  If you link a program with the
-library, you must provide complete object files to the
-recipients so that they can relink them with the library, after
-making changes to the library and recompiling it.  And you must
-show them these terms so they know their rights.
-
-Our method of protecting your rights has two steps: (1)
-copyright the library, and (2) offer you this license which
-gives you legal permission to copy, distribute and/or modify the
-library.
-
-Also, for each distributor's protection, we want to make certain
-that everyone understands that there is no warranty for this
-free library.  If the library is modified by someone else and
-passed on, we want its recipients to know that what they have is
-not the original version, so that any problems introduced by
-others will not reflect on the original authors' reputations.
- 
-Finally, any free program is threatened constantly by software
-patents.  We wish to avoid the danger that companies
-distributing free software will individually obtain patent
-licenses, thus in effect transforming the program into
-proprietary software.  To prevent this, we have made it clear
-that any patent must be licensed for everyone's free use or not
-licensed at all.
-
-Most GNU software, including some libraries, is covered by the
-ordinary GNU General Public License, which was designed for
-utility programs.  This license, the GNU Library General Public
-License, applies to certain designated libraries.  This license
-is quite different from the ordinary one; be sure to read it in
-full, and don't assume that anything in it is the same as in the
-ordinary license.
-
-The reason we have a separate public license for some libraries
-is that they blur the distinction we usually make between
-modifying or adding to a program and simply using it.  Linking a
-program with a library, without changing the library, is in some
-sense simply using the library, and is analogous to running a
-utility program or application program.  However, in a textual
-and legal sense, the linked executable is a combined work, a
-derivative of the original library, and the ordinary General
-Public License treats it as such.
-
-Because of this blurred distinction, using the ordinary General
-Public License for libraries did not effectively promote
-software sharing, because most developers did not use the
-libraries.  We concluded that weaker conditions might promote
-sharing better.
-
-However, unrestricted linking of non-free programs would deprive
-the users of those programs of all benefit from the free status
-of the libraries themselves.  This Library General Public
-License is intended to permit developers of non-free programs to
-use free libraries, while preserving your freedom as a user of
-such programs to change the free libraries that are incorporated
-in them.  (We have not seen how to achieve this as regards
-changes in header files, but we have achieved it as regards
-changes in the actual functions of the Library.)  The hope is
-that this will lead to faster development of free libraries.
-
-The precise terms and conditions for copying, distribution and
-modification follow.  Pay close attention to the difference
-between a "work based on the library" and a "work that uses the
-library".  The former contains code derived from the library,
-while the latter only works together with the library.
-
-Note that it is possible for a library to be covered by the
-ordinary General Public License rather than by this special one.
-
-                GNU LIBRARY GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
-0. This License Agreement applies to any software library which
-contains a notice placed by the copyright holder or other
-authorized party saying it may be distributed under the terms of
-this Library General Public License (also called "this
-License").  Each licensee is addressed as "you".
-
-A "library" means a collection of software functions and/or data
-prepared so as to be conveniently linked with application
-programs (which use some of those functions and data) to form
-executables.
-
-The "Library", below, refers to any such software library or
-work which has been distributed under these terms.  A "work
-based on the Library" means either the Library or any derivative
-work under copyright law: that is to say, a work containing the
-Library or a portion of it, either verbatim or with
-modifications and/or translated straightforwardly into another
-language.  (Hereinafter, translation is included without
-limitation in the term "modification".)
-
-"Source code" for a work means the preferred form of the work
-for making modifications to it.  For a library, complete source
-code means all the source code for all modules it contains, plus
-any associated interface definition files, plus the scripts used
-to control compilation and installation of the library.
-
-Activities other than copying, distribution and modification are
-not covered by this License; they are outside its scope.  The
-act of running a program using the Library is not restricted,
-and output from such a program is covered only if its contents
-constitute a work based on the Library (independent of the use
-of the Library in a tool for writing it).  Whether that is true
-depends on what the Library does and what the program that uses
-the Library does.
-  
-1. You may copy and distribute verbatim copies of the Library's
-complete source code as you receive it, in any medium, provided
-that you conspicuously and appropriately publish on each copy an
-appropriate copyright notice and disclaimer of warranty; keep
-intact all the notices that refer to this License and to the
-absence of any warranty; and distribute a copy of this License
-along with the Library.
-
-You may charge a fee for the physical act of transferring a
-copy, and you may at your option offer warranty protection in
-exchange for a fee.
- 
-2. You may modify your copy or copies of the Library or any
-portion of it, thus forming a work based on the Library, and
-copy and distribute such modifications or work under the terms
-of Section 1 above, provided that you also meet all of these
-conditions:
-
-    a) The modified work must itself be a software library.
-
-    b) You must cause the files modified to carry prominent notices
-    stating that you changed the files and the date of any change.
-
-    c) You must cause the whole of the work to be licensed at no
-    charge to all third parties under the terms of this License.
-
-    d) If a facility in the modified Library refers to a function or a
-    table of data to be supplied by an application program that uses
-    the facility, other than as an argument passed when the facility
-    is invoked, then you must make a good faith effort to ensure that,
-    in the event an application does not supply such function or
-    table, the facility still operates, and performs whatever part of
-    its purpose remains meaningful.
-
-    (For example, a function in a library to compute square roots has
-    a purpose that is entirely well-defined independent of the
-    application.  Therefore, Subsection 2d requires that any
-    application-supplied function or table used by this function must
-    be optional: if the application does not supply it, the square
-    root function must still compute square roots.)
-
-These requirements apply to the modified work as a whole.  If
-identifiable sections of that work are not derived from the
-Library, and can be reasonably considered independent and
-separate works in themselves, then this License, and its terms,
-do not apply to those sections when you distribute them as
-separate works.  But when you distribute the same sections as
-part of a whole which is a work based on the Library, the
-distribution of the whole must be on the terms of this License,
-whose permissions for other licensees extend to the entire
-whole, and thus to each and every part regardless of who wrote
-it.
-
-Thus, it is not the intent of this section to claim rights or
-contest your rights to work written entirely by you; rather, the
-intent is to exercise the right to control the distribution of
-derivative or collective works based on the Library.
-
-In addition, mere aggregation of another work not based on the
-Library with the Library (or with a work based on the Library)
-on a volume of a storage or distribution medium does not bring
-the other work under the scope of this License.
-
-3. You may opt to apply the terms of the ordinary GNU General
-Public License instead of this License to a given copy of the
-Library.  To do this, you must alter all the notices that refer
-to this License, so that they refer to the ordinary GNU General
-Public License, version 2, instead of to this License.  (If a
-newer version than version 2 of the ordinary GNU General Public
-License has appeared, then you can specify that version instead
-if you wish.)  Do not make any other change in these notices.
- 
-Once this change is made in a given copy, it is irreversible for
-that copy, so the ordinary GNU General Public License applies to
-all subsequent copies and derivative works made from that copy.
-
-This option is useful when you wish to copy part of the code of
-the Library into a program that is not a library.
-
-4. You may copy and distribute the Library (or a portion or
-derivative of it, under Section 2) in object code or executable
-form under the terms of Sections 1 and 2 above provided that you
-accompany it with the complete corresponding machine-readable
-source code, which must be distributed under the terms of
-Sections 1 and 2 above on a medium customarily used for software
-interchange.
-
-If distribution of object code is made by offering access to
-copy from a designated place, then offering equivalent access to
-copy the source code from the same place satisfies the
-requirement to distribute the source code, even though third
-parties are not compelled to copy the source along with the
-object code.
-
-5. A program that contains no derivative of any portion of the
-Library, but is designed to work with the Library by being
-compiled or linked with it, is called a "work that uses the
-Library".  Such a work, in isolation, is not a derivative work
-of the Library, and therefore falls outside the scope of this
-License.
-
-However, linking a "work that uses the Library" with the Library
-creates an executable that is a derivative of the Library
-(because it contains portions of the Library), rather than a
-"work that uses the library".  The executable is therefore
-covered by this License. Section 6 states terms for distribution
-of such executables.
-
-When a "work that uses the Library" uses material from a header
-file that is part of the Library, the object code for the work
-may be a derivative work of the Library even though the source
-code is not. Whether this is true is especially significant if
-the work can be linked without the Library, or if the work is
-itself a library.  The threshold for this to be true is not
-precisely defined by law.
-
-If such an object file uses only numerical parameters, data
-structure layouts and accessors, and small macros and small
-inline functions (ten lines or less in length), then the use of
-the object file is unrestricted, regardless of whether it is
-legally a derivative work.  (Executables containing this object
-code plus portions of the Library will still fall under Section
-6.)
-
-Otherwise, if the work is a derivative of the Library, you may
-distribute the object code for the work under the terms of
-Section 6. Any executables containing that work also fall under
-Section 6, whether or not they are linked directly with the
-Library itself.
- 
-6. As an exception to the Sections above, you may also compile
-or link a "work that uses the Library" with the Library to
-produce a work containing portions of the Library, and
-distribute that work under terms of your choice, provided that
-the terms permit modification of the work for the customer's own
-use and reverse engineering for debugging such modifications.
-
-You must give prominent notice with each copy of the work that
-the Library is used in it and that the Library and its use are
-covered by this License.  You must supply a copy of this
-License.  If the work during execution displays copyright
-notices, you must include the copyright notice for the Library
-among them, as well as a reference directing the user to the
-copy of this License.  Also, you must do one of these things:
-
-    a) Accompany the work with the complete corresponding
-    machine-readable source code for the Library including whatever
-    changes were used in the work (which must be distributed under
-    Sections 1 and 2 above); and, if the work is an executable linked
-    with the Library, with the complete machine-readable "work that
-    uses the Library", as object code and/or source code, so that the
-    user can modify the Library and then relink to produce a modified
-    executable containing the modified Library.  (It is understood
-    that the user who changes the contents of definitions files in the
-    Library will not necessarily be able to recompile the application
-    to use the modified definitions.)
-
-    b) Accompany the work with a written offer, valid for at
-    least three years, to give the same user the materials
-    specified in Subsection 6a, above, for a charge no more
-    than the cost of performing this distribution.
-
-    c) If distribution of the work is made by offering access to copy
-    from a designated place, offer equivalent access to copy the above
-    specified materials from the same place.
-
-    d) Verify that the user has already received a copy of these
-    materials or that you have already sent this user a copy.
-
-For an executable, the required form of the "work that uses the
-Library" must include any data and utility programs needed for
-reproducing the executable from it.  However, as a special
-exception, the source code distributed need not include anything
-that is normally distributed (in either source or binary form)
-with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that
-component itself accompanies the executable.
-
-It may happen that this requirement contradicts the license
-restrictions of other proprietary libraries that do not normally
-accompany the operating system.  Such a contradiction means you
-cannot use both them and the Library together in an executable
-that you distribute.
- 
-7. You may place library facilities that are a work based on the
-Library side-by-side in a single library together with other
-library facilities not covered by this License, and distribute
-such a combined library, provided that the separate distribution
-of the work based on the Library and of the other library
-facilities is otherwise permitted, and provided that you do
-these two things:
-
-    a) Accompany the combined library with a copy of the same work
-    based on the Library, uncombined with any other library
-    facilities.  This must be distributed under the terms of the
-    Sections above.
-
-    b) Give prominent notice with the combined library of the fact
-    that part of it is a work based on the Library, and explaining
-    where to find the accompanying uncombined form of the same work.
-
-8. You may not copy, modify, sublicense, link with, or
-distribute the Library except as expressly provided under this
-License.  Any attempt otherwise to copy, modify, sublicense,
-link with, or distribute the Library is void, and will
-automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you
-under this License will not have their licenses terminated so
-long as such parties remain in full compliance.
-
-9. You are not required to accept this License, since you have
-not signed it.  However, nothing else grants you permission to
-modify or distribute the Library or its derivative works.  These
-actions are prohibited by law if you do not accept this
-License.  Therefore, by modifying or distributing the Library
-(or any work based on the Library), you indicate your acceptance
-of this License to do so, and all its terms and conditions for
-copying, distributing or modifying the Library or works based on
-it.
-
-10. Each time you redistribute the Library (or any work based on
-the Library), the recipient automatically receives a license
-from the original licensor to copy, distribute, link with or
-modify the Library subject to these terms and conditions.  You
-may not impose any further restrictions on the recipients'
-exercise of the rights granted herein. You are not responsible
-for enforcing compliance by third parties to this License.
- 
-11. If, as a consequence of a court judgment or allegation of
-patent infringement or for any other reason (not limited to
-patent issues), conditions are imposed on you (whether by court
-order, agreement or otherwise) that contradict the conditions of
-this License, they do not excuse you from the conditions of this
-License.  If you cannot distribute so as to satisfy
-simultaneously your obligations under this License and any other
-pertinent obligations, then as a consequence you may not
-distribute the Library at all.  For example, if a patent license
-would not permit royalty-free redistribution of the Library by
-all those who receive copies directly or indirectly through you,
-then the only way you could satisfy both it and this License
-would be to refrain entirely from distribution of the Library.
-
-If any portion of this section is held invalid or unenforceable
-under any particular circumstance, the balance of the section is
-intended to apply, and the section as a whole is intended to
-apply in other circumstances.
-
-It is not the purpose of this section to induce you to infringe
-any patents or other property right claims or to contest
-validity of any such claims; this section has the sole purpose
-of protecting the integrity of the free software distribution
-system which is implemented by public license practices.  Many
-people have made generous contributions to the wide range of
-software distributed through that system in reliance on
-consistent application of that system; it is up to the
-author/donor to decide if he or she is willing to distribute
-software through any other system and a licensee cannot impose
-that choice.
-
-This section is intended to make thoroughly clear what is
-believed to be a consequence of the rest of this License.
-
-12. If the distribution and/or use of the Library is restricted
-in certain countries either by patents or by copyrighted
-interfaces, the original copyright holder who places the Library
-under this License may add an explicit geographical distribution
-limitation excluding those countries, so that distribution is
-permitted only in or among countries not thus excluded.  In such
-case, this License incorporates the limitation as if written in
-the body of this License.
-
-13. The Free Software Foundation may publish revised and/or new
-versions of the Library General Public License from time to
-time. Such new versions will be similar in spirit to the present
-version, but may differ in detail to address new problems or
-concerns.
-
-Each version is given a distinguishing version number.  If the
-Library specifies a version number of this License which applies
-to it and "any later version", you have the option of following
-the terms and conditions either of that version or of any later
-version published by the Free Software Foundation.  If the
-Library does not specify a license version number, you may
-choose any version ever published by the Free Software
-Foundation.
-
-14. If you wish to incorporate parts of the Library into other
-free programs whose distribution conditions are incompatible
-with these, write to the author to ask for permission.  For
-software which is copyrighted by the Free Software Foundation,
-write to the Free Software Foundation; we sometimes make
-exceptions for this.  Our decision will be guided by the two
-goals of preserving the free status of all derivatives of our
-free software and of promoting the sharing and reuse of software
-generally.
-
-                           NO WARRANTY
-
-  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
-WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
-EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
-OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND,
-EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
-LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
-THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
-  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
-WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
-AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
-FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL
-DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
-LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
-RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
-FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
-SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
-
-                    END OF TERMS AND CONDITIONS
-
- Appendix: How to Apply These Terms to Your New Libraries
-
-If you develop a new library, and you want it to be of the
-greatest possible use to the public, we recommend making it free
-software that everyone can redistribute and change.  You can do
-so by permitting redistribution under these terms (or,
-alternatively, under the terms of the ordinary General Public
-License).
-
-To apply these terms, attach the following notices to the
-library.  It is safest to attach them to the start of each
-source file to most effectively convey the exclusion of
-warranty; and each file should have at least the "copyright"
-line and a pointer to where the full notice is found.
-
-    <one line to give the library's name and a brief idea of what it does.>
-    Copyright (C) <year>  <name of author>
-
-    This library is free software; you can redistribute it and/or
-    modify it under the terms of the GNU Library General Public
-    License as published by the Free Software Foundation; either
-    version 2 of the License, or (at your option) any later version.
-
-    This library is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-    Library General Public License for more details.
-
-    You should have received a copy of the GNU Library General Public
-    License along with this library; if not, write to the Free
-    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-Also add information on how to contact you by electronic and paper mail.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the library, if
-necessary.  Here is a sample; alter the names:
-
-  Yoyodyne, Inc., hereby disclaims all copyright interest in the
-  library `Frob' (a library for tweaking knobs) written by James Random Hacker.
-
-  <signature of Ty Coon>, 1 April 1990
-  Ty Coon, President of Vice
-
-That's all there is to it!
-

libwin/kolfpc/KOL-CE.rc

@@ -1,75 +0,0 @@
-// Dummy menu resources. Needed for menu support.
-//*****************************************************
-
-// 2 simple menu items
-20000 MENU DISCARDABLE
-BEGIN
-  MENUITEM " ", 1
-  MENUITEM " ", 2
-END
-
-20000 RCDATA DISCARDABLE
-BEGIN
-    20000, 2,
-    -2, 1, 8, 0x10, 0, 0, 0xFFFF,
-    -2, 2, 8, 0x10, 0, 0, 0xFFFF
-END
-
-// popup and simple menu item
-20001 MENU DISCARDABLE
-BEGIN
-  POPUP " "
-  BEGIN
-    MENUITEM " ", 1
-  END
-  MENUITEM " ", 2
-END
-
-20001 RCDATA DISCARDABLE
-BEGIN
-    20001, 2,
-    -2, 1, 4, 0x18, 0, 0, 0,
-    -2, 2, 4, 0x10, 0, 0, 0xFFFF
-END
-
-// simple item and popup menu
-20002 MENU DISCARDABLE
-BEGIN
-  MENUITEM " ", 1
-  POPUP " "
-  BEGIN
-    MENUITEM " ", 2
-  END
-END
-
-20002 RCDATA DISCARDABLE
-BEGIN
-    20002, 2,
-    -2, 1, 4, 0x10, 0, 0, 0xFFFF,
-    -2, 2, 4, 0x18, 0, 0, 1
-END
-
-// 2 popup menus
-20003 MENU DISCARDABLE
-BEGIN
-  POPUP " "
-  BEGIN
-    MENUITEM " ", 1
-  END
-  POPUP " "
-  BEGIN
-    MENUITEM " ", 2
-  END
-END
-
-20003 RCDATA DISCARDABLE
-BEGIN
-    20003, 2,
-    -2, 1, 4, 0x18, 0, 0, 0,
-    -2, 2, 4, 0x18, 0, 0, 1
-END
-
-//*****************************************************
-
-// Uncomment the line below to run application in real VGA mode
-// HI_RES_AWARE CEUX {1}

libwin/kolfpc/KOLCEOpenDir.inc

@@ -1,125 +0,0 @@
-{$ifdef read_interface}
-//[OpenDirectory Object]
-{ ----------------------------------------------------------------------
-                               TOpenDirDialog
------------------------------------------------------------------------ }
-//[TOpenDirDialog DEFINITION]
-  TOpenDirDialog = object( TObj )
-  {* Dialog for open directories, uses SHBrowseForFolder. }
-  private
-    FWnd: HWnd;
-    function GetDialogWnd: HWnd;
-    function GetTitle: KOLString;
-    procedure SetTitle(const AValue: KOLString);
-  protected
-    FDlg: PObj;
-    FOptions: TOpenDirOptions;
-    FCenterOnScreen: Boolean;
-    FOnSelChanged: TOnODSelChange;
-    function GetPath: KOLString;
-    procedure SetInitialPath(const Value: KOLString);
-    procedure SetCenterOnScreen(const Value: Boolean);
-    procedure SetOnSelChanged(const Value: TOnODSelChange);
-    function GetInitialPath: KOLString;
-  public
-    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
-    {* destructor }
-    function Execute : Boolean;
-    {* Call it to select directory by user. Returns True, if operation was
-       not cancelled by user. }
-    property Title : KOLString read GetTitle write SetTitle;
-    {* Title for a dialog. }
-    property Options : TOpenDirOptions read FOptions write FOptions;
-    {* Option flags. }
-    property Path : KOLString read GetPath;
-    {* Resulting (selected by user) path. }
-    property InitialPath: KOLString read GetInitialPath write SetInitialPath;
-    {* Set this property to a path of directory to be selected initially
-       in a dialog. }
-    property CenterOnScreen: Boolean read FCenterOnScreen write SetCenterOnScreen;
-    {* Set it to True to center dialog on screen. }
-    property OnSelChanged: TOnODSelChange read FOnSelChanged write SetOnSelChanged;
-    {* This event is called every time, when user selects another directory.
-       It is possible to enable/disable OK button in dialog and/or change
-       dialog status text in responce to event. }
-    property WndOwner: HWnd read FWnd write FWnd;
-    {* Owner window. If you want to provide your dialog visible over stay-on-top
-       form, fire it as a child of the form, assigning the handle of form window
-       to this property first. }
-    property DialogWnd: HWnd read GetDialogWnd;
-    {* Handle to the open directory dialog itself, become available on the
-       first call of callback procedure (i.e. on the first call to OnSelChanged).
-    }
-  end;
-//[END OF TOpenDirDialog DEFINITION]
-{$endif read_interface}
-
-{$ifdef read_implementation}
-{$I KOLDirDlgEx.pas}
-
-function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ):
-         POpenDirDialog;
-begin
-  New( Result, Create );
-  Result.FDlg:=NewOpenDirDialogEx;
-  Result.FOptions := [ odOnlySystemDirs ];
-  if Options <> [] then
-    Result.FOptions := Options;
-  Result.Title := Title;
-end;
-
-{ TOpenDirDialog }
-
-function TOpenDirDialog.GetTitle: KOLString;
-begin
-  Result:=POpenDirDialogEx(FDlg).Title;
-end;
-
-function TOpenDirDialog.GetDialogWnd: HWnd;
-begin
-  Result:=POpenDirDialogEx(FDlg).Form.GetWindowHandle;
-end;
-
-procedure TOpenDirDialog.SetTitle(const AValue: KOLString);
-begin
-  POpenDirDialogEx(FDlg).Title:=AValue;
-end;
-
-function TOpenDirDialog.GetPath: KOLString;
-begin
-  Result:=ExcludeTrailingPathDelimiter(POpenDirDialogEx(FDlg).Path);
-  if Result = '' then
-    Result:='\';
-end;
-
-procedure TOpenDirDialog.SetInitialPath(const Value: KOLString);
-begin
-  POpenDirDialogEx(FDlg).InitialPath:=Value;
-end;
-
-procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean);
-begin
-end;
-
-procedure TOpenDirDialog.SetOnSelChanged(const Value: TOnODSelChange);
-begin
-end;
-
-function TOpenDirDialog.GetInitialPath: KOLString;
-begin
-  Result:=POpenDirDialogEx(FDlg).InitialPath;
-end;
-
-destructor TOpenDirDialog.Destroy;
-begin
-  POpenDirDialogEx(FDlg).Free;
-  inherited;
-end;
-
-function TOpenDirDialog.Execute: Boolean;
-begin
-  Result:=POpenDirDialogEx(FDlg).Execute;
-end;
-
-{$endif read_implementation}
-

libwin/kolfpc/KOLCE_IniFile.inc

@@ -1,240 +0,0 @@
-{$ifdef read_interface}
-type
-  PIniFile = ^TIniFile;
-
-  { TIniFile }
-
-  TIniFile = object( TObj )
-  private
-    procedure SetMode(const AValue: TIniFileMode);
-  protected
-    fMode: TIniFileMode;
-    fFileName: KOLString;
-    fSection: KOLString;
-    fData: PStrList;
-  protected
-    function FindSection(var First, Last: Integer): Boolean;
-    function FindKey(Key: String; First, Last: Integer; var Value: String): Integer;
-  public
-    destructor Destroy; virtual;
-    property Mode: TIniFileMode read fMode write SetMode;
-    property FileName: KOLString read fFileName;
-    property Section: KOLString read fSection write fSection;
-    function ValueInteger( const Key: KOLString; Value: Integer ): Integer;
-    function ValueString( const Key: KOLString; const Value: KOLString ): KOLString;
-    function ValueBoolean( const Key: KOLString; Value: Boolean ): Boolean;
-    function ValueData( const Key: KOLString; Value: Pointer; Count: Integer ): Boolean;
-    procedure ClearAll;
-    procedure ClearSection;
-    procedure ClearKey( const Key: KOLString );
-    procedure GetSectionNames(Names: {$IFNDEF UNICODE_CTRLS}PStrList{$ELSE}PWStrList{$ENDIF});
-    procedure SectionData(Names: {$IFNDEF UNICODE_CTRLS}PStrList{$ELSE}PWStrList{$ENDIF});
-    procedure UpdateFile;
-  end;
-{$endif read_interface}
-
-{$ifdef read_implementation}
-function OpenIniFile( const FileName: KOLString ): PIniFile;
-begin
-  New(Result, Create);
-  Result.fFileName := FileName;
-  Result.fData:= NewStrList;
-  Result.fMode:= ifmRead;
-  Result.fData.LoadFromFile(FileName);
-end;
-
-function GetSection(var S: String): Boolean;
-var L: Integer;
-begin
-  S:= Trim(S);
-  L:= Length(S);
-  Result:= (L > 2) and (S[1] = '[') and (S[L] = ']');
-  if Result then begin
-    Delete(S, L, 1); Delete(S, 1, 1);
-    S:= Trim(S);
-//      Result:= (S <> '');
-  end;
-end;
-
-procedure TIniFile.ClearAll;
-begin
-  fData.Clear;
-  fData.SaveToFile(fFileName);
-end;
-
-procedure TIniFile.ClearKey(const Key: KOLString);
-var k, F, L: Integer;
-    S: String;
-begin
-  if FindSection(F, L) then begin
-    k:= FindKey(Key, F, L, S);
-    if k >= 0 then fData.Delete(k);
-    fData.SaveToFile(fFileName);
-  end;
-end;
-
-procedure TIniFile.ClearSection;
-var i, F, L: Integer;
-begin
-  if FindSection(F, L) then begin
-    for i := L downto F do begin
-      fData.Delete(i);
-    end;
-    fData.SaveToFile(fFileName);
-  end;
-end;
-
-destructor TIniFile.Destroy;
-begin
-  if fMode = ifmWrite then fData.SaveToFile(fFileName);
-  fData.Free;
-  fFileName := '';
-  fSection := '';
-  inherited;
-end;
-
-procedure TIniFile.GetSectionNames(Names: {$IFNDEF UNICODE_CTRLS}PStrList{$ELSE}PWStrList{$ENDIF});
-var i: Integer;
-    S: String;
-begin
-  for i:= 0 to fData.Count-1 do begin
-    S:= fData.Items[i];
-    if GetSection(S) then Names.Add(S)
-  end;
-end;
-
-procedure TIniFile.SectionData(Names: {$IFNDEF UNICODE_CTRLS}PStrList{$ELSE}PWStrList{$ENDIF});
-var i, F, L: Integer;
-    S: String;
-begin
-  if fMode = ifmRead then begin
-    if FindSection(F, L) then
-      for i := F+1 to L do begin
-        S:= Trim(fData.Items[i]);
-        if S <> '' then Names.Add(S);
-      end;
-  end
-  else begin
-    ClearSection;
-    fData.Add('[' + fSection + ']');
-    for i:= 0 to Names.Count-1 do begin
-      S:= Trim(Names.Items[i]);
-      if S <> '' then fData.Add(S);
-    end;
-  end;
-end;
-
-procedure TIniFile.UpdateFile;
-begin
-    if fMode = ifmRead then fData.LoadFromFile(fFileName)
-    else fData.SaveToFile(fFileName);
-end;
-
-function TIniFile.ValueBoolean(const Key: KOLString; Value: Boolean): Boolean;
-begin
-  Result:= ValueInteger(Key, Ord(Value)) <> 0;
-end;
-
-function TIniFile.ValueData(const Key: KOLString; Value: Pointer; Count: Integer): Boolean;
-var i: Integer;
-    S: String;
-begin
-  if fMode = ifmRead then begin
-    S:= ValueString(Key, '');
-    for i:= 0 to Min(Length(S) div 2, Count) - 1 do begin
-      PByte(Value)^:= Hex2Int(Copy(S, 1+i*2, 2));
-      cardinal(Value):= cardinal(Value) + 1;
-      Result:= True;
-    end;
-  end
-  else begin
-    S:= '';
-    for i:= 0 to Count - 1 do begin
-      S:= S + Int2Hex(PByte(Value)^, 2);
-      cardinal(Value):= cardinal(Value) + 1;
-      Result:= True;
-    end;
-    ValueString(Key, S);
-  end;
-end;
-
-function TIniFile.ValueInteger(const Key: KOLString; Value: Integer): Integer;
-begin
-  Result:= Str2Int(ValueString(Key, Int2Str(Value)));
-end;
-
-function TIniFile.ValueString( const Key: KOLString; const Value: KOLString ): KOLString;
-var k, F, L: Integer;
-    S: String;
-    fSect: Boolean;
-begin
-  fSect:= FindSection(F, L);
-  if fSect then k:= FindKey(Key, F, L, S) else k:= -1;
-  if fMode = ifmRead then begin
-    if fSect and (k > 0) then Result:= S else Result := Value;
-  end
-  else begin
-    if not fSect then begin
-      fData.Add('[' + fSection + ']');
-      fData.Add(''); k:= fData.Count-1;
-    end;
-    if k < 0 then begin k:= L+1; fData.Insert(k, ''); end;
-    fData.Items[k]:= Key+'='+Value;
-  end;
-end;
-
-procedure TIniFile.SetMode(const AValue: TIniFileMode);
-begin
-    if fMode = AValue then Exit;
-    if fMode = ifmWrite then fData.SaveToFile(fFileName)
-    else fData.LoadFromFile(fFileName);
-    fMode:= AValue;
-end;
-
-function TIniFile.FindSection(var First, Last: Integer): Boolean;
-var i: Integer;
-    Sec, S: String;
-begin
-  Result:= False;
-  Sec := Trim(fSection);
-  for i:= 0 to fData.Count-1 do begin
-    S:= fData.Items[i];
-    if GetSection(S) and (AnsiCompareStrNoCase(S, Sec) = 0) then begin
-      First:= i; Result:= True; Break;
-    end;
-  end;
-  if Result then begin
-    for i:= First+1 to fData.Count-1 do begin
-      S:= fData.Items[i];
-      if GetSection(S) then begin
-        Last:= i-1; Exit;
-      end;
-    end;
-    Last:= fData.Count-1;
-  end;
-end;
-
-function TIniFile.FindKey(Key: String; First, Last: Integer; var Value: String): Integer;
-var i, k: Integer;
-    S: String;
-begin
-  Result:= -1;
-  Key:= Trim(Key);
-  for i:= First to Last do begin
-    S:= fData.Items[i];
-    k:= Pos('=', S);
-    if k > 0 then begin
-      if AnsiCompareStrNoCase(Key, Trim(Copy(S, 1, k-1))) = 0 then Result:= i;
-      if Result >= 0 then begin
-        Delete(S, 1, k);
-        Value:= Trim(S);
-        k:= Length(Value);
-        if (k > 0) and (Value[1] = '"') and (Value[k] = '"') then begin
-          Delete(Value, k, 1); Delete(Value, 1, 1);
-        end;
-        Exit;
-      end;
-    end;
-  end;
-end;
-{$endif read_implementation}

libwin/kolfpc/KOLDEF.INC

@@ -1,146 +0,0 @@
-{$IFDEF VER90}
-              {$DEFINE _D2}
-              {$DEFINE _D2orD3}
-              {$DEFINE _D2orD3orD4}
-{$ENDIF}
-
-{$IFDEF VER100}
-              {$DEFINE _D3}
-              {$DEFINE _D3orHigher}
-              {$DEFINE _D2orD3}
-              {$DEFINE _D2orD3orD4}
-              {$DEFINE _D3orD4}
-{$ENDIF}
-
-{$IFDEF VER120}
-              {$DEFINE _D3orHigher}
-              {$DEFINE _D3orD4}
-              {$DEFINE _D4}
-              {$DEFINE _D4orHigher}
-              {$DEFINE _D2orD3orD4}
-{$ENDIF}
-
-{$IFDEF VER130}
-              {$DEFINE _D3orHigher}
-              {$DEFINE _D4orHigher}
-              {$DEFINE _D5}
-              {$DEFINE _D5orHigher}
-{$ENDIF}
-
-{$IFDEF VER140}
-              {$DEFINE _D3orHigher}
-              {$DEFINE _D4orHigher}
-              {$DEFINE _D5orHigher}
-              {$DEFINE _D6}
-              {$DEFINE _D6orHigher}
-{$ENDIF}
-
-{$IFDEF VER150}
-              {$DEFINE _D3orHigher}
-              {$DEFINE _D4orHigher}
-              {$DEFINE _D5orHigher}
-              {$DEFINE _D6orHigher}
-              {$DEFINE _D7}
-              {$DEFINE _D7orHigher}
-{$WARN UNIT_DEPRECATED OFF}
-{$WARN SYMBOL_PLATFORM OFF}
-{$WARN UNSAFE_TYPE OFF}
-{$WARN UNSAFE_CAST OFF}
-{$WARN UNSAFE_CODE OFF}
-{$ENDIF}
-
-{$IFDEF VER160} // Delphi 8
-Delphi version 8 not supported! (delphi 8 is .net only)
-{$ENDIF}
-
-{$IFDEF VER170} // Delphi 2005
-             {$DEFINE _D3orHigher}
-             {$DEFINE _D4orHigher}
-             {$DEFINE _D5orHigher}
-             {$DEFINE _D6orHigher}
-             {$DEFINE _D7}
-             {$DEFINE _D7orHigher}
-             {$DEFINE _D2005orHigher}
-{$WARN UNIT_DEPRECATED OFF}
-{$WARN SYMBOL_PLATFORM OFF}
-{$WARN UNSAFE_TYPE OFF}
-{$WARN UNSAFE_CAST OFF}
-{$WARN UNSAFE_CODE OFF}
-{$ENDIF}
-
-{$IFDEF VER180} // Delphi 2006
-             {$DEFINE _D3orHigher}
-             {$DEFINE _D4orHigher}
-             {$DEFINE _D5orHigher}
-             {$DEFINE _D6orHigher}
-             {$DEFINE _D7}
-             {$DEFINE _D7orHigher}
-             {$DEFINE _D2005orHigher}
-             {$DEFINE _D2006orHigher}
-{$WARN UNIT_DEPRECATED OFF}
-{$WARN SYMBOL_PLATFORM OFF}
-{$WARN UNSAFE_TYPE OFF}
-{$WARN UNSAFE_CAST OFF}
-{$WARN UNSAFE_CODE OFF}
-{$ENDIF}
-
-{$IFDEF _D2005orHigher}
-
-  // by Thaddy de Koning:
-  {$IFDEF VER185} // Delphi 2007 ( and Highlander )
-               {$DEFINE _D3orHigher}
-               {$DEFINE _D4orHigher}
-               {$DEFINE _D5orHigher}
-               {$DEFINE _D6orHigher}
-               {$DEFINE _D7}
-               {$DEFINE _D7orHigher}
-               {$DEFINE _D2005orHigher}
-               {$DEFINE _D2006orHigher}
-               {$DEFINE _D2007orHigher}
-  {$WARN UNIT_DEPRECATED OFF}
-  {$WARN SYMBOL_PLATFORM OFF}
-  {$WARN UNSAFE_TYPE OFF}
-  {$WARN UNSAFE_CAST OFF}
-  {$WARN UNSAFE_CODE OFF}
-  {$ENDIF}
-
-{$INLINE OFF}
-{$ENDIF}
-
-{$IFDEF FPC}
-{------------------------------------
-by Thaddy de Koning:
-
-FPC version 2.1.1 is very compatible with Delphi and kol now.
-You can simply use the $(DELPHI)\source\rtl\win\*.pas files from Delphi 4/5 instead of the prepared files that were needed for 
-FPC1.X
- 
-That is all to have full compatibility.
-------------------------------------}
-  {$DEFINE PAS_VERSION}
-    {$IFDEF VER2}
-     {$DEFINE _D3orHigher}
-     {$DEFINE _D4orHigher}
-     {$DEFINE _D5orHigher}
-     {$DEFINE _D6orHigher}
-     {$DEFINE _D7}
-     {$DEFINE _D7orHigher}
-    {$ENDIF VER2}
-  {$IFDEF WINCE}
-    {$DEFINE USE_PROP}
-    {$DEFINE UNICODE_CTRLS}
-    {$DEFINE NOT_USE_RICHEDIT}
-  {$ENDIF WINCE}
-  {$ELSE FPC}
-    {$DEFINE cpu86}
-{$ENDIF FPC}
-
-{$IFNDEF _NOT_KOLCtrlWrapper_}
- {$DEFINE _KOLCtrlWrapper_}
-{$ENDIF}
-
-{$IFNDEF _NOT_KOLCtrlWrapper_}
-  {$DEFINE _KOLCtrlWrapper_}
-{$ENDIF}
-
-

libwin/kolfpc/KOLMHToolTip.pas

@@ -1,909 +0,0 @@
-//{$DEFINE DEBUG}
-{$IFDEF DEBUG}
-{$DEFINE interface}
-{$DEFINE implementation}
-{$DEFINE initialization}
-{$DEFINE finalization}
-{$ENDIF}
-
-{$IFDEF Frame}
-unit KOLMHToolTip;
-
-interface
-
-uses Windows, KOL, Messages;
-
-type
-{$ENDIF Frame}
-{$IFDEF interface}
-
-  TFE = (eTextColor, eBkColor, eAPDelay, eRDelay, eIDelay);
-
-  TFI = record
-    FE: set of TFE;
-    Colors: array[0..1] of TColor;
-    Delays: array[0..3] of Integer;
-  end;
-
-  PMHToolTipManager = ^TMHToolTipManager;
-  TKOLMHToolTipManager = PMHToolTipManager;
-
-  PMHToolTip = ^TMHToolTip;
-  TKOLMHToolTip = PMHToolTip;
-
-{$ENDIF interface}
-
-{$IFDEF pre_interface}
-  PMHHint = ^TMHHint;
-  TKOLMHHint = PMHHint;
-{$ENDIF pre_interface}
-
-{$IFDEF interface}
-
-  TMHToolTipManager = object(TObj)
-  protected
-    destructor Destroy; virtual;
-  public
-    TTT: array of PMHToolTip;
-    function AddTip: Integer;
-    function FindNeed(FI: TFI): PMHToolTip;
-    function CreateNeed(FI: TFI): PMHToolTip;
-  end;
-
-  TMHHint = object(TObj)
-  private
-    function GetManager:PMHToolTipManager;
-    // Spec
-    procedure ProcBegin(var TI: TToolInfo);
-    procedure ProcEnd(var TI: TToolInfo);
-    procedure ReConnect(FI: TFI);
-    procedure MoveTool(T1: PMHToolTip);
-    procedure CreateToolTip;
-    function GetFI: TFI;
-
-    // Group
-    function GetDelay(const Index: Integer): Integer;
-    procedure SetDelay(const Index: Integer; const Value: Integer);
-    function GetColor(const Index: Integer): TColor;
-    procedure SetColor(const Index: Integer; const Value: TColor);
-
-    // Local
-    procedure SetText(Value: KOLString);
-    function GetText: KOLString;
-  public
-    ToolTip: PMHToolTip;
-    HasTool: Boolean;
-    Parent: PControl;
-    destructor Destroy; virtual;
-    procedure Pop;
-    procedure Popup;
-
-    property AutoPopDelay: Integer index 2 read GetDelay write SetDelay;
-    property InitialDelay: Integer index 3 read GetDelay write SetDelay;
-    property ReshowDelay: Integer index 1 read GetDelay write SetDelay;
-
-    property TextColor: TColor index 1 read GetColor write SetColor;
-    property BkColor: TColor index 0 read GetColor write SetColor;
-    property Text: KOLString read GetText write SetText;
-  end;
-
-  TMHToolTip = object(TObj)
-
-  private
-    fHandle: THandle;
-    Count: Integer;
-
-    function GetDelay(const Index: Integer): Integer;
-    procedure SetDelay(const Index: Integer; const Value: Integer);
-    function GetColor(const Index: Integer): TColor;
-    procedure SetColor(const Index: Integer; const Value: TColor);
-    function GetMaxWidth: Integer;
-    procedure SetMaxWidth(const Value: Integer);
-    function GetMargin: TRect;
-    procedure SetMargin(const Value: TRect);
-    function GetActivate: Boolean;
-    procedure SetActivate(const Value: Boolean);
-//    function GetText: string;
-//    procedure SetText(const Value: string);
-//    function GetToolCount: Integer;
-//    function GetTool(Index: Integer): TToolInfo;
-
-
-
-  protected
-
-  public
-    destructor Destroy; virtual;
-    procedure Pop;
-    procedure Popup;
-    procedure Update;
-
-//    function GetInfo: TToolInfo; // Hide in Info
-//    procedure SetInfo(Value: TToolInfo);
-
-//  handle:Thandle;
-//    procedure SetC(C: PControl);
-//    procedure SetI(C: PControl; S: string);
-//    procedure Add(Value: TToolInfo);
-//    procedure Delete(Value: TToolInfo);
-//    function Connect(Value: PControl): Integer;
-
-
-//    property OnCloseUp: TOnEvent read GetOnDropDown write SetOnDropDown;
-
-
-
-    property AutoPopDelay: Integer index 2 read GetDelay write SetDelay;
-    property InitialDelay: Integer index 3 read GetDelay write SetDelay;
-    property ReshowDelay: Integer index 1 read GetDelay write SetDelay;
-
-    property TextColor: TColor index 1 read GetColor write SetColor;
-    property BkColor: TColor index 0 read GetColor write SetColor;
-
-    property MaxWidth: Integer read GetMaxWidth write SetMaxWidth;
-
-    property Margin: TRect read GetMargin write SetMargin;
-    property Activate: Boolean read GetActivate write SetActivate;
-    property Handle: THandle read fHandle;
-//    property Text: string read GetText write SetText;
-//    property ToolCount: Integer read GetToolCount;
-//    property Tools[Index: Integer]: TToolInfo read GetTool;
-
-  end;
-
-const
-  Dummy = 0;
-
-
-function NewHint(A: PControl): PMHHint;
-function NewManager: PMHToolTipManager;
-function NewMHToolTip(AParent: PControl): PMHToolTip;
-
-var
-  Manager: PMHToolTipManager;
-
-{$ENDIF interface}
-
-{$IFDEF Frame}
-
-implementation
-
-{$ENDIF Frame}
-
-{$IFDEF implementation}
-
-const
-  Dummy1 = 1;
-
-  TTDT_AUTOMATIC = 0;
-  TTDT_RESHOW = 1;
-  TTDT_AUTOPOP = 2;
-  TTDT_INITIAL = 3;
-
-//function WndProcMHDateTimePicker(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
-{begin
-  Result := False;}
-//end;
-
-
-
-function NewMHToolTip(AParent: PControl): PMHToolTip;
-//var
-//  Data: PDateTimePickerData;
-//  T: TWndClassEx;
-//  a: integer;
-const
-  CS_DROPSHADOW = $00020000;
-begin
-  DoInitCommonControls(ICC_BAR_CLASSES);
-  New(Result, Create);
-
-  Result.fHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, '', 0, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, AParent.GetWindowHandle, 0, HInstance, nil);
-//  SetClassLong(Result.handle,GCL_STYLE,CS_DROPSHADOW);
-
-//  Result := PMHToolTip(_NewControl(AParent, TOOLTIPS_CLASS, 0, False, 0)); //PMHToolTip(_NewCommonControl(AParent,TOOLTIPS_CLASS, 0{TTS_ALWAYSTIP}{WS_CHILD or WS_VISIBLE},False,0));
-//  Result.Style:=0;
-//  Result.ExStyle:=0;
-//  GetMem(Data,Sizeof(Data^));
-//  FillChar(Data^,Sizeof(Data^),0);
-//  a:=SetClassLong(Result.Handle,GCL_STYLE,CS_DROPSHADOW);
-//  ShowMessage(Int2Str(a));
-//  Result.CustomData:=Data;
-
-{  T.cbSize:=SizeOf(T);
-  GetClassInfoEx(hInstance,TOOLTIPS_CLASS,T);
-  T.style:=T.style or CS_DROPSHADOW;
-  T.hInstance:=hInstance;
-  T.lpszClassName:='ZharovHint';
-  a:=RegisterClassEx(T);
-  ShowMessage(Int2Str(a)); }
-//  Result.handle := CreateWindowEx(0, {'ZharovHint'} TOOLTIPS_CLASS, '', 0 {orCS_DROPSHADOW or WS_POPUP or WS_BORDER or CS_SAVEBITS or WS_CHILD or WS_CLIPSIBLINGS}, CW_USEDEFAULT, CW_USEDEFAULT,
-//    CW_USEDEFAULT, CW_USEDEFAULT, AParent.Handle, 0, HInstance, nil);
-//  Data.ttt:=CreateWindowEx (CS_IMEWS_EX_TOOLWINDOW or WS_EX_CONTROLPARENT{ or CS_SAVEBITS or WS_POPUP or WS_BORDER}{65536},{'ZharovHint'}TOOLTIPS_CLASS,'',{WS_CHILD or}{ WS_VISIBLE}{100663296}{WS_EX_TOOLWINDOW}CS_DROPSHADOW or WS_POPUP or WS_BORDER or CS_SAVEBITS or WS_CHILD or WS_CLIPSIBLINGS,CW_USEDEFAULT,CW_USEDEFAULT,
-//                              CW_USEDEFAULT,CW_USEDEFAULT,AParent.Handle,0,HInstance,NIL);
-//  SetClassLong(Data.ttt,GCL_STYLE,CS_DROPSHADOW);
-//  SendMessage (Data.ttt,TTM_SETDELAYTIME,TTDT_INITIAL,5);
-//  SendMessage (Data.ttt,TTM_SETDELAYTIME,TTDT_RESHOW,20);
-//  SendMessage (Result.handle,TTM_SETDELAYTIME,TTDT_AUTOPOP,2000);
-//  Result.CreateWindow;
-//  Result.Parent := AParent;
-//  Result.Perform(TTM_SETTIPTEXTCOLOR,clRed,0);
-//  SendMessage (Result.handle,TTM_SETTIPTEXTCOLOR,clBlue,0);
-//  SendMessage (Result.handle,TTM_SETTIPTEXTCOLOR,clRed,0);
-//  Result.Color:=clRed;
-//  Result.Font.Color:=clRed;
-//  Data.FCalColors:=NewMonthCalColors(Result);
-//  Data.FOnDropDown:=nil;
-//    Result.AttachProc(WndProcMHDateTimePicker);
-//  Result.AttachProc(WndProcMHDateTimePicker);
-end;
-
-{procedure TMHToolTip.SetC(C: PControl);
-var
-  TI: TToolInfo;
-  R: Trect;
-//  Data:PDateTimePickerData;
-begin
-  R := C.ClientRect;
- // Control:= C.Handle;
-  with TI do
-  begin
-    cbSize := SizeOf(TI);
-    uFlags := TTF_SUBCLASS; // or TTF_IDISHWND;
-    hWnd := C.GetWindowHandle; //Control;
-    uId := 0;
-    rect.Left := R.Left;
-    rect.Top := R.Top;
-    rect.Right := R.Right;
-    rect.Bottom := R.Bottom;
-    hInst := 0;
-    lpszText := Pchar('I am ' + C.Caption);
-  end;
-  PostMessage(handle, TTM_ADDTOOL, 0, DWORD(@TI));
-//  Perform(TTM_ADDTOOL, 0, DWord(@TI));
-end;      }
-
-function TMHToolTip.GetDelay(const Index: Integer): Integer;
-begin
-  Result := SendMessage(fHandle, TTM_GETDELAYTIME, Index, 0);
-end;
-
-
-procedure TMHToolTip.SetDelay(const Index, Value: Integer);
-begin
-  SendMessage(handle, TTM_SETDELAYTIME, Index, MAKELONG(Value, 0));
-end;
-
-
-function TMHToolTip.GetColor(const Index: Integer): TColor;
-begin
-  Result := SendMessage(handle, TTM_GETTIPBKCOLOR + Index, 0, 0);
-end;
-
-procedure TMHToolTip.SetColor(const Index: Integer; const Value: TColor);
-begin
-  SendMessage(handle, TTM_SETTIPBKCOLOR + Index, Value, 0);
-end;
-
-function TMHToolTip.GetMaxWidth: Integer;
-begin
-  Result := SendMessage(fHandle, TTM_GETMAXTIPWIDTH, 0, 0);
-end;
-
-procedure TMHToolTip.SetMaxWidth(const Value: Integer);
-begin
-  SendMessage(fHandle, TTM_SETMAXTIPWIDTH, 0, Value);
-end;
-
-{procedure TMHToolTip.SetI(C: PControl; S: string);
-var
-  TI: TToolInfo;
-  R: Trect;
-//  Data:PDateTimePickerData;
-begin
-  R := C.ClientRect;
- // Control:= C.Handle;
-  with TI do
-  begin
-    cbSize := SizeOf(TI);
-    uFlags := TTF_SUBCLASS;
-    hWnd := C.GetWindowHandle; //Control;
-    uId := 0;
-    rect.Left := R.Left;
-    rect.Top := R.Top;
-    rect.Right := R.Right;
-    rect.Bottom := R.Bottom;
-    hInst := 0;
-    lpszText := PChar(S);
-  end;
-//   PostMessage (handle,TTM_ADDTOOL,0,DWORD (@TI));
-//  Perform(TTM_SETTOOLINFO, 0, DWord(@TI));
-end;    }
-
-function TMHToolTip.GetMargin: TRect;
-begin
-  SendMessage(fHandle, TTM_GETMARGIN, 0, DWord(@Result));
-end;
-
-procedure TMHToolTip.SetMargin(const Value: TRect);
-begin
-  SendMessage(fHandle, TTM_SETMARGIN, 0, DWord(@Value));
-end;
-
-function TMHToolTip.GetActivate: Boolean;
-begin
-  // ??????
-  Result := False;
-end;
-
-procedure TMHToolTip.SetActivate(const Value: Boolean);
-begin
-  SendMessage(fHandle, TTM_ACTIVATE, DWord(Value), 0);
-end;
-
-procedure TMHToolTip.Pop;
-begin
-  SendMessage(fHandle, TTM_POP, 0, 0);
-end;
-
-procedure TMHToolTip.Popup;
-begin
-  SendMessage(fHandle, $0422 {TTM_POPUP}, 0, 0);
-end;
-
-{function TMHToolTip.GetText: string;
-begin
-
-end;
-
-procedure TMHToolTip.SetText(const Value: string);
-var
-  TI: TToolInfo;
-begin
-  TI := GetInfo;
-  TI.lpszText := PChar(Value);
-  SetInfo(TI);
-end;       }
-
-{function TMHToolTip.GetInfo: TToolInfo;
-begin
-  with Result do
-  begin
-    // ????
-    FillChar(Result, SizeOf(Result), 0);
-    cbSize := SizeOf(Result);
-//    hWnd := Parent.GetWindowHandle;
-    uId := 0;
-  end;
-//  Perform(TTM_GETTOOLINFO, 0, DWord(@Result));
-end;
-
-procedure TMHToolTip.SetInfo(Value: TToolInfo);
-begin
-//  Perform(TTM_SETTOOLINFO, 0, DWord(@Value));
-end;}
-
-{function TMHToolTip.GetToolCount: Integer;
-begin
-//  Result := Perform(TTM_GETTOOLCOUNT, 0, 0);
-end;
-
-function TMHToolTip.GetTool(Index: Integer): TToolInfo;
-begin
-  FillChar(Result, SizeOf(Result), 0); // ????
-  Result.cbSize := SizeOf(Result);
-//  Perform(TTM_ENUMTOOLS, Index, DWord(@Result));
-end;     }
-
-{procedure TMHToolTip.Add(Value: TToolInfo);
-begin
-//  Perform(TTM_ADDTOOL, 0, DWord(@Value));
-end;}
-
-{procedure TMHToolTip.Delete(Value: TToolInfo);
-begin
-//  Perform(TTM_DELTOOL, 0, DWord(@Value));
-end;}
-
-procedure TMHToolTip.Update;
-begin
-  inherited; // ???
-  SendMessage(fHandle, TTM_UPDATE, 0, 0);
-end;
-
-function NewHint(A: PControl): PMHHint;
-begin
-  New(Result, Create);
-
-  with Result^ do
-  begin
-    Parent := A;
-    ToolTip := nil; // ???
-    HasTool := False; // ???
-  end;
-  A.Add2AutoFree(Result);
-end;
-
-function NewManager: PMHToolTipManager;
-begin
-  New(Result, Create);
-end;
-
-{ TMHHint }
-
-function TMHHint.GetDelay(const Index: Integer): Integer;
-begin
-//  CreateToolTip;
-  Result := 0;
-  if Assigned(ToolTip) then
-    Result := ToolTip.GetDelay(Index);
-end;
-
-function TMHHint.GetFI: TFI;
-begin
-  /// !!! DANGER-WITH !!!
-  with Result, ToolTip^ do
-  begin
-    FE := FE + [eTextColor];
-    Colors[1] := TextColor;
-
-    FE := FE + [eBkColor];
-    Colors[0] := BkColor;
-
-    FE := FE + [eAPDelay];
-    Delays[TTDT_AUTOPOP] := AutoPopDelay;
-
-    FE := FE + [eRDelay];
-    Delays[TTDT_RESHOW] := ReshowDelay;
-
-    FE := FE + [eIDelay];
-    Delays[TTDT_INITIAL] := InitialDelay;
-  end;
-end;
-
-procedure TMHHint.ReConnect(FI: TFI);
-var
-  TMP: PMHToolTip;
-begin
-  with GetManager^ do
-  begin
-    TMP := FindNeed(FI);
-    if not Assigned(TMP) then
-      TMP := CreateNeed(FI);
-    if Assigned(ToolTip) and HasTool then
-      MoveTool(TMP);
-    ToolTip := TMP;
-  end;
-end;
-
-procedure TMHHint.MoveTool(T1: PMHToolTip);
-var
-  TI: TToolInfo;
-  TextL: array[0..255] of KOLChar;
-begin
-  if T1 = ToolTip then
-    Exit;
-  with TI do
-  begin
-    cbSize := SizeOf(TI);
-    hWnd := Parent.GetWindowHandle;
-    uId := Parent.GetWindowHandle;
-    lpszText := @TextL[0];
-  end;
-
-  SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI));
-  SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI));
-  ToolTip.Count := ToolTip.Count - 1;
-  SendMessage(T1.handle, TTM_ADDTOOL, 0, DWORD(@TI));
-  T1.Count := T1.Count - 1;
-
-  HasTool := True;
-
-end;
-
-procedure TMHHint.SetColor(const Index: Integer; const Value: TColor);
-var
-  FI: TFI;
-begin
-  if Assigned(ToolTip) then
-  begin
-    if ToolTip.Count + Byte(not HasTool) = 1 then
-    begin
-      ToolTip.SetColor(Index, Value);
-      Exit;
-    end;
-    FI := GetFI;
-  end;
-
-  case Index of
-    0: FI.FE := FI.FE + [eBkColor];
-    1: FI.FE := FI.FE + [eTextColor];
-  end;
-  FI.Colors[Index] := Value;
-
-  ReConnect(FI);
-end;
-
-function TMHHint.GetColor(const Index: Integer): TColor;
-begin
-  Result := 0;
-  if Assigned(ToolTip) then
-    Result := ToolTip.GetColor(Index);
-end;
-
-procedure TMHHint.SetDelay(const Index, Value: Integer);
-var
-  FI: TFI;
-begin
-  if Assigned(ToolTip) then
-  begin
-    if ToolTip.Count + Byte(not HasTool) = 1 then
-    begin
-      ToolTip.SetDelay(Index, Value);
-      Exit;
-    end;
-    FI := GetFI;
-  end;
-
-  case Index of
-    TTDT_AUTOPOP: FI.FE := FI.FE + [eAPDelay]; // Spec
-    TTDT_INITIAL: FI.FE := FI.FE + [eIDelay]; // Spec
-    TTDT_RESHOW: FI.FE := FI.FE + [eRDelay]; // Spec
-  end; //case
-
-  FI.Delays[Index] := Value; //Spec
-
-  ReConnect(FI);
-end;
-
-procedure TMHHint.SetText(Value: KOLString);
-var
-  TI: TToolInfo;
-begin
-  ProcBegin(TI);
-
-  with TI do
-  begin
-    uFlags := TTF_SUBCLASS or TTF_IDISHWND; // Spec
-    lpszText := PKOLChar(Value); // Spec
-  end;
-
-  procEnd(TI);
-
-  if HasTool then
-  begin
-    TI.lpszText := PKOLChar(Value);
-    SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI));
-  end;
-end;
-
-(*
-procedure TMHHint.SetText(Value: string);
-var
-  TI: TToolInfo;
-  R: Trect;
-  TextLine: array[0..255] of Char;
-begin
-  if not Assigned(ToolTip) then
-  begin
-    if Length(Manager.TTT) = 0 then
-      Manager.AddTip;
-    ToolTip := Manager.TTT[0];
-  end;
-
-  with TI do
-  begin
-    cbSize := SizeOf(TI);
-    hWnd := Parent.GetWindowHandle;
-    uId := Parent.GetWindowHandle;
-    hInst := 0;
-  end;
-
-  if not HasTool {TTool = -1} then
-  begin
-    R := Parent.ClientRect;
- // Control:= C.Handle;
-    with TI do
-    begin
-//      cbSize := SizeOf(TI);
-      uFlags := TTF_SUBCLASS;
-//      hWnd := Parent.GetWindowHandle; //Control;
-//      uId := Parent.GetWindowHandle;
-      rect.Left := R.Left;
-      rect.Top := R.Top;
-      rect.Right := R.Right;
-      rect.Bottom := R.Bottom;
-//      hInst := 0;
-      lpszText := PChar(Value);
-    end;
-    SendMessage({Manager.TTT[TTip]} ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI));
-    HasTool := True;
-//    TTool := 0;
-    ToolTip {Manager.TTT[TTip]}.Count := ToolTip {Manager.TTT[TTip]}.Count + 1;
-
-  end
-  else
-  begin
-
-    with TI do
-    begin
-    // ????
-//      FillChar(TI, SizeOf(TI), 0);
-//      cbSize := SizeOf(TI);
-//      hWnd := Parent.GetWindowHandle;
-//      uId := Parent.GetWindowHandle;
-      lpszText := @TextLine; //PChar(S);
-    end;
-    SendMessage(ToolTip {Manager.TTT[TTip]}.handle, TTM_GETTOOLINFO, 0, DWord(@TI));
-    TI.lpszText := PChar(Value);
-//  Perform(TTM_GETTOOLINFO, 0, DWord(@Result));
-    SendMessage(ToolTip {Manager.TTT[TTip]}.handle, TTM_SETTOOLINFO, 0, DWord(@TI));
-  end;
-//  Manager.TTT[TTip].Tool[TTool].SSSetText(Value);
-end;
-*)
-
-{ TMHToolTipManager }
-
-{function TMHToolTipManager.AddColor(C: TColor): Integer;
-begin
-  SetLength(TTT, Length(TTT) + 1);
-  TTT[Length(TTT) - 1] := NewMHToolTip(Applet);
-  TTT[Length(TTT) - 1].SetColor(1, C);
-  Result := Length(TTT) - 1;
-end;         }
-
-function TMHToolTipManager.AddTip: Integer;
-begin
-  SetLength(TTT, Length(TTT) + 1);
-  TTT[Length(TTT) - 1] := NewMHToolTip(Applet);
-  Result := Length(TTT) - 1;
-end;
-
-{function TMHToolTip.Connect(Value: PControl): Integer;
-var
-  TI: TToolInfo;
-  R: Trect;
-//  Data:PDateTimePickerData;
-begin
-  R := Value.ClientRect;
- // Control:= C.Handle;
-  with TI do
-  begin
-    cbSize := SizeOf(TI);
-    uFlags := TTF_SUBCLASS;
-    hWnd := Value.GetWindowHandle; //Control;
-    uId := Value.GetWindowHandle;
-    rect.Left := R.Left;
-    rect.Top := R.Top;
-    rect.Right := R.Right;
-    rect.Bottom := R.Bottom;
-    hInst := 0;
-    lpszText := PChar('Super');
-  end;
-  PostMessage(handle, TTM_ADDTOOL, 0, DWORD(@TI));
-//  Perform(TTM_ADDTOOL, 0, DWord(@TI));
-end;}
-
-{function TMHToolTipManager.FindTip(N: Integer): Integer;
-begin
-  Result := -1;
-end;}
-
-function TMHToolTipManager.FindNeed(FI: TFI): PMHToolTip;
-var
-  i: Integer;
-begin
-  Result := nil;
-  for i := 0 to length(TTT) - 1 do
-  begin
-    if ((eTextColor in FI.FE) and (not (FI.Colors[1] = TTT[i].TextColor))) or
-      ((eBkColor in FI.FE) and (not (FI.Colors[0] = TTT[i].BkColor))) or
-      ((eAPDelay in FI.FE) and (not (FI.Delays[TTDT_AUTOPOP] = TTT[i].AutoPopDelay))) or
-      ((eIDelay in FI.FE) and (not (FI.Delays[TTDT_INITIAL] = TTT[i].InitialDelay))) or
-      ((eRDelay in FI.FE) and (not (FI.Delays[TTDT_RESHOW] = TTT[i].ReshowDelay))) then
-      Continue;
-    Result := TTT[i];
-    Break;
-  end;
-end;
-
-function TMHToolTipManager.CreateNeed(FI: TFI): PMHToolTip;
-
-begin
-  Setlength(TTT, length(TTT) + 1);
-  TTT[length(TTT) - 1] := NewMHToolTip(Applet);
-  with TTT[length(TTT) - 1]^ do
-  begin
-    if (eTextColor in FI.FE) then
-      TextColor := FI.Colors[1];
-    if (eBkColor in FI.FE) then
-      BkColor := FI.Colors[0];
-    if (eAPDelay in FI.FE) then
-      AutoPopDelay := FI.Delays[TTDT_AUTOPOP];
-    if (eIDelay in FI.FE) then
-      InitialDelay := FI.Delays[TTDT_INITIAL];
-    if (eRDelay in FI.FE) then
-      ReshowDelay := FI.Delays[TTDT_RESHOW];
-  end;
-  Result := TTT[length(TTT) - 1];
-end;
-
-procedure TMHHint.ProcBegin(var TI: TToolInfo);
-begin
-  CreateToolTip;
-
-  with TI do
-  begin
-    cbSize := SizeOf(TI);
-    hWnd := Parent.GetWindowHandle;
-    uId := Parent.GetWindowHandle;
-    hInst := 0;
-  end;
-end;
-
-procedure TMHHint.ProcEnd(var TI: TToolInfo);
-var
-  TextLine: array[0..255] of KOLChar;
-begin
-  if not HasTool then
-  begin
-    SendMessage(ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI));
-    HasTool := True;
-    ToolTip.Count := ToolTip.Count + 1;
-  end
-  else
-  begin
-    with TI do
-    begin
-      lpszText := @TextLine[0];
-    end;
-    SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI));
-  end;
-end;
-
-destructor TMHToolTipManager.Destroy;
-var
-  i: Integer;
-begin
-  for i := 0 to Length(TTT) - 1 do
-    TTT[i].Free;
-  SetLength(TTT, 0);
-  inherited;
-end;
-
-procedure TMHHint.Pop;
-begin
-  if Assigned(ToolTip) and (HasTool) then
-  begin // ^^^^^^^^^^^^ ???
-//  CreateToolTip;
-    ToolTip.Pop;
-  end;
-end;
-
-procedure TMHHint.Popup;
-begin
-  if Assigned(ToolTip) and (HasTool) then
-  begin // ^^^^^^^^^^^^ ???
-//  CreateToolTip;
-    ToolTip.Popup;
-  end;
-end;
-
-destructor TMHHint.Destroy;
-var
-  TI: TToolInfo;
-  i: integer;
-begin
-  with TI do
-  begin
-    cbSize := SizeOf(TI);
-    hWnd := Parent.GetWindowHandle;
-    uId := Parent.GetWindowHandle;
-  end;
-
-  SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI));
-  ToolTip.Count := ToolTip.Count - 1;
-  if ToolTip.Count <= 0 then begin
-    i:=Length(Manager.TTT);
-    if i > 1 then begin
-      Manager.TTT[i - 1].Free;
-      SetLength(Manager.TTT, i - 1);
-    end
-    else
-      Free_And_Nil(Manager);
-  end;
-  inherited;
-end;
-
-destructor TMHToolTip.Destroy;
-begin
-  inherited;
-end;
-
-procedure TMHHint.CreateToolTip;
-begin
-  if not Assigned(ToolTip) then
-  begin
-    if Length(GetManager.TTT) = 0 then
-      GetManager.AddTip;
-    ToolTip := GetManager.TTT[0];
-  end;
-end;
-
-function TMHHint.GetText: KOLString;
-var
-  TI: TToolInfo;
-  TextL: array[0..255] of KOLChar;
-begin
-  if Assigned(ToolTip) and (HasTool) then
-  begin
-    // !!!
-    with TI do
-    begin
-    // ????
-//      FillChar(TI, SizeOf(TI), 0);
-      cbSize := SizeOf(TI);
-      hWnd := Parent.GetWindowHandle;
-      uId := Parent.GetWindowHandle;
-      lpszText := @TextL[0];
-    end;
-    SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI));
-    Result := TextL; //TI.lpszText;// := PChar(Value);
-  end;
-end;
-
-function TMHHint.GetManager: PMHToolTipManager;
-begin
-  if Manager=nil then
-    Manager:=NewManager;
-  Result:=Manager;
-end;
-
-{$ENDIF implementation}
-
-{$IFDEF Frame}
-
-initialization
-{$ENDIF Frame}
-{$IFDEF initialization}
-
-  Manager := NewManager;
-{$ENDIF initialization}
-
-{$IFDEF Frame}
-finalization
-{$ENDIF Frame}
-{$IFDEF finalization}
-//  Manager.Free;
-{$ENDIF finalization}
-
-
-{$IFDEF Frame}
-end.
-{$ENDIF Frame}
-
-{$IFDEF function}
-function GetHint: PMHHint;
-{$ENDIF function}
-
-{$IFDEF public}
-  property Hint: PMHHint read GetHint;
-  {$ENDIF public}
-
-  {$IFDEF code}
-    function TControl.GetHint: PMHHint;
-    begin
-      if fHint = nil then
-        fHint := NewHint(@Self);
-      Result := fHint;
-    end;
-  {$ENDIF code}
-
-  {$IFDEF MHdestroy}
-    fHint.Free;
-  {$ENDIF MHdestroy}
-
-  {$IFDEF var}
-    fHint: PMHHint;
-  {$ENDIF var}

libwin/kolfpc/LICENSE.txt

@@ -1,51 +0,0 @@
-                wxWindows Library Licence, Version 3
-                ====================================
-
-  Copyright (C) 1998 Julian Smart, Robert Roebling [, ...]
-
-  Everyone is permitted to copy and distribute verbatim copies
-  of this licence document, but changing it is not allowed.
-
-                       WXWINDOWS LIBRARY LICENCE
-     TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-  
-  This library is free software; you can redistribute it and/or modify it
-  under the terms of the GNU Library General Public Licence as published by
-  the Free Software Foundation; either version 2 of the Licence, or (at
-  your option) any later version.
-  
-  This library is distributed in the hope that it will be useful, but
-  WITHOUT ANY WARRANTY; without even the implied warranty of
-  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library
-  General Public Licence for more details.
-
-  You should have received a copy of the GNU Library General Public Licence
-  along with this software, usually in a file named COPYING.LIB.  If not,
-  write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-  Boston, MA 02111-1307 USA.
-
-  EXCEPTION NOTICE
-
-  1. As a special exception, the copyright holders of this library give
-  permission for additional uses of the text contained in this release of
-  the library as licenced under the wxWindows Library Licence, applying
-  either version 3 of the Licence, or (at your option) any later version of
-  the Licence as published by the copyright holders of version 3 of the
-  Licence document.
-
-  2. The exception is that you may use, copy, link, modify and distribute
-  under the user's own terms, binary object code versions of works based
-  on the Library.
-
-  3. If you copy code from files distributed under the terms of the GNU
-  General Public Licence or the GNU Library General Public Licence into a
-  copy of this library, as this licence permits, the exception does not
-  apply to the code that you add in this way.  To avoid misleading anyone as
-  to the status of such modified files, you must delete this exception
-  notice from such code and/or adjust the licensing conditions notice
-  accordingly.
-
-  4. If you write modifications of your own for this library, it is your
-  choice whether to permit this exception to apply to your modifications. 
-  If you do not wish that, you must delete the exception notice from such
-  code and/or adjust the licensing conditions notice accordingly.

libwin/kolfpc/MCKfakeClasses.inc

@@ -1,77 +0,0 @@
-{
-  KOL MCK (C) 2000 by Vladimir Kladov
-
-  MCKfakeClasses.inc
-
-  This file redefines mirror class types to PControl / PObj
-  to use it by Delphi compiler - while compiling mirror KOL
-  project. At design time these definitions are not visible
-  for Delphi IDE because of conditional compiling directives.
-}
-
-{$I KOLDEF.INC}
-{$IFNDEF FPC}
-{$IFDEF _D7orHigher}
-  {$WARN UNSAFE_TYPE OFF} // Too many such warnings in Delphi7
-  {$WARN UNSAFE_CODE OFF}
-  {$WARN UNSAFE_CAST OFF}
-{$ENDIF}
-{$ENDIF}
-
-  TKOLProject = Pointer;
-  TKOLApplet = Pointer;
-  TKOLForm = Pointer;
-  TKOLDataModule = Pointer;
-  TKOLFrame = Pointer;
-  TKOLMDIClient = PControl;
-  TKOLMDIChild = Pointer;
-  TKOLService = Pointer;
-
-  TKOLButton = PControl;
-  TKOLLabel = PControl;
-  TKOLLabelEffect = PControl;
-  TKOLPanel = PControl;
-  TKOLSplitter = PControl;
-  TKOLGradientPanel = PControl;
-  TKOLBitBtn = PControl;
-  TKOLGroupBox = PControl;
-  TKOLCheckBox = PControl;
-  TKOLRadioBox = PControl;
-  TKOLEditBox = PControl;
-  TKOLMemo = PControl;
-  TKOLListBox = PControl;
-  TKOLComboBox = PControl;
-  TKOLPaintBox = PControl;
-  TKOLImageShow = PControl;
-
-  TKOLRichEdit = PControl;
-  TKOLProgressBar = PControl;
-  TKOLListView = PControl;
-  TKOLTreeView = PControl;
-  TKOLToolbar = PControl;
-  TKOLTabControl = PControl;
-  TTabPage = PControl;
-  TKOLScrollBox = PControl;
-  TKOLDateTimePicker = PControl;
-
-  TKOLTimer = PTimer;
-  TKOLThread = PThread;
-  TKOLImageList = PImageList;
-  TKOLMainMenu = PMenu;
-  TKOLPopupMenu = PMenu;
-  TKOLOpenSaveDialog = POpenSaveDialog;
-  //TKOLOpenDirDialog = POpenDirDialog;
-  TKOLTrayIcon = PTrayIcon;
-  TKOLColorDialog = PColorDialog;
-  //TKOLActionList = PActionList;
-  //TKOLAction = PAction;
-  TKOLScrollBar = PControl;
-
-{$IFNDEF FPC}
-{$IFDEF _D7orHigher}
-  //{$WARN UNSAFE_TYPE ON} // Too many such warnings in Delphi7
-  //{$WARN UNSAFE_CODE ON}
-  //{$WARN UNSAFE_CAST ON}
-{$ENDIF}
-{$ENDIF}
-

libwin/kolfpc/READ1ST.TXT

@@ -1,64 +0,0 @@
-KEY OBJECTS LIBRARY for Delphi (and Free Pascal Compiler) - to make applications small and power. This library is freeware and open source. Delphi 2, 3, 4, 5, 6, 7, 8, BDS 2005, 2006, TurboDelphi5 and Free Pascal Compiler 1.0.5, 1.0.6, and higher (2.0.4 and above) are supported. Partially compatible with Kylix (Linux/Qt platform, use special converting tool and provided files in Tools section on the site http://kolmck.net). Also a version for WinCE exists.
-
-Copyright (C) by Vladimir Kladov, 1999-2007.
-Some parts of code are Copyright (C) intellectual property by other people, see comments in code and on KOL site. Thanks to all for help with KOL and MCK!
-
-version 2.80 (19-Sep-2007)
-
-To get newer version, go to Web-page http://kolmck.net and get there updates.
-
-__________________
-BRIEF DESCRIPTION:
-    KOL - Key Objects Library is a set of objects to develop applications using Delphi. It is distributed free of charge, with source code.
-   KOL allows to create very compact GUI applications (starting from ~14,0K without compression - if suggested system units replacement used). The majority of the code is converted to assembly.
-   A Help generating tool, xHelpGen is provided for KOL, which creates detailed documentation in html format. Documentation is generated on from the source code comments, so developers instantly  have access to the most fresh and complete documentation.
-   With advent of the MCK (Mirror Classes Kit) package, all advantages of visual programming are available for developers who use KOL. Additionally with MCK it is possible to make large enough projects smaller converting part of machine code to a byte code of Forth-like virtual (emulated at run time) machint (see more detailed: Collapse).
-   A lot of additions are available for KOL, which allow to work with data bases, Active-X components, print reports, different image and compression formats, etc.
---------------------------------------------
-
-This archive contains Key Objects Library main part: KOL.PAS and several test samples. 
-At the KOL Web page (http://kolmck.net), you can download also additional components:
-
-MCK		- Mirror Classes Kit - visual programming environment for KOL
-xHelpGen	- utility to generate html-documentation from comments within the source code;
-KolErr	(~25K) - "light" (for 6K), but functional exception handling unit
-KOLEdb, KOLODBC, StrDb (by Mike Talcott), TdkDbKol (by Thaddy de Koning) - DB-extensions for KOL
-KolGif	(~20K) - GIF (animated, transparent) support for KOL
-KolJpegObj (~127K + 340K) - JPEG support for KOL
-KolOGL12 (~59K) - OpenGL support for KOL
-KOLword (~12K) - MS Word automation
-Service	(~20K) - writing NT services with KOL
-KOLSocket (~30K) - sockets for KOL (by Alexander Shakhaylo)
-TestKOLRas (~20K) - RAS dial-up for KOL (by Alexander Shakhaylo)
-sysdcu	(~200K) - system.dcu, sysinit.dcu replacement for Delphi5 (it provides a savings of 9KBytes from the .exe's file size)
-sysdcuD6 (~200K) - system.dcu, ... replacement for Delphi6
-HeapMM  (~1K) - alteranative memory manager
-MapMem
-Widgets
-ZLib
-... and many others, this list is constantly extended with new items.
-
-
-_____________
-INSTALLATION:
-
-1. When You install KOL the first time, create a new directory for KOL (e.g., E:\KOL).
-
-2. Unpack all files from KOL.ZIP there. (If upgrading, confirm overwriting of old files with new ones).
-
-3. If You downloaded xhelpgen.zip package, also unpack it into the same directory. Read also docs for xHelpGen from the package.
-
-4. If You downloaded SYSDCU.ZIP, create subdirectory for it (e.g. E:\KOL\SYS) and unpack it there. Read also docs for system units replacement in the package.
-
-5. To learn how to install the MCK (Mirror Classes Kit) see instructions in the MCK archive.
-
-6. To learn how to install KOLEdb, see instructions in KOLEDB.ZIP archive. 
-
-7. For more information on the use and or installation of any of the packages packages and programs found on KOL site: look for help within it's package.
-
-Note: KOL itself does not require creating a package since it has no design-time components to install it onto Component Palette. See MCK, which has such components and allows visual programming using KOL.
---------------------------------------------------
-
-Web address: http://kolmck.net
-vk@kolmck.net      
-Vladimir Kladov

libwin/kolfpc/Readme-KOL-CE.txt

@@ -1,25 +0,0 @@
-KOL-CE notes.
-
-Main project page:
-http://wiki.freepascal.org/KOL-CE
-
-Project pages at SourceForge:
-http://sourceforge.net/projects/kol-ce/
-
-Usage
-=====
-
-You need to download or create arm-wince cross compiler to be able to use this library.
-How to do that read here:
-http://wiki.freepascal.org/index.php?title=WinCE_port
-
-Port notes
-==========
-
-* To make form fullscreen as most Pocket PC applications dont change the form position and size. If form size and/or position was changed the form will look like dialog with caption and close button. 
-
-Known issues
-============
-
-* The following components are not supported: RichEdit, TrayIcon.
-* Only gsVertical, gsHorizontal gradient panel styles are supported.

libwin/kolfpc/delphidef.inc

@@ -1,46 +0,0 @@
-//{$DEFINE _FPC}
-{$DEFINE ASM_VERSION} // Comment this line to produce Pascal code.
-                      // Or, just add PAS_VERSION to conditionals
-                      // of your project (must be rebuilt).
-
-{$IFDEF ASM_VERSION}
-  {$IFDEF PAS_VERSION}
-    {$UNDEF ASM_VERSION}
-    // To compile a project with ASM_VERSION option turned off,
-    // define a symbol PAS_VERSION in project options.
-  {$ENDIF}
-{$ENDIF}
-
-{$I KOLDEF.INC}
-
-//{$DEFINE USE_CONSTRUCTORS}
-// Comment this line to produce smaller code if constructors are not used.
-// When uncommented, this definition allows to create descendant controls
-// and objects overriding constructors, which are actually members of objects.
-// Otherwise, global functions (usually named New<ObjectName>) are used to
-// create and initialize object instances. This gives smaller code, but
-// prevents from using OOP inheritance.
-// Note: creating descendant objects derived from TObj does not require using
-// of this option. It is actually needed only for deriving new controls on
-// base of TControl. See also option USE_CUSTOMEXTENSIONS below.
-
-//{$DEFINE USE_CUSTOMEXTENSIONS}
-// Uncomment this option or add it to your project conditional defines,
-// if You wish to extend existing TControl object from
-// the inner of those. When this option is turned on, include directive at the
-// tail of TControl declaration is enabled, causing a compiler to include your
-// portion of source directly into the TControl body. See comments near this
-// directive there. (Search the word: USE_CUSTOMEXTENSIONS).
-// Please note, that this option is not fully supported now.
-
-{$IFNDEF NOT_UNLOAD_RICHEDITLIB}
-  {$DEFINE UNLOAD_RICHEDITLIB}
-{$ENDIF}
-// You can freely comment this directive. 1st, if the application does not
-// use richedit control. 2nd, even if it does, freeing the library handle
-// actually is not needed.
-// Another way to turn this option off is to define symbol NOT_UNLOAD_RICHEDITLIB
-// in your project options.
-
-//{$DEFINE TEST_VERSION}
-{$DEFINE PARANOIA} //seems not needed under D6 !!! Inprise fixed this, finally... :)

libwin/kolfpc/delphiusesh.inc

@@ -1 +0,0 @@
-windows, messages, RichEdit {$IFDEF CHK_GDI}, ChkGdi {$ENDIF}

libwin/kolfpc/fpc_unicode_add.inc

@@ -1,561 +0,0 @@
-const
-  MAX_PROFILE_LEN = 80;
-  MM_MAX_AXES_NAMELEN = 16;
-  MM_MAX_NUMAXES = 16;
-  HW_PROFILE_GUIDLEN = 39;
-
-type
-  HDEVNOTIFY = Pointer;
-  PHDEVNOTIFY = ^HDEVNOTIFY;
-
-  _GET_FILEEX_INFO_LEVELS = (GetFileExInfoStandard, GetFileExMaxInfoLevel);
-  TGetFileExInfoLevels = _GET_FILEEX_INFO_LEVELS;
-  GET_FILEEX_INFO_LEVELS = _GET_FILEEX_INFO_LEVELS;
-
-  _FINDEX_INFO_LEVELS = (FindExInfoStandard, FindExInfoMaxInfoLevel);
-  TFindexInfoLevels = _FINDEX_INFO_LEVELS;
-  FINDEX_INFO_LEVELS = _FINDEX_INFO_LEVELS;
-
-  _FINDEX_SEARCH_OPS = (FindExSearchNameMatch, FindExSearchLimitToDirectories,
-    FindExSearchLimitToDevices, FindExSearchMaxSearchOp);
-  TFindexSearchOps = _FINDEX_SEARCH_OPS;
-  FINDEX_SEARCH_OPS = _FINDEX_SEARCH_OPS;
-
-  TFNPropEnumProc = TFarProc;
-  TFNPropEnumProcEx = TFarProc;
-  TFNEditWordBreakProc = TFarProc;
-  TFNNameEnumProc = TFarProc;
-  TFNWinStaEnumProc = TFNNameEnumProc;
-  TFNDeskTopEnumProc = TFNNameEnumProc;
-  TFNWndProc = TFarProc;
-  TFNDlgProc = TFarProc;
-  TFNTimerProc = TFarProc;
-  TFNGrayStringProc = TFarProc;
-  TFNWndEnumProc = TFarProc;
-  TFNSendAsyncProc = TFarProc;
-  TFNDrawStateProc = TFarProc;
-  TFNOldFontEnumProcW = TFarProc;
-  TFNGObjEnumProc = TFarProc;
-  TFNLineDDAProc = TFarProc;
-  TFNFontEnumProcW = TFarProc;
-  TFNProgressRoutine = TFarProc;
-  TFNLocaleEnumProc = TFarProc;
-  TFNCodepageEnumProc = TFarProc;
-  TFNDateFmtEnumProc = TFarProc;
-  TFNTimeFmtEnumProc = TFarProc;
-  TFNCalInfoEnumProc = TFarProc;
-  TFNICMEnumProc = TFarProc;
-
-  MakeIntAtomW = PWideChar;
-  
-  PRecoveryAgentInformationW = ^TRecoveryAgentInformationW;
-  _RECOVERY_AGENT_INFORMATIONW = record
-    NextEntryOffset: DWORD;
-    AgentNameLength: DWORD;
-    AgentInformation: array[0..0] of CHAR;
-  end;
-  TRecoveryAgentInformationW = _RECOVERY_AGENT_INFORMATIONW;
-  RECOVERY_AGENT_INFORMATIONW = _RECOVERY_AGENT_INFORMATIONW;
-  
-  PWin32FindDataW = ^TWin32FindDataW;
-  _WIN32_FIND_DATAW = record
-    dwFileAttributes: DWORD;
-    ftCreationTime: TFileTime;
-    ftLastAccessTime: TFileTime;
-    ftLastWriteTime: TFileTime;
-    nFileSizeHigh: DWORD;
-    nFileSizeLow: DWORD;
-    dwReserved0: DWORD;
-    dwReserved1: DWORD;
-    cFileName: array[0..MAX_PATH - 1] of WideChar;
-    cAlternateFileName: array[0..13] of WideChar;
-  end;
-  TWin32FindDataW = _WIN32_FIND_DATAW;
-  WIN32_FIND_DATAW = _WIN32_FIND_DATAW;
-
-  PHWProfileInfoW = ^THWProfileInfoW;
-  tagHW_PROFILE_INFOW = packed record
-    dwDockInfo: DWORD;
-    szHwProfileGuid: packed array[0..HW_PROFILE_GUIDLEN-1] of WideChar;
-    szHwProfileName: packed array[0..MAX_PROFILE_LEN-1] of WideChar;
-  end;
-  THWProfileInfoW = tagHW_PROFILE_INFOW;
-  HW_PROFILE_INFOW = tagHW_PROFILE_INFOW;
-
-  PLogColorSpaceW = ^TLogColorSpaceW;
-  tagLOGCOLORSPACEW = packed record
-    lcsSignature: DWORD;
-    lcsVersion: DWORD;
-    lcsSize: DWORD;
-    lcsCSType: LCSCSTYPE;
-    lcsIntent: LCSGAMUTMATCH;
-    lcsEndpoints: TCIEXYZTriple;
-    lcsGammaRed: DWORD;
-    lcsGammaGreen: DWORD;
-    lcsGammaBlue: DWORD;
-    lcsFilename: array[0..259] of WideChar;
-  end;
-  TLogColorSpaceW = tagLOGCOLORSPACEW;
-  LOGCOLORSPACEW = tagLOGCOLORSPACEW;
-
-  PNewTextMetricW = ^TNewTextMetricW;
-  tagNEWTEXTMETRICW = record
-    tmHeight: Longint;
-    tmAscent: Longint;
-    tmDescent: Longint;
-    tmInternalLeading: Longint;
-    tmExternalLeading: Longint;
-    tmAveCharWidth: Longint;
-    tmMaxCharWidth: Longint;
-    tmWeight: Longint;
-    tmOverhang: Longint;
-    tmDigitizedAspectX: Longint;
-    tmDigitizedAspectY: Longint;
-    tmFirstChar: WideChar;
-    tmLastChar: WideChar;
-    tmDefaultChar: WideChar;
-    tmBreakChar: WideChar;
-    tmItalic: Byte;
-    tmUnderlined: Byte;
-    tmStruckOut: Byte;
-    tmPitchAndFamily: Byte;
-    tmCharSet: Byte;
-    ntmFlags: DWORD;
-    ntmSizeEM: UINT;
-    ntmCellHeight: UINT;
-    ntmAvgWidth: UINT;
-  end;
-  TNewTextMetricW = tagNEWTEXTMETRICW;
-  NEWTEXTMETRICW = tagNEWTEXTMETRICW;
-
-  PNewTextMetricExW = ^TNewTextMetricExW;
-  tagNEWTEXTMETRICEXW = packed record
-    ntmTm: TNewTextMetricW;
-    ntmFontSig: TFontSignature;
-  end;
-  TNewTextMetricExW = tagNEWTEXTMETRICEXW;
-  NEWTEXTMETRICEXW = tagNEWTEXTMETRICEXW;
-
-  PEnumLogFontW = ^TEnumLogFontW;
-  tagENUMLOGFONTW = packed record
-    elfLogFont: TLogFontW;
-    elfFullName: array[0..LF_FULLFACESIZE - 1] of WideChar;
-    elfStyle: array[0..LF_FACESIZE - 1] of WideChar;
-  end;
-  TEnumLogFontW = tagENUMLOGFONTW;
-  ENUMLOGFONTW = tagENUMLOGFONTW;
-
-  PEnumLogFontExW = ^TEnumLogFontExW;
-  tagENUMLOGFONTEXW = packed record
-    elfLogFont: TLogFontW;
-    elfFullName: array[0..LF_FULLFACESIZE - 1] of WideChar;
-    elfStyle: array[0..LF_FACESIZE - 1] of WideChar;
-    elfScript: array[0..LF_FACESIZE - 1] of WideChar;
-  end;
-  TEnumLogFontExW = tagENUMLOGFONTEXW;
-  ENUMLOGFONTEXW = tagENUMLOGFONTEXW;
-
-  PExtLogFontW = ^TExtLogFontW;
-  tagEXTLOGFONTW = record
-    elfLogFont: TLogFontW;
-    elfFullName: array[0..LF_FULLFACESIZE - 1] of WideChar;
-    elfStyle: array[0..LF_FACESIZE - 1] of WideChar;
-    elfVersion: DWORD;     { 0 for the first release of NT }
-    elfStyleSize: DWORD;
-    elfMatch: DWORD;
-    elfReserved: DWORD;
-    elfVendorId: array[0..ELF_VENDOR_SIZE - 1] of Byte;
-    elfCulture: DWORD;     { 0 for Latin }
-    elfPanose: TPanose;
-  end;
-  TExtLogFontW = tagEXTLOGFONTW;
-  EXTLOGFONTW = tagEXTLOGFONTW;
-
-  PDisplayDeviceW = ^TDisplayDeviceW;
-  _DISPLAY_DEVICEW = packed record
-    cb: DWORD;
-    DeviceName: array[0..31] of WideChar;
-    DeviceString: array[0..127] of WideChar;
-    StateFlags: DWORD;
-  end;
-  TDisplayDeviceW = _DISPLAY_DEVICEW;
-
-  POutlineTextmetricW = ^TOutlineTextmetricW;
-  _OUTLINETEXTMETRICW = record
-    otmSize: UINT;
-    otmTextMetrics: TTextMetricW;
-    otmFiller: Byte;
-    otmPanoseNumber: TPanose;
-    otmfsSelection: UINT;
-    otmfsType: UINT;
-    otmsCharSlopeRise: Integer;
-    otmsCharSlopeRun: Integer;
-    otmItalicAngle: Integer;
-    otmEMSquare: UINT;
-    otmAscent: Integer;
-    otmDescent: Integer;
-    otmLineGap: UINT;
-    otmsCapEmHeight: UINT;
-    otmsXHeight: UINT;
-    otmrcFontBox: TRect;
-    otmMacAscent: Integer;
-    otmMacDescent: Integer;
-    otmMacLineGap: UINT;
-    otmusMinimumPPEM: UINT;
-    otmptSubscriptSize: TPoint;
-    otmptSubscriptOffset: TPoint;
-    otmptSuperscriptSize: TPoint;
-    otmptSuperscriptOffset: TPoint;
-    otmsStrikeoutSize: UINT;
-    otmsStrikeoutPosition: Integer;
-    otmsUnderscoreSize: Integer;
-    otmsUnderscorePosition: Integer;
-    otmpFamilyName: PWideChar;
-    otmpFaceName: PWideChar;
-    otmpStyleName: PWideChar;
-    otmpFullName: PWideChar;
-  end;
-  TOutlineTextmetricW = _OUTLINETEXTMETRICW;
-  OUTLINETEXTMETRICW = _OUTLINETEXTMETRICW;
-
-  PPolyTextW = ^TPolyTextW;
-  tagPOLYTEXTW = packed record
-    x: Integer;
-    y: Integer;
-    n: UINT;
-    PAnsiChar: PWideChar;
-    uiFlags: UINT;
-    rcl: TRect;
-    pdx: PINT;
-  end;
-  TPolyTextW = tagPOLYTEXTW;
-  POLYTEXTW = tagPOLYTEXTW;
-
-  PGCPResultsW = ^TGCPResultsW;
-  tagGCP_RESULTSW = packed record
-    lStructSize: DWORD;
-    lpOutString: PWideChar;
-    lpOrder: PUINT;
-    lpDx: PINT;
-    lpCaretPos: PINT;
-    lpClass: PWideChar;
-    lpGlyphs: PUINT;
-    nGlyphs: UINT;
-    nMaxFit: Integer;
-  end;
-  TGCPResultsW = tagGCP_RESULTSW;
-  GCP_RESULTSW = tagGCP_RESULTSW;
-
- PAxisInfoW = ^TAxisInfoW;
-  tagAXISINFOW = packed record
-    axMinValue: Longint;
-    axMaxValue: Longint;
-    axAxisName: array[0..MM_MAX_AXES_NAMELEN-1] of WideChar;
-  end;
-  TAxisInfoW = tagAXISINFOW;
-  PAxesListW = ^TAxesListW;
-  tagAXESLISTW = packed record
-    axlReserved: DWORD;
-    axlNumAxes: DWORD;
-    axlAxisInfo: array[0..MM_MAX_NUMAXES-1] of TAxisInfoW;
-  end;
-  TAxesListW = tagAXESLISTW;
-
-  PDesignVector = ^TDesignVector;
-  tagDESIGNVECTOR = packed record
-    dvReserved: DWORD;
-    dvNumAxes: DWORD;
-    dvValues: array[0..MM_MAX_NUMAXES-1] of Longint;
-  end;
-  TDesignVector = tagDESIGNVECTOR;
-
-  PEnumLogFontExDVW = ^TEnumLogFontExDVW;
-  tagENUMLOGFONTEXDVW = packed record
-    elfEnumLogfontEx: TEnumLogFontExW;
-    elfDesignVector: TDesignVector;
-  end;
-  TEnumLogFontExDVW = tagENUMLOGFONTEXDVW;
-
-  PEnumTextMetricW = ^TEnumTextMetricW;
-  tagENUMTEXTMETRICW = packed record
-    etmNewTextMetricEx: TNewTextMetricExW;
-    etmAxesList: TAxesListW;
-  end;
-  TEnumTextMetricW = tagENUMTEXTMETRICW;
-
-  PDocInfoW = ^TDocInfoW;
-  _DOCINFOW = packed record
-    cbSize: Integer;
-    lpszDocName: PWideChar;
-    lpszOutput: PWideChar;
-    lpszDatatype: PWideChar;
-    fwType: DWORD;
-  end;
-  TDocInfoW = _DOCINFOW;
-  DOCINFOW = _DOCINFOW;
-
-  PCreateStructW = ^TCreateStructW;
-  tagCREATESTRUCTW = packed record
-    lpCreateParams: Pointer;
-    hInstance: HINST;
-    hMenu: HMENU;
-    hwndParent: HWND;
-    cy: Integer;
-    cx: Integer;
-    y: Integer;
-    x: Integer;
-    style: Longint;
-    lpszName: PWideChar;
-    lpszClass: PWideChar;
-    dwExStyle: DWORD;
-  end;
-  TCreateStructW = tagCREATESTRUCTW;
-  CREATESTRUCTW = tagCREATESTRUCTW;
-
-  TPRMsgBoxCallback = procedure(var lpHelpInfo: THelpInfo);
-  PMsgBoxParamsW = ^TMsgBoxParamsW;
-  tagMSGBOXPARAMSW = packed record
-    cbSize: UINT;
-    hwndOwner: HWND;
-    hInstance: HINST;
-    lpszText: PWideChar;
-    lpszCaption: PWideChar;
-    dwStyle: DWORD;
-    lpszIcon: PWideChar;
-    dwContextHelpId: DWORD;
-    lpfnMsgBoxCallback: TPRMsgBoxCallback;
-    dwLanguageId: DWORD;
-  end;
-  TMsgBoxParamsW = tagMSGBOXPARAMSW;
-  MSGBOXPARAMSW = tagMSGBOXPARAMSW;
-
-  PMDICreateStructW = ^TMDICreateStructW;
-  tagMDICREATESTRUCTW = packed record
-    szClass: PWideChar;
-    szTitle: PWideChar;
-    hOwner: THandle;
-    x: Integer;
-    y: Integer;
-    cx: Integer;
-    cy: Integer;
-    style: DWORD;
-    lParam: LPARAM;  { app-defined stuff }
-  end;
-  TMDICreateStructW = tagMDICREATESTRUCTW;
-  MDICREATESTRUCTW = tagMDICREATESTRUCTW;
-
-  PMultiKeyHelpW = ^TMultiKeyHelpW;
-  tagMULTIKEYHELPW = record
-    mkSize: DWORD;
-    mkKeylist: WideChar;
-    szKeyphrase: array[0..0] of WideChar;
-  end;
-  TMultiKeyHelpW = tagMULTIKEYHELPW;
-  MULTIKEYHELPW = tagMULTIKEYHELPW;
-
-  PHelpWinInfoW = ^THelpWinInfoW;
-  tagHELPWININFOW = record
-    wStructSize: Integer;
-    x: Integer;
-    y: Integer;
-    dx: Integer;
-    dy: Integer;
-    wMax: Integer;
-    rgchMember: array[0..1] of WideChar;
-  end;
-  THelpWinInfoW = tagHELPWININFOW;
-  HELPWININFOW = tagHELPWININFOW;
-
-  PNonClientMetricsW = ^TNonClientMetricsW;
-  tagNONCLIENTMETRICSW = packed record
-    cbSize: UINT;
-    iBorderWidth: Integer;
-    iScrollWidth: Integer;
-    iScrollHeight: Integer;
-    iCaptionWidth: Integer;
-    iCaptionHeight: Integer;
-    lfCaptionFont: TLogFontW;
-    iSmCaptionWidth: Integer;
-    iSmCaptionHeight: Integer;
-    lfSmCaptionFont: TLogFontW;
-    iMenuWidth: Integer;
-    iMenuHeight: Integer;
-    lfMenuFont: TLogFontW;
-    lfStatusFont: TLogFontW;
-    lfMessageFont: TLogFontW;
-  end;
-  TNonClientMetricsW = tagNONCLIENTMETRICSW;
-  NONCLIENTMETRICSW = tagNONCLIENTMETRICSW;
-
-  PIconMetricsW = ^TIconMetricsW;
-  tagICONMETRICSW = packed record
-    cbSize: UINT;
-    iHorzSpacing: Integer;
-    iVertSpacing: Integer;
-    iTitleWrap: Integer;
-    lfFont: TLogFontW;
-  end;
-  TIconMetricsW = tagICONMETRICSW;
-  ICONMETRICSW = tagICONMETRICSW;
-
-  PSerialKeysW = ^TSerialKeysW;
-  tagSERIALKEYSW = packed record
-    cbSize: UINT;
-    dwFlags: DWORD;
-    lpszActivePort: PWideChar;
-    lpszPort: PWideChar;
-    iBaudRate: UINT;
-    iPortState: UINT;
-    iActive: UINT;
-  end;
-  TSerialKeysW = tagSERIALKEYSW;
-  SERIALKEYSW = tagSERIALKEYSW;
-
-  PHighContrastW = ^THighContrastW;
-  tagHIGHCONTRASTW = packed record
-    cbSize: UINT;
-    dwFlags: DWORD;
-    lpszDefaultScheme: PWideChar;
-  end;
-  THighContrastW = tagHIGHCONTRASTW;
-  HIGHCONTRASTW = tagHIGHCONTRASTW;
-
-  PSoundsEntryW = ^TSoundsEntryW;
-  tagSOUNDSENTRYW = packed record
-    cbSize: UINT;
-    dwFlags: DWORD;
-    iFSTextEffect: DWORD;
-    iFSTextEffectMSec: DWORD;
-    iFSTextEffectColorBits: DWORD;
-    iFSGrafEffect: DWORD;
-    iFSGrafEffectMSec: DWORD;
-    iFSGrafEffectColor: DWORD;
-    iWindowsEffect: DWORD;
-    iWindowsEffectMSec: DWORD;
-    lpszWindowsEffectDLL: PWideChar;
-    iWindowsEffectOrdinal: DWORD;
-  end;
-  TSoundsEntryW = tagSOUNDSENTRYW;
-  SOUNDSENTRYW = tagSOUNDSENTRYW;
-
-  PNumberFmtW = ^TNumberFmtW;
-  _numberfmtW = packed record
-    NumDigits: UINT;        { number of decimal digits }
-    LeadingZero: UINT;      { if leading zero in decimal fields }
-    Grouping: UINT;         { group size left of decimal }
-    lpDecimalSep: PWideChar;   { ptr to decimal separator string }
-    lpThousandSep: PWideChar;  { ptr to thousand separator string }
-    NegativeOrder: UINT;    { negative number ordering }
-  end;
-  TNumberFmtW = _numberfmtW;
-  NUMBERFMTW = _numberfmtW;
-
-  PCurrencyFmtW = ^TCurrencyFmtW;
-  _currencyfmtW = packed record
-    NumDigits: UINT;           { number of decimal digits }
-    LeadingZero: UINT;         { if leading zero in decimal fields }
-    Grouping: UINT;            { group size left of decimal }
-    lpDecimalSep: PWideChar;      { ptr to decimal separator string }
-    lpThousandSep: PWideChar;     { ptr to thousand separator string }
-    NegativeOrder: UINT;       { negative currency ordering }
-    PositiveOrder: UINT;       { positive currency ordering }
-    lpCurrencySymbol: PWideChar;  { ptr to currency symbol string }
-  end;
-  TCurrencyFmtW = _currencyfmtW;
-  CURRENCYFMTW = _currencyfmtW;
-
-  PPValueW = ^TPValueW;
-  pvalueW = packed record
-    pv_valuename: PWideChar;           { The value name pointer }
-    pv_valuelen: BOOL;
-    pv_value_context: Pointer;
-    pv_type: DWORD;
-  end;
-  TPValueW = pvalueW;
-
-  PValueEntW = ^TValueEntW;
-  value_entW = packed record
-    ve_valuename: PWideChar;
-    ve_valuelen: DWORD;
-    ve_valueptr: DWORD;
-    ve_type: DWORD;
-  end;
-  TValueEntW = value_entW;
-  VALENTW = value_entW;
-
-  PNetResourceW = ^TNetResourceW;
-  _NETRESOURCEW = packed record
-    dwScope: DWORD;
-    dwType: DWORD;
-    dwDisplayType: DWORD;
-    dwUsage: DWORD;
-    lpLocalName: PWideChar;
-    lpRemoteName: PWideChar;
-    lpComment: PWideChar;
-    lpProvider: PWideChar;
-  end;
-  TNetResourceW = _NETRESOURCEW;
-  NETRESOURCEW = _NETRESOURCEW;
-
-  PDiscDlgStructW = ^TDiscDlgStructW;
-  _DISCDLGSTRUCTW = packed record
-    cbStructure: DWORD;       { size of this structure in bytes }
-    hwndOwner: HWND;          { owner window for the dialog }
-    lpLocalName: PWideChar;       { local device name }
-    lpRemoteName: PWideChar;      { network resource name }
-    dwFlags: DWORD;
-  end;
-  TDiscDlgStructW = _DISCDLGSTRUCTW;
-  DISCDLGSTRUCTW = _DISCDLGSTRUCTW;
-
-  PUniversalNameInfoW = ^TUniversalNameInfoW;
-  _UNIVERSAL_NAME_INFOW = packed record
-    lpUniversalName: PWideChar;
-  end;
-  TUniversalNameInfoW = _UNIVERSAL_NAME_INFOW;
-  UNIVERSAL_NAME_INFOW = _UNIVERSAL_NAME_INFOW;
-
-  PRemoteNameInfoW = ^TRemoteNameInfoW;
-  _REMOTE_NAME_INFOW = packed record
-    lpUniversalName: PWideChar;
-    lpConnectionName: PWideChar;
-    lpRemainingPath: PWideChar;
-  end;
-  TRemoteNameInfoW = _REMOTE_NAME_INFOW;
-  REMOTE_NAME_INFOW = _REMOTE_NAME_INFOW;
-
-  PAltTabInfo = ^TAltTabInfo;
-  tagALTTABINFO = packed record
-    cbSize: DWORD;
-    cItems: Integer;
-    cColumns: Integer;
-    cRows: Integer;
-    iColFocus: Integer;
-    iRowFocus: Integer;
-    cxItem: Integer;
-    cyItem: Integer;
-    ptStart: TPoint;
-  end;
-  TAltTabInfo = tagALTTABINFO;
-  
-  PMenuItemInfoW = ^TMenuItemInfoW;
-  tagMENUITEMINFOW = packed record
-    cbSize: UINT;
-    fMask: UINT;
-    fType: UINT;             { used if MIIM_TYPE}
-    fState: UINT;            { used if MIIM_STATE}
-    wID: UINT;               { used if MIIM_ID}
-    hSubMenu: HMENU;         { used if MIIM_SUBMENU}
-    hbmpChecked: HBITMAP;    { used if MIIM_CHECKMARKS}
-    hbmpUnchecked: HBITMAP;  { used if MIIM_CHECKMARKS}
-    dwItemData: DWORD;       { used if MIIM_DATA}
-    dwTypeData: PWideChar;      { used if MIIM_TYPE}
-    cch: UINT;               { used if MIIM_TYPE}
-    hbmpItem: HBITMAP;       { used if MIIM_BITMAP}
-  end;
-  TMenuItemInfoW = tagMENUITEMINFOW;
-  MENUITEMINFOW = tagMENUITEMINFOW;
-
-  PMenuItemInfo = PMenuItemInfoW;
-  TMenuItemInfo = TMenuItemInfoW;
-  MENUITEMINFO = MENUITEMINFOW;

libwin/kolfpc/read1st_rus.txt

@@ -1,61 +0,0 @@
-KEY OBJECTS LIBRARY для Delphi (и Free Pascal Compiler) - предназначен для того, чтобы сделать программы, изготовленные с использованием языка Паскаль, маленькими и очень маленькими. 
-Copyright (C) by Vladimir Kladov, 1999-2007. Бесплатно, с исходными текстами.
-
-версия 2.80 (19 сентября 2007 г.)
-
-_________________
-КРАТКОЕ ОПИСАНИЕ:
-   KOL - Key Objects Library - это библиотека объектов для программирования в среде Delphi. 
-   Поддерживаются версии Delphi2, Delph3, Delphi4, Delphi5, Delphi6, Delphi7, Delphi8, BDS2005, BDS2006, Turbo-Delphi а так же Free Pascal v1.0.5, v2.0.4 и выше. Имеется так же частичная совместимость с Kylix (требуется конвертер и набор файлов, см. в разделе "Инструменты разработчика" на сайте http://kolmck.net). Ведется работа над портированием на другие платформы (Linux, Win CE).
-   Библиотека KOL позволяет разрабатывать чрезвычайно компактные GUI-приложения (от 11К без сжатия - при условии использования предлагаемой замены системных модулей system, sysinit, см. на сайте раздел "Архивы"). Большая часть кода переведана на ассемблер.
-   К библиотеке прилагается программа - генератор справки (xHelpGen), формирующая подробную документацию по библиотеке в html-формате. Справка формируется на основе комментариев в исходных текстах, так что разработчики всегда имеют доступ к самой свежей и полной документации. 
-   С использованием MCK (Mirror Classes Kit - набор зеркальных классов) все прелести визуальной разработки программ в полной мере доступны и для разработчиков, использующих KOL. Дополнительно с MCK имеется возможность еще более уменьшать приложения, автоматически генерируя П-код виртуальной машины вместо Паскаль-кода для инициализации форм (см. подроблее: Collapse).
-----------------------------------
-
-Данный архив содержит самодостаточную часть библиотеки Key Objects Library: файл KOL.PAS. На странице (http://kolmck.net) возможно также загрузить дополнительные расширения, в том числе:
-
-MCK		- Mirror Classes Kit - полноценная визуальная среда для KOL
-xHelpGen	(~50K) - генератор html-справки на основе комментариев в исходном коде
-KolErr	(~20K) - "облегченная" (на 6К), но вполне фунциональная обработка исключений
-KOLEdb, KOLODBC, StrDb, TdkDbKol - расширения для работы с БД
-KOLWord	(~12K) - MS Word automation
-KolGif	(~20K) - поддержка анимированных gif-файлов
-KolJpegObj	(~127K) - поддержка JPEG
-KolOgl12	(~59K) - поддержка OpenGL	
-Service	(~30K) - написание NT сервисов в KOL
-KOLSocket	(~30K) - сокеты
-sysdcu	(~200K) - замена system.dcu, sysinit.dcu для Delphi5 (экономия еще 9К в .exe)
-HeapMM	(~1K) - альтернативный менеджер памяти
-
-...
-И так далее, список пополняется постоянно.
-
-__________________________________________________
-УСТАНОВКА И ПЕРЕУСТАНОВКА (УСТАНОВКА НОВОЙ ВЕРСИИ):
-
-1. При первой установке создать новую директорию (например, E:\KOL).
-
-2. Распаковать файлы из KOL.ZIP туда же. (При переустановке подтвердить замещение старых файлов новыми).
-
-4. Если Вы загрузили архив xhelpgen.zip, так же распаковывайте его в ту же директорию. Не забудьте прочитать прилагаемую к нему инструкцию.
-
-5. Если Вы загрузили архив SYSDCU.ZIP, создайте поддиректорию для него (например, E:\KOL\SYS) и распакуйте туда его содержимое. К нему так же прилагается своя инструкция.
-
-6. Инструкции по установке MCK (Mirror Classes Kit) см. в архиве MCK.ZIP.
-
-7. Аналогично для koledb, kolword и других дополнений.
-
-Примечание: для самого KOL не требуется создавать Package, т.к. KOL не имеет компонент времени разработки, требующих установки на палтру компонентов. См. пакет MCK, которое имеет такие компоненты, и позволяет разрабатывать приложения с использованием KOL, визуально.
--------------------------------------------------------------
-
-ЛИЦЕНЗИРОВАНИЕ.
-
-Данный параграф введен здесь, чтобы не переводить на русский язык лицензию, см. файл LICENSE.txt.
-
-На использование библиотеки в качестве инструмента для разработки исполнимых модулей (exe, dll и т.д.) не накладывается никаких ограничений. Нельзя продавать библиотеку полностью или частично. Нельзя распространять ее бесплатно, полностью или частично, без согласия автора и без ссылок на автора. В случае, если распространяется модифицированная библиотека, пользователи обязаны быть информированы о первоисточнике и о том, кто является автором оригинальной библиотеки, и как с ним связаться.
-
--------------------------------------------------------------
-
-http://kolmck.net 
-vk@kolmck.net
-Владимир Кладов

libwin/lcore/Makefile

@@ -1,26 +0,0 @@
-all: lcoretest
-
-nomessages:
-	fpc -Sd -gl -dipv6 -dnomessages lcoretest.dpr
-
-lcoretest: *.pas *.inc lcoretest.dpr
-	fpc -Sd -gl -dipv6 lcoretest.dpr
-	
-clean:
-	-rm *.o
-	-rm *.ppu
-	-rm *.exe
-	-rm *.dcu
-	-rm lcoretest
-
-date := $(shell date +%Y%m%d)
-
-zip:
-	mkdir -p lcorewin32_$(date)
-	cp -a *.pas lcorewin32_$(date)
-	cp -a *.inc lcorewin32_$(date)
-	cp -a *.dpr lcorewin32_$(date)
-	cp -a Makefile lcorewin32_$(date)
-	-rm ../lcorewin32_$(date).zip
-	zip -r ../lcorewin32_$(date).zip lcorewin32_$(date)
-	rm -rf lcorewin32_$(date)

libwin/lcore/bfifo.pas

@@ -1,148 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-unit bfifo;
-{$ifdef fpc}
-  {$mode delphi}
-{$endif}
-
-interface
-
-uses blinklist,pgtypes;
-
-const
-  pagesize=1420;
-
-type
-  tfifo=class(tobject)
-  private
-    l:tlinklist;     {add to}
-    getl:tlinklist; {remove from}
-    ofs:integer;
-    getofs:integer;
-  public
-    size:integer;
-    procedure add(data:pointer;len:integer);
-    function get(var resultptr:pointer;len:integer):integer;
-    procedure del(len:integer);
-    constructor create;
-    destructor destroy; override;
-  end;
-
-
-implementation
-
-var
-  testcount:integer;
-
-{
-
-xx1..... add
-xxxxxxxx
-....2xxx delete
-
-1 ofs
-2 getofs
-
-}
-
-procedure tfifo.add;
-var
-  a:integer;
-  p:tlinklist;
-begin
-  if len <= 0 then exit;
-  inc(size,len);
-  while len > 0 do begin
-    p := l;
-    if ofs = pagesize then begin
-      p := tplinklist.create;
-      if getl = nil then getl := p;
-      getmem(tplinklist(p).p,pagesize);
-      inc(testcount);
-      linklistadd(l,p);
-      ofs := 0;
-    end;
-    a := pagesize - ofs;
-    if len < a then a := len;
-    move(data^,pointer(taddrint(tplinklist(p).p)+ofs)^,a);
-    inc(taddrint(data),a);
-    dec(len,a);
-    inc(ofs,a);
-  end;
-end;
-
-function tfifo.get;
-var
-  p:tlinklist;
-  a:integer;
-begin
-  if len > size then len := size;
-  if len <= 0 then begin
-    result := 0;
-    resultptr := nil;
-    exit;
-  end;
-  p := getl;
-  resultptr := pointer(taddrint(tplinklist(p).p)+getofs);
-  result := pagesize-getofs;
-  if result > len then result := len;
-end;
-
-procedure tfifo.del;
-var
-  a:integer;
-  p,p2:tlinklist;
-begin
-  if len <= 0 then exit;
-  p := getl;
-  if len > size then len := size;
-  dec(size,len);
-
-  if len = 0 then exit;
-
-  while len > 0 do begin
-    a := pagesize-getofs;
-    if a > len then a := len;
-    inc(getofs,a);
-    dec(len,a);
-    if getofs = pagesize then begin
-      p2 := p.prev;
-      freemem(tplinklist(p).p);
-      dec(testcount);
-      linklistdel(l,p);
-      p.destroy;
-      p := p2;
-      getl := p;
-      getofs := 0;
-    end;
-  end;
-
-  if size = 0 then begin
-    if assigned(l) then begin
-      p := l;
-      freemem(tplinklist(p).p);
-      dec(testcount);
-      linklistdel(l,p);
-      p.destroy;
-      getl := nil;
-    end;
-    ofs := pagesize;
-    getofs := 0;
-  end;
-end;
-
-constructor tfifo.create;
-begin
-  ofs := pagesize;
-  inherited create;
-end;
-
-destructor tfifo.destroy;
-begin
-  del(size);
-  inherited destroy;
-end;
-
-end.

libwin/lcore/binipstuff.pas

@@ -1,632 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-unit binipstuff;
-
-interface
-
-{$include lcoreconfig.inc}
-
-{$ifndef win32}
-{$ifdef ipv6}
-uses sockets;
-{$endif}
-{$endif}
-
-{$ifdef fpc}
-  {$mode delphi}
-{$endif}
-{$ifdef cpu386}{$define i386}{$endif}
-{$ifdef i386}{$define ENDIAN_LITTLE}{$endif}
-
-{$include uint32.inc}
-
-const
-  hexchars:array[0..15] of char='0123456789abcdef';
-  AF_INET=2;
-  {$ifdef win32}
-    AF_INET6=23;
-  {$else}
-    AF_INET6=10;
-  {$endif}
-
-type
-  {$ifdef ipv6}
-    
-    {$ifdef win32}
-      {$define want_Tin6_addr}
-    {$endif}
-    {$ifdef ver1_0}
-      {$define want_Tin6_addr}
-    {$endif}
-    {$ifdef want_Tin6_addr}
-      Tin6_addr = packed record
-        case byte of
-          0: (u6_addr8  : array[0..15] of byte);
-          1: (u6_addr16 : array[0..7] of Word);
-          2: (u6_addr32 : array[0..3] of uint32);
-          3: (s6_addr8  : array[0..15] of shortint);
-          4: (s6_addr   : array[0..15] of shortint);
-          5: (s6_addr16 : array[0..7] of smallint);
-          6: (s6_addr32 : array[0..3] of LongInt);
-      end;
-    {$endif}
-  {$endif}
-
-  tbinip=record
-    family:integer;
-    {$ifdef ipv6}
-      case integer of
-        0: (ip:longint);
-        1: (ip6:tin6_addr);
-    {$else}
-      ip:longint;
-    {$endif}
-  end;
-
-  {$ifdef win32}
-    TInetSockAddr = packed Record
-      family:Word;
-      port  :Word;
-      addr  :uint32;
-      pad   :array [1..8] of byte;
-    end;
-    {$ifdef ipv6}
-
-      TInetSockAddr6 = packed record
-        sin6_family: word;
-        sin6_port: word;
-        sin6_flowinfo: uint32;
-        sin6_addr: tin6_addr;
-        sin6_scope_id: uint32;
-      end;
-    {$endif}
-  {$endif}
-
-
-
-  {$ifdef ipv6}
-    {$ifdef ver1_0}
-      cuint16=word;
-      cuint32=dword;
-      sa_family_t=word;
-
      TInetSockAddr6 = packed record
-        sin6_family: word;
-        sin6_port: word;
-        sin6_flowinfo: uint32;
-        sin6_addr: tin6_addr;
-        sin6_scope_id: uint32;
-      end;
-    {$endif}
-  {$endif}
-  TinetSockAddrv = packed record
-    case integer of
-      0: (InAddr:TInetSockAddr);
-      {$ifdef ipv6}
-      1: (InAddr6:TInetSockAddr6);
-      {$endif}
-  end;
-  Pinetsockaddrv = ^Tinetsockaddrv;
-
-  type
-    tsockaddrin=TInetSockAddr;
-
-
-
-{
-bin IP list code, by beware
-while this is really just a string, on the interface side it must be treated
-as an opaque var which is passed as "var" when it needs to be modified}
-
-  tbiniplist=string;
-
-function biniplist_new:tbiniplist;
-procedure biniplist_add(var l:tbiniplist;ip:tbinip);
-function biniplist_getcount(const l:tbiniplist):integer;
-function biniplist_get(const l:tbiniplist;index:integer):tbinip;
-procedure biniplist_set(var l:tbiniplist;index:integer;ip:tbinip);
-procedure biniplist_setcount(var l:tbiniplist;newlen:integer);
-procedure biniplist_free(var l:tbiniplist);
-procedure biniplist_addlist(var l:tbiniplist;const l2:tbiniplist);
-function biniplist_tostr(const l:tbiniplist):string;
-function isbiniplist(const l:tbiniplist):boolean;
-
-function htons(w:word):word;
-function htonl(i:uint32):uint32;
-
-function ipstrtobin(const s:string;var binip:tbinip):boolean;
-function ipstrtobinf(const s:string):tbinip;
-function ipbintostr(const binip:tbinip):string;
-{$ifdef ipv6}
-function ip6bintostr(const bin:tin6_addr):string;
-function ip6strtobin(const s:string;var bin:tin6_addr):boolean;
-{$endif}
-
-function comparebinip(const ip1,ip2:tbinip):boolean;
-procedure maskbits(var binip:tbinip;bits:integer);
-function comparebinipmask(ip1,ip2:tbinip;bits:integer):boolean;
-
-procedure addipsoffamily(var l:tbiniplist;const l2:tbiniplist;family:integer);
-
-{deprecated}
-function longip(s:string):longint;
-
-function needconverttov4(const ip:tbinip):boolean;
-procedure converttov4(var ip:tbinip);
-
-function inaddrvtobinip(inaddrv:tinetsockaddrv):tbinip;
-function makeinaddrv(addr:tbinip;port:string;var inaddr:tinetsockaddrv):integer;
-function inaddrsize(inaddr:tinetsockaddrv):integer;
-
-implementation
-
-uses sysutils;
-
-function htons(w:word):word;
-begin
-  {$ifdef ENDIAN_LITTLE}
-  result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);
-  {$else}
-  result := w;
-  {$endif}
-end;
-
-function htonl(i:uint32):uint32;
-begin
-  {$ifdef ENDIAN_LITTLE}
-  result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);
-  {$else}
-  result := i;
-  {$endif}
-end;
-
-
-function inaddrvtobinip(inaddrv:tinetsockaddrv):tbinip;
-begin
-  result.family := inaddrv.inaddr.family;
-  if result.family = AF_INET then result.ip := inaddrv.inaddr.addr;
-  {$ifdef ipv6}
-  if result.family = AF_INET6 then result.ip6 := inaddrv.inaddr6.sin6_addr;
-  {$endif}
-end;
-
-function makeinaddrv(addr:tbinip;port:string;var inaddr:tinetsockaddrv):integer;
-begin
-  result := 0;
-{  biniptemp := forwardlookup(addr,10);}
-  fillchar(inaddr,sizeof(inaddr),0);
-  //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp));
-  if addr.family = AF_INET then begin
-    inAddr.InAddr.family:=AF_INET;
-    inAddr.InAddr.port:=htons(strtointdef(port,0));
-    inAddr.InAddr.addr:=addr.ip;
-    result := sizeof(tinetsockaddr);
-  end else
-  {$ifdef ipv6}
-  if addr.family = AF_INET6 then begin
-    inAddr.InAddr6.sin6_family:=AF_INET6;
-    inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0));
-    inAddr.InAddr6.sin6_addr:=addr.ip6;
-    result := sizeof(tinetsockaddr6);
-  end;
-  {$endif}
-end;
-
-function inaddrsize(inaddr:tinetsockaddrv):integer;
-begin
-  {$ifdef ipv6}
-  if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else
-  {$endif}
-  result := sizeof(tinetsockaddr);
-end;
-
-{internal}
-{converts dotted v4 IP to longint. returns host endian order}
-function longip(s:string):longint;
-var
-  l:longint;
-  a,b:integer;
-function convertbyte(const s:string):integer;
-begin
-  result := strtointdef(s,-1);
-  if result < 0 then begin
-    result := -1;
-    exit;
-  end;
-  if result > 255 then begin
-    result := -1;
-    exit;
-  end;
-  {01 exception}
-  if (result <> 0) and (s[1] = '0') then begin
-    result := -1;
-    exit;
-  end;
-  {+1 exception}
-  if not (s[1] in ['0'..'9']) then begin
-    result := -1;
-    exit
-  end;
-end;
-
-begin
-  result := 0;
-  a := pos('.',s);
-  if a = 0 then exit;
-  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
-  l := b shl 24;
-  s := copy(s,a+1,256);
-  a := pos('.',s);
-  if a = 0 then exit;
-  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
-  l := l or b shl 16;
-  s := copy(s,a+1,256);
-  a := pos('.',s);
-  if a = 0 then exit;
-  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
-  l := l or b shl 8;
-  s := copy(s,a+1,256);
-  b := convertbyte(copy(s,1,256));if (b < 0) then exit;
-  l := l or b;
-  result := l;
-end;
-
-
-function ipstrtobinf;
-begin
-  ipstrtobin(s,result);
-end;
-
-function ipstrtobin(const s:string;var binip:tbinip):boolean;
-begin
-  binip.family := 0;
-  result := false;
-  {$ifdef ipv6}
-  if pos(':',s) <> 0 then begin
-    {try ipv6. use builtin routine}
-    result := ip6strtobin(s,binip.ip6);
-    if result then binip.family := AF_INET6;
-    exit;
-  end;
-  {$endif}
-
-  {try v4}
-  binip.ip := htonl(longip(s));
-  if (binip.ip <> 0) or (s = '0.0.0.0') then begin
-    result := true;
-    binip.family := AF_INET;
-    exit;
-  end;
-end;
-
-function ipbintostr(const binip:tbinip):string;
-var
-  a:integer;
-begin
-  result := '';
-  {$ifdef ipv6}
-  if binip.family = AF_INET6 then begin
-    result := ip6bintostr(binip.ip6);
-  end else
-  {$endif}
-  if binip.family = AF_INET then begin
-    a := htonl(binip.ip);
-    result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff);
-  end;
-end;
-
-
-{------------------------------------------------------------------------------}
-
-{$ifdef ipv6}
-
-{
-IPv6 address binary to/from string conversion routines
-written by beware (steendijk at xs4all dot nl)
-
-- implementation does not depend on other ipv6 code such as the tin6_addr type,
-  the parameter can also be untyped.
-- it is host endian neutral - binary format is aways network order
-- it supports compression of zeroes
-- it supports ::ffff:192.168.12.34 style addresses
-- they are made to do the Right Thing, more efficient implementations are possible
-}
-
-{fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet}
-
-
-function ip6bintostr(const bin:tin6_addr):string;
-{base16 with lowercase output}
-function makehex(w:word):string;
-begin
-  result := '';
-  if w >= 4096 then result := result + hexchars[w shr 12];
-  if w >= 256 then result := result + hexchars[w shr 8 and $f];
-  if w >= 16 then result := result + hexchars[w shr 4 and $f];
-  result := result + hexchars[w and $f];
-end;
-
-var
-  a,b,c,addrlen:integer;
-  runbegin,runlength:integer;
-  bytes:array[0..15] of byte absolute bin;
-  words:array[0..7] of word;
-  dwords:array[0..3] of integer absolute words;
-begin
-  for a := 0 to 7 do begin
-    words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1];
-  end;
-  if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin
-    {::ffff:/96 exception: v4 IP}
-    addrlen := 6;
-  end else begin
-    addrlen := 8;
-  end;
-  {find longest run of zeroes}
-  runbegin := 0;
-  runlength := 0;
-  for a := 0 to addrlen-1 do begin
-    if words[a] = 0 then begin
-      c := 0;
-      for b := a to addrlen-1 do if words[b] = 0 then begin
-        inc(c);
-      end else break;
-      if (c > runlength) then begin
-        runlength := c;
-        runbegin := a;
-      end;
-    end;
-  end;
-  result := '';
-  for a := 0 to runbegin-1 do begin
-    if (a <> 0) then result := result + ':';
-    result := result + makehex(words[a]);
-  end;
-  if runlength > 0 then result := result + '::';
-  c := runbegin+runlength;
-  for a := c to addrlen-1 do begin
-    if (a > c) then result := result + ':';
-    result := result + makehex(words[a]);
-  end;
-  if addrlen = 6 then begin
-    result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]);
-  end;
-end;
-
-function ip6strtobin(const s:string;var bin:tin6_addr):boolean;
-var
-  a,b:integer;
-  fields:array[0..7] of string;
-  fieldcount:integer;
-  emptyfield:integer;
-  wordcount:integer;
-  words:array[0..7] of word;
-  bytes:array[0..15] of byte absolute bin;
-begin
-  result := false;
-  for a := 0 to 7 do fields[a] := '';
-  fieldcount := 0;
-  for a := 1 to length(s) do begin
-    if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a];
-    if fieldcount > 7 then exit;
-  end;
-  if fieldcount < 2 then exit;
-
-  {find the empty field (compressed zeroes), not counting the first and last there may be at most 1}
-  emptyfield := -1;
-  for a := 1 to fieldcount-1 do begin
-    if fields[a] = '' then begin
-      if emptyfield = -1 then emptyfield := a else exit;
-    end;
-  end;
-
-  {check if last field is a valid v4 IP}
-  a := longip(fields[fieldcount]);
-  if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8;
-  {0:1:2:3:4:5:6.6.6.6
-   0:1:2:3:4:5:6:7}
-  fillchar(words,sizeof(words),0);
-  if wordcount = 6 then begin
-    if fieldcount > 6 then exit;
-    words[6] := a shr 16;
-    words[7] := a and $ffff;
-  end;
-  if emptyfield = -1 then begin
-    {no run length: must be an exact number of fields}
-    if wordcount = 6 then begin
-      if fieldcount <> 6 then exit;
-      emptyfield := 5;
-    end else if wordcount = 8 then begin
-      if fieldcount <> 7 then exit;
-      emptyfield := 7;
-    end else exit;
-  end;
-  for a := 0 to emptyfield do begin
-    if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1);
-    if (b < 0) or (b > $ffff) then exit;
-    words[a] := b;
-  end;
-  if wordcount = 6 then dec(fieldcount);
-  for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin
-    b := a+fieldcount-wordcount+1;
-    if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1);
-    if (b < 0) or (b > $ffff) then exit;
-    words[a] := b;
-  end;
-  for a := 0 to 7 do begin
-    bytes[a shl 1] := words[a] shr 8;
-    bytes[a shl 1 or 1] := words[a] and $ff;
-  end;
-  result := true;
-end;
-{$endif}
-
-function comparebinip(const ip1,ip2:tbinip):boolean;
-begin
-  if (ip1.ip <> ip2.ip) then begin
-    result := false;
-    exit;
-  end;
-
-  {$ifdef ipv6}
-  if ip1.family = AF_INET6 then begin
-    if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1])
-    or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2])
-    or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin
-      result := false;
-      exit;
-    end;
-  end;
-  {$endif}
-
-  result := (ip1.family = ip2.family);
-end;
-
-procedure maskbits(var binip:tbinip;bits:integer);
-const
-  ipmax={$ifdef ipv6}15{$else}3{$endif};
-type tarr=array[0..ipmax] of byte;
-var
-  arr:^tarr;
-  a,b:integer;
-begin
-  arr := @binip.ip;
-  if bits = 0 then b := 0 else b := ((bits-1) div 8)+1;
-  for a := b to ipmax do begin
-    arr[a] := 0;
-  end;
-  if (bits and 7 <> 0) then begin
-    arr[bits shr 3] := arr[bits div 8] and not ($ff shr (bits and 7))
-  end;
-end;
-
-function comparebinipmask;
-begin
-  maskbits(ip1,bits);
-  maskbits(ip2,bits);
-  result := comparebinip(ip1,ip2);
-end;
-
-function needconverttov4(const ip:tbinip):boolean;
-begin
-  {$ifdef ipv6}
-  if ip.family = AF_INET6 then begin
-    if (ip.ip6.u6_addr32[0] = 0) and (ip.ip6.u6_addr32[1] = 0) and
-    (ip.ip6.u6_addr16[4] = 0) and (ip.ip6.u6_addr16[5] = $ffff) then begin
-      result := true;
-      exit;
-    end;
-  end;
-  {$endif}
-
-  result := false;
-end;
-
-{converts a binary IP to v4 if it is a v6 IP in the v4 range}
-procedure converttov4(var ip:tbinip);
-begin
-  {$ifdef ipv6}
-  if needconverttov4(ip) then begin
-    ip.family := AF_INET;
-    ip.ip := ip.ip6.s6_addr32[3];
-  end;
-  {$endif}
-end;
-
-{-----------biniplist stuff--------------------------------------------------}
-
-const
-  biniplist_prefix='bipl'#0;
-  //fpc 1.0.x doesn't seem to like use of length function in a constant 
-  //definition
-  //biniplist_prefixlen=length(biniplist_prefix);
-
  biniplist_prefixlen=5;
-  
-function biniplist_new:tbiniplist;
-begin
-  result := biniplist_prefix;
-end;
-
-procedure biniplist_add(var l:tbiniplist;ip:tbinip);
-var
-  a:integer;
-begin
-  a := biniplist_getcount(l);
-  biniplist_setcount(l,a+1);
-  biniplist_set(l,a,ip);
-end;
-
-function biniplist_getcount(const l:tbiniplist):integer;
-begin
-  result := (length(l)-biniplist_prefixlen) div sizeof(tbinip);
-end;
-
-function biniplist_get(const l:tbiniplist;index:integer):tbinip;
-begin
-  if (index >= biniplist_getcount(l)) then begin
-    fillchar(result,sizeof(result),0);
-    exit;
-  end;
-  move(l[index*sizeof(tbinip)+1+biniplist_prefixlen],result,sizeof(result));
-end;
-
-procedure biniplist_set(var l:tbiniplist;index:integer;ip:tbinip);
-begin
-  uniquestring(l);
-  move(ip,l[index*sizeof(tbinip)+1+biniplist_prefixlen],sizeof(ip));
-end;
-
-procedure biniplist_setcount(var l:tbiniplist;newlen:integer);
-begin
-  setlength(l,(sizeof(tbinip)*newlen)+biniplist_prefixlen);
-end;
-
-procedure biniplist_free(var l:tbiniplist);
-begin
-  l := '';
-end;
-
-procedure biniplist_addlist;
-begin
-  l := l + copy(l2,biniplist_prefixlen+1,maxlongint);
-end;
-
-function biniplist_tostr(const l:tbiniplist):string;
-var
-  a:integer;
-begin
-  result := '(';
-  for a := 0 to biniplist_getcount(l)-1 do begin
-    if result <> '(' then result := result + ', ';
-    result := result + ipbintostr(biniplist_get(l,a));
-  end;
-  result := result + ')';
-end;
-
-function isbiniplist(const l:tbiniplist):boolean;
-var
-  i : integer;
-begin
-  for i := 1 to biniplist_prefixlen do begin
-    if biniplist_prefix[i] <> l[i] then begin
-      result := false;
-      exit;
-    end;
-  end;
-  result := true;
-end;
-
-procedure addipsoffamily(var l:tbiniplist;const l2:tbiniplist;family:integer);
-var
-  a:integer;
-  biniptemp:tbinip;
-begin
-  for a := biniplist_getcount(l2)-1 downto 0 do begin
-    biniptemp := biniplist_get(l2,a);
-    if (biniptemp.family = family) then biniplist_add(l,biniptemp);
-  end;
-end;
-
-
-end.

libwin/lcore/blinklist.pas

@@ -1,106 +0,0 @@
-
-{ Copyright (C) 2005 Bas Steendijk
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-    which is included in the package
-      ----------------------------------------------------------------------------- }
-
-unit blinklist;
-{$ifdef fpc}
-  {$mode delphi}
-{$endif}
-
-
-interface
-
-type
-  tlinklist=class(tobject)
-    next:tlinklist;
-    prev:tlinklist;
-    constructor create;
-    destructor destroy; override;
-  end;
-
-  {linklist with 2 links}
-  tlinklist2=class(tlinklist)
-    next2:tlinklist2;
-    prev2:tlinklist2;
-  end;
-
-  {linklist with one pointer}
-  tplinklist=class(tlinklist)
-    p:pointer
-  end;
-
-  tstringlinklist=class(tlinklist)
-    s:string;
-  end;
-
-  tthing=class(tlinklist)
-    name:string;      {name/nick}
-    hashname:integer; {hash of name}
-  end;
-
-{
-adding new block to list (baseptr)
-}
-procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);
-procedure linklistdel(var baseptr:tlinklist;item:tlinklist);
-
-
-procedure linklist2add(var baseptr,newptr:tlinklist2);
-procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);
-
-var
-  linklistdebug:integer;
-
-implementation
-
-procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);
-var
-  p:tlinklist;
-begin
-  p := baseptr;
-  baseptr := newptr;
-  baseptr.prev := nil;
-  baseptr.next := p;
-  if p <> nil then p.prev := baseptr;
-end;
-
-procedure linklistdel(var baseptr:tlinklist;item:tlinklist);
-begin
-  if item = baseptr then baseptr := item.next;
-  if item.prev <> nil then item.prev.next := item.next;
-  if item.next <> nil then item.next.prev := item.prev;
-end;
-
-procedure linklist2add(var baseptr,newptr:tlinklist2);
-var
-  p:tlinklist2;
-begin
-  p := baseptr;
-  baseptr := newptr;
-  baseptr.prev2 := nil;
-  baseptr.next2 := p;
-  if p <> nil then p.prev2 := baseptr;
-end;
-
-procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);
-begin
-  if item = baseptr then baseptr := item.next2;
-  if item.prev2 <> nil then item.prev2.next2 := item.next2;
-  if item.next2 <> nil then item.next2.prev2 := item.prev2;
-end;
-
-constructor tlinklist.create;
-begin
-  inherited create;
-  inc(linklistdebug);
-end;
-
-destructor tlinklist.destroy;
-begin
-  dec(linklistdebug);
-  inherited destroy;
-end;
-
-end.

libwin/lcore/bsearchtree.pas

@@ -1,101 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-  
-{actually a hashtable. it was a tree in earlier versions}
-
-unit bsearchtree;
-
-interface
-
-uses blinklist;
-
-const
-  hashtable_size=$4000;
-
-type
-  thashitem=class(tlinklist)
-    hash:integer;
-    s:string;
-    p:pointer;
-  end;
-  thashtable=array[0..hashtable_size-1] of thashitem;
-  phashtable=^thashtable;
-
-{adds "item" to the tree for name "s". the name must not exist (no checking done)}
-procedure addtree(t:phashtable;s:string;item:pointer);
-
-{removes name "s" from the tree. the name must exist (no checking done)}
-procedure deltree(t:phashtable;s:string);
-
-{returns the item pointer for s, or nil if not found}
-function findtree(t:phashtable;s:string):pointer;
-
-implementation
-
-function makehash(s:string):integer;
-const
-  shifter=6;
-var
-  a,b:integer;
-begin
-  result := 0;
-  b := length(s);
-  for a := 1 to b do begin
-    result := (result shl shifter) xor byte(s[a]);
-  end;
-  result := (result xor result shr 16) and (hashtable_size-1);
-end;
-
-procedure addtree(t:phashtable;s:string;item:pointer);
-var
-  hash:integer;
-  p:thashitem;
-begin
-  hash := makehash(s);
-  p := thashitem.create;
-  p.hash := hash;
-  p.s := s;
-  p.p := item;
-  linklistadd(tlinklist(t[hash]),tlinklist(p));
-end;
-
-procedure deltree(t:phashtable;s:string);
-var
-  p,p2:thashitem;
-  hash:integer;
-begin
-  hash := makehash(s);
-  p := t[hash];
-  p2 := nil;
-  while p <> nil do begin
-    if p.s = s then begin
-      p2 := p;
-      break;
-    end;
-    p := thashitem(p.next);
-  end;
-  linklistdel(tlinklist(t[hash]),tlinklist(p2));
-  p2.destroy;
-end;
-
-
-function findtree(t:phashtable;s:string):pointer;
-var
-  p:thashitem;
-  hash:integer;
-begin
-  result := nil;
-  hash := makehash(s);
-  p := t[hash];
-  while p <> nil do begin
-    if p.s = s then begin
-      result := p.p;
-      exit;
-    end;
-    p := thashitem(p.next);
-  end;
-end;
-
-end.

libwin/lcore/btime.pas

@@ -1,593 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-{
-this unit returns unix timestamp with seconds and microseconds (as float)
-works on windows/delphi, and on freepascal on unix.
-}
-
-
-unit btime;
-
-interface
-
-type
-  float=extended;
-
-const
-  colorburst=39375000/11;  {3579545.4545....}
-
-var
-  timezone:integer;
-  timezonestr:string;
-  irctime,unixtime:integer;
-  tickcount:integer;
-  settimebias:integer;
-  performancecountfreq:extended;
-
-function irctimefloat:float;
-function irctimeint:integer;
-
-function unixtimefloat:float;
-function unixtimeint:integer;
-
-function wintimefloat:float;
-
-procedure settime(newtime:integer);
-procedure gettimezone;
-procedure timehandler;
-procedure init;
-
-function timestring(i:integer):string;
-function timestrshort(i:integer):string;
-
-{$ifdef win32}
-function unixtimefloat_systemtime:float;
-{$endif}
-
-function oletounixfloat(t:float):float;
-function oletounix(t:tdatetime):integer;
-function unixtoole(i:integer):tdatetime;
-
-{$ifdef win32}
-function mmtimefloat:float;
-function qpctimefloat:float;
-{$endif}
-
-const
-  mmtime_driftavgsize=32;
-  mmtime_warmupnum=4;
-  mmtime_warmupcyclelength=15;
-var
-  //this flag is to be set when btime has been running long enough to stabilise
-  warmup_finished:boolean;
-
-  timefloatbias:float;
-  ticks_freq:float=0;
-  ticks_freq2:float=0;
-  ticks_freq_known:boolean=false;
-  lastunixtimefloat:float=0;
-  lastsynctime:float=0;
-  lastsyncbias:float=0;
-
-  mmtime_last:integer=0;
-  mmtime_wrapadd:float;
-  mmtime_lastsyncmm:float=0;
-  mmtime_lastsyncqpc:float=0;
-  mmtime_drift:float=1;
-  mmtime_lastresult:float;
-  mmtime_nextdriftcorrection:float;
-  mmtime_driftavg:array[0..mmtime_driftavgsize] of float;
-  mmtime_synchedqpc:boolean;
-
-  mmtime_prev_drift:float;
-  mmtime_prev_lastsyncmm:float;
-  mmtime_prev_lastsyncqpc:float;
-
-implementation
-
-{$ifdef fpc}
-  {$mode delphi}
-{$endif}
-
-uses
-  {$ifdef UNIX}
-    {$ifdef VER1_0}
-      linux,
-    {$else}
-      baseunix,unix,unixutil, {needed for 2.0.2}
-    {$endif}
-  {$else}
-    windows,unitsettc,mmsystem,
-  {$endif}
-  sysutils;
-
-  {$include unixstuff.inc}
-
-
-const
-  daysdifference=25569;
-
-function oletounixfloat(t:float):float;
-begin
-  t := (t - daysdifference) * 86400;
-  result := t;
-end;
-
-function oletounix(t:tdatetime):integer;
-begin
-  result := trunc(oletounixfloat(t));
-end;
-
-function unixtoole(i:integer):tdatetime;
-begin
-  result := ((i)/86400)+daysdifference;
-end;
-
-const
-  highdwordconst=65536.0 * 65536.0;
-
-function utrunc(f:float):integer;
-{converts float to integer, in 32 bits unsigned range}
-begin
-  if f >= (highdwordconst/2) then f := f - highdwordconst;
-  result := trunc(f);
-end;
-
-function uinttofloat(i:integer):float;
-{converts 32 bits unsigned integer to float}
-begin
-  result := i;
-  if result < 0 then result := result + highdwordconst;
-end;
-
-{$ifdef unix}
-{-----------------------------------------*nix/freepascal code to read time }
-
-function unixtimefloat:float;
-var
-  tv:ttimeval;
-begin
-  gettimeofday(tv);
-  result := tv.tv_sec+(tv.tv_usec/1000000);
-end;
-
-function wintimefloat:extended;
-begin
-  result := unixtimefloat;
-end;
-
-function unixtimeint:integer;
-var
-  tv:ttimeval;
-begin
-  gettimeofday(tv);
-  result := tv.tv_sec;
-end;
-
-{$else} {delphi 3}
-{------------------------------ windows/delphi code to read time}
-
-{
-time float: gettickcount
-resolution: 9x: ~55 ms NT: 1/64th of a second
-guarantees: continuous without any jumps
-frequency base: same as system clock.
-epoch: system boot
-note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on.
-note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster
-}
-
-function mmtimefloat:float;
-const
-  wrapduration=highdwordconst * 0.001;
-var
-  i:integer;
-begin
-  i := gettickcount; {timegettime}
-  if i < mmtime_last then begin
-    mmtime_wrapadd := mmtime_wrapadd + wrapduration;
-  end;
-  mmtime_last := i;
-  result := mmtime_wrapadd + i * 0.001;
-
-  if (ticks_freq <> 0) and ticks_freq_known then result := int((result / ticks_freq)+0.5) * ticks_freq; //turn the float into an exact multiple of 1/64th sec to improve accuracy of things using this
-end;
-
-procedure measure_ticks_freq;
-var
-  f,g:float;
-  o:tosversioninfo;
-  isnt:boolean;
-  is9x:boolean;
-begin
-  if (performancecountfreq = 0) then qpctimefloat;
-  ticks_freq_known := false;
-  settc;
-  f := mmtimefloat;
-  repeat g := mmtimefloat until g > f;
-  unsettc;
-  f := g - f;
-  fillchar(o,sizeof(o),0);
-  o.dwOSVersionInfoSize := sizeof(o);
-  getversionex(o);
-  isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;
-  is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;
-
-  ticks_freq2 := f;
-  mmtime_synchedqpc := false;
-  {
-  NT 64 Hz
-  identify mode as: nt64
-  QPC rate: either 3579545 or TSC freq
-  QPC synched to gettickcount: no
-  duration between 2 ticks is constant: yes
-  gettickcount tick duration: 64 Hz
-  }
-  if (f >= 0.014) and (f <= 0.018) and isnt then begin
-    ticks_freq_known := true;
-    ticks_freq := 1/64;
-    mmtime_synchedqpc := false;
-  end;
-
-  {
-  NT 100 Hz
-  identify mode as: nt100
-  QPC rate: 1193182
-  QPC synched to gettickcount: yes
-  duration between 2 ticks is constant: no?
-  gettickcount tick duration: ~99.85 Hz
-  }
-  if (performancecountfreq = 1193182) and (f >= 0.008) and (f <= 0.012) and isnt then begin
-    ticks_freq_known := true;
-    ticks_freq2 := 11949 / (colorburst / 3);
-   //  ticks_freq2 := 11949 / 1193182;
-    ticks_freq := 0;
-    {the ticks freq should be very close to the real one but if it's not exact, it will cause drift and correction jumps}
-    mmtime_synchedqpc := true;
-  end;
-
-  {9x}
-  if (performancecountfreq = 1193182) and (g >= 0.050) and (g <= 0.060) then begin
-    ticks_freq_known := true;
-    ticks_freq := 65536 / (colorburst / 3);
-    mmtime_synchedqpc := true;
-  end;
-  ticks_freq_known := true;
-  if ticks_freq <> 0 then ticks_freq2 := ticks_freq;
-//  writeln(formatfloat('0.000000',ticks_freq));
-end;
-
-{
-time float: QueryPerformanceCounter
-resolution: <1us
-guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.
-frequency base: on NT, not the system clock, drifts compared to it.
-epoch: system boot
-}
-function qpctimefloat:extended;
-var
-  p:packed record
-    lowpart:longint;
-    highpart:longint
-  end;
-  p2:tlargeinteger absolute p;
-  e:extended;
-begin
-  if performancecountfreq = 0 then begin
-    QueryPerformancefrequency(p2);
-    e := p.lowpart;
-    if e < 0 then e := e + highdwordconst;
-    performancecountfreq := ((p.highpart*highdwordconst)+e);
-  end;
-  queryperformancecounter(p2);
-  e := p.lowpart;
-  if e < 0 then e := e + highdwordconst;
-
-  result := ((p.highpart*highdwordconst)+e)/performancecountfreq;
-end;
-
-{
-time float: QPC locked to gettickcount
-resolution: <1us
-guarantees: continuous without any jumps
-frequency base: same as system clock.
-epoch: system boot
-}
-
-function mmqpctimefloat:float;
-const
-  maxretries=5;
-  margin=0.002;
-var
-  jump:float;
-  mm,f,qpc,newdrift,f1,f2:float;
-  qpcjumped:boolean;
-  a,b,c:integer;
-  retrycount:integer;
-begin
-  if not ticks_freq_known then measure_ticks_freq;
-  retrycount := maxretries;
-
-  qpc := qpctimefloat;
-  mm := mmtimefloat;
-  f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
-  //writeln('XXXX ',formatfloat('0.000000',qpc-mm));
-  qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);
-//  if qpcjumped then writeln('qpc jumped ',(f-mm));
-  if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin
-
-    mmtime_nextdriftcorrection := qpc + 1;
-    repeat
-      mmtime_prev_drift := mmtime_drift;
-      mmtime_prev_lastsyncmm := mmtime_lastsyncmm;
-      mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;
-
-      mm := mmtimefloat;
-      dec(retrycount);
-      settc;
-      result := qpctimefloat;
-      f := mmtimefloat;
-      repeat
-        if f = mm then result := qpctimefloat;
-        f := mmtimefloat
-      until f > mm;
-      qpc := qpctimefloat;
-
-      unsettc;
-      if (qpc > result + 0.0001) then begin
-        continue;
-      end;
-      mm := f;
-
-      if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin
-        newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);
-        mmtime_drift := newdrift;
-     {   writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}
-        move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));
-        mmtime_driftavg[0] := mmtime_drift;
-
-{        write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}
-{        mmtime_drift := 0;}
-        b := 0;
-        for a := 0 to high(mmtime_driftavg) do begin
-          if mmtime_driftavg[a] <> 0 then inc(b);
-{          mmtime_drift := mmtime_drift + mmtime_driftavg[a];}
-        end;
-{        mmtime_drift := mmtime_drift / b;}
-        if (b = 1) then a := 5 else if (b = 2) then a := 15 else if (b = 3) then a := 30 else if (b = 4) then a := 60 else if (b = 5) then a := 120 else if (b >= 5) then a := 120;
-        mmtime_nextdriftcorrection := qpc + a;
-        if (b >= 2) then warmup_finished := true;
-{        writeln(formatfloat('0.00000000',mmtime_drift));}
-       if mmtime_synchedqpc then mmtime_drift := 1;
-      end;
-
-      mmtime_lastsyncqpc := qpc;
-      mmtime_lastsyncmm := mm;
-  {   writeln(formatfloat('0.00000000',mmtime_drift));}
-      break;
-    until false;
-
-
-    qpc := qpctimefloat;
-
-    result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
-    f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;
-
-    jump := result-f;
-    {writeln('jump ',formatfloat('0.000000',jump),'   drift ',formatfloat('0.00000000',mmtime_drift),' duration ',formatfloat('0.000',(mmtime_lastsyncqpc-mmtime_prev_lastsyncqpc)),' ',formatfloat('0.00000000',jump/(mmtime_lastsyncqpc-mmtime_prev_lastsyncqpc)));}
-
-    f := result;
-  end;
-
-  result := f;
-
-  if (result < mmtime_lastresult) then result := mmtime_lastresult + 0.000001;
-  mmtime_lastresult := result;
-end;
-
-{ free pascals tsystemtime is incomaptible with windows api calls
- so we declare it ourselves - plugwash
-}
-{$ifdef fpc}
-type
-  TSystemTime = record
-     wYear: Word;
-     wMonth: Word;
-     wDayOfWeek: Word;
-     wDay: Word;
-     wHour: Word;
-     wMinute: Word;
-     wSecond: Word;
-     wMilliseconds: Word;
-  end;
- {$endif}
-function Date_utc: extended;
-var
-  SystemTime: TSystemTime;
-begin
-  {$ifdef fpc}
-    GetsystemTime(@SystemTime);
-  {$else}
-    GetsystemTime(SystemTime);
-  {$endif}
-  with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);
-end;
-
-function Time_utc: extended;
-var
-  SystemTime: TSystemTime;
-begin
-  {$ifdef fpc}
-    GetsystemTime(@SystemTime);
-  {$else}
-    GetsystemTime(SystemTime);
-  {$endif}
-  with SystemTime do
-    Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);
-end;
-
-function Now_utc: extended;
-begin
-  Result := round(Date_utc) + Time_utc;
-end;
-
-function unixtimefloat_systemtime:float;
-begin
-  {result := oletounixfloat(now_utc);}
-
-  {this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}
-  result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;
-end;
-
-function wintimefloat:extended;
-begin
-  result := mmqpctimefloat;
-end;
-
-function unixtimefloat:float;
-const
-  margin = 0.0012;
-var
-  f,g,h:float;
-begin
-  result := wintimefloat+timefloatbias;
-  f := result-unixtimefloat_systemtime;
-  if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin
-//    writeln('unixtimefloat init');
-    f := unixtimefloat_systemtime;
-    settc;
-    repeat g := unixtimefloat_systemtime; h := wintimefloat until g > f;
-    unsettc;
-    timefloatbias := g-h;
-    result := unixtimefloat;
-  end;
-
-  {for small changes backwards, guarantee no steps backwards}
-  if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001;
-  lastunixtimefloat := result;
-end;
-
-function unixtimeint:integer;
-begin
-  result := trunc(unixtimefloat);
-end;
-
-{$endif}
-{-----------------------------------------------end of platform specific}
-
-function irctimefloat:float;
-begin
-  result := unixtimefloat+settimebias;
-end;
-
-function irctimeint:integer;
-begin
-  result := unixtimeint+settimebias;
-end;
-
-
-procedure settime(newtime:integer);
-var
-  a:integer;
-begin
-  a := irctimeint-settimebias;
-  if newtime = 0 then settimebias := 0 else settimebias := newtime-a;
-
-  irctime := irctimeint;
-end;
-
-procedure timehandler;
-begin
-  if unixtime = 0 then init;
-  unixtime := unixtimeint;
-  irctime := irctimeint;
-  if unixtime and 63 = 0 then begin
-    {update everything, apply timezone changes, clock changes, etc}
-    gettimezone;
-    timefloatbias := 0;
-    unixtime := unixtimeint;
-    irctime := irctimeint;
-  end;
-end;
-
-
-procedure gettimezone;
-var
-  {$ifdef UNIX}
-    {$ifndef ver1_9_4}
-      {$ifndef ver1_0}
-        {$define above194}
-      {$endif}
-    {$endif}
-    {$ifndef above194}
-      hh,mm,ss:word;
-    {$endif}
-  {$endif}
-  l:integer;
-begin
-  {$ifdef UNIX}
-    {$ifdef above194}
-      timezone := tzseconds;
-    {$else}
-      gettime(hh,mm,ss);
-      timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);
-    {$endif}
-  {$else}
-  timezone := round((now-now_utc)*86400);
-  {$endif}
-
-  while timezone > 43200 do dec(timezone,86400);
-  while timezone < -43200 do inc(timezone,86400);
-
-  if timezone >= 0 then timezonestr := '+' else timezonestr := '-';
-  l := abs(timezone) div 60;
-  timezonestr := timezonestr + char(l div 600 mod 10+48)+char(l div 60 mod 10+48)+':'+char(l div 10 mod 6+48)+char(l mod 10+48);
-end;
-
-function timestrshort(i:integer):string;
-const
-  weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');
-  month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
-var
-  y,m,d,h,min,sec,ms:word;
-  t:tdatetime;
-begin
-  t := unixtoole(i+timezone);
-  decodedate(t,y,m,d);
-  decodetime(t,h,min,sec,ms);
-  result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+
-  inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+
-  inttostr(y);
-end;
-
-function timestring(i:integer):string;
-const
-  weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');
-  month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');
-var
-  y,m,d,h,min,sec,ms:word;
-  t:tdatetime;
-begin
-  t := unixtoole(i+timezone);
-  decodedate(t,y,m,d);
-  decodetime(t,h,min,sec,ms);
-  result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+
-  inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+
-  timezonestr;
-end;
-
-procedure init;
-begin
-  {$ifdef win32}timebeginperiod(1);{$endif} //ensure stable unchanging clock
-  fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);
-  settimebias := 0;
-  gettimezone;
-  unixtime := unixtimeint;
-  irctime := irctimeint;
-end;
-
-initialization init;
-
-end.

libwin/lcore/dnsasync.pas

@@ -1,394 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-//FIXME: this code only ever seems to use one dns server for a request and does
-//not seem to have any form of retry code.
-
-unit dnsasync;
-
-interface
-
-uses
-  {$ifdef win32}
-    dnswin,
-  {$endif}
-  lsocket,lcore,
-  classes,binipstuff,dnscore,btime,lcorernd;
-
-{$include lcoreconfig.inc}
-
-const
-  numsock=1{$ifdef ipv6}+1{$endif};
-
-type
-
-  //after completion or cancelation a dnswinasync may be reused
-  tdnsasync=class(tcomponent)
-
-  private
-    //made a load of stuff private that does not appear to be part of the main
-    //public interface. If you make any of it public again please consider the
-    //consequences when using windows dns. --plugwash.
-    sockets: array[0..numsock-1] of tlsocket;
-
-    states: array[0..numsock-1] of tdnsstate;
-
-    destinations: array[0..numsock-1] of tbinip;
-
-    dnsserverids : array[0..numsock-1] of integer;
-    startts:double;
-    {$ifdef win32}
-      dwas : tdnswinasync;
-    {$endif}
-
-    numsockused : integer;
-    fresultlist : tbiniplist;
-    requestaf : integer;
-    procedure asyncprocess(socketno:integer);
-    procedure receivehandler(sender:tobject;error:word);
-    function sendquery(socketno:integer;const packet:tdnspacket;len:integer):boolean;
-    {$ifdef win32}
-      procedure winrequestdone(sender:tobject;error:word);
-    {$endif}
-
-  public
-    onrequestdone:tsocketevent;
-
-    //addr and port allow the application to specify a dns server specifically
-    //for this dnsasync object. This is not a reccomended mode of operation
-    //because it limits the app to one dns server but is kept for compatibility
-    //and special uses.
-    addr,port:string;
-
-    overrideaf : integer;
-
-    procedure cancel;//cancel an outstanding dns request
-    function dnsresult:string; //get result of dnslookup as a string
-    procedure dnsresultbin(var binip:tbinip); //get result of dnslookup as a tbinip
-    property dnsresultlist : tbiniplist read fresultlist;
-    procedure forwardlookup(const name:string); //start forward lookup,
-                                                //preffering ipv4
-    procedure reverselookup(const binip:tbinip); //start reverse lookup
-    procedure customlookup(const name:string;querytype:integer); //start custom type lookup
-
-    constructor create(aowner:tcomponent); override;
-    destructor destroy; override;
-
-  end;
-
-implementation
-
-uses sysutils;
-
-constructor tdnsasync.create;
-begin
-  inherited create(aowner);
-  dnsserverids[0] := -1;
-  sockets[0] := twsocket.create(self);
-  sockets[0].tag := 0;
-  {$ifdef ipv6}
-    dnsserverids[1] := -1;
-    sockets[1] := twsocket.Create(self);
-    sockets[1].tag := 1;
-  {$endif}
-end;
-
-destructor tdnsasync.destroy;
-var
-  socketno : integer;
-begin
-  for socketno := 0 to numsock -1 do begin
-    if dnsserverids[socketno] >= 0 then begin
-      reportlag(dnsserverids[socketno],-1);
-      dnsserverids[socketno] := -1;
-    end;
-    sockets[socketno].release;
-    setstate_request_init('',states[socketno]);
-  end;
-  inherited destroy;
-end;
-
-procedure tdnsasync.receivehandler(sender:tobject;error:word);
-var
-  socketno : integer;
-  Src    : TInetSockAddrV;
-  SrcLen : Integer;
-  fromip:tbinip;
-  fromport:string;
-begin
-  socketno := tlsocket(sender).tag;
-  //writeln('got a reply on socket number ',socketno);
-  fillchar(states[socketno].recvpacket,sizeof(states[socketno].recvpacket),0);
-
-  SrcLen := SizeOf(Src);
-  states[socketno].recvpacketlen := twsocket(sender).ReceiveFrom(@(states[socketno].recvpacket), SizeOf(states[socketno].recvpacket), Src, SrcLen);
-
-  fromip := inaddrvtobinip(Src);
-  fromport := inttostr(htons(src.InAddr.port));
-
-  if ((not comparebinip(fromip,destinations[socketno])) or (fromport <> port)) then begin
-   // writeln('dnsasync received from wrong IP:port ',ipbintostr(fromip),'#',fromport,', expected ',ipbintostr(destinations[socketno]),'#',port);
-    exit;
-  end;
-
-  states[socketno].parsepacket := true;
-  if states[socketno].resultaction <> action_done then begin
-    //we ignore packets that come after we are done
-    if dnsserverids[socketno] >= 0 then begin
-      reportlag(dnsserverids[socketno],trunc((unixtimefloat-startts)*1000000));
-      dnsserverids[socketno] := -1;
-    end;
-  {  writeln('received reply');}
-
-    asyncprocess(socketno);
-    //writeln('processed it');
-  end else begin
-    //writeln('ignored it because request is done');
-  end;
-end;
-
-function tdnsasync.sendquery(socketno:integer;const packet:tdnspacket;len:integer):boolean;
-var
-  destination : string;
-  inaddr : tinetsockaddrv;
-  trytolisten:integer;
-begin
-{  writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}
-  //writeln('trying to send query on socket number ',socketno);
-  result := false;
-  if len = 0 then exit; {no packet}
-  if sockets[socketno].state <> wsconnected then begin
-    startts := unixtimefloat;
-    if port = '' then port := '53';
-    sockets[socketno].Proto := 'udp';
-    sockets[socketno].ondataavailable := receivehandler;
-
-    {we are going to bind on a random local port for the DNS request, against the kaminsky attack
-    there is a small chance that we're trying to bind on an already used port, so retry a few times}
-    for trytolisten := 3 downto 0 do begin
-      try
-        sockets[socketno].port := inttostr(1024 + randominteger(65536 - 1024));
-        sockets[socketno].listen;
-      except
-        {writeln('failed to listen ',sockets[socketno].localport,' ',trytolisten);}
-        if (trytolisten = 0) then begin
-          result := false;
-          exit;
-        end;
-      end;
-    end;
-
-  end;
-  if addr <> '' then begin
-    dnsserverids[socketno] := -1;
-    destination := addr
-  end else begin
-    destination := getcurrentsystemnameserver(dnsserverids[socketno]);
-  end;
-  destinations[socketno] := ipstrtobinf(destination);
-
-  {$ifdef ipv6}{$ifdef win32}
-  if destinations[socketno].family = AF_INET6 then if (requestaf = useaf_default) then requestaf := useaf_preferv6;
-  {$endif}{$endif}
-
-  makeinaddrv(destinations[socketno],port,inaddr);
-  sockets[socketno].sendto(inaddr,sizeof(inaddr), @packet,len);
-  result := true;
-
-
-end;
-
-procedure tdnsasync.asyncprocess(socketno:integer);
-begin
-  state_process(states[socketno]);
-  case states[socketno].resultaction of
-    action_ignore: begin {do nothing} end;
-    action_done: begin
-      {$ifdef ipv6}
-      if (numsockused = 1) or (states[socketno xor 1].resultaction=action_done) then
-      //if using two sockets we need to wait until both sockets are in the done
-      //state before firing the event
-      {$endif}
-      begin
-        fresultlist := biniplist_new;
-        if (numsockused = 1) then begin
-          //writeln('processing for one state');
-          biniplist_addlist(fresultlist,states[0].resultlist);
-        {$ifdef ipv6}
-        end else if (requestaf = useaf_preferv6) then begin
-          //writeln('processing for two states, ipv6 preference');
-          //writeln('merging lists '+biniplist_tostr(states[1].resultlist)+' and '+biniplist_tostr(states[0].resultlist));
-          biniplist_addlist(fresultlist,states[1].resultlist);
-          biniplist_addlist(fresultlist,states[0].resultlist);
-        end else begin
-          //writeln('processing for two states, ipv4 preference');
-          biniplist_addlist(fresultlist,states[0].resultlist);
-          biniplist_addlist(fresultlist,states[1].resultlist);
-        {$endif}
-        end;
-        //writeln(biniplist_tostr(fresultlist));
-        onrequestdone(self,0);
-      end;
-    end;
-    action_sendquery:begin
-      sendquery(socketno,states[socketno].sendpacket,states[socketno].sendpacketlen);
-    end;
-  end;
-end;
-
-procedure tdnsasync.forwardlookup;
-var
-  bip : tbinip;
-  i : integer;
-begin
-  ipstrtobin(name,bip);
-
-  if bip.family <> 0 then begin
-    // it was an IP address
-    fresultlist := biniplist_new;
-    biniplist_add(fresultlist,bip);
-    onrequestdone(self,0);
-    exit;
-  end;
-
-  if (overridednsserver <> '') and (addr = '') then addr := overridednsserver;
-
-  if overrideaf = useaf_default then begin
-    {$ifdef ipv6}
-      {$ifdef win32}if not (usewindns and (addr = '')) then{$endif}
-      initpreferredmode;
-    {$endif}
-    requestaf := useaf;
-  end else begin
-    requestaf := overrideaf;
-  end;
-
-  {$ifdef win32}
-    if usewindns and (addr = '') then begin
-      dwas := tdnswinasync.create;
-      dwas.onrequestdone := winrequestdone;
-
-      dwas.forwardlookup(name);
-
-      exit;
-    end;
-  {$endif}
-
-  numsockused := 0;
-  fresultlist := biniplist_new;
-  if (requestaf <> useaf_v6) then begin
-    setstate_forward(name,states[numsockused],af_inet);
-    inc(numsockused);
-  end;
-
-  {$ifdef ipv6}
-    if (requestaf <> useaf_v4) then begin
-      setstate_forward(name,states[numsockused],af_inet6);
-      inc(numsockused);
-    end;
-  {$endif}
-  for i := 0 to numsockused-1 do begin
-    asyncprocess(i);
-  end;
-
-end;
-
-procedure tdnsasync.reverselookup;
-begin
-  if (overridednsserver <> '') and (addr = '') then addr := overridednsserver;
-  {$ifdef win32}
-    if usewindns and (addr = '') then begin
-      dwas := tdnswinasync.create;
-      dwas.onrequestdone := winrequestdone;
-      dwas.reverselookup(binip);
-      exit;
-    end;
-  {$endif}
-
-  setstate_reverse(binip,states[0]);
-  numsockused := 1;
-  asyncprocess(0);
-end;
-
-procedure tdnsasync.customlookup;
-begin
-  if (overridednsserver <> '') and (addr = '') then addr := overridednsserver;
-  setstate_custom(name,querytype,states[0]);
-  numsockused := 1;
-  asyncprocess(0);
-end;
-
-function tdnsasync.dnsresult;
-begin
-  if states[0].resultstr <> '' then result := states[0].resultstr else begin
-    result := ipbintostr(biniplist_get(fresultlist,0));
-  end;
-end;
-
-procedure tdnsasync.dnsresultbin(var binip:tbinip);
-begin
-  binip := biniplist_get(fresultlist,0);
-end;
-
-procedure tdnsasync.cancel;
-var
-  socketno : integer;
-begin
-  {$ifdef win32}
-    if assigned(dwas) then begin
-      dwas.release;
-      dwas := nil;
-    end else
-  {$endif}
-  begin
-    for socketno := 0 to numsock-1 do begin
-      reportlag(dnsserverids[socketno],-1);
-      dnsserverids[socketno] := -1;
-
-      sockets[socketno].close;
-    end;
-
-  end;
-  for socketno := 0 to numsock-1 do begin
-    setstate_failure(states[socketno]);
-
-  end;
-  fresultlist := biniplist_new;
-  onrequestdone(self,0);
-end;
-
-{$ifdef win32}
-  procedure tdnsasync.winrequestdone(sender:tobject;error:word);
- 
-  begin
-    if dwas.reverse then begin
-      states[0].resultstr := dwas.name;
-    end else begin 
-
-      {$ifdef ipv6}
-      if (requestaf = useaf_preferv4) then begin
-        {prefer mode: sort the IP's}
-        fresultlist := biniplist_new;
-        addipsoffamily(fresultlist,dwas.iplist,af_inet);
-        addipsoffamily(fresultlist,dwas.iplist,af_inet6);
-
-      end else if (requestaf = useaf_preferv6) then begin
-        {prefer mode: sort the IP's}
-        fresultlist := biniplist_new;
-        addipsoffamily(fresultlist,dwas.iplist,af_inet6);
-        addipsoffamily(fresultlist,dwas.iplist,af_inet);
-        
-      end else
-      {$endif}
-      begin
-        fresultlist := dwas.iplist;
-      end;
-
-    end;
-    dwas.release;
-    onrequestdone(self,error);
-  end;
-{$endif}
-end.

libwin/lcore/dnscore.pas

@@ -1,880 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-{
-
-  code wanting to use this dns system should act as follows (note: app
-  developers will probablly want to use dnsasync or dnssync or write a similar
-  wrapper unit of thier own).
-
-  for normal lookups call setstate_forward or setstate_reverse to set up the
-  state, for more obscure lookups use setstate_request_init and fill in other
-  relavent state manually.
-
-  call state_process which will do processing on the information in the state
-  and return an action
-  action_ignore means that dnscore wants the code that calls it to go
-  back to waiting for packets
-  action_sendpacket means that dnscore wants the code that calls it to send
-  the packet in sendpacket/sendpacketlen and then start (or go back to) listening
-  for
-  action_done means the request has completed (either suceeded or failed)
-
-  callers should resend the last packet they tried to send if they have not
-  been asked to send a new packet for more than some timeout value they choose.
-
-  when a packet is received the application should put the packet in
-  recvbuf/recvbuflen , set state.parsepacket and call state_process again
-
-  once the app gets action_done it can determine sucess or failure in the
-  following ways.
-
-  on failure state.resultstr will be an empty string and state.resultbin will
-  be zeroed out (easilly detected by the fact that it will have a family of 0)
-
-  on success for a A or AAAA lookup state.resultstr will be an empty string
-  and state.resultbin will contain the result (note: AAAA lookups require IPV6
-  enabled).
-
-  if an A lookup fails and the code is built with ipv6 enabled then the code
-  will return any AAAA records with the same name. The reverse does not apply
-  so if an application preffers IPV6 but wants IPV4 results as well it must
-  check them seperately.
-
-  on success for any other type of lookup state.resultstr will be an empty
-
-  note the state contains ansistrings, setstate_init with a null name parameter
-  can be used to clean theese up if required.
-
-  callers may use setstate_failure to mark the state as failed themseleves
-  before passing it on to other code, for example this may be done in the event
-  of a timeout.
-}
-unit dnscore;
-
-{$ifdef fpc}{$mode delphi}{$endif}
-
-{$include lcoreconfig.inc}
-
-interface
-
-uses binipstuff,classes,pgtypes,lcorernd;
-
-var usewindns : boolean = {$ifdef win32}true{$else}false{$endif};
-{hint to users of this unit that they should use windows dns instead.
-May be disabled by applications if desired. (e.g. if setting a custom
-dnsserverlist).
-
-note: this unit will not be able to self populate it's dns server list on
-older versions of windows.}
-
-const
-  useaf_default=0;
-  useaf_preferv4=1;
-  useaf_preferv6=2;
-  useaf_v4=3;
-  useaf_v6=4;
-{
-hint to users of this unit to how to deal with connecting to hostnames regarding ipv4 or ipv6 usage
-can be set by apps as desired
-}
-var useaf:integer = useaf_default;
-
-{
-(temporarily) use a different nameserver, regardless of the dnsserverlist
-}
-var overridednsserver:string;
-
-const
-  maxnamelength=127;
-  maxnamefieldlen=63;
-  //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries
-  //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway
-  action_ignore=0;
-  action_done=1;
-  action_sendquery=2;
-  querytype_a=1;
-  querytype_cname=5;
-  querytype_aaaa=28;
-  querytype_a6=38;
-  querytype_ptr=12;
-  querytype_ns=2;
-  querytype_soa=6;
-  querytype_mx=15;
-  querytype_txt=16;
-  querytype_spf=99;
-  maxrecursion=50;
-  maxrrofakind=20;
-
-  retryafter=300000; //microseconds must be less than one second;
-  timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)
-type
-  dvar=array[0..0] of byte;
-  pdvar=^dvar;
-  tdnspacket=packed record
-    id:word;
-    flags:word;
-    rrcount:array[0..3] of word;
-    payload:array[0..511-12] of byte;
-  end;
-
-
-
-  tdnsstate=record
-    id:word;
-    recursioncount:integer;
-    queryname:string;
-    requesttype:word;
-    parsepacket:boolean;
-    resultstr:string;
-    resultbin:tbinip;
-    resultlist:tbiniplist;
-    resultaction:integer;
-    numrr1:array[0..3] of integer;
-    numrr2:integer;
-    rrdata:string;
-    sendpacketlen:integer;
-    sendpacket:tdnspacket;
-    recvpacketlen:integer;
-    recvpacket:tdnspacket;
-    forwardfamily:integer;
-  end;
-
-  trr=packed record
-    requesttypehi:byte;
-    requesttype:byte;
-    clas:word;
-    ttl:integer;
-    datalen:word;
-    data:array[0..511] of byte;
-  end;
-
-  trrpointer=packed record
-    p:pointer;
-    ofs:integer;
-    len:integer;
-    namelen:integer;
-  end;
-
-//commenting out functions from interface that do not have documented semantics
-//and probablly should not be called from outside this unit, reenable them
-//if you must but please document them at the same time --plugwash
-
-//function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;
-
-//returns the DNS name used to reverse look up an IP, such as 4.3.2.1.in-addr.arpa for 1.2.3.4
-function makereversename(const binip:tbinip):string;
-
-procedure setstate_request_init(const name:string;var state:tdnsstate);
-
-//set up state for a foward lookup. A family value of AF_INET6 will give only
-//ipv6 results. Any other value will give only ipv4 results
-procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);
-
-procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
-procedure setstate_failure(var state:tdnsstate);
-//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
-
-//for custom raw lookups such as TXT, as desired by the user
-procedure setstate_custom(const name:string; requesttype:integer; var state:tdnsstate);
-
-procedure state_process(var state:tdnsstate);
-
-//function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;
-
-procedure populatednsserverlist;
-procedure cleardnsservercache;
-
-var
-  dnsserverlist : tstringlist;
-//  currentdnsserverno : integer;
-
-
-//getcurrentsystemnameserver returns the nameserver the app should use and sets
-//id to the id of that nameserver. id should later be used to report how laggy
-//the servers response was and if it was timed out.
-function getcurrentsystemnameserver(var id:integer) :string;
-procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
-
-//var
-//  unixnameservercache:string;
-{ $endif}
-
-
-{$ifdef ipv6}
-function getv6localips:tbiniplist;
-procedure initpreferredmode;
-
-var
-  preferredmodeinited:boolean;
-
-{$endif}
-
-var
-  failurereason:string;
-
-function getquerytype(s:string):integer;
-
-implementation
-
-uses
-  {$ifdef win32}
-    windows,
-  {$endif}
-
-  sysutils;
-
-
-
-function getquerytype(s:string):integer;
-begin
-  s := uppercase(s);
-  result := 0;
-  if (s = 'A') then result := querytype_a else
-  if (s = 'CNAME') then result := querytype_cname else
-  if (s = 'AAAA') then result := querytype_aaaa else
-  if (s = 'PTR') then result := querytype_ptr else
-  if (s = 'NS') then result := querytype_ns else
-  if (s = 'MX') then result := querytype_mx else
-  if (s = 'A6') then result := querytype_a6 else
-  if (s = 'TXT') then result := querytype_txt else
-  if (s = 'SOA') then result := querytype_soa else
-  if (s = 'SPF') then result := querytype_spf;
-end;
-
-function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;
-var
-  a,b:integer;
-  s:string;
-  arr:array[0..sizeof(packet)-1] of byte absolute packet;
-begin
- { writeln('buildrequest: name: ',name);}
-  result := 0;
-  fillchar(packet,sizeof(packet),0);
-  packet.id := randominteger($10000);
-
-  packet.flags := htons($0100);
-  packet.rrcount[0] := htons($0001);
-
-
-  s := copy(name,1,maxnamelength);
-  if s = '' then exit;
-  if s[length(s)] <> '.' then s := s + '.';
-  b := 0;
-  {encode name}
-  if (s = '.') then begin
-    packet.payload[0] := 0;
-    result := 12+5;
-  end else begin
-    for a := 1 to length(s) do begin
-      if s[a] = '.' then begin
-        if b > maxnamefieldlen then exit;
-        if (b = 0) then exit;
-        packet.payload[a-b-1] := b;
-        b := 0;
-      end else begin
-        packet.payload[a] := byte(s[a]);
-        inc(b);
-      end;
-    end;
-    if b > maxnamefieldlen then exit;
-    packet.payload[length(s)-b] := b;
-    result := length(s) + 12+5;
-  end;
-
-  arr[result-1] := 1;
-  arr[result-3] := requesttype and $ff;
-  arr[result-4] := requesttype shr 8;
-end;
-
-function makereversename(const binip:tbinip):string;
-var
-  name:string;
-  a,b:integer;
-begin
-  name := '';
-  if binip.family = AF_INET then begin
-    b := htonl(binip.ip);
-    for a := 0 to 3 do begin
-      name := name + inttostr(b shr (a shl 3) and $ff)+'.';
-    end;
-    name := name + 'in-addr.arpa';
-  end else
-  {$ifdef ipv6}
-  if binip.family = AF_INET6 then begin
-    for a := 15 downto 0 do begin
-      b := binip.ip6.u6_addr8[a];
-      name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';
-    end;
-    name := name + 'ip6.arpa';
-  end else
-  {$endif}
-  begin
-    {empty name}
-  end;
-  result := name;
-end;
-
-{
-decodes DNS format name to a string. does not includes the root dot.
-doesnt read beyond len.
-empty result + non null failurereason: failure
-empty result + null failurereason: internal use
-}
-function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;
-var
-  arr:array[0..sizeof(packet)-1] of byte absolute packet;
-  s:string;
-  a,b:integer;
-begin
-  numread := 0;
-  repeat
-    if (start+numread < 0) or (start+numread >= len) then begin
-      result := '';
-      failurereason := 'decoding name: got out of range1';
-      exit;
-    end;
-    b := arr[start+numread];
-    if b >= $c0 then begin
-      {recursive sub call}
-      if recursion > 10 then begin
-        result := '';
-        failurereason := 'decoding name: max recursion';
-        exit;
-      end;
-      if ((start+numread+1) >= len) then begin
-        result := '';
-        failurereason := 'decoding name: got out of range3';
-        exit;
-      end;
-      a := ((b shl 8) or arr[start+numread+1]) and $3fff;
-      s := decodename(packet,len,a,recursion+1,a);
-      if (s = '') and (failurereason <> '') then begin
-        result := '';
-        exit;
-      end;
-      if result <> '' then result := result + '.';
-      result := result + s;
-      inc(numread,2);
-      exit;
-    end else if b < 64 then begin
-      if (numread <> 0) and (b <> 0) then result := result + '.';
-      for a := start+numread+1 to start+numread+b do begin
-        if (a >= len) then begin
-          result := '';
-          failurereason := 'decoding name: got out of range2';
-          exit;
-        end;
-        result := result + char(arr[a]);
-      end;
-      inc(numread,b+1);
-
-      if b = 0 then begin
-        if (result = '') and (recursion = 0) then result := '.';
-        exit; {reached end of name}
-      end;
-    end else begin
-      failurereason := 'decoding name: read invalid char';
-      result := '';
-      exit; {invalid}
-    end;
-  until false;
-end;
-
-{==============================================================================}
-
-function getrawfromrr(const rrp:trrpointer;len:integer):string;
-begin
-  setlength(result,htons(trr(rrp.p^).datalen));
-  uniquestring(result);
-  move(trr(rrp.p^).data,result[1],length(result));
-end;
-
-
-function getipfromrr(const rrp:trrpointer;len:integer):tbinip;
-begin
-  fillchar(result,sizeof(result),0);
-  case trr(rrp.p^).requesttype of
-    querytype_a: begin
-      if htons(trr(rrp.p^).datalen) <> 4 then exit;
-      move(trr(rrp.p^).data,result.ip,4);
-      result.family :=AF_INET;
-    end;
-    {$ifdef ipv6}
-    querytype_aaaa: begin
-      if htons(trr(rrp.p^).datalen) <> 16 then exit;
-      result.family := AF_INET6;
-      move(trr(rrp.p^).data,result.ip6,16);
-    end;
-    {$endif}
-  else
-    {}
-  end;
-end;
-
-procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
-var
-  a:integer;
-begin
-  state.resultaction := action_done;
-  state.resultstr := '';
-  case trr(rrp.p^).requesttype of
-    querytype_a{$ifdef ipv6},querytype_aaaa{$endif}: begin
-      state.resultbin := getipfromrr(rrp,len);
-    end;
-    querytype_txt:begin
-      {TXT returns a raw string}
-      state.resultstr := copy(getrawfromrr(rrp,len),2,9999);
-      fillchar(state.resultbin,sizeof(state.resultbin),0);
-    end;
-    querytype_mx:begin
-      {MX is a name after a 16 bits word}
-      state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+12,0,a);
-      fillchar(state.resultbin,sizeof(state.resultbin),0);
-    end;
-  else
-    {other reply types (PTR, MX) return a hostname}
-    state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);
-    fillchar(state.resultbin,sizeof(state.resultbin),0);
-  end;
-end;
-
-procedure setstate_request_init(const name:string;var state:tdnsstate);
-begin
-  {destroy things properly}
-  state.resultstr := '';
-  state.queryname := '';
-  state.rrdata := '';
-  fillchar(state,sizeof(state),0);
-  state.queryname := name;
-  state.parsepacket := false;
-end;
-
-procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);
-begin
-  setstate_request_init(name,state);
-  state.forwardfamily := family;
-  {$ifdef ipv6}
-  if family = AF_INET6 then state.requesttype := querytype_aaaa else
-  {$endif}
-  state.requesttype := querytype_a;
-end;
-
-procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
-begin
-  setstate_request_init(makereversename(binip),state);
-  state.requesttype := querytype_ptr;
-end;
-
-procedure setstate_custom(const name:string; requesttype:integer; var state:tdnsstate);
-begin
-  setstate_request_init(name,state);
-  state.requesttype := requesttype;
-end;
-
-
-procedure setstate_failure(var state:tdnsstate);
-begin
-  state.resultstr := '';
-  fillchar(state.resultbin,sizeof(state.resultbin),0);
-  state.resultaction := action_done;
-end;
-
-procedure state_process(var state:tdnsstate);
-label recursed;
-label failure;
-var
-  a,b,ofs:integer;
-  rrtemp:^trr;
-  rrptemp:^trrpointer;
-begin
-  if state.parsepacket then begin
-    if state.recvpacketlen < 12 then begin
-      failurereason := 'Undersized packet';
-      state.resultaction := action_ignore;
-      exit;
-    end;
-    if state.id <> state.recvpacket.id then begin
-      failurereason := 'ID mismatch';
-      state.resultaction := action_ignore;
-      exit;
-    end;
-    state.numrr2 := 0;
-    for a := 0 to 3 do begin
-      state.numrr1[a] := htons(state.recvpacket.rrcount[a]);
-      if state.numrr1[a] > maxrrofakind then goto failure;
-      inc(state.numrr2,state.numrr1[a]);
-    end;
-
-    setlength(state.rrdata,state.numrr2*sizeof(trrpointer));
-
-    {- put all replies into a list}
-
-    ofs := 12;
-    {get all queries}
-    for a := 0 to state.numrr1[0]-1 do begin
-      if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;
-      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
-      rrptemp.p := @state.recvpacket.payload[ofs-12];
-      rrptemp.ofs := ofs;
-      decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);
-      rrptemp.len := b + 4;
-      inc(ofs,rrptemp.len);
-    end;
-
-    for a := state.numrr1[0] to state.numrr2-1 do begin
-      if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;
-      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
-      if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;
-      rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}
-      rrptemp.p := rrtemp;
-      rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}
-      rrptemp.namelen := b;
-      b := htons(rrtemp.datalen);
-      rrptemp.len := b + 10 + rrptemp.namelen;
-      inc(ofs,rrptemp.len);
-    end;
-    if (ofs <> state.recvpacketlen) then begin
-      failurereason := 'ofs <> state.packetlen';
-      goto failure;
-    end;
-
-    {if we requested A or AAAA build a list of all replies}
-    if (state.requesttype = querytype_a) or (state.requesttype = querytype_aaaa) then begin
-      state.resultlist := biniplist_new;
-      for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
-        rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
-        rrtemp := rrptemp.p;
-        b := rrptemp.len;
-        if rrtemp.requesttype = state.requesttype then begin
-          biniplist_add(state.resultlist,getipfromrr(rrptemp^,b));
-        end;
-      end;
-    end;
-
-    {- check for items of the requested type in answer section, if so return success first}
-    for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
-      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
-      rrtemp := rrptemp.p;
-      b := rrptemp.len;
-      if rrtemp.requesttype = state.requesttype then begin
-        setstate_return(rrptemp^,b,state);
-        exit;
-      end;
-    end;
-
-    {if no items of correct type found, follow first cname in answer section}
-    for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
-      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
-      rrtemp := rrptemp.p;
-      b := rrptemp.len;
-      if rrtemp.requesttype = querytype_cname then begin
-        state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);
-        goto recursed;
-      end;
-    end;
-
-    {no cnames found, no items of correct type found}
-    if state.forwardfamily <> 0 then goto failure;
-
-    goto failure;
-recursed:
-    {here it needs recursed lookup}
-    {if needing to follow a cname, change state to do so}
-    inc(state.recursioncount);
-    if state.recursioncount > maxrecursion then goto failure;
-  end;
-
-  {here, a name needs to be resolved}
-  if state.queryname = '' then begin
-    failurereason := 'empty query name';
-    goto failure;
-  end;
-
-  {do /ets/hosts lookup here}
-  state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);
-  if state.sendpacketlen = 0 then begin
-    failurereason := 'building request packet failed';
-    goto failure;
-  end;
-  state.id := state.sendpacket.id;
-  state.resultaction := action_sendquery;
-
-  exit;
-failure:
-  setstate_failure(state);
-end;
-{$ifdef win32}
-  const
-    MAX_HOSTNAME_LEN = 132;
-    MAX_DOMAIN_NAME_LEN = 132;
-    MAX_SCOPE_ID_LEN = 260    ;
-    MAX_ADAPTER_NAME_LENGTH = 260;
-    MAX_ADAPTER_ADDRESS_LENGTH = 8;
-    MAX_ADAPTER_DESCRIPTION_LENGTH = 132;
-    ERROR_BUFFER_OVERFLOW = 111;
-    MIB_IF_TYPE_ETHERNET = 6;
-    MIB_IF_TYPE_TOKENRING = 9;
-    MIB_IF_TYPE_FDDI = 15;
-    MIB_IF_TYPE_PPP = 23;
-    MIB_IF_TYPE_LOOPBACK = 24;
-    MIB_IF_TYPE_SLIP = 28;
-
-
-  type
-    tip_addr_string=packed record
-      Next :pointer;
-      IpAddress : array[0..15] of char;
-      ipmask    : array[0..15] of char;
-      context   : dword;
-    end;
-    pip_addr_string=^tip_addr_string;
-    tFIXED_INFO=packed record
-       HostName         : array[0..MAX_HOSTNAME_LEN-1] of char;
-       DomainName       : array[0..MAX_DOMAIN_NAME_LEN-1] of char;
-       currentdnsserver : pip_addr_string;
-       dnsserverlist    : tip_addr_string;
-       nodetype         : longint;
-       ScopeId          : array[0..MAX_SCOPE_ID_LEN + 4] of char;
-       enablerouting    : longbool;
-       enableproxy      : longbool;
-       enabledns        : longbool;
-    end;
-    pFIXED_INFO=^tFIXED_INFO;
-
-  var
-    iphlpapi : thandle;
-    getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall;
-{$endif}
-procedure populatednsserverlist;
-var
-  {$ifdef win32}
-    fixed_info : pfixed_info;
-    fixed_info_len : longint;
-    currentdnsserver : pip_addr_string;
-  {$else}
-    t:textfile;
-    s:string;
-    a:integer;
-  {$endif}
-begin
-  //result := '';
-  if assigned(dnsserverlist) then begin
-    dnsserverlist.clear;
-  end else begin
-    dnsserverlist := tstringlist.Create;
-  end;
-  {$ifdef win32}
-    if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll');
-    if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams');
-    if not assigned(getnetworkparams) then exit;
-    fixed_info_len := 0;
-    if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit;
-    //fixed_info_len :=sizeof(tfixed_info);
-    getmem(fixed_info,fixed_info_len);
-    if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin
-      freemem(fixed_info);
-      exit;
-    end;
-    currentdnsserver := @(fixed_info.dnsserverlist);
-    while assigned(currentdnsserver) do begin
-      dnsserverlist.Add(currentdnsserver.IpAddress);
-      currentdnsserver := currentdnsserver.next;
-    end;
-    freemem(fixed_info);
-  {$else}
-    filemode := 0;
-    assignfile(t,'/etc/resolv.conf');
-    {$i-}reset(t);{$i+}
-    if ioresult <> 0 then exit;
-
-    while not eof(t) do begin
-      readln(t,s);
-      if not (copy(s,1,10) = 'nameserver') then continue;
-      s := copy(s,11,500);
-      while s <> '' do begin
-        if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break;
-      end;
-      a := pos(' ',s);
-      if a <> 0 then s := copy(s,1,a-1);
-      a := pos(#9,s);
-      if a <> 0 then s := copy(s,1,a-1);
-      //result := s;
-      //if result <> '' then break;
-      dnsserverlist.Add(s);
-    end;
-    close(t);
-  {$endif}
-end;
-
-procedure cleardnsservercache;
-begin
-  if assigned(dnsserverlist) then begin
-    dnsserverlist.destroy;
-    dnsserverlist := nil;
-  end;
-end;
-
-function getcurrentsystemnameserver(var id:integer):string;
-var
-  counter : integer;
-
-begin
-  if not assigned(dnsserverlist) then populatednsserverlist;
-  if dnsserverlist.count=0 then raise exception.create('no dns servers availible');
-  id := 0;
-  if dnsserverlist.count >1 then begin
-
-    for counter := 1 to dnsserverlist.count-1 do begin
-      if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter;
-    end;
-  end;
-  result := dnsserverlist[id]
-end;
-
-procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
-var
-  counter : integer;
-  temp : integer;
-begin
-  if (id < 0) or (id >= dnsserverlist.count) then exit;
-  if lag = -1 then lag := timeoutlag;
-  for counter := 0 to dnsserverlist.count-1 do begin
-    temp := taddrint(dnsserverlist.objects[counter]) *15;
-    if counter=id then temp := temp + lag;
-    dnsserverlist.objects[counter] := tobject(temp div 16);
-  end;
-
-end;
-
-
-
-{$ifdef ipv6}
-
-{$ifdef linux}
-function getv6localips:tbiniplist;
-var
-  t:textfile;
-  s,s2:string;
-  ip:tbinip;
-  a:integer;
-begin
-  result := biniplist_new;
-
-  assignfile(t,'/proc/net/if_inet6');
-  {$i-}reset(t);{$i+}
-  if ioresult <> 0 then exit; {none found, return empty list}
-
-  while not eof(t) do begin
-    readln(t,s);
-    s2 := '';
-    for a := 0 to 7 do begin
-      if (s2 <> '') then s2 := s2 + ':';
-      s2 := s2 + copy(s,(a shl 2)+1,4);
-    end;
-    ipstrtobin(s2,ip);
-    if ip.family <> 0 then biniplist_add(result,ip);
-  end;
-  closefile(t);
-end;
-
-{$else}
-function getv6localips:tbiniplist;
-begin
-  result := biniplist_new;
-end;
-{$endif}
-
-procedure initpreferredmode;
-var
-  l:tbiniplist;
-  a:integer;
-  ip:tbinip;
-  ipmask_global,ipmask_6to4,ipmask_teredo:tbinip;
-
-begin
-  if preferredmodeinited then exit;
-  if useaf <> useaf_default then exit;
-  l := getv6localips;
-  if biniplist_getcount(l) = 0 then exit;
-  useaf := useaf_preferv4;
-  ipstrtobin('2000::',ipmask_global);
-  ipstrtobin('2001::',ipmask_teredo);
-  ipstrtobin('2002::',ipmask_6to4);
-  {if there is any v6 IP which is globally routable and not 6to4 and not teredo, prefer v6}
-  for a := biniplist_getcount(l)-1 downto 0 do begin
-    ip := biniplist_get(l,a);
-    if not comparebinipmask(ip,ipmask_global,3) then continue;
-    if comparebinipmask(ip,ipmask_teredo,32) then continue;
-    if comparebinipmask(ip,ipmask_6to4,16) then continue;
-    useaf := useaf_preferv6;
-    preferredmodeinited := true;
-    exit;
-  end;
-end;
-
-{$endif}
-
-
-{  quick and dirty description of dns packet structure to aid writing and
-   understanding of parser code, refer to appropriate RFCs for proper specs
-- all words are network order
-
-www.google.com A request:
-
-0, 2: random transaction ID
-2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)
-4, 2: questions: 1
-6, 2: answer RR's: 0.
-8, 2: authority RR's: 0.
-10, 2: additional RR's: 0.
-12, n: payload:
-  query:
-    #03 "www" #06 "google" #03 "com" #00
-    size-4, 2: type: host address (1)
-    size-2, 2: class: inet (1)
-
-reply:
-
-0,2: random transaction ID
-2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)
-4,4: questions: 1
-6,4: answer RR's: 2
-8,4: authority RR's: 9
-10,4: additional RR's: 9
-12: payload:
-  query:
-    ....
-  answer: CNAME
-    0,2 "c0 0c" "name: www.google.com"
-    2,2 "00 05" "type: cname for an alias"
-    4,2 "00 01" "class: inet"
-    6,4: TTL
-    10,2: data length "00 17" (23)
-    12: the cname name (www.google.akadns.net)
-  answer: A
-    0,2 ..
-    2,2 "00 01" host address
-    4,2 ...
-    6,4 ...
-    10,2: data length (4)
-    12,4: binary IP
-  authority - 9 records
-  additional - 9 records
-
-
-  ipv6 AAAA reply:
-    0,2: ...
-    2,2: type: 001c
-    4,2: class: inet (0001)
-    6,2: TTL
-    10,2: data size (16)
-    12,16: binary IP
-
-  ptr request: query type 000c
-
-name compression: word "cxxx" in the name, xxx points to offset in the packet}
-
-end.

libwin/lcore/dnssync.pas

@@ -1,407 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-unit dnssync;
-{$ifdef fpc}
-  {$mode delphi}
-{$endif}
-
-{$include lcoreconfig.inc}
-
-interface
-  uses
-    dnscore,
-    binipstuff,
-    {$ifdef win32}
-      winsock,
-      windows,
-    {$else}
-      {$ifdef VER1_0}
-        linux,
-      {$else}
-        baseunix,unix,unixutil,
-      {$endif}
-      sockets,
-      fd_utils,
-    {$endif}
-    lcorernd,
-    sysutils;
-
-//convert a name to an IP
-//will return v4 or v6 depending on what seems favorable, or manual preference setting
-//on error the binip will have a family of 0 (other fiels are also currently
-//zeroed out but may be used for further error information in future)
-//timeout is in miliseconds, it is ignored when using windows dns
-function forwardlookup(name:string;timeout:integer):tbinip;
-
-//convert a name to a list of all IP's returned
-//this returns both v4 and v6 IP's, or possibly only v4 or v6, depending on settings
-//on error, returns an empty list
-function forwardlookuplist(name:string;timeout:integer):tbiniplist;
-
-
-//convert an IP to a name, on error a null string will be returned, other
-//details as above
-function reverselookup(ip:tbinip;timeout:integer):string;
-
-
-
-const
-  tswrap=$4000;
-  tsmask=tswrap-1;
-
-  numsock=1{$ifdef ipv6}+1{$endif};
-  defaulttimeout=10000;
-  const mintimeout=16;
-
-  toport='53';
-
-var
-  id:integer;
-
-  sendquerytime:array[0..numsock-1] of integer;
-implementation
-
-{$ifdef win32}
-  uses dnswin;
-{$endif}
-
-
-{$ifndef win32}
-{$define syncdnscore}
-{$endif}
-
-{$i unixstuff.inc}
-{$i ltimevalstuff.inc}
-
-var
-  numsockused:integer;
-  fd:array[0..numsock-1] of integer;
-  state:array[0..numsock-1] of tdnsstate;
-  toaddr:array[0..numsock-1] of tbinip;
-
-{$ifdef syncdnscore}
-
-{$ifdef win32}
-  const
-    winsocket = 'wsock32.dll';
-  function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddrV; tolen: Integer): Integer; stdcall; external    winsocket name 'sendto';
-  function bind(s: TSocket; var addr: TinetSockAddrV; namelen: Integer): Longbool; stdcall; external    winsocket name 'bind';
-  type
-    fdset=tfdset;
-{$endif}
-
-
-function getts:integer;
-{$ifdef win32}
-begin
-  result := GetTickCount and tsmask;
-{$else}
-var
-  temp:ttimeval;
-begin
-  gettimeofday(temp);
-  result := ((temp.tv_usec div 1000) + (temp.tv_sec * 1000)) and tsmask;
-{$endif}
-end;
-
-
-function sendquery(socknum:integer;const packet:tdnspacket;len:integer):boolean;
-var
-  a:integer;
-  addr       : string;
-  port       : string;
-  inaddr     : TInetSockAddrV;
-begin
-{  writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}
-  result := false;
-  if len = 0 then exit; {no packet}
-
-  if overridednsserver <> '' then addr := overridednsserver else addr := getcurrentsystemnameserver(id);
-
-  {$ifdef ipv6}{$ifdef win32}
-  if toaddr[socknum].family = AF_INET6 then if (useaf = 0) then useaf := useaf_preferv6;
-  {$endif}{$endif}
-
-  port := toport;
-  toaddr[socknum] := ipstrtobinf(addr);
-  makeinaddrv(toaddr[socknum],port,inaddr);
-
-  sendto(fd[socknum],packet,len,0,inaddr,inaddrsize(inaddr));
-  sendquerytime[socknum] := getts;
-  result := true;
-end;
-
-procedure setupsocket;
-var
-  inAddrtemp : TInetSockAddrV;
-  a:integer;
-  biniptemp:tbinip;
-  addr:string;
-begin
-  //init both sockets smultaneously, always, so they get succesive fd's
-  if fd[0] > 0 then exit;
-
-  if overridednsserver <> '' then addr := overridednsserver else addr := getcurrentsystemnameserver(id);
-  //must get the DNS server here so we know to init v4 or v6
-
-  ipstrtobin(addr,biniptemp);
-
-  if biniptemp.family = AF_INET6 then biniptemp := ipstrtobinf('::') else biniptemp := ipstrtobinf('0.0.0.0');
-
-
-  for a := 0 to numsockused-1 do begin
-    makeinaddrv(biniptemp,inttostr( 1024 + randominteger(65536 - 1024) ),inaddrtemp);
-
-    fd[a] := Socket(biniptemp.family,SOCK_DGRAM,0);
-
-    If {$ifndef win32}Not{$endif} Bind(fd[a],inAddrtemp,inaddrsize(inaddrtemp)) Then begin
-      {$ifdef win32}
-        raise Exception.create('unable to bind '+inttostr(WSAGetLastError));
-      {$else}
-        raise Exception.create('unable to bind '+inttostr(socketError));
-      {$endif}
-    end;
-  end;
-end;
-
-procedure resolveloop(timeout:integer);
-var
-  selectresult   : integer;
-  fds            : fdset;
-
-  endtime      : longint;
-  starttime    : longint;
-  wrapmode     : boolean;
-  currenttime  : integer;
-
-  lag            : ttimeval;
-  currenttimeout : ttimeval;
-  selecttimeout	 : ttimeval;
-  socknum:integer;
-  needprocessing:array[0..numsock-1] of boolean;
-  finished:array[0..numsock-1] of boolean;
-  a,b:integer;
-
-  Src    : TInetSockAddrV;
-  Srcx   : {$ifdef win32}sockaddr_in{$else}TInetSockAddrV{$endif} absolute Src;
-  SrcLen : Integer;
-  fromip:tbinip;
-  fromport:string;
-
-begin
-  if timeout < mintimeout then timeout := defaulttimeout;
-
-    starttime := getts;
-    endtime := starttime + timeout;
-    if (endtime and tswrap)=0 then begin
-      wrapmode := false;
-    end else begin
-      wrapmode := true;
-    end;
-    endtime := endtime and tsmask;
-
-  setupsocket;
-  for socknum := 0 to numsockused-1 do begin
-    needprocessing[socknum] := true;
-    finished[socknum] := false;
-  end;
-
-  repeat
-    for socknum := numsockused-1 downto 0 do if needprocessing[socknum] then begin
-      state_process(state[socknum]);
-      case state[socknum].resultaction of
-        action_ignore: begin
-          {do nothing}
-        end;
-        action_done: begin
-          finished[socknum] := true;
-          //exit if all resolvers are finished
-          b := 0;
-          for a := 0 to numsockused-1 do begin
-            if finished[a] then inc(b);
-          end;
-          if (b = numsockused) then begin
-            exit;
-          end;
-          //onrequestdone(self,0);
-        end;
-        action_sendquery:begin
-{        writeln('send query');}
-          sendquery(socknum,state[socknum].sendpacket,state[socknum].sendpacketlen);
-        end;
-      end;
-      needprocessing[socknum] := false;
-    end;
-
-    currenttime := getts;
-    msectotimeval(selecttimeout, (endtime-currenttime) and tsmask);
-
-    fd_zero(fds);
-    for socknum := numsockused-1 downto 0 do if not finished[socknum] then fd_set(fd[socknum],fds);
-    if (selecttimeout.tv_sec > 0) or (selecttimeout.tv_usec > retryafter) then begin
-      selecttimeout.tv_sec := 0;
-      selecttimeout.tv_usec := retryafter;
-    end;
-    //find the highest of the used fd's
-    b := 0;
-    for socknum := numsockused-1 downto 0 do if fd[socknum] > b then b := fd[socknum];
-    selectresult := select(b+1,@fds,nil,nil,@selecttimeout);
-    if selectresult > 0 then begin
-      currenttime := getts;
-      for socknum := numsockused-1 downto 0 do if fd_isset(fd[socknum],fds) then begin
-  {      writeln('selectresult>0');}
-        //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash
-
-        fillchar(state[socknum].recvpacket,sizeof(state[socknum].recvpacket),0);
-        msectotimeval(lag,(currenttime-sendquerytime[socknum]) and tsmask);
-
-        if overridednsserver = '' then reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec);
-
-        SrcLen := SizeOf(Src);
-        state[socknum].recvpacketlen := recvfrom(fd[socknum],state[socknum].recvpacket, SizeOf(state[socknum].recvpacket),0,Srcx,SrcLen);
-
-        if (state[socknum].recvpacketlen > 0) then begin
-          fromip := inaddrvtobinip(Src);
-          fromport := inttostr(htons(src.InAddr.port));
-          if ((not comparebinip(toaddr[socknum],fromip)) or (fromport <> toport)) then begin
-//            writeln('dnssync received from wrong IP:port ',ipbintostr(fromip),'#',fromport);
-            state[socknum].recvpacketlen := 0;
-          end else begin
-            state[socknum].parsepacket := true;
-            needprocessing[socknum] := true;
-          end;
-        end;
-      end;
-    end;
-    if selectresult < 0 then exit;
-    if selectresult = 0 then begin
-
-      currenttime := getts;
-
-      if overridednsserver = '' then reportlag(id,-1);
-      if (currenttime >= endtime) and ((not wrapmode) or (currenttime < starttime)) then begin
-        exit;
-      end else begin
-        //resend
-        for socknum := numsockused-1 downto 0 do begin
-          sendquery(socknum,state[socknum].sendpacket,state[socknum].sendpacketlen);
-        end;
-      end;
-    end;
-  until false;
-end;
-{$endif}
-
-
-
-function forwardlookuplist(name:string;timeout:integer):tbiniplist;
-var
-  dummy : integer;
-  a,b:integer;
-  biniptemp:tbinip;
-  l:tbiniplist;
-begin
-  ipstrtobin(name,biniptemp);
-  if biniptemp.family <> 0 then begin
-    result := biniplist_new;
-    biniplist_add(result,biniptemp);
-    exit; //it was an IP address, no need for dns
-  end;
-
-  {$ifdef win32}
-  if usewindns then begin
-    if (useaf = useaf_v4) then a := af_inet else if (useaf = useaf_v6) then a := af_inet6 else a := 0;
-    result := winforwardlookuplist(name,a,dummy);
-    {$ifdef ipv6}
-    if (useaf = useaf_preferv4) then begin
-      {prefer mode: sort the IP's}
-      l := biniplist_new;
-      addipsoffamily(l,result,af_inet);
-      addipsoffamily(l,result,af_inet6);
-      result := l;
-    end;
-    if (useaf = useaf_preferv6) then begin
-      {prefer mode: sort the IP's}
-      l := biniplist_new;
-      addipsoffamily(l,result,af_inet6);
-      addipsoffamily(l,result,af_inet);
-      result := l;
-    end;
-    {$endif}
-  end else
-  {$endif}
-  begin
-  {$ifdef syncdnscore}
-    {$ifdef ipv6}initpreferredmode;{$endif}
-
-    numsockused := 0;
-
-    result := biniplist_new;
-    if (useaf <> useaf_v6) then begin
-      setstate_forward(name,state[numsockused],af_inet);
-      inc(numsockused);
-    end;
-    {$ifdef ipv6}
-    if (useaf <> useaf_v4) then begin
-      setstate_forward(name,state[numsockused],af_inet6);
-      inc(numsockused);
-    end;
-    {$endif}
-
-    resolveloop(timeout);
-
-    if (numsockused = 1) then begin
-      biniplist_addlist(result,state[0].resultlist);
-    {$ifdef ipv6}
-    end else if (useaf = useaf_preferv6) then begin
-      biniplist_addlist(result,state[1].resultlist);
-      biniplist_addlist(result,state[0].resultlist);
-    end else begin
-      biniplist_addlist(result,state[0].resultlist);
-      biniplist_addlist(result,state[1].resultlist);
-    {$endif}
-    end;
-    {$endif}
-  end;
-end;
-
-function forwardlookup(name:string;timeout:integer):tbinip;
-var
-  listtemp:tbiniplist;
-begin
-  listtemp := forwardlookuplist(name,timeout);
-  result := biniplist_get(listtemp,0);
-end;
-
-function reverselookup(ip:tbinip;timeout:integer):string;
-var
-  dummy : integer;
-begin
-  {$ifdef win32}
-    if usewindns then begin
-      result := winreverselookup(ip,dummy);
-      exit;
-    end;
-  {$endif}
-  {$ifdef syncdnscore}
-  setstate_reverse(ip,state[0]);
-  numsockused := 1;
-  resolveloop(timeout);
-  result := state[0].resultstr;
-  {$endif}
-end;
-
-{$ifdef win32}
-  var
-    wsadata : twsadata;
-
-  initialization
-    WSAStartUp($2,wsadata);
-  finalization
-    WSACleanUp;
-{$endif}
-end.
-
-

libwin/lcore/dnswin.pas

@@ -1,357 +0,0 @@
-unit dnswin;
-
-interface
-
-uses binipstuff,classes,lcore;
-
-{$include lcoreconfig.inc}
-
-//on failure a null string or zeroed out binip will be retuned and error will be
-//set to a windows error code (error will be left untouched under non error
-//conditions).
-function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist;
-function winreverselookup(ip:tbinip;var error:integer):string;
-
-
-type
-  //do not call destroy on a tdnswinasync instead call release and the
-  //dnswinasync will be freed when appropriate. Calling destroy will block
-  //the calling thread until the dns lookup completes.
-  //release should only be called from the main thread
-  tdnswinasync=class(tthread)
-  private
-    freverse : boolean;
-    error : integer;
-    freewhendone : boolean;
-    hadevent : boolean;
-  protected
-    procedure execute; override;
-  public
-    onrequestdone:tsocketevent;
-    name : string;
-    iplist : tbiniplist;
-
-    procedure forwardlookup(name:string);
-    procedure reverselookup(ip:tbinip);
-    destructor destroy; override;
-    procedure release;
-    constructor create;
-    property reverse : boolean read freverse;
-
-  end;
-
-implementation
-uses
-  lsocket,pgtypes,sysutils,winsock,windows,messages;
-
-type
-  //taddrinfo = record; //forward declaration
-  paddrinfo = ^taddrinfo;
-  taddrinfo = packed record
-    ai_flags : longint;
-    ai_family : longint;
-    ai_socktype : longint;
-    ai_protocol : longint;
-    ai_addrlen : taddrint;
-    ai_canonname : pchar;
-    ai_addr : pinetsockaddrv;
-    ai_next : paddrinfo;
-  end;
-  ppaddrinfo = ^paddrinfo;
-  tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;
-  tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;
-  tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;
-var
-  getaddrinfo : tgetaddrinfo;
-  freeaddrinfo : tfreeaddrinfo;
-  getnameinfo : tgetnameinfo;
-procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall;
-var
-  next:paddrinfo;
-begin
-  while assigned(ai) do begin
-    freemem(ai.ai_addr);
-    next := ai.ai_next;
-    freemem(ai);
-    ai := next;
-  end;
-end;
-
-type
-  plongint = ^longint;
-  pplongint = ^plongint;
-
-function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;
-var
-  output,prev,first : paddrinfo;
-  hostent : phostent;
-  addrlist:^pointer;
-begin
-  if hints.ai_family <> af_inet6 then begin
-    result := 0;
-
-
-    hostent := gethostbyname(nodename);
-    if hostent = nil then begin
-      result := wsagetlasterror;
-      v4onlyfreeaddrinfo(output);
-      exit;
-    end;
-    addrlist := pointer(hostent.h_addr_list);
-
-    //ipint := pplongint(hostent.h_addr_list)^^;
-    prev := nil;
-    first := nil;
-    repeat
-      if not assigned(addrlist^) then break;
-
-      getmem(output,sizeof(taddrinfo));
-      if assigned(prev) then prev.ai_next := output;
-      getmem(output.ai_addr,sizeof(tinetsockaddr));
-      if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0;
-      output.ai_addr.InAddr.addr := longint(addrlist^^);
-      inc(integer(addrlist),4);
-      output.ai_flags := 0;
-      output.ai_family := af_inet;
-      output.ai_socktype := 0;
-      output.ai_protocol := 0;
-      output.ai_addrlen := sizeof(tinetsockaddr);
-      output.ai_canonname := nil;
-      output.ai_next := nil;
-      prev := output;
-      if not assigned(first) then first := output;
-    until false;
-    res^ := first;
-  end else begin
-    result := WSANO_RECOVERY;
-  end;
-end;
-
-function min(a,b : integer):integer;
-begin
-  if a<b then result := a else result := b;
-end;
-
-function v4onlygetnameinfo(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;
-var
-  hostent : phostent;
-  bytestocopy : integer;
-begin
-  if sa.InAddr.family = af_inet then begin
-    result := 0;
-    hostent := gethostbyaddr(@(sa.inaddr.addr),4,AF_INET);
-    if hostent = nil then begin
-      result := wsagetlasterror;
-      exit;
-    end;
-    bytestocopy := min(strlen(hostent.h_name)+1,hostlen);
-    move((hostent.h_name)^,host^,bytestocopy);
-
-
-  end else begin
-    result := WSANO_RECOVERY;
-  end;
-end;
-
-
-procedure populateprocvars;
-var
-  libraryhandle : hmodule;
-  i : integer;
-  dllname : string;
-
-begin
-  if assigned(getaddrinfo) then exit; //procvars already populated
-  for i := 0 to 1 do begin
-    if i=0 then dllname := 'Ws2_32.dll' else dllname := 'Wship6.dll';
-    libraryhandle := LoadLibrary(pchar(dllname));
-    getaddrinfo := getprocaddress(libraryhandle,'getaddrinfo');
-    freeaddrinfo := getprocaddress(libraryhandle,'freeaddrinfo');
-    getnameinfo := getprocaddress(libraryhandle,'getnameinfo');
-    if assigned(getaddrinfo) and assigned(freeaddrinfo) and assigned(getnameinfo) then begin
-      //writeln('found getaddrinfo and freeaddrinfo in'+dllname);
-      exit; //success
-    end;
-
-  end;
-  //writeln('could not find getaddrinfo and freeaddrinfo, falling back to ipv4 only lookup');
-  getaddrinfo := v4onlygetaddrinfo;
-  freeaddrinfo := v4onlyfreeaddrinfo;
-  getnameinfo := v4onlygetnameinfo;
-end;
-
-
-function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist;
-var
-  hints: taddrinfo;
-  res0,res : paddrinfo;
-  getaddrinforesult : integer;
-  biniptemp:tbinip;
-begin
-  populateprocvars;
-
-  hints.ai_flags := 0;
-  hints.ai_family := familyhint;
-  hints.ai_socktype := 0;
-  hints.ai_protocol := 0;
-  hints.ai_addrlen := 0;
-  hints.ai_canonname := nil;
-  hints.ai_addr := nil;
-  hints.ai_next := nil;
-  getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res);
-  res0 := res;
-  result := biniplist_new;
-  if getaddrinforesult = 0 then begin
-
-    while assigned(res) do begin
-      if res.ai_family = af_inet then begin
-        biniptemp.family := af_inet;
-        biniptemp.ip := res.ai_addr.InAddr.addr;
-        biniplist_add(result,biniptemp);
-      {$ifdef ipv6}
-      end else if res.ai_family = af_inet6 then begin
-        biniptemp.family := af_inet6;
-        biniptemp.ip6 := res.ai_addr.InAddr6.sin6_addr;
-        biniplist_add(result,biniptemp);
-      {$endif}
-      end;
-      res := res.ai_next;
-    end;
-    freeaddrinfo(res0);
-    exit;
-  end;
-
-  if getaddrinforesult <> 0 then begin
-    fillchar(result,0,sizeof(result));
-    error := getaddrinforesult;
-  end;
-end;
-
-function winreverselookup(ip:tbinip;var error : integer):string;
-var
-  sa : tinetsockaddrv;
-  getnameinforesult : integer;
-begin
-
-  if ip.family = AF_INET then begin
-    sa.InAddr.family := AF_INET;
-    sa.InAddr.port := 1;
-    sa.InAddr.addr := ip.ip;
-  end else {$ifdef ipv6}if ip.family = AF_INET6 then begin
-    sa.InAddr6.sin6_family  := AF_INET6;
-    sa.InAddr6.sin6_port := 1;
-    sa.InAddr6.sin6_addr := ip.ip6;
-  end else{$endif} begin
-    raise exception.create('unrecognised address family');
-  end;
-  populateprocvars;
-  setlength(result,1025);
-  getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0);
-  if getnameinforesult <> 0 then begin
-    error := getnameinforesult;
-    result := '';
-    exit;
-  end;
-  if pos(#0,result) >= 0 then begin
-    setlength(result,pos(#0,result)-1);
-  end;
-end;
-
-var
-  hwnddnswin : hwnd;
-
-function MyWindowProc(
-    ahWnd   : HWND;
-    auMsg   : Integer;
-    awParam : WPARAM;
-    alParam : LPARAM): Integer; stdcall;
-var
-  dwas : tdnswinasync;
-begin
-  if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin
-    Dwas := tdnswinasync(alparam);
-    if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);
-    dwas.hadevent := true;
-    if dwas.freewhendone then dwas.free;
-  end else begin
-    //not passing unknown messages on to defwindowproc will cause window
-    //creation to fail! --plugwash
-    Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
-  end;
-end;
-
-procedure tdnswinasync.forwardlookup(name:string);
-begin
-  self.name := name;
-  freverse := false;
-  resume;
-end;
-procedure tdnswinasync.reverselookup(ip:tbinip);
-begin
-  iplist := biniplist_new;
-  biniplist_add(iplist,ip);
-  freverse := true;
-  resume;
-end;
-
-procedure tdnswinasync.execute;
-var
-  error : integer;
-
-begin
-  error := 0;
-  if reverse then begin
-    name := winreverselookup(biniplist_get(iplist,0),error);
-  end else begin
-    iplist := winforwardlookuplist(name,0,error);
-
-  end;
-  postmessage(hwnddnswin,wm_user,error,taddrint(self));
-end;
-
-destructor tdnswinasync.destroy;
-begin
-  WaitFor;
-  inherited destroy;
-end;
-procedure tdnswinasync.release;
-begin
-  if hadevent then destroy else begin
-    onrequestdone := nil;
-    freewhendone := true;
-  end;
-end;
-
-constructor tdnswinasync.create;
-begin
-  inherited create(true);
-end;
-
-var
-  MyWindowClass : TWndClass = (style         : 0;
-                                 lpfnWndProc   : @MyWindowProc;
-                                 cbClsExtra    : 0;
-                                 cbWndExtra    : 0;
-                                 hInstance     : 0;
-                                 hIcon         : 0;
-                                 hCursor       : 0;
-                                 hbrBackground : 0;
-                                 lpszMenuName  : nil;
-                                 lpszClassName : 'dnswinClass');
-begin
-
-    if Windows.RegisterClass(MyWindowClass) = 0 then halt;
-  //writeln('about to create lcore handle, hinstance=',hinstance);
-  hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW,
-                               MyWindowClass.lpszClassName,
-                               '',        { Window name   }
-                               WS_POPUP,  { Window Style  }
-                               0, 0,      { X, Y          }
-                               0, 0,      { Width, Height }
-                               0,         { hWndParent    }
-                               0,         { hMenu         }
-                               HInstance, { hInstance     }
-                               nil);      { CreateParam   }
-  //writeln('dnswin hwnd is ',hwnddnswin);
-  //writeln('last error is ',GetLastError);
-end.

libwin/lcore/fastmd5.pas

@@ -1,297 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  Which is included in the package
-  ----------------------------------------------------------------------------- }
-
-unit fastmd5;
-
-{
-pascal implementation of MD5
-
-written by Bas Steendijk - steendijk@xs4all.nl
-
-based on RFC1321 - The MD5 Message-Digest Algorithm
-
-optimized for speed: saved on copying and sub calls in the core routine
-
-verified on:
-- Borland Delphi 3
-- Borland Turbo Pascal 7
-- Free Pascal 1.0.6 for i386 (on *nix)
-- various other versions of freepascal on windows and linux i386
-- various other versions of delphi
-- free pascal 1.9.5 on powerpc darwin
-
-this unit is endian portable but is likely to be significantly slower on big endian systems
-}
-
-{$Q-,R-}
-
-interface
-
-
-
-
-
-type
-  Tmd5=array[0..15] of byte;
-
-{$i uint32.inc}
-
-type
-  dvar=array[0..0] of byte;
-  Tmd5state=record
-    buf:array[0..63] of byte;
-    H:array[0..3] of uint32;
-    msglen:longint;
-    msglenhi:longint;
-  end;
-
-procedure md5processblock(var h:array of uint32;const data);
-
-procedure md5init(var state:tmd5state);
-procedure md5process(var state:tmd5state;const data;len:longint);
-procedure md5finish(var state:tmd5state;var result);
-
-procedure getmd5(const data;len:longint;var result);
-
-function md5tostr(const md5:tmd5):string;
-
-implementation
-
-function inttohex(val,bits:integer):string;
-const
-  hexchar:array[0..15] of char='0123456789abcdef';
-begin
-  inttohex := hexchar[val shr 4]+hexchar[val and $f];
-end;
-
-{$ifdef cpu386}
-function rol(w,bits:uint32): uint32; assembler;
-asm
-  {cpu386 is not defined on freepascal. but fpc assembler is incompatible, uses different code}
-  {inline($89/$d1/$d3/$c0);}
-  mov   ecx,edx
-  rol   eax,cl
-end;
-{$else}
-function rol(w,bits:uint32):uint32;
-begin
-  rol := (w shl bits) or (w shr (32-bits));
-end;
-{$endif}
-
-
-{function swapbytes(invalue:uint32):uint32;
-var
-  inbytes  : array[0..3] of byte absolute invalue;
-  outbytes : array[0..3] of byte absolute result;
-
-
-begin
-  outbytes[0] := inbytes[3];
-  outbytes[1] := inbytes[2];
-  outbytes[2] := inbytes[1];
-  outbytes[3] := inbytes[0];
-end;}
-
-procedure md5processblock(var h:array of uint32;const data);
-const
-  S11=7;  S12=12;  S13=17;  S14=22;
-  S21=5;  S22=9;   S23=14;  S24=20;
-  S31=4;  S32=11;  S33=16;  S34=23;
-  S41=6;  S42=10;  S43=15;  S44=21;
-
-var
-  A,B,C,D:uint32;
-  w:array[0..63] of byte absolute data;
-  x:array[0..15] of uint32 {$ifndef ENDIAN_BIG} absolute data{$endif} ;
-  y:array[0..63] of byte absolute x;
-  {$ifdef ENDIAN_BIG}counter : integer;{$endif}
-begin
-  A := h[0];
-  B := h[1];
-  C := h[2];
-  D := h[3];
-  {$ifdef ENDIAN_BIG}
-    for counter := 0 to 63 do begin
-      y[counter] := w[counter xor 3];
-    end;
-  {$endif}
-  a := rol(a + ((b and c) or ((not b) and d)) + x[ 0] + $d76aa478, S11) + b;
-  d := rol(d + ((a and b) or ((not a) and c)) + x[ 1] + $e8c7b756, S12) + a;
-  c := rol(c + ((d and a) or ((not d) and b)) + x[ 2] + $242070db, S13) + d;
-  b := rol(b + ((c and d) or ((not c) and a)) + x[ 3] + $c1bdceee, S14) + c;
-  a := rol(a + ((b and c) or ((not b) and d)) + x[ 4] + $f57c0faf, S11) + b;
-  d := rol(d + ((a and b) or ((not a) and c)) + x[ 5] + $4787c62a, S12) + a;
-  c := rol(c + ((d and a) or ((not d) and b)) + x[ 6] + $a8304613, S13) + d;
-  b := rol(b + ((c and d) or ((not c) and a)) + x[ 7] + $fd469501, S14) + c;
-  a := rol(a + ((b and c) or ((not b) and d)) + x[ 8] + $698098d8, S11) + b;
-  d := rol(d + ((a and b) or ((not a) and c)) + x[ 9] + $8b44f7af, S12) + a;
-  c := rol(c + ((d and a) or ((not d) and b)) + x[10] + $ffff5bb1, S13) + d;
-  b := rol(b + ((c and d) or ((not c) and a)) + x[11] + $895cd7be, S14) + c;
-  a := rol(a + ((b and c) or ((not b) and d)) + x[12] + $6b901122, S11) + b;
-  d := rol(d + ((a and b) or ((not a) and c)) + x[13] + $fd987193, S12) + a;
-  c := rol(c + ((d and a) or ((not d) and b)) + x[14] + $a679438e, S13) + d;
-  b := rol(b + ((c and d) or ((not c) and a)) + x[15] + $49b40821, S14) + c;
-
-  a := rol(a + ((b and d) or (c and (not d))) + x[ 1] + $f61e2562, S21) + b;
-  d := rol(d + ((a and c) or (b and (not c))) + x[ 6] + $c040b340, S22) + a;
-  c := rol(c + ((d and b) or (a and (not b))) + x[11] + $265e5a51, S23) + d;
-  b := rol(b + ((c and a) or (d and (not a))) + x[ 0] + $e9b6c7aa, S24) + c;
-  a := rol(a + ((b and d) or (c and (not d))) + x[ 5] + $d62f105d, S21) + b;
-  d := rol(d + ((a and c) or (b and (not c))) + x[10] + $02441453, S22) + a;
-  c := rol(c + ((d and b) or (a and (not b))) + x[15] + $d8a1e681, S23) + d;
-  b := rol(b + ((c and a) or (d and (not a))) + x[ 4] + $e7d3fbc8, S24) + c;
-  a := rol(a + ((b and d) or (c and (not d))) + x[ 9] + $21e1cde6, S21) + b;
-  d := rol(d + ((a and c) or (b and (not c))) + x[14] + $c33707d6, S22) + a;
-  c := rol(c + ((d and b) or (a and (not b))) + x[ 3] + $f4d50d87, S23) + d;
-  b := rol(b + ((c and a) or (d and (not a))) + x[ 8] + $455a14ed, S24) + c;
-  a := rol(a + ((b and d) or (c and (not d))) + x[13] + $a9e3e905, S21) + b;
-  d := rol(d + ((a and c) or (b and (not c))) + x[ 2] + $fcefa3f8, S22) + a;
-  c := rol(c + ((d and b) or (a and (not b))) + x[ 7] + $676f02d9, S23) + d;
-  b := rol(b + ((c and a) or (d and (not a))) + x[12] + $8d2a4c8a, S24) + c;
-
-  a := rol(a + (b xor c xor d) + x[ 5] + $fffa3942, S31) + b;
-  d := rol(d + (a xor b xor c) + x[ 8] + $8771f681, S32) + a;
-  c := rol(c + (d xor a xor b) + x[11] + $6d9d6122, S33) + d;
-  b := rol(b + (c xor d xor a) + x[14] + $fde5380c, S34) + c;
-  a := rol(a + (b xor c xor d) + x[ 1] + $a4beea44, S31) + b;
-  d := rol(d + (a xor b xor c) + x[ 4] + $4bdecfa9, S32) + a;
-  c := rol(c + (d xor a xor b) + x[ 7] + $f6bb4b60, S33) + d;
-  b := rol(b + (c xor d xor a) + x[10] + $bebfbc70, S34) + c;
-  a := rol(a + (b xor c xor d) + x[13] + $289b7ec6, S31) + b;
-  d := rol(d + (a xor b xor c) + x[ 0] + $eaa127fa, S32) + a;
-  c := rol(c + (d xor a xor b) + x[ 3] + $d4ef3085, S33) + d;
-  b := rol(b + (c xor d xor a) + x[ 6] + $04881d05, S34) + c;
-  a := rol(a + (b xor c xor d) + x[ 9] + $d9d4d039, S31) + b;
-  d := rol(d + (a xor b xor c) + x[12] + $e6db99e5, S32) + a;
-  c := rol(c + (d xor a xor b) + x[15] + $1fa27cf8, S33) + d;
-  b := rol(b + (c xor d xor a) + x[ 2] + $c4ac5665, S34) + c;
-
-  a := rol(a + (c xor (b or (not d))) + x[ 0] + $f4292244, S41) + b;
-  d := rol(d + (b xor (a or (not c))) + x[ 7] + $432aff97, S42) + a;
-  c := rol(c + (a xor (d or (not b))) + x[14] + $ab9423a7, S43) + d;
-  b := rol(b + (d xor (c or (not a))) + x[ 5] + $fc93a039, S44) + c;
-  a := rol(a + (c xor (b or (not d))) + x[12] + $655b59c3, S41) + b;
-  d := rol(d + (b xor (a or (not c))) + x[ 3] + $8f0ccc92, S42) + a;
-  c := rol(c + (a xor (d or (not b))) + x[10] + $ffeff47d, S43) + d;
-  b := rol(b + (d xor (c or (not a))) + x[ 1] + $85845dd1, S44) + c;
-  a := rol(a + (c xor (b or (not d))) + x[ 8] + $6fa87e4f, S41) + b;
-  d := rol(d + (b xor (a or (not c))) + x[15] + $fe2ce6e0, S42) + a;
-  c := rol(c + (a xor (d or (not b))) + x[ 6] + $a3014314, S43) + d;
-  b := rol(b + (d xor (c or (not a))) + x[13] + $4e0811a1, S44) + c;
-  a := rol(a + (c xor (b or (not d))) + x[ 4] + $f7537e82, S41) + b;
-  d := rol(d + (b xor (a or (not c))) + x[11] + $bd3af235, S42) + a;
-  c := rol(c + (a xor (d or (not b))) + x[ 2] + $2ad7d2bb, S43) + d;
-  b := rol(b + (d xor (c or (not a))) + x[ 9] + $eb86d391, S44) + c;
-
-  inc(h[0],A);
-  inc(h[1],B);
-  inc(h[2],C);
-  inc(h[3],D);
-end;
-
-procedure md5init(var state:tmd5state);
-begin
-  state.h[0] := $67452301;
-  state.h[1] := $EFCDAB89;
-  state.h[2] := $98BADCFE;
-  state.h[3] := $10325476;
-  state.msglen := 0;
-  state.msglenhi := 0;
-end;
-
-procedure md5process(var state:tmd5state;const data;len:longint);
-var
-  a,b:longint;
-  ofs:longint;
-  p:dvar absolute data;
-begin
-  b := state.msglen and 63;
-
-  inc(state.msglen,len);
-  while (state.msglen > $20000000) do begin
-    dec(state.msglen,$20000000);
-    inc(state.msglenhi);
-  end;
-  ofs := 0;
-  if b > 0 then begin
-    a := 64-b;
-    if a > len then a := len;
-    move(p[0],state.buf[b],a);
-    inc(ofs,a);
-    dec(len,a);
-    if b+a = 64 then md5processblock(state.h,state.buf);
-    if len = 0 then exit;
-  end;
-  while len >= 64 do begin
-    md5processblock(state.h,p[ofs]);
-    inc(ofs,64);
-    dec(len,64);
-  end;
-  if len > 0 then move(p[ofs],state.buf[0],len);
-end;
-
-procedure md5finish(var state:tmd5state;var result);
-var
-  b       :integer;
-  {$ifdef endian_big}
-    h       :tmd5 absolute state.h;
-    r       :tmd5 absolute result;
-    counter :integer ;
-  {$endif}
-begin
-  b := state.msglen and 63;
-  state.buf[b] := $80;
-  if b >= 56 then begin
-    {-- for a := b+1 to 63 do state.buf[a] := 0; }
-    fillchar(state.buf[b+1],63-b,0);
-    md5processblock(state.h,state.buf);
-    fillchar(state.buf,56,0);
-  end else begin
-    {-- for a := b+1 to 55 do state.buf[a] := 0; }
-    fillchar(state.buf[b+1],55-b,0);
-  end;
-  state.msglen := state.msglen shl 3;
-
-  state.buf[56] := state.msglen;
-  state.buf[57] := state.msglen shr 8;
-  state.buf[58] := state.msglen shr 16;
-  state.buf[59] := state.msglen shr 24;
-  state.buf[60] := state.msglenhi;
-  state.buf[61] := state.msglenhi shr 8;
-  state.buf[62] := state.msglenhi shr 16;
-  state.buf[63] := state.msglenhi shr 24;
-
-  md5processblock(state.h,state.buf);
-  {$ifdef ENDIAN_BIG}
-    for counter := 0 to 15 do begin
-      r[counter] := h[counter xor 3];
-    end;
-  {$else} 
-    move(state.h,result,16);
-  {$endif}
-  fillchar(state,sizeof(state),0);
-end;
-
-procedure getmd5(const data;len:longint;var result);
-var
-  t:tmd5state;
-begin
-  md5init(t);
-  md5process(t,data,len);
-  md5finish(t,result);
-end;
-
-function md5tostr(const md5:tmd5):string;
-var
-  a:integer;
-  s:string;
-begin
-  s := '';
-  for a := 0 to 15 do s := s + inttohex(md5[a],2);
-  md5tostr := s;
-end;
-
-end.

libwin/lcore/fd_utils.pas

@@ -1,72 +0,0 @@
-// this file contains code copied from linux.pp in the free pascal rtl
-// i had to copy them because i use a different definition of fdset to them
-// the copyright block from the file in question is shown below
-{
-   $Id: fd_utils.pas,v 1.2 2004/08/19 23:12:09 plugwash Exp $
-   This file is part of the Free Pascal run time library.
-   Copyright (c) 1999-2000 by Michael Van Canneyt,
-   BSD parts (c) 2000 by Marco van de Voort
-   members of the Free Pascal development team.
-
-   See the file COPYING.FPC, included in this distribution,
-   for details about the copyright.
-
-   This program is distributed in the hope that it will be useful,
-   but WITHOUT ANY WARRANTY;without even the implied warranty of
-   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
-**********************************************************************}
-{$ifdef fpc}
-  {$mode delphi}
-  {$inlining on}
-{$endif}
-unit fd_utils;
-interface
-
-type
-    FDSet= Array [0..255] of longint; {31}
-    PFDSet= ^FDSet;
-
-Procedure FD_Clr(fd:longint;var fds:fdSet);
-Procedure FD_Zero(var fds:fdSet);
-Procedure FD_Set(fd:longint;var fds:fdSet);
-Function FD_IsSet(fd:longint;var fds:fdSet):boolean;
-
-{$ifdef fpc}
-  {$ifndef ver1_0}
-    {$define useinline}
-  {$endif}
-{$endif}
-
-implementation  
-uses sysutils;
-Procedure FD_Clr(fd:longint;var fds:fdSet);{$ifdef useinline}inline;{$endif}
-{ Remove fd from the set of filedescriptors}
-begin
-  if (fd < 0) then raise exception.create('FD_Clr fd out of range: '+inttostr(fd));
-  fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31)));
-end;
-
-Procedure FD_Zero(var fds:fdSet);
-{ Clear the set of filedescriptors }
-begin
-  FillChar(fds,sizeof(fdSet),0);
-end;
-
-Procedure FD_Set(fd:longint;var fds:fdSet);{$ifdef useinline}inline;{$endif}
-{ Add fd to the set of filedescriptors }
-begin
-  if (fd < 0) then raise exception.create('FD_set fd out of range: '+inttostr(fd));
-  fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31));
-end;
-
-Function FD_IsSet(fd:longint;var fds:fdSet):boolean;{$ifdef useinline}inline;{$endif}
-{ Test if fd is part of the set of filedescriptors }
-begin
-  if (fd < 0) then begin
-    result := false;
-    exit;
-  end;
-  FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0);
-end;
-end.

libwin/lcore/lcore.pas

@@ -1,906 +0,0 @@
-{lsocket.pas}
-
-{io and timer code by plugwash}
-
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-{note: you must use the @ in the last param to tltask.create not doing so will
- compile without error but will cause an access violation -pg}
-
-//note: events after release are normal and are the apps responsibility to deal with safely
-
-unit lcore;
-{$ifdef fpc}
-  {$mode delphi}
-{$endif}
-{$ifdef win32}
-  {$define nosignal}
-{$endif}
-interface
-  uses
-    sysutils,
-    {$ifndef win32}
-      {$ifdef VER1_0}
-        linux,
-      {$else}
-        baseunix,unix,unixutil,
-      {$endif}
-      fd_utils,
-    {$endif}
-    classes,pgtypes,bfifo;
-  procedure processtasks;
-
-
-  const
-    {how this number is made up:
-    - ethernet: MTU 1500
-    - be safe for either "ethernet v1" or "PPPoE", both take 8 bytes
-    - IPv6 header: 40 bytes (IPv4 is 20)
-    - TCP/UDP header: 20 bytes
-    }
-    packetbasesize = 1432;
-    receivebufsize=packetbasesize*8;
-
-  var
-    absoloutemaxs:integer=0;
-
-  type
-    {$ifdef ver1_0}
-      sigset= array[0..31] of longint;
-    {$endif}
-
-    ESocketException   = class(Exception);
-    TBgExceptionEvent  = procedure (Sender : TObject;
-                                  E : Exception;
-                                  var CanClose : Boolean) of object;
-
-    // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket
-    // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening
-    TSocketState       = (wsInvalidState,
-                        wsOpened,     wsBound,
-                        wsConnecting, wsConnected,
-                        wsAccepting,  wsListening,
-                        wsClosed);
-
-    TWSocketOption       = (wsoNoReceiveLoop, wsoTcpNoDelay);
-    TWSocketOptions      = set of TWSocketOption;
-
-    TSocketevent     = procedure(Sender: TObject; Error: word) of object;
-    //Tdataavailevent  = procedure(data : string);
-    TSendData          = procedure (Sender: TObject; BytesSent: Integer) of object;
-
-    tlcomponent = class(tcomponent)
-    private
-      procedure releasetaskhandler(wparam,lparam:longint);
-    public
-      procedure release; virtual;
-      destructor destroy; override;
-    end;
-
-    tlasio = class(tlcomponent)
-    public
-      state              : tsocketstate      ;
-      ComponentOptions   : TWSocketOptions;
-      fdhandlein         : Longint           ;  {file discriptor}
-      fdhandleout        : Longint           ;  {file discriptor}
-
-      onsessionclosed    : tsocketevent      ;
-      ondataAvailable    : tsocketevent      ;
-      onsessionAvailable : tsocketevent      ;
-
-      onsessionconnected : tsocketevent      ;
-      onsenddata         : tsenddata      ;
-      ondatasent         : tsocketevent      ;
-      //connected          : boolean         ;
-
-      recvq              : tfifo;
-      OnBgException      : TBgExceptionEvent ;
-      //connectread        : boolean           ;
-      sendq              : tfifo;
-      closehandles       : boolean           ;
-      writtenthiscycle   : boolean           ;
-      onfdwrite           : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd
-      lasterror:integer;
-      destroying:boolean;
-      recvbufsize:integer;
-      function receivestr:string; virtual;
-      procedure close;
-      procedure abort;
-      procedure internalclose(error:word); virtual;
-      constructor Create(AOwner: TComponent); override;
-
-      destructor destroy; override;
-      procedure fdcleanup;
-      procedure HandleBackGroundException(E: Exception);
-      procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual;
-      procedure dup(invalue:longint);
-
-      function sendflush : integer;
-      procedure sendstr(const str : string);virtual;
-      procedure putstringinsendbuffer(const newstring : string);
-      function send(data:pointer;len:integer):integer;virtual;
-      procedure putdatainsendbuffer(data:pointer;len:integer); virtual;
-      procedure deletebuffereddata;
-
-      //procedure messageloop;
-      function Receive(Buf:Pointer;BufSize:integer):integer; virtual;
-      procedure flush;virtual;
-      procedure dodatasent(wparam,lparam:longint);
-      procedure doreceiveloop(wparam,lparam:longint);
-      procedure sinkdata(sender:tobject;error:word);
-
-      procedure release; override; {test -beware}
-
-      function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd
-
-      procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif}
-      function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}
-      function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}
-    protected
-      procedure dupnowatch(invalue:longint);
-    end;
-    ttimerwrapperinterface=class(tlcomponent)
-    public
-      function createwrappedtimer : tobject;virtual;abstract;
-//      procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;
-      procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract;
-      procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;
-      procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract;
-    end;
-
-  var
-    timerwrapperinterface : ttimerwrapperinterface;
-  type
-    {$ifdef win32}
-      ttimeval = record
-        tv_sec : longint;
-        tv_usec : longint;
-      end;
-    {$endif}
-    tltimer=class(tlcomponent)
-    protected
-
-
-      wrappedtimer : tobject;
-
-
-//      finitialevent       : boolean           ;
-      fontimer            : tnotifyevent      ;
-      fenabled            : boolean           ;
-      finterval	          : integer	     ; {miliseconds, default 1000}
-      {$ifndef win32}
-        procedure resettimes;
-      {$endif}
-//      procedure setinitialevent(newvalue : boolean);
-      procedure setontimer(newvalue:tnotifyevent);
-      procedure setenabled(newvalue : boolean);
-      procedure setinterval(newvalue : integer);
-    public
-      //making theese public for now, this code should probablly be restructured later though
-      prevtimer          : tltimer           ;
-      nexttimer          : tltimer           ;
-      nextts	         : ttimeval          ;
-
-      constructor create(aowner:tcomponent);override;
-      destructor destroy;override;
-//      property initialevent : boolean read finitialevent write setinitialevent;
-      property ontimer : tnotifyevent read fontimer write setontimer;
-      property enabled : boolean read fenabled write setenabled;
-      property interval	: integer read finterval write setinterval;
-
-    end;
-
-    ttaskevent=procedure(wparam,lparam:longint) of object;
-
-    tltask=class(tobject)
-    public
-      handler  : ttaskevent;
-      obj      : tobject;
-      wparam   : longint;
-      lparam   : longint;
-      nexttask : tltask;
-      constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-    end;
-
-
-
-    teventcore=class
-    public
-      procedure processmessages; virtual;abstract;
-      procedure messageloop; virtual;abstract;
-      procedure exitmessageloop; virtual;abstract;
-      procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract;
-      procedure rmasterset(fd : integer;islistensocket : boolean);  virtual;abstract;
-      procedure rmasterclr(fd: integer);  virtual;abstract;
-      procedure wmasterset(fd : integer); virtual;abstract;
-      procedure wmasterclr(fd: integer);  virtual;abstract;
-    end;
-var
-    eventcore : teventcore;
-
-procedure processmessages;
-procedure messageloop;
-procedure exitmessageloop;
-
-var
-  firsttimer                            : tltimer    ;
-  firsttask  , lasttask   , currenttask : tltask     ;
-
-  numread                               : integer    ;
-  mustrefreshfds                        : boolean    ;
-{  lcoretestcount:integer;}
-
-  asinreleaseflag:boolean;
-
-
-procedure disconnecttasks(aobj:tobject);
-procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-type
-  tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-var
-  onaddtask : tonaddtask;
-
-
-procedure sleep(i:integer);
-{$ifndef nosignal}
-  procedure prepsigpipe;{$ifndef ver1_0}inline;{$endif}
-{$endif}
-
-
-implementation
-{$ifndef nosignal}
-  uses {sockets,}lloopback,lsignal;
-{$endif}
-{$ifdef win32}
-  uses windows,winsock;
-{$endif}
-{$ifndef win32}
-  {$include unixstuff.inc}
-{$endif}
-{$include ltimevalstuff.inc}
-
-
-{!!! added sleep call -beware}
-procedure sleep(i:integer);
-var
-  tv:ttimeval;
-begin
-  {$ifdef win32}
-    windows.sleep(i);
-  {$else}
-    tv.tv_sec := i div 1000;
-    tv.tv_usec := (i mod 1000) * 1000;
-    select(0,nil,nil,nil,@tv);
-  {$endif}
-end;
-
-destructor tlcomponent.destroy;
-begin
-  disconnecttasks(self);
-  inherited destroy;
-end;
-
-procedure tlcomponent.releasetaskhandler(wparam,lparam:longint);
-begin
-  free;
-end;
-
-
-procedure tlcomponent.release;
-begin
-  addtask(releasetaskhandler,self,0,0);
-end;
-
-procedure tlasio.release;
-begin
-  asinreleaseflag := true;
-  inherited release;
-end;
-
-procedure tlasio.doreceiveloop;
-begin
-  if recvq.size = 0 then exit;
-  if assigned(ondataavailable) then ondataavailable(self,0);
-  if not (wsonoreceiveloop in componentoptions) then
-  if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0);
-end;
-
-function tlasio.receivestr;
-begin
-  setlength(result,recvq.size);
-  receive(@result[1],length(result));
-end;
-
-function tlasio.receive(Buf:Pointer;BufSize:integer):integer;
-var
-  i,a,b:integer;
-  p:pointer;
-begin
-  i := bufsize;
-  if recvq.size < i then i := recvq.size;
-  a := 0;
-  while (a < i) do begin
-    b := recvq.get(p,i-a);
-    move(p^,buf^,b);
-    inc(taddrint(buf),b);
-    recvq.del(b);
-    inc(a,b);
-  end;
-  result := i;
-  if wsonoreceiveloop in componentoptions then begin
-    if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false);
-  end;
-end;
-
-constructor tlasio.create;
-begin
-  inherited create(AOwner);
-  if not assigned(eventcore) then raise exception.create('no event core');
-  sendq := tfifo.create;
-  recvq := tfifo.create;
-  state := wsclosed;
-  fdhandlein := -1;
-  fdhandleout := -1;
-end;
-
-destructor tlasio.destroy;
-begin
-  destroying := true;
-  if state <> wsclosed then close;
-  recvq.free;
-  sendq.free;
-  inherited destroy;
-end;
-
-procedure tlasio.close;
-begin
-  internalclose(0);
-end;
-
-procedure tlasio.abort;
-begin
-  close;
-end;
-
-procedure tlasio.fdcleanup;
-begin
-  if fdhandlein <> -1 then begin
-    eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster)
-  end;
-  if fdhandleout <> -1 then begin
-    eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster)
-  end;
-  if fdhandlein=fdhandleout then begin
-    if fdhandlein <> -1 then begin
-      myfdclose(fdhandlein);
-    end;
-  end else begin
-    if fdhandlein <> -1 then begin
-      myfdclose(fdhandlein);
-    end;
-    if fdhandleout <> -1 then begin
-      myfdclose(fdhandleout);
-    end;
-  end;
-  fdhandlein := -1;
-  fdhandleout := -1;
-end;
-
-procedure tlasio.internalclose(error:word);
-begin
-  if (state<>wsclosed) and (state<>wsinvalidstate) then begin
-    // -2 is a special indication that we should just exist silently
-    // (used for connect failure handling when socket creation fails)
-    if (fdhandlein = -2) and (fdhandleout = -2) then exit;
-    if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles');
-    eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster);
-    eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);
-
-    if closehandles then begin
-      {$ifndef win32}
-        //anyone remember why this is here? --plugwash
-        fcntl(fdhandlein,F_SETFL,0);
-      {$endif}
-      myfdclose(fdhandlein);
-      if fdhandleout <> fdhandlein then begin
-        {$ifndef win32}
-          fcntl(fdhandleout,F_SETFL,0);
-        {$endif}
-        myfdclose(fdhandleout);
-      end;
-      eventcore.setfdreverse(fdhandlein,nil);
-      eventcore.setfdreverse(fdhandleout,nil);
-
-      fdhandlein := -1;
-      fdhandleout := -1;
-    end;
-    state := wsclosed;
-
-    if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error);
-  end;
-  if assigned(sendq) then sendq.del(maxlongint);
-end;
-
-
-{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
-{ All exceptions *MUST* be handled. If an exception is not handled, the     }
-{ application will most likely be shut down !                               }
-procedure tlasio.HandleBackGroundException(E: Exception);
-var
-  CanAbort : Boolean;
-begin
-  CanAbort := TRUE;
-  { First call the error event handler, if any }
-  if Assigned(OnBgException) then begin
-    try
-      OnBgException(Self, E, CanAbort);
-    except
-    end;
-  end;
-  { Then abort the socket }
-  if CanAbort then begin
-    try
-      close;
-    except
-    end;
-  end;
-end;
-
-procedure tlasio.sendstr(const str : string);
-begin
-  putstringinsendbuffer(str);
-  sendflush;
-end;
-
-procedure tlasio.putstringinsendbuffer(const newstring : string);
-begin
-  if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring));
-end;
-
-function tlasio.send(data:pointer;len:integer):integer;
-begin
-  if state <> wsconnected then begin
-    result := -1;
-    exit;
-  end;
-  if len < 0 then len := 0;
-  result := len;
-  putdatainsendbuffer(data,len);
-  sendflush;
-end;
-
-
-procedure tlasio.putdatainsendbuffer(data:pointer;len:integer);
-begin
-  sendq.add(data,len);
-end;
-
-function tlasio.sendflush : integer;
-var
-  lensent : integer;
-  data:pointer;
-//  fdstestr : fdset;
-//  fdstestw : fdset;
-begin
-  if state <> wsconnected then begin
-    result := -1;
-    exit;
-  end;
-
-  lensent := sendq.get(data,packetbasesize*2);
-  if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0;
-
-  if result = -1 then lensent := 0 else lensent := result;
-
-  //sendq := copy(sendq,lensent+1,length(sendq)-lensent);
-  sendq.del(lensent);
-
-  //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write
-                            // that sends nothing because a previous socket has
-                            // slready flushed this socket when the message loop
-                            // reaches it
-//  if sendq.size > 0 then begin
-    eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster);
-//  end else begin
-//    wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);
-//  end;
-  if result > 0 then begin
-    if assigned(onsenddata) then onsenddata(self,result);
-//    if sendq.size=0 then if assigned(ondatasent) then begin
-//      tltask.create(self.dodatasent,self,0,0);
-//      //begin test code
-//      fd_zero(fdstestr);
-//      fd_zero(fdstestw);
-//      fd_set(fdhandlein,fdstestr);
-//      fd_set(fdhandleout,fdstestw);
-//      select(maxs,@fdstestr,@fdstestw,nil,0);
-//      writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw));
-//      //end test code
-//    
-//    end;
-    writtenthiscycle := true;
-  end;
-end;
-
-procedure tlasio.dupnowatch(invalue:longint);
-begin
-  {  debugout('invalue='+inttostr(invalue));}
-  //readln;
-  if state<> wsclosed then close;
-  fdhandlein := invalue;
-  fdhandleout := invalue;
-  eventcore.setfdreverse(fdhandlein,self);
-  {$ifndef win32}
-    fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK);
-  {$endif}
-  state := wsconnected;
-
-end;
-
-
-procedure tlasio.dup(invalue:longint);
-begin
-  dupnowatch(invalue);
-  eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);
-  eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);
-end;
-
-
-procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean);
-var
-  sendflushresult : integer;
-  tempbuf:array[0..receivebufsize-1] of byte;
-  a:integer;
-begin
-  if (state=wsconnected) and writetrigger then begin
-    //writeln('write trigger');
-
-    if (sendq.size >0) then begin
-
-      sendflushresult := sendflush;
-      if (sendflushresult <= 0) and (not writtenthiscycle) then begin
-        if sendflushresult=0 then begin // linuxerror := 0;
-          internalclose(0);
-
-        end else begin
-          {$ifdef win32}
-          if getlasterror=WSAEWOULDBLOCK then begin
-            //the asynchronous nature of windows messages means we sometimes
-            //get here with the buffer full
-            //so do nothing in that case
-          end else
-          {$endif}
-          begin
-            internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});
-          end  
-        end;
-      end;
-
-    end else begin
-      //everything is sent fire off ondatasent event
-      if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);
-      if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);
-    end;
-    if assigned(onfdwrite) then onfdwrite(self,0);
-  end;
-  writtenthiscycle := false;
-  if (state =wsconnected) and readtrigger then begin
-    if recvq.size=0 then begin
-      a := recvbufsize;
-      if (a <= 0) or (a > sizeof(tempbuf)) then a := sizeof(tempbuf);
-      numread := myfdread(fdhandlein,tempbuf,a);
-      if (numread=0) and (not mustrefreshfds) then begin
-        {if i remember correctly numread=0 is caused by eof
-        if this isn't dealt with then you get a cpu eating infinite loop
-        however if onsessionconencted has called processmessages that could
-        cause us to drop to here with an empty recvq and nothing left to read
-        and we don't want that to cause the socket to close}
-
-        internalclose(0);
-      end else if (numread=-1) then begin
-        {$ifdef win32}
-          //sometimes on windows we get stale messages due to the inherent delays
-          //in the windows message queue
-          if WSAGetLastError = wsaewouldblock then begin
-            //do nothing
-          end else
-        {$endif}
-        begin
-          numread := 0;
-          internalclose({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});
-        end;
-      end else if numread > 0 then recvq.add(@tempbuf,numread);
-    end;
-
-    if recvq.size > 0 then begin
-      if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);
-      if assigned(ondataavailable) then ondataAvailable(self,0);
-      if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then
-      tltask.create(self.doreceiveloop,self,0,0);
-    end;
-    //until (numread = 0) or (currentsocket.state<>wsconnected);
-{    debugout('inner loop complete');}
-  end;
-end;
-
-procedure tlasio.flush;
-{$ifdef win32}
-type fdset = tfdset;
-{$endif}
-var
-  fds : fdset;
-begin
-  fd_zero(fds);
-  fd_set(fdhandleout,fds);
-  while sendq.size>0 do begin
-    select(fdhandleout+1,nil,@fds,nil,nil);
-    if sendflush <= 0 then exit;
-  end;
-end;
-
-procedure tlasio.dodatasent(wparam,lparam:longint);
-begin
-  if assigned(ondatasent) then ondatasent(self,lparam);
-end;
-
-procedure tlasio.deletebuffereddata;
-begin
-  sendq.del(maxlongint);
-end;
-
-procedure tlasio.sinkdata(sender:tobject;error:word);
-begin
-  tlasio(sender).recvq.del(maxlongint);
-end;
-
-{$ifndef win32}
-  procedure tltimer.resettimes;
-  begin
-    gettimeofday(nextts);
-    {if not initialevent then} tv_add(nextts,interval);
-  end;
-{$endif}
-
-{procedure tltimer.setinitialevent(newvalue : boolean);
-begin
-  if newvalue <> finitialevent then begin
-    finitialevent := newvalue;
-    if assigned(timerwrapperinterface) then begin
-      timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);
-    end else begin
-      resettimes;
-    end;
-  end;
-end;}
-
-procedure tltimer.setontimer(newvalue:tnotifyevent);
-begin
-  if @newvalue <> @fontimer then begin
-    fontimer := newvalue;
-    if assigned(timerwrapperinterface) then begin
-      timerwrapperinterface.setontimer(wrappedtimer,newvalue);
-    end else begin
-
-    end;
-  end;
-
-end;
-
-
-procedure tltimer.setenabled(newvalue : boolean);
-begin
-  if newvalue <> fenabled then begin
-    fenabled := newvalue;
-    if assigned(timerwrapperinterface) then begin
-      timerwrapperinterface.setenabled(wrappedtimer,newvalue);
-    end else begin
-      {$ifdef win32}
-        raise exception.create('non wrapper timers are not permitted on windows');
-      {$else}
-        resettimes;
-      {$endif}
-    end;
-  end;
-end;
-
-procedure tltimer.setinterval(newvalue:integer);
-begin
-  if newvalue <> finterval then begin
-    finterval := newvalue;
-    if assigned(timerwrapperinterface) then begin
-      timerwrapperinterface.setinterval(wrappedtimer,newvalue);
-    end else begin
-      {$ifdef win32}
-        raise exception.create('non wrapper timers are not permitted on windows');
-      {$else}
-        resettimes;
-      {$endif}
-    end;
-  end;
-
-end;
-
-
-
-
-constructor tltimer.create;
-begin
-  inherited create(AOwner);
-  if assigned(timerwrapperinterface) then begin
-    wrappedtimer := timerwrapperinterface.createwrappedtimer;
-  end else begin
-
-
-    nexttimer := firsttimer;
-    prevtimer := nil;
-
-    if assigned(nexttimer) then nexttimer.prevtimer := self;
-    firsttimer := self;
-  end;
-  interval := 1000;
-  enabled := true;
-end;
-
-destructor tltimer.destroy;
-begin
-  if assigned(timerwrapperinterface) then begin
-    wrappedtimer.free;
-  end else begin
-    if prevtimer <> nil then begin
-      prevtimer.nexttimer := nexttimer;
-    end else begin
-      firsttimer := nexttimer;
-    end;
-    if nexttimer <> nil then begin
-      nexttimer.prevtimer := prevtimer;
-    end;
-    
-  end;
-  inherited destroy;
-end;
-
-constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-begin
-  inherited create;
-  if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);
-  handler   := ahandler;
-  obj       := aobj;
-  wparam    := awparam;
-  lparam    := alparam;
-  {nexttask  := firsttask;
-  firsttask := self;}
-  if assigned(lasttask) then begin
-    lasttask.nexttask := self;
-  end else begin
-    firsttask := self;
-  end;
-  lasttask := self;
-  //ahandler(wparam,lparam);
-end;
-
-procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-begin
-
-  tltask.create(ahandler,aobj,awparam,alparam);
-end;
-
-{$ifndef nosignal}
-  procedure prepsigpipe;{$ifndef ver1_0}inline;
-{$endif}
-  begin
-    starthandlesignal(sigpipe);
-    if not assigned(signalloopback) then begin
-      signalloopback := tlloopback.create(nil);
-      signalloopback.ondataAvailable := signalloopback.sinkdata;
-
-    end;
-
-  end;
-{$endif}
-
-procedure processtasks;//inline;
-var
-  temptask                : tltask   ;
-
-begin
-
-  if not assigned(currenttask) then begin
-    currenttask := firsttask;
-    firsttask := nil;
-    lasttask  := nil;
-  end;
-  while assigned(currenttask) do begin
-
-    if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);
-    if assigned(currenttask) then begin
-      temptask := currenttask;
-      currenttask := currenttask.nexttask;
-      temptask.free;
-    end;
-    //writeln('processed a task');
-  end;
-
-end;
-
-
-
-
-procedure disconnecttasks(aobj:tobject);
-var
-  currenttasklocal : tltask ;
-  counter          : byte   ;
-begin
-  for counter := 0 to 1 do begin
-    if counter = 0 then begin
-      currenttasklocal := firsttask; //main list of tasks
-    end else begin
-      currenttasklocal := currenttask; //needed in case called from a task
-    end;
-    // note i don't bother to sestroy the links here as that will happen when
-    // the list of tasks is processed anyway
-    while assigned(currenttasklocal) do begin
-      if currenttasklocal.obj = aobj then begin
-        currenttasklocal.obj := nil;
-        currenttasklocal.handler := nil;
-      end;
-      currenttasklocal := currenttasklocal.nexttask;
-    end;
-  end;
-end;
-
-
-procedure processmessages;
-begin
-  eventcore.processmessages;
-end;
-procedure messageloop;
-begin
-  eventcore.messageloop;
-end;
-
-procedure exitmessageloop;
-begin
-  eventcore.exitmessageloop;
-end;
-
-function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;
-begin
-  result := myfdwrite(fdhandleout,data^,len);
-  if (result > 0) and assigned(onsenddata) then onsenddata(self,result);
-  eventcore.wmasterset(fdhandleout);
-end;
-{$ifndef win32}
-  procedure tlasio.myfdclose(fd : integer);
-  begin
-    fdclose(fd);
-  end;
-  function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;
-  begin
-    result := fdwrite(fd,buf,size);
-  end;
-
-  function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;
-  begin
-    result := fdread(fd,buf,size);
-  end;
-
-
-{$endif}
-
-
-begin
-  firsttask := nil;
-  
-
-  {$ifndef nosignal}
-    signalloopback := nil;
-  {$endif}
-end.
-
-
-
-
-

libwin/lcore/lcoreconfig.inc

@@ -1,40 +0,0 @@
-
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-{this enables the entire ipv6 functionality - resolving, connecting, etc
-this is enabled by default to make all apps using lcore automatically ipv6 aware.
-to disable, undefine it here, or define "noipv6" in the app}
-
-{$ifndef noipv6}
-{$define ipv6}
-{$endif}
-
-{-------------------------------------------------------------------------------------}
-{there are 2 ways to use DNS in lcore: dnscore, which an entire built in DNS client, and getaddrinfo.
-dnscore is always included on *nix to avoid libc dependency problems, but getaddrinfo is used on windows.
-when getaddrinfo is used, there is no reason to include dnscore, and it increases the exe size,
-unless you want to use custom nameserver addresses. enable this setting to always include it.}
-
-{-$define syncdnscore}
-
-{-------------------------------------------------------------------------------------}
-{lcore contains a built in general purpose secure random number generator, which is used elsewhere in lcore, for
-example by the DNS resolver. the used random function can be hooked to point to one's own RNG as desired.
-it is then also possible to not include the built in RNG in the exe, which reduces code size}
-
-{-$define nolcorernd}
-
-{-------------------------------------------------------------------------------------}
-{on windows up to XP, listening on ipv6 will not listen on ipv4, while on other platforms it does, 
-so a single listener cant get all connections for a port number, only those for one address family.
-also it means a portable app would gave to deal with inconsistent behavior.
-enable this option to simulate the behavior of listening on both v4 and v6}
-
-{$ifdef win32}{$ifdef ipv6}
-{$define secondlistener}
-{$endif}{$endif}
-
-{-------------------------------------------------------------------------------------}

libwin/lcore/lcoregtklaz.pas

@@ -1,142 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-      
-unit lcoregtklaz;
-{$mode delphi}
-interface
-	
-uses baseunix,unix,glib, gdk, gtk,lcore,forms,fd_utils,classes;
-//procedure lcoregtklazrun;
-const
-  G_IO_IN=1;
-  G_IO_OUT=4;
-  G_IO_PRI=2;
-  G_IO_ERR=8;
-
-  G_IO_HUP=16;
-  G_IO_NVAL=32;
-type
-  tlaztimerwrapperinterface=class(ttimerwrapperinterface)
-  public
-    function createwrappedtimer : tobject;override;
-//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;
-    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;
-    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;
-    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;
-  end;
-
-procedure lcoregtklazinit;
-implementation
-  uses
-    ExtCtrls;
-{$I unixstuff.inc}
-var
-  giochannels : array[0..absoloutemaxs] of pgiochannel;
-
-function iocallback(source:PGIOChannel; condition:TGIOCondition; data:gpointer):gboolean;cdecl;
-// return true if we want the callback to stay
-var
-  fd                    : integer ;
-  fdsrlocal , fdswlocal : fdset   ;
-  currentasio           : tlasio  ;
-begin
-  fd := g_io_channel_unix_get_fd(source);
-  fd_zero(fdsrlocal);
-  fd_set(fd,fdsrlocal);
-  fdswlocal := fdsrlocal;
-  select(fd+1,@fdsrlocal,@fdswlocal,nil,0);
-  if fd_isset(fd,fdsrlocal) or fd_isset(fd,fdsrlocal) then begin
-    currentasio := fdreverse[fd];
-    if assigned(currentasio) then begin
-      currentasio.handlefdtrigger(fd_isset(currentasio.fdhandlein,fdsrlocal),fd_isset(currentasio.fdhandleout,fdswlocal));
-    end else begin
-      rmasterclr(fd);
-      wmasterclr(fd);
-    end;
-  end;
-  case condition of
-    G_IO_IN : begin
-      result := rmasterisset(fd);
-    end;
-    G_IO_OUT : begin
-      result := wmasterisset(fd);
-    end;
-  end;
-end;
-
-procedure gtkrmasterset(fd : integer);
-begin
-  if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);
-  g_io_add_watch(giochannels[fd],G_IO_IN,iocallback,nil);
-end;
-
-procedure gtkrmasterclr(fd: integer);
-begin
-end;
-  
-procedure gtkwmasterset(fd : integer);
-begin
-  if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);
-  g_io_add_watch(giochannels[fd],G_IO_OUT,iocallback,nil);
-end;
-
-procedure gtkwmasterclr(fd: integer);
-begin
-end;
-
-type
-  tsc = class
-    procedure dotasksandsink(sender:tobject;error:word);
-  end;
-var
-  taskloopback : tlloopback;
-  sc           : tsc;
-procedure tsc.dotasksandsink(sender:tobject;error:word);
-begin
-  with tlasio(sender) do begin
-    sinkdata(sender,error);
-    processtasks;
-  end;
-end;
-procedure gtkaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-begin
-  taskloopback.sendstr(' ');
-  
-end;
-
-procedure lcoregtklazinit;
-begin
-  onrmasterset := gtkrmasterset;
-  onrmasterclr := gtkrmasterclr;
-  onwmasterset := gtkwmasterset;
-  onwmasterclr := gtkwmasterclr;
-  onaddtask := gtkaddtask;
-  taskloopback := tlloopback.create(nil);
-  taskloopback.ondataavailable := sc.dotasksandsink;
-  timerwrapperinterface := tlaztimerwrapperinterface.create(nil);
-end;
-
-function tlaztimerwrapperinterface.createwrappedtimer : tobject;
-begin
-  result := ttimer.create(nil);
-end;
-procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
-begin
-  ttimer(wrappedtimer).ontimer := newvalue;
-end;
-procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
-begin
-  ttimer(wrappedtimer).enabled := newvalue;
-end;
-
-
-procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
-begin
-  ttimer(wrappedtimer).interval := newvalue;
-end;
-
-
-end.
-

libwin/lcore/lcorernd.pas

@@ -1,432 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-unit lcorernd;
-
-interface
-
-{$include lcoreconfig.inc}
-
-{
-written by Bas Steendijk (beware)
-
-the aim of this unit is to provide randomness in a consistent way, using OS specific methods for seeding
-
-this unit uses MD5 for performance and code size, but it is made so it is easy to use a different hash,
-as long as it is atleat 128 bits, and a multiple of the "word size" (32 bits)
-
-goals:
-
-- for the code to be:
- - relatively simple and small
- - reasonably fast
-
-- for the numbers to be
- - random: pass diehard and similar tests
- - unique: generate UUID's
- - secure: difficult for a remote attacker to guess the internal state, even
-   when given some output
-
-typical intended uses:
- - anything that needs random numbers without extreme demands on security or
-   speed should be able to use this
- - seeding other (faster) RNG's
- - generation of passwords, UUID's, cookies, and session keys
- - randomizing protocol fields to protect against spoofing attacks
- - randomness for games
-
-this is not intended to be directly used for:
-- high securirity purposes (generating RSA root keys etc)
-- needing random numbers at very high rates (disk wiping, some simulations, etc)
-
-performance:
-- 24 MB/s on 2.2 GHz athlon64 core on windows XP 32 bits
-- 6.4 MB/s on 1 GHz p3 on linux
-
-exe size:
-- fpc 2.2, linux: fastmd5: 12 kb; lcorernd: 6 kb.
-- delphi 6: fastmd5: 3 kb; lcorernd: 2 kb
-
-reasoning behind the security of this RNG:
-
-- seeding:
-1: i assume that any attacker has no local access to the machine. if one gained
-  this, then there are more seriousness weaknesses to consider.
-2: i attempt to use enough seeding to be difficult to guess.
-  on windows: GUID, various readouts of hi res timestamps, heap stats, cursor
-  position
-  on *nix: i assume /dev/(u)random output is secure and difficult to guess. if
-  it misses, i use /dev/wtmp, which typically has as lot of entropy in it. i also use hi res timestamps.
-3: on a state compromise, one can easily get up to the hash size worth of previous output, beyond that one has
-  to invert the hash operation.
-
-- mixing/expansion: a secure hash random walk on a buffer with a constant secret and a changing exposed part,
-  the big secret part serves to make it difficult for an attacker to predict next and previous output.
-  the secret part is changed during a reseed.
-
-
-                                       OS randomness
-                                             v
-                              <wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww>
- ____________________________  ________________________________________________
-[            pool            ][                    seed                        ]
-[hashsize][hashsize][hashsize]
-          <rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr>
-                bighash()             seeding
-                   v
-          <wwwwwwwwwwwwwwwwww>
-<rrrrrrrrrrrrrrrrrrrrrrrrrrrr>
-  hash()                            random walk
-    v
-<wwwwwwww>
-[ output ][      secret      ]
-
-
-this needs testing on platforms other than i386
-
-
-these routines are called by everything else in lcore, and if the app coder desires, by the app.
-because one may want to use their own random number source, the PRNG here can be excluded from linking,
-and the routines here can be hooked.
-}
-
-{$include uint32.inc}
-
-{return a dword with 32 random bits}
-type
-  wordtype=uint32;
-
-var
-  randomdword:function:wordtype;
-
-{fill a buffer with random bytes}
-procedure fillrandom(var buf;length:integer);
-
-{generate an integer of 0 <= N < i}
-function randominteger(i:longint):longint;
-
-{generate an integer with the lowest b bits being random}
-function randombits(b:integer):longint;
-
-{generate a version 4 random uuid}
-function generate_uuid:string;
-
-{$ifndef nolcorernd}
-
-{call this to mix seeding into the pool. is normally done automatically and does not have to be called
-but can be done if one desires more security, for example for key generation}
-procedure seedpool;
-
-{get some raw OS specific randomness. the output is not mixed so it should not be used directly as random numbers}
-function collect_seeding(var output;const bufsize:integer):integer;
-
-function internalrandomdword:wordtype;
-
-var
-  reseedinterval:integer=64;
-{$endif}
-
-implementation
-
-{$ifndef nolcorernd}
-uses
-  {$ifdef win32}windows,activex,{$endif}
-  {$ifdef unix}
-    {$ifdef ver1_0}
-      linux,
-    {$else}
-      baseunix,unix,unixutil,
-    {$endif}
-  {$endif}
-  fastmd5,sysutils;
-
-{$ifdef unix}{$include unixstuff.inc}{$endif}
-
-type
-  {hashtype must be array of bytes}
-  hashtype=tmd5;
-
-const
-  wordsizeshift=2;
-  wordsize=1 shl wordsizeshift;
-  //wordsize check commented out for d3 compatibility
-  //{ $if (wordsize <> sizeof(wordtype))}'wordsizeshift must be setcorrectly'{ $ifend}
-  hashsize=sizeof(hashtype);
-  halfhashsize=hashsize div 2;
-  hashdwords=hashsize div wordsize;
-  pooldwords=3*hashdwords;
-  seeddwords=32;
-  hashpasssize=48; {this number has to be small enough that hashing this size uses only one block transform}
-
-var
-  {the seed part of this buffer must be atleast as big as the OS seed (windows: 104 bytes, unix: 36 bytes)}
-  pool:array[0..(pooldwords+seeddwords-1)] of wordtype;
-  reseedcountdown:integer;
-
-{$ifdef win32}
-function collect_seeding(var output;const bufsize:integer):integer;
-var
-  l:packed record
-    guid:array[0..3] of longint;
-    qpcbuf:array[0..1] of longint;
-    rdtscbuf:array[0..1] of longint;
-    systemtimebuf:array[0..3] of longint;
-    pid:longint;
-    tid:longint;
-    cursor:tpoint;
-    hs:theapstatus;
-  end absolute output;
-  rdtsc_0,rdtsc_1:integer;
-begin
-  result := 0;
-  if (bufsize < sizeof(l)) then exit;
-  result := sizeof(l);
-  {PID}
-  l.pid := GetCurrentProcessId;
-  l.tid := GetCurrentThreadId;
-
-  {COCREATEGUID}
-  cocreateguid(tguid(l.guid));
-
-  {QUERYPERFORMANCECOUNTER}
-  queryperformancecounter(tlargeinteger(l.qpcbuf));
-
-  {RDTSC}
-  {$ifdef cpu386}
-  asm
-    db $0F; db $31
-    mov rdtsc_0,eax
-    mov rdtsc_1,edx
-  end;
-  l.rdtscbuf[0] := rdtsc_0;
-  l.rdtscbuf[1] := rdtsc_1;
-  {$endif}
-  {GETSYSTEMTIME}
-  getsystemtime(tsystemtime(l.systemtimebuf));
-
-  {cursor position}
-  getcursorpos(l.cursor);
-
-  l.hs := getheapstatus;
-end;
-{$endif}
-
-{$ifdef unix}
-
-var
-  wtmpinited:boolean;
-  wtmpcached:hashtype;
-
-procedure wtmphash;
-var
-  f:file;
-  buf:array[0..4095] of byte;
-  numread:integer;
-  state:tmd5state;
-begin
-  if wtmpinited then exit;
-
-  assignfile(f,'/var/log/wtmp');
-  filemode := 0;
-  {$i-}reset(f,1);{$i+}
-  if (ioresult <> 0) then exit;
-  md5init(state);
-  while not eof(f) do begin
-    blockread(f,buf,sizeof(buf),numread);
-    md5process(state,buf,numread);
-  end;
-  closefile(f);
-  md5finish(state,wtmpcached);
-  wtmpinited := true;
-end;
-
-
-function collect_seeding(var output;const bufsize:integer):integer;
-var
-  f:file;
-  a:integer;
-  l:packed record
-    devrnd:array[0..3] of integer;
-    rdtscbuf:array[0..1] of integer;
-    tv:ttimeval;
-    pid:integer;
-  end absolute output;
-  rdtsc_0,rdtsc_1:integer;
-
-begin
-  result := 0;
-  if (bufsize < sizeof(l)) then exit;
-  result := sizeof(l);
-
-  {/DEV/URANDOM}
-  a := 1;
-  assignfile(f,'/dev/urandom');
-  filemode := 0;
-  {$i-}reset(f,1);{$i+}
-  a := ioresult;
-  if (a <> 0) then begin
-    assignfile(f,'/dev/random');
-    {$i-}reset(f,1);{$i+}
-    a := ioresult;
-  end;
-  if (a = 0) then begin
-    blockread(f,l.devrnd,sizeof(l.devrnd));
-    closefile(f);
-  end else begin
-    {the OS we are on has no /dev/random or /dev/urandom, get a hash from /var/log/wtmp}
-    wtmphash;
-    move(wtmpcached,l.devrnd,sizeof(l.devrnd));
-  end;
-  {get more randomness in case there's no /dev/random}
-  {$ifdef cpu386}{$ASMMODE intel}
-  asm
-    db $0F; db $31
-    mov rdtsc_0,eax
-    mov rdtsc_1,edx
-  end;
-  l.rdtscbuf[0] := rdtsc_0;
-  l.rdtscbuf[1] := rdtsc_1;
-  {$endif}
-
-  gettimeofday(l.tv);
-  l.pid := getpid;
-end;
-{$endif}
-
-{this produces a hash which is twice the native hash size (32 bytes for MD5)}
-procedure bighash(const input;len:integer;var output);
-var
-  inarr:array[0..65535] of byte absolute input;
-  outarr:array[0..65535] of byte absolute output;
-
-  h1,h2,h3,h4:hashtype;
-  a:integer;
-begin
-  a := len div 2;
-  {first hash round}
-  getmd5(inarr[0],a,h1);
-  getmd5(inarr[a],len-a,h2);
-
-  move(h1[0],h3[0],halfhashsize);
-  move(h2[0],h3[halfhashsize],halfhashsize);
-  move(h1[halfhashsize],h4[0],halfhashsize);
-  move(h2[halfhashsize],h4[halfhashsize],halfhashsize);
-
-  getmd5(h3,hashsize,outarr[0]);
-  getmd5(h4,hashsize,outarr[hashsize]);
-end;
-
-procedure seedpool;
-var
-  a:integer;
-begin
-  a := collect_seeding(pool[pooldwords],seeddwords*wordsize);
-  if (a = 0) then halt;
-  bighash(pool[hashdwords],(2*hashsize)+a,pool[hashdwords]);
-  getmd5(pool[0],hashpasssize,pool[0]);
-end;
-
-function internalrandomdword;
-begin
-  if (reseedcountdown <= 0) then begin
-    seedpool;
-    reseedcountdown := reseedinterval * hashdwords;
-  end else if ((reseedcountdown mod hashdwords) = 0) then begin;
-    getmd5(pool[0],hashpasssize,pool[0]);
-  end;
-  dec(reseedcountdown);
-
-  result := pool[reseedcountdown mod hashdwords];
-end;
-{$endif}
-
-procedure fillrandom(var buf;length:integer);
-var
-  a,b:integer;
-  buf_:array[0..16383] of uint32 absolute buf;
-
-begin
-  b := 0;
-  for a := (length shr wordsizeshift)-1 downto 0 do begin
-    buf_[b] := randomdword;
-    inc(b);
-  end;
-  length := length and (wordsize-1);
-  if length <> 0 then begin
-    a := randomdword;
-    move(a,buf_[b],length);
-  end;
-end;
-
-const
-  wordsizebits=32;
-
-function randombits(b:integer):longint;
-begin
-  result := randomdword;
-  result := result and (-1 shr (wordsizebits-b));
-  if (b = 0) then result := 0;
-end;
-
-function randominteger(i:longint):longint;
-var
-  a,b:integer;
-  j:integer;
-begin
-  //bitscounter := bitscounter + numofbitsininteger(i);
-  if (i = 0) then begin
-    result := 0;
-    exit;
-  end;
-  {find number of bits needed}
-  j := i-1;
-  if (j < 0) then begin
-    result := randombits(wordsizebits);
-    exit
-  end else if (j >= (1 shl (wordsizebits-2))) then begin
-    b := wordsizebits-1
-  end else begin
-    b := -1;
-    for a := 0 to (wordsizebits-2) do begin
-      if j < 1 shl a then begin
-        b := a;
-        break;
-      end;
-    end;
-  end;
-  repeat
-    result := randombits(b);
-  until result < i;
-end;
-
-const
-  ch:array[0..15] of char='0123456789abcdef';
-
-function generate_uuid:string;
-var
-  buf:array[0..7] of word;
-function inttohex(w:word):string;
-begin
-  result := ch[w shr 12] + ch[(w shr 8) and $f] + ch[(w shr 4) and $f] + ch[w and $f];
-end;
-begin
-  fillrandom(buf,sizeof(buf));
-
-  {uuid version 4}
-  buf[3] := (buf[3] and $fff) or $4000;
-
-  {uuid version 4}
-  buf[4] := (buf[4] and $3fff) or $8000;
-
-  result := inttohex(buf[0]) + inttohex(buf[1]) + '-' + inttohex(buf[2]) +'-'+ inttohex(buf[3]) + '-' + inttohex(buf[4])
-  + '-' + inttohex(buf[5]) + inttohex(buf[6]) + inttohex(buf[7]);
-end;
-
-{$ifndef nolcorernd}
-initialization randomdword := @internalrandomdword;
-{$endif}
-
-end.
-

libwin/lcore/lcoreselect.pas

@@ -1,382 +0,0 @@
-{lsocket.pas}
-
-{io and timer code by plugwash}
-
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-{$ifdef fpc}
-  {$ifndef ver1_0}
-    {$define useinline}
-  {$endif}
-{$endif}
-
-unit lcoreselect;
-
-
-interface
-uses
-  {$ifdef VER1_0}
-    linux,
-  {$else}
-    baseunix,unix,unixutil,
-  {$endif}
-  fd_utils;
-var
-  maxs                                  : longint    ;
-  exitloopflag                          : boolean    ; {if set by app, exit mainloop}
-
-function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif}
-function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif}
-
-procedure lcoreinit;
-
-implementation
-uses
-  lcore,sysutils,
-  classes,pgtypes,bfifo,
-  {$ifndef nosignal}
-    lsignal;
-  {$endif}
-
-{$include unixstuff.inc}
-{$include ltimevalstuff.inc}
-
-const
-  absoloutemaxs_select = (sizeof(fdset)*8)-1;
-
-var
-  fdreverse:array[0..absoloutemaxs_select] of tlasio;
-type
-  tselecteventcore=class(teventcore)
-    public
-      procedure processmessages; override;
-      procedure messageloop; override;
-      procedure exitmessageloop;override;
-      procedure setfdreverse(fd : integer;reverseto : tlasio); override;
-      procedure rmasterset(fd : integer;islistensocket : boolean); override;
-      procedure rmasterclr(fd: integer); override;
-      procedure wmasterset(fd : integer); override;
-      procedure wmasterclr(fd: integer); override;
-    end;
-
-procedure processtimers;inline;
-var
-  tv           ,tvnow     : ttimeval ;
-  currenttimer            : tltimer   ;
-  temptimer               : tltimer  ;
-
-begin
-  gettimeofday(tvnow);
-  currenttimer := firsttimer;
-  while assigned(currenttimer) do begin
-    //writeln(currenttimer.enabled);
-    if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin
-      //if assigned(currenttimer.ontimer) then begin
-      //  if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);
-      //  currenttimer.initialdone := true;
-      //end;
-      if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);
-      currenttimer.nextts := timeval(tvnow);
-      tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);
-    end;
-    temptimer := currenttimer;
-    currenttimer := currenttimer.nexttimer;
-  end;
-end;
-
-procedure processasios(var fdsr,fdsw:fdset);//inline;
-var
-  currentsocket : tlasio  ;
-  tempsocket    : tlasio  ;
-  socketcount   : integer ; // for debugging perposes :)
-  dw,bt:integer;
-begin
-{  inc(lcoretestcount);}
-
-    //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed
-    //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;
-
-
-  {------- test optimised loop}
-  socketcount := 0;
-  for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin
-    for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin
-      inc(socketcount);
-      currentsocket := fdreverse[dw shl 5 or bt];
-      {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');
-      if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}
-      {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}
-      if not assigned(currentsocket) then begin
-        fdclose(dw shl 5 or bt);
-        continue
-      end;
-      if currentsocket.fdhandlein < 0 then begin
-        fdclose(dw shl 5 or bt);
-        continue
-      end;
-      try
-        currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));
-      except
-        on E: exception do begin
-          currentsocket.HandleBackGroundException(e);
-        end;
-      end;
-
-      if mustrefreshfds then begin
-        if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin
-          fd_zero(fdsr);
-          fd_zero(fdsw);
-        end;
-      end;
-    end;
-  end;
-
-  {
-  !!! issues:
-  - sockets which are released may not be freed because theyre never processed by the loop
-  made new code for handling this, using asinreleaseflag
-
-  - when/why does the mustrefreshfds select apply, sheck if i did it correctly?
-
-  - what happens if calling handlefdtrigger for a socket which does not have an event
-  }
-  {------- original loop}
-
-  (*
-  currentsocket := firstasin;
-  socketcount := 0;
-  while assigned(currentsocket) do begin
-    if mustrefreshfds then begin
-      if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin
-        fd_zero(fdsr);
-        fd_zero(fdsw);
-      end;
-    end;
-    try
-      if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin
-        currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));
-      end;
-    except
-      on E: exception do begin
-        currentsocket.HandleBackGroundException(e);
-      end;
-    end;
-    tempsocket := currentsocket;
-    currentsocket := currentsocket.nextasin;
-    inc(socketcount);
-    if tempsocket.released then begin
-      tempsocket.free;
-    end;
-  end; *)
-{  debugout('socketcount='+inttostr(socketcount));}
-end;
-
-procedure tselecteventcore.processmessages;
-var
-  fdsr         , fdsw : fdset   ;
-  selectresult        : longint ;
-begin
-  mustrefreshfds := false;
-  {$ifndef nosignal}
-    prepsigpipe;
-  {$endif}
-  selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);
-  while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin;
-
-    processtasks;
-    processtimers;
-    if selectresult > 0 then begin
-      processasios(fdsr,fdsw);
-    end;
-    selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);
-
-  end;
-  mustrefreshfds := true;
-end;
-
-
-var
-  FDSR , FDSW : fdset;
-
-var
-  fdsrmaster , fdswmaster               : fdset      ;
-
-function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}
-begin
-  result := fdsrmaster;
-end;
-function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}
-begin
-  result := fdswmaster;
-end;
-
-
-Function  doSelect(timeOut:PTimeVal):longint;//inline;
-var
-  localtimeval : ttimeval;
-  maxslocal    : integer;
-begin
-  //unblock signals
-  //zeromemory(@sset,sizeof(sset));
-  //sset[0] := ;
-  fdsr := getfdsrmaster;
-  fdsw := getfdswmaster;
-
-  if assigned(firsttask) then begin
-    localtimeval.tv_sec  := 0;
-    localtimeval.tv_usec := 0;
-    timeout := @localtimeval;
-  end;
-
-  maxslocal := maxs;
-  mustrefreshfds := false;
-{  debugout('about to call select');}
-  {$ifndef nosignal}
-    sigprocmask(SIG_UNBLOCK,@blockset,nil);
-  {$endif}
-  result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);
-  if result <= 0 then begin
-    fd_zero(FDSR);
-    fd_zero(FDSW);
-    if result=-1 then begin
-      if linuxerror = SYS_EINTR then begin
-        // we received a signal it's not a problem
-      end else begin
-        raise esocketexception.create('select returned error '+inttostr(linuxerror));
-      end;
-    end;
-  end;
-  {$ifndef nosignal}
-    sigprocmask(SIG_BLOCK,@blockset,nil);
-  {$endif}
-{  debugout('select complete');}
-end;
-
-procedure tselecteventcore.exitmessageloop;
-begin
-  exitloopflag := true
-end;
-
-
-
-procedure tselecteventcore.messageloop;
-var
-  tv           ,tvnow     : ttimeval ;
-  currenttimer            : tltimer  ;
-  selectresult:integer;
-begin
-  {$ifndef nosignal}
-    prepsigpipe;
-  {$endif}
-  {currentsocket := firstasin;
-  if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed
-  repeat
-
-    if currentsocket.state = wsconnected then currentsocket.sendflush;
-    currentsocket := currentsocket.nextasin;
-  until not assigned(currentsocket);}
-
-
-  repeat
-
-    //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed
-    processtasks;
-    //currenttask := nil;
-    {beware}
-    //if assigned(firsttimer) then begin
-    //  tv.tv_sec := maxlongint;
-    tv := tv_invalidtimebig;
-    currenttimer := firsttimer;
-    while assigned(currenttimer) do begin
-      if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;
-      currenttimer := currenttimer.nexttimer;
-    end;
-
-
-    if tv_compare(tv,tv_invalidtimebig) then begin    
-      //writeln('no timers active');
-      if exitloopflag then break;
-{    sleep(10);}
-      selectresult := doselect(nil);
-
-    end else begin
-      gettimeofday(tvnow);
-      tv_substract(tv,tvnow);
-
-      //writeln('timers active');
-      if tv.tv_sec < 0 then begin
-        tv.tv_sec := 0;
-        tv.tv_usec := 0; {0.1 sec}
-      end;
-      if exitloopflag then break;
-{    sleep(10);}
-      selectresult := doselect(@tv);
-      processtimers;
-
-    end;
-    if selectresult > 0 then processasios(fdsr,fdsw);
-    {!!!only call processasios if select has asio events -beware}
-
-    {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}
-  until false;
-end;
-
-
-procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);
-begin
-  if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');
-  if fd > maxs then maxs := fd;
-  if fd_isset(fd,fdsrmaster) then exit;
-  fd_set(fd,fdsrmaster);
-
-end;
-
-procedure tselecteventcore.rmasterclr(fd: integer);
-begin
-  if not fd_isset(fd,fdsrmaster) then exit;
-  fd_clr(fd,fdsrmaster);
-
-end;
-
-
-procedure tselecteventcore.wmasterset(fd : integer);
-begin
-  if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');
-  if fd > maxs then maxs := fd;
-
-  if fd_isset(fd,fdswmaster) then exit;
-  fd_set(fd,fdswmaster);
-
-end;
-
-procedure tselecteventcore.wmasterclr(fd: integer);
-begin
-  if not fd_isset(fd,fdswmaster) then exit;
-  fd_clr(fd,fdswmaster);
-end;
-
-procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);
-begin
-  fdreverse[fd] := reverseto;
-end;
-
-var
-  inited:boolean;
-
-procedure lcoreinit;
-begin
-  if inited then exit;
-  inited := true;
-  eventcore := tselecteventcore.create;
-
-  absoloutemaxs := absoloutemaxs_select;
-
-  maxs := 0;
-  fd_zero(fdsrmaster);
-  fd_zero(fdswmaster);
-end;
-
-end.

libwin/lcore/lcorewsaasyncselect.pas

@@ -1,233 +0,0 @@
-unit lcorewsaasyncselect;
-
-interface
-
-procedure lcoreinit;
-
-implementation
-
-uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes,lsocket;
-type
-  twineventcore=class(teventcore)
-  public
-    procedure processmessages; override;
-    procedure messageloop; override;
-    procedure exitmessageloop;override;
-    procedure setfdreverse(fd : integer;reverseto : tlasio); override;
-    procedure rmasterset(fd : integer;islistensocket : boolean); override;
-    procedure rmasterclr(fd: integer); override;
-    procedure wmasterset(fd : integer); override;
-    procedure wmasterclr(fd: integer); override;
-  end;
-const
-  wm_dotasks=wm_user+1;
-type
-  twintimerwrapperinterface=class(ttimerwrapperinterface)
-  public
-    function createwrappedtimer : tobject;override;
-//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;
-    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;
-    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;
-    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;
-  end;
-
-procedure twineventcore.processmessages;
-begin
-  wcore.processmessages;//pass off to wcore
-end;
-procedure twineventcore.messageloop;
-begin
-  wcore.messageloop; //pass off to wcore
-end;
-procedure twineventcore.exitmessageloop;
-begin
-  wcore.exitmessageloop;
-end;
-var
-  fdreverse : thashtable;
-  fdwatches : thashtable;
-
-procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);
-begin
-  if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));
-  if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);
-end;
-
-var
-  hwndlcore : hwnd;
-procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);
-var
-  leventold : integer;
-  leventnew : integer;
-  wsaaresult : integer;
-begin
-  leventold := taddrint(findtree(@fdwatches,inttostr(fd)));
-  leventnew := leventold or leventadd;
-  leventnew := leventnew and not leventremove;
-  if leventold <> leventnew then begin
-    if leventold <> 0 then deltree(@fdwatches,inttostr(fd));
-    if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));
-  end;
-  wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);
-
-end;
-
-
-//to allow detection of errors:
-//if we are asked to monitor for read or accept we also monitor for close
-//if we are asked to monitor for write we also monitor for connect
-
-
-procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);
-begin
-  if islistensocket then begin
-//    writeln('setting accept watch for socket number ',fd);
-    dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);
-  end else begin
-//    writeln('setting read watch for socket number',fd);
-    dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);
-  end;
-end;
-procedure twineventcore.rmasterclr(fd: integer);
-begin
-  //writeln('clearing read of accept watch for socket number ',fd);
-  dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);
-end;
-procedure twineventcore.wmasterset(fd : integer);
-begin
-  dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);
-end;
-
-procedure twineventcore.wmasterclr(fd: integer);
-begin
-  dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);
-end;
-
-var
-  tasksoutstanding : boolean;
-
-function MyWindowProc(
-    ahWnd   : HWND;
-    auMsg   : Integer;
-    awParam : WPARAM;
-    alParam : LPARAM): Integer; stdcall;
-var
-  socket : integer;
-  event : integer;
-  error : integer;
-  readtrigger : boolean;
-  writetrigger : boolean;
-  lasio : tlasio;
-begin
-//  writeln('got a message');
-  Result := 0;  // This means we handled the message
-  if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin
-//    writeln('it appears to be a response to our wsaasyncselect');
-    socket := awparam;
-    event := alparam and $FFFF;
-    error := alparam shr 16;
-//    writeln('socket=',socket,' event=',event,' error=',error);
-    readtrigger := false;
-    writetrigger := false;
-    lasio := findtree(@fdreverse,inttostr(socket));
-    if assigned(lasio) then begin
-      if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin
-        if (lasio.state = wsconnecting) and (error <> 0) then begin
-          if lasio is tlsocket then tlsocket(lasio).connectionfailedhandler(error)
-        end else begin
-          lasio.internalclose(error);
-        end;
-      end else begin
-        if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;
-        if (event and (FD_WRITE)) <> 0 then writetrigger := true;
-
-        if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);
-      end;
-      // don't reset the event manually for listen sockets to avoid unwanted
-      // extra onsessionavailible events
-      if (taddrint(findtree(@fdwatches,inttostr(socket))) and (FD_ACCEPT)) = 0 then dowsaasyncselect(socket,0,0); // if not a listen socket reset watches
-    end;
-  end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin
-      //writeln('processing tasks');
-      tasksoutstanding := false;
-      processtasks;
-  end else begin
-      //writeln('passing unknown message to defwindowproc');
-      //not passing unknown messages on to defwindowproc will cause window
-      //creation to fail! --plugwash
-      Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
-  end;
-
-end;
-
-procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-begin
-  if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);
-end;
-type
-  twcoretimer = wcore.tltimer;
-
-function twintimerwrapperinterface.createwrappedtimer : tobject;
-begin
-  result := twcoretimer.create(nil);
-end;
-procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
-begin
-  twcoretimer(wrappedtimer).ontimer := newvalue;
-end;
-procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
-begin
-  twcoretimer(wrappedtimer).enabled := newvalue;
-end;
-
-
-procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
-begin
-  twcoretimer(wrappedtimer).interval := newvalue;
-end;
-
-var
-  MyWindowClass : TWndClass = (style         : 0;
-                                 lpfnWndProc   : @MyWindowProc;
-                                 cbClsExtra    : 0;
-                                 cbWndExtra    : 0;
-                                 hInstance     : 0;
-                                 hIcon         : 0;
-                                 hCursor       : 0;
-                                 hbrBackground : 0;
-                                 lpszMenuName  : nil;
-                                 lpszClassName : 'lcoreClass');
-  GInitData: TWSAData;
-
-var
-  inited:boolean;
-procedure lcoreinit;
-begin
-  if (inited) then exit;
-
-  eventcore := twineventcore.create;
-  if Windows.RegisterClass(MyWindowClass) = 0 then halt;
-  //writeln('about to create lcore handle, hinstance=',hinstance);
-  hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,
-                               MyWindowClass.lpszClassName,
-                               '',        { Window name   }
-                               WS_POPUP,  { Window Style  }
-                               0, 0,      { X, Y          }
-                               0, 0,      { Width, Height }
-                               0,         { hWndParent    }
-                               0,         { hMenu         }
-                               HInstance, { hInstance     }
-                               nil);      { CreateParam   }
-  //writeln('lcore hwnd is ',hwndlcore);
-  //writeln('last error is ',GetLastError);
-  onaddtask := winaddtask;
-  timerwrapperinterface := twintimerwrapperinterface.create(nil);
-
-  WSAStartup(2, GInitData);
-  absoloutemaxs := maxlongint;
-
-
-  inited := true;
-end;
-
-end.

libwin/lcore/lloopback.pas

@@ -1,34 +0,0 @@
-unit lloopback;
-
-interface
-uses lcore,classes;
-
-type
-  tlloopback=class(tlasio)
-  public
-    constructor create(aowner:tcomponent); override;
-  end;
-
-
-implementation
-uses
-{$ifdef ver1_0}
-  linux;
-{$else}
-  baseunix,unix,unixutil;  
-{$endif}
-{$i unixstuff.inc}
-
-constructor tlloopback.create(aowner:tcomponent);
-begin
-  inherited create(aowner);
-  closehandles := true;
-  assignpipe(fdhandlein,fdhandleout);
-
-  eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);
-  eventcore.wmasterclr(fdhandlein);//fd_clr(fdhandleout,fdswmaster);
-  eventcore.setfdreverse(fdhandlein,self);
-  eventcore.setfdreverse(fdhandleout,self);
-  state := wsconnected;
-end;
-end.

libwin/lcore/lmessages.pas

@@ -1,675 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-//this unit provides a rough approximation of windows messages on linux
-//it is usefull for multithreaded applications on linux to communicate back to
-//the main lcore thread
-//This unit is *nix only, on windows you should use the real thing
-
-unit lmessages;
-//windows messages like system based on lcore tasks
-interface
-
-uses pgtypes,sysutils,bsearchtree,strings,syncobjs;
-
-
-{$if (fpc_version < 2) or ((fpc_version=2) and ((fpc_release < 2) or ((fpc_release = 2) and (fpc_patch < 2)) ))}
-  {$error this code is only supported under fpc 2.2.2 and above due to bugs in the eventobject code in older versions}
-{$endif}
-
-type
-  lparam=taddrint;
-  wparam=taddrint;
-  thinstance=pointer;
-  hicon=pointer;
-  hcursor=pointer;
-  hbrush=pointer;
-  hwnd=qword; //window handles are monotonically increasing 64 bit integers,
-              //this should allow for a million windows per second for over half
-              //a million years!
-
-  twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
-
-
-  twndclass=record
-    style : dword;
-    lpfnwndproc : twndproc;
-    cbclsextra : integer;
-    cbwndextra : integer;
-    hinstance : thinstance;
-    hicon : hicon;
-    hcursor : hcursor;
-    hbrbackground : hbrush;
-    lpszmenuname : pchar;
-    lpszclassname : pchar;
-  end;
-  PWNDCLASS=^twndclass;
-  
-  UINT=dword;
-  WINBOOL = longbool;
-  tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall;
-  ATOM = pointer;
-  LPCSTR = pchar;
-  LPVOID = pointer;
-  HMENU = pointer;
-  HINST = pointer;
-
-  TPOINT = record 
-    x : LONGint; 
-    y : LONGint; 
-  end; 
-  
-  TMSG = record 
-    hwnd : HWND; 
-    message : UINT; 
-    wParam : WPARAM; 
-    lParam : LPARAM; 
-    time : DWORD; 
-    pt : TPOINT;
-  end; 
-  THevent=TEventObject;
-const
-  WS_EX_TOOLWINDOW = $80;
-  WS_POPUP = longint($80000000);
-  hinstance=nil;
-  PM_REMOVE = 1;
-  WM_USER = 1024;
-  WM_TIMER = 275;
-  INFINITE = syncobjs.infinite;
-function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;
-function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;
-function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
-function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;
-function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;
-function DestroyWindow(ahWnd:HWND):WINBOOL;
-function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;
-function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;
-function DispatchMessage(const lpMsg: TMsg): Longint;
-function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;
-function SetEvent(hEvent:THevent):WINBOOL;
-function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;
-function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean;
-function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;
-function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;
-function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;
-
-procedure init;
-
-implementation
-uses
-  baseunix,unix,lcore,unixutil;//,safewriteln;
-{$i unixstuff.inc}
-
-type
-  tmessageintransit = class
-    msg : tmsg;
-    next : tmessageintransit;
-  end;
-
-  tthreaddata = class
-    messagequeue : tmessageintransit;
-    messageevent : teventobject;
-    waiting : boolean;
-    lcorethread : boolean;
-    nexttimer : ttimeval;
-    threadid : integer;
-  end;
-  twindow=class
-    hwnd : hwnd;
-    extrawindowmemory : pointer;
-    threadid : tthreadid;
-    windowproc : twndproc;
-  end;
-
-var
-  structurelock : tcriticalsection;
-  threaddata : thashtable;
-  windowclasses : thashtable;
-  lcorelinkpipesend : integer;
-  lcorelinkpiperecv : tlasio;
-  windows : thashtable;
-  //I would rather things crash immediately
-  //if they use an insufficiant size type
-  //than crash after over four billion
-  //windows have been made ;)
-  nextwindowhandle : qword = $100000000;
-{$i ltimevalstuff.inc}
-
-//findthreaddata should only be called while holding the structurelock
-function findthreaddata(threadid : integer) : tthreaddata;
-begin
-  result := tthreaddata(findtree(@threaddata,inttostr(threadid)));
-  if result = nil then begin
-    result := tthreaddata.create;
-    result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result)));
-    result.nexttimer := tv_invalidtimebig;
-    result.threadid := threadid;
-    addtree(@threaddata,inttostr(threadid),result);
-  end;
-end;
-
-//deletethreaddataifunused should only be called while holding the structurelock
-procedure deletethreaddataifunused(athreaddata : tthreaddata);
-begin
-  //writeln('in deletethreaddataifunused');
-  if (athreaddata <> nil) then if (athreaddata.waiting=false) and (athreaddata.messagequeue=nil) and (athreaddata.lcorethread=false) and (athreaddata.nexttimer.tv_sec=tv_invalidtimebig.tv_sec) and (athreaddata.nexttimer.tv_usec=tv_invalidtimebig.tv_usec) then begin
-    //writeln('threaddata is unused, freeing messageevent');
-    athreaddata.messageevent.free;
-    //writeln('freeing thread data object');
-    athreaddata.free;
-    //writeln('deleting thread data object from hashtable');
-    deltree(@threaddata,inttostr(athreaddata.threadid));
-    //writeln('finished deleting thread data');
-  end else begin
-    //writeln('thread data is not unused');
-  end;
-end;
-
-function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;
-var
-  window : twindow;
-begin
-  structurelock.acquire;
-  try
-    window := findtree(@windows,inttostr(ahwnd));
-    if window <> nil then begin
-      result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;
-    end else begin
-      result := 0;
-    end;
-  finally
-    structurelock.release;
-  end;
-end;
-
-function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;
-var
-  window : twindow;
-begin
-  structurelock.acquire;
-  try
-    window := findtree(@windows,inttostr(ahwnd));
-    if window <> nil then begin
-      result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;
-      paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong;
-    end else begin
-      result := 0;
-    end;
-  finally
-    structurelock.release;
-  end;
-
-end;
-
-
-function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
-begin
-  result := 0;
-end;
-
-function strdup(s:pchar) : pchar;
-begin
-  //swriteln('in strdup, about to allocate memory');
-  result := getmem(strlen(s)+1);
-  //swriteln('about to copy string');
-  strcopy(s,result);
-  //swriteln('leaving strdup');
-end;
-
-function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;
-var
-  storedwindowclass:pwndclass;
-begin
-  structurelock.acquire;
-  try
-    //swriteln('in registerclass, about to check for duplicate window class');
-    storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname);
-    if storedwindowclass <> nil then begin
-
-      if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin
-        //swriteln('duplicate window class registered with different settings');
-        raise exception.create('duplicate window class registered with different settings');
-      end else begin
-        //swriteln('duplicate window class registered with same settings, tollerated');
-      end;
-    end else begin
-      //swriteln('about to allocate memory for new windowclass');
-      storedwindowclass := getmem(sizeof(twndclass));
-      //swriteln('about to copy windowclass from parameter');
-      move(lpwndclass,storedwindowclass^,sizeof(twndclass));
-      //swriteln('about to copy strings');
-      if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname);
-      if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname);
-      //swriteln('about to add result to list of windowclasses');
-      addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass);
-    end;
-    //swriteln('about to return result');
-    result := storedwindowclass;
-    //swriteln('leaving registerclass');
-  finally
-    structurelock.release;
-  end;
-end;
-
-function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;
-var
-  wndclass : pwndclass;
-  tm : tthreadmanager;
-  window : twindow;
-begin
-  structurelock.acquire;
-  try
-    window := twindow.create;
-    window.hwnd := nextwindowhandle;
-    result := window.hwnd;
-    nextwindowhandle := nextwindowhandle + 1;
-    addtree(@windows,inttostr(window.hwnd),window);
-    wndclass := findtree(@windowclasses,lpclassname);
-    window.extrawindowmemory := getmem(wndclass.cbwndextra);
-
-    getthreadmanager(tm);
-    window.threadid := tm.GetCurrentThreadId;
-    window.windowproc := wndclass.lpfnwndproc;
-  finally
-    structurelock.release;
-  end;
-end;
-function DestroyWindow(ahWnd:HWND):WINBOOL;
-var
-  window : twindow;
-  windowthreaddata : tthreaddata;
-  currentmessage : tmessageintransit;
-  prevmessage : tmessageintransit;
-begin
-  //writeln('started to destroy window');
-  structurelock.acquire;
-  try
-    window := twindow(findtree(@windows,inttostr(ahwnd)));
-    if window <> nil then begin
-      freemem(window.extrawindowmemory);
-      //writeln('aboute to delete window from windows structure');
-      deltree(@windows,inttostr(ahwnd));
-      //writeln('deleted window from windows structure');
-      windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(window.threadid)));
-
-      if windowthreaddata <> nil then begin
-        //writeln('found thread data scanning for messages to clean up');
-        currentmessage := windowthreaddata.messagequeue;
-        prevmessage := nil;
-        while currentmessage <> nil do begin
-          while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin
-            if prevmessage = nil then begin
-              windowthreaddata.messagequeue := currentmessage.next;
-            end else begin
-              prevmessage.next := currentmessage.next;
-            end;
-            currentmessage.free;
-            if prevmessage = nil then begin
-              currentmessage := windowthreaddata.messagequeue;
-            end else begin
-              currentmessage := prevmessage.next;
-            end;
-          end;
-          if currentmessage <> nil then begin
-            prevmessage := currentmessage;
-            currentmessage := currentmessage.next;
-          end;
-        end;
-        //writeln('deleting thread data structure if it is unused');
-        deletethreaddataifunused(windowthreaddata);
-      end else begin
-        //writeln('there is no thread data to search for messages to cleanup');
-      end;
-      //writeln('freeing window');
-      window.free;
-      result := true;
-    end else begin
-      result := false;
-    end;
-  finally
-    structurelock.release;
-  end;
-  //writeln('window destroyed');
-end;
-
-
-
-function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;
-var
-  threaddata : tthreaddata;
-  message : tmessageintransit;
-  messagequeueend : tmessageintransit;
-  window : twindow;
-begin
-  structurelock.acquire;
-  try
-    window := findtree(@windows,inttostr(hwnd));
-    if window <> nil then begin
-      threaddata := findthreaddata(window.threadid);
-      message := tmessageintransit.create;
-      message.msg.hwnd := hwnd;
-      message.msg.message := msg;
-      message.msg.wparam := wparam;
-      message.msg.lparam := lparam;
-      if threaddata.lcorethread then begin
-        //swriteln('posting message to lcore thread');
-        fdwrite(lcorelinkpipesend,message,sizeof(message));
-      end else begin
-        //writeln('posting message to non lcore thread');
-        if threaddata.messagequeue = nil then begin
-          threaddata.messagequeue := message;
-        end else begin
-          messagequeueend := threaddata.messagequeue;
-          while messagequeueend.next <> nil do begin
-            messagequeueend := messagequeueend.next;
-          end;
-          messagequeueend.next := message;
-        end;
-
-        //writeln('message added to queue');
-        if threaddata.waiting then threaddata.messageevent.setevent;
-      end;
-      result := true;
-    end else begin
-      result := false;
-    end;
-  finally
-    structurelock.release;
-  end;
-
-end;
-
-function gettickcount : dword;
-var
-  result64: integer;
-  tv : ttimeval;
-begin
-  gettimeofday(tv);
-  result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000);
-  result := result64;
-end;
-
-function DispatchMessage(const lpMsg: TMsg): Longint;
-var
-  timerproc : ttimerproc;
-  window : twindow;
-  windowproc : twndproc;
-begin
-  ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16));
-  if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin
-    timerproc := ttimerproc(lpmsg.lparam);
-    timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount);
-    result := 0;
-  end else begin
-    structurelock.acquire;
-    try
-      window := findtree(@windows,inttostr(lpmsg.hwnd));
-      //we have to get the window procedure while the structurelock
-      //is still held as the window could be destroyed from another thread
-      //otherwise.
-      if window <> nil then begin
-        windowproc := window.windowproc;
-      end else begin
-        windowproc := nil;
-      end;
-    finally
-      structurelock.release;
-    end;
-    if assigned(windowproc) then begin
-      result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);
-    end else begin
-      result := -1;
-    end;
-  end;
-end;
-
-procedure processtimers;
-begin
-end;
-
-function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL;
-var
-  tm : tthreadmanager;
-  threaddata : tthreaddata;
-  message : tmessageintransit;
-  nowtv : ttimeval;
-  timeouttv : ttimeval;
-  timeoutms : int64;
-
-begin
-  if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported');
-  if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported');
-  structurelock.acquire;
-  result := true;
-  try
-    getthreadmanager(tm);
-    threaddata := findthreaddata(tm.GetCurrentThreadId);
-    if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread');
-    message := threaddata.messagequeue;
-    gettimeofday(nowtv);
-    while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin
-      threaddata.waiting := true;
-      structurelock.release;
-      if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin
-        threaddata.messageevent.waitfor(INFINITE);
-      end else begin
-
-        timeouttv := threaddata.nexttimer;
-        timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000);
-        //i'm assuming the timeout is in milliseconds
-        if (timeoutms > maxlongint) then timeoutms := maxlongint;
-        threaddata.messageevent.waitfor(timeoutms);
-
-      end;
-      structurelock.acquire;
-      threaddata.waiting := false;
-      message := threaddata.messagequeue;
-      gettimeofday(nowtv);
-    end;
-    if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin
-      processtimers;
-    end;
-    message := threaddata.messagequeue;
-    if message <> nil then begin
-      lpmsg := message.msg;
-      if wremovemsg=PM_REMOVE then begin
-        threaddata.messagequeue := message.next;
-        message.free;
-      end;
-    end else begin
-      result :=false;
-    end;
-    deletethreaddataifunused(threaddata);
-  finally
-    structurelock.release;
-  end;
-end;
-
-function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;
-begin
-  result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false);
-end;
-
-function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;
-begin
-  result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,wRemoveMsg,true);
-end;
-
-function SetEvent(hEvent:THevent):WINBOOL;
-begin
-  hevent.setevent;
-  result := true;
-end;
-
-function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;
-begin
-  result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname);
-end;
-
-function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean;
-var
-  tm : tthreadmanager;
-begin
-  getthreadmanager(tm);
-  tm.killthread(threadhandle);
-  result := true;
-end;
-
-function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;
-begin
-  result := event.waitfor(timeout);
-end;
-
-procedure removefrombuffer(n : integer; var buffer:string);
-begin
-  if n=length(buffer) then begin
-    buffer := '';
-  end else begin
-    uniquestring(buffer);
-    move(buffer[n+1],buffer[1],length(buffer)-n);
-    setlength(buffer,length(buffer)-n);
-  end;
-end;
-
-type
-  tsc=class
-    procedure available(sender:tobject;error:word);
-  end;
-
-var
-  recvbuf : string;
-
-procedure tsc.available(sender:tobject;error:word);
-var
-  message : tmessageintransit;
-  messagebytes : array[1..sizeof(tmessageintransit)] of char absolute  message;
-  i : integer;
-begin
-  //swriteln('received data on lcorelinkpipe');
-  recvbuf := recvbuf + lcorelinkpiperecv.receivestr;
-  while length(recvbuf) >= sizeof(tmessageintransit) do begin
-    for i := 1 to sizeof(tmessageintransit) do begin
-      messagebytes[i] := recvbuf[i];
-    end;
-    dispatchmessage(message.msg);
-    message.free;
-    removefrombuffer(sizeof(tmessageintransit),recvbuf);
-  end;
-end;
-
-procedure init;
-var
-  tm : tthreadmanager;
-  threaddata : tthreaddata;
-  pipeends : tfildes;
-  sc : tsc;
-begin
-  structurelock := tcriticalsection.create;
-  getthreadmanager(tm);
-  threaddata := findthreaddata(tm.GetCurrentThreadId);
-  threaddata.lcorethread := true;
-  fppipe(pipeends);
-  lcorelinkpipesend := pipeends[1];
-  lcorelinkpiperecv := tlasio.create(nil);
-  lcorelinkpiperecv.dup(pipeends[0]);
-  lcorelinkpiperecv.ondataavailable := sc.available;
-  recvbuf := '';
-end;
-
-var
-  lcorethreadtimers : thashtable;
-type
-  tltimerformsg = class(tltimer)
-  public
-    hwnd : hwnd;
-    id : taddrint;
-    procedure timer(sender : tobject);
-  end;
-
-procedure tltimerformsg.timer(sender : tobject);
-var
-  msg : tmsg;
-begin
-  ////swriteln('in tltimerformsg.timer');
-  fillchar(msg,sizeof(msg),0);
-  msg.message := WM_TIMER;
-  msg.hwnd := hwnd;
-  msg.wparam := ID;
-  msg.lparam := 0;
-  dispatchmessage(msg);
-end;
-
-function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;
-var
-  threaddata : tthreaddata;
-  ltimer : tltimerformsg;
-  tm : tthreadmanager;
-  window : twindow;
-begin
-  structurelock.acquire;
-  try
-    window := findtree(@windows,inttostr(ahwnd));
-    if window= nil then raise exception.create('invalid window');
-    threaddata := findthreaddata(window.threadid);
-  finally
-    structurelock.release;
-  end;
-  if threaddata.lcorethread then begin
-    getthreadmanager(tm);
-    if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread');
-    if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');
-    if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported');
-
-    //remove preexisting timer with same ID
-    killtimer(ahwnd,nIDEvent);
-
-    ltimer := tltimerformsg.create(nil);
-    ltimer.interval := uelapse;
-    ltimer.id := nidevent;
-    ltimer.hwnd := ahwnd;
-    ltimer.enabled := true;
-    ltimer.ontimer := ltimer.timer;
-
-    addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer);
-
-    result := nidevent;
-  end else begin
-    raise exception.create('settimer not implemented for threads other than the lcore thread');
-  end;
-end;
-
-function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;
-var
-  threaddata : tthreaddata;
-  ltimer : tltimerformsg;
-  tm : tthreadmanager;
-  window : twindow;
-begin
-  structurelock.acquire;
-  try
-    window := findtree(@windows,inttostr(ahwnd));
-    if window= nil then raise exception.create('invalid window');
-    threaddata := findthreaddata(window.threadid);
-  finally
-    structurelock.release;
-  end;
-  if threaddata.lcorethread then begin
-    getthreadmanager(tm);
-    if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread');
-    if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');
-    ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)));
-    if ltimer <> nil then begin
-      deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent));
-      ltimer.free;
-      result := true;
-    end else begin
-      result := false;
-    end;
-  end else begin
-    raise exception.create('settimer not implemented for threads other than the lcore thread');
-  end;
-end;
-
-end.

libwin/lcore/lsignal.pas

@@ -1,201 +0,0 @@
-{lsocket.pas}
-
-{signal code by plugwash}
-
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-      
-unit lsignal;
-{$mode delphi}
-interface
-  uses sysutils,
-    {$ifdef VER1_0}
-      linux,
-    {$else}
-      baseunix,unix,unixutil,
-    {$endif}
-    classes,lcore,lloopback;
-
-  type
-    tsignalevent=procedure(sender:tobject;signal:integer) of object;
-    tlsignal=class(tcomponent)
-    public
-      onsignal           : tsignalevent      ;
-      prevsignal         : tlsignal          ;
-      nextsignal         : tlsignal          ;
-
-      constructor create(aowner:tcomponent);override;
-      destructor destroy;override;
-    end;
-
-  
-  procedure starthandlesignal(signal:integer);
-
-var
-  firstsignal : tlsignal;
-  blockset : sigset;
-  signalloopback                        : tlloopback ;
-  
-implementation
-{$include unixstuff.inc}
-
-constructor tlsignal.create;
-begin
-  inherited create(AOwner);
-  nextsignal := firstsignal;
-  prevsignal := nil;
-
-  if assigned(nextsignal) then nextsignal.prevsignal := self;
-  firstsignal := self;
-
-  //interval := 1000;
-  //enabled := true;
-  //released := false;
-end;
-
-destructor tlsignal.destroy;
-begin
-  if prevsignal <> nil then begin
-    prevsignal.nextsignal := nextsignal;
-  end else begin
-    firstsignal := nextsignal;
-  end;
-  if nextsignal <> nil then begin
-    nextsignal.prevsignal := prevsignal;
-  end;
-  inherited destroy;
-end;
-{$ifdef linux}
-  {$ifdef ver1_9_8}
-    {$define needsignalworkaround}
-  {$endif}
-  {$ifdef ver2_0_0}
-    {$define needsignalworkaround}
-  {$endif}
-  {$ifdef ver2_0_2}
-    {$define needsignalworkaround}
-  {$endif}
-{$endif}
-{$ifdef needsignalworkaround}
-  //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken
-  type
-    TSysParam  = Longint;
-    TSysResult = longint;
-  const
-            syscall_nr_sigaction		= 67;
-  //function Do_SysCall(sysnr:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0';
-  //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1';
-  //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2';
-  function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3';
-  //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4';
-  //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5';
-
-  function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION'];
-  {
-    Change action of process upon receipt of a signal.
-    Signum specifies the signal (all except SigKill and SigStop).
-    If Act is non-nil, it is used to specify the new action.
-    If OldAct is non-nil the previous action is saved there.
-  }
-  begin
-  //writeln('fucking');
-  {$ifdef RTSIGACTION}
-    {$ifdef cpusparc}
-      { Sparc has an extra stub parameter }
-      Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8));
-    {$else cpusparc}
-      Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8));
-    {$endif cpusparc}
-  {$else RTSIGACTION}
-    //writeln('nice');
-    Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact));
-  {$endif RTSIGACTION}
-  end;
-{$endif}
-
-// cdecl procedures are not name mangled
-// so USING something unlikely to cause colliesions in the global namespace
-// is a good idea
-procedure lsignal_handler( Sig : Integer);cdecl;
-var
-  currentsignal : tlsignal;
-begin
-//  writeln('in lsignal_hanler');
-  currentsignal := firstsignal;
-  while assigned(currentsignal) do begin
-    if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig);
-    currentsignal := currentsignal.nextsignal;
-
-  end;
-//  writeln('about to send down signalloopback');
-  if assigned(signalloopback) then begin
-    signalloopback.sendstr(' ');
-  end;
-//  writeln('left lsignal_hanler');
-end;
-
-{$ifdef freebsd}
-
-{$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))}
-procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl;
-{$else}
-procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl;
-{$endif}
-
-begin
-  lsignal_handler(signal);
-end;
-{$endif}
-
-
-const
-  allbitsset=-1;
-  {$ifdef ver1_0}
-    saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);
-  {$else}
-    {$ifdef darwin}
-      saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);
-    {$else}
-      {$ifdef freebsd}
-        //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH
-        {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}
-          saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0);
-        {$else}
-          saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);
-        {$endif}
-							  
-      {$else}
-        {$ifdef ver1_9_2}
-          saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);
-        {$else}
-	  //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH
-	  {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}
-	    saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler);sa_flags:0;sa_restorer:nil);
-	  {$else}
-            saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler));
-	  {$endif}
-        {$endif}
-      {$endif}
-    {$endif}
-  {$endif}
-procedure starthandlesignal(signal:integer);
-begin
-  if signal in ([0..31]-[sigkill,sigstop]) then begin
-    sigprocmask(SIG_BLOCK,@blockset,nil);
-    sigaction(signal,@saction,nil)
-  end else begin
-    raise exception.create('invalid signal number')
-  end;
-end;
-
-initialization
-  fillchar(blockset,sizeof(blockset),0);
-  blockset[0] := $FFFFFFFF - (1 shl sigstop) - (1 shl sigkill) - (1 shl sigsegv);
-  {$ifdef ver1_0}
-    saction.sa_mask := blockset[0];
-  {$else}
-    saction.sa_mask := blockset;
-  {$endif}
-end.

libwin/lcore/lsocket.pas

@@ -1,747 +0,0 @@
-{lsocket.pas}
-
-{socket code by plugwash}
-
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-{
-changes by plugwash (20030728)
-* created handlefdtrigger virtual method in tlasio (overridden in tlsocket) and moved a lot of code from messageloop into it
-* changed tlasio to tlasio
-* split fdhandle into fdhandlein and fdhandleout
-* i now use fdsrmaster and fdswmaster instead of rebuilding the lists every loop
-* split lsocket.pas into lsocket.pas and lcore.pas
-
-
-changes by beware (20030903)
-* added getxaddr, getxport (local addr, port, as string)
-* added getpeername, remote addr+port as binary
-* added htons and htonl functions (endian swap, same interface as windows API)
-
-beware (20030905)
-* if connect failed (conn refused) set state to connected and call internalclose, to get closed handler (instead of fdclose)
-* (lcore) if closing the fd's in internalcose, set fd's to -1 because closing an fd makes it invalid
-
-beware (20030927)
-* fixed: on connect failed, tried to close fdhandle's which were already set to -1, added check
-
-beware (20031017)
-* added getpeeraddr, getpeerport, remote addr+port as string
-}
-
-
-unit lsocket;
-{$ifdef fpc}
-  {$mode delphi}
-{$endif}
-
-{$include lcoreconfig.inc}
-
-interface
-  uses
-    sysutils,
-    {$ifdef win32}
-      windows,winsock,
-    {$else}
-
-      {$ifdef VER1_0}
-        linux,
-      {$else}
-        baseunix,unix,unixutil,
-      {$endif}
-      sockets,
-    {$endif}
-    classes,{pgdebugout,}pgtypes,lcore,fd_utils,binipstuff,dnssync;
-
-{$ifdef ipv6}
-const
-  v4listendefault:boolean=false;
-{$endif}
-
-
-type
-  sunB = packed record
-    s_b1, s_b2, s_b3, s_b4: byte;
-  end;
-
-  SunW = packed record
-    s_w1, s_w2: word;
-  end;
-
-  TInAddr = packed record
-    case integer of
-      0: (S_un_b: SunB);
-      1: (S_un_w: SunW);
-      2: (S_addr: cardinal);
-  end;
-
-  type
-    TLsocket = class(tlasio)
-    public
-      //a: string;
-
-      inAddr             : TInetSockAddrV;
-
-      biniplist:tbiniplist;
-      trymoreips:boolean;
-      currentip:integer;
-      connecttimeout:tltimer;
-
-{      inAddrSize:integer;}
-
-      //host               : THostentry      ;
-
-      //mainthread         : boolean         ; //for debuggin only
-      addr:string;
-      port:string;
-      localaddr:string;
-      localport:string;
-      proto:string;
-      udp,dgram:boolean;
-      listenqueue:integer;
-      {$ifdef secondlistener}
-      secondlistener:tlsocket;
-      lastsessionfromsecond:boolean;
-      procedure secondaccepthandler(sender:tobject;error:word);
-      procedure internalclose(error:word);override;
-      {$endif}
-      function getaddrsize:integer;
-      procedure connect; virtual;
-      procedure realconnect;
-      procedure bindsocket;
-      procedure listen;
-      function accept : longint;
-      function sendto(dest:TInetSockAddrV;destlen:integer;data:pointer;len:integer):integer; virtual;
-      function receivefrom(data:pointer;len:integer;var src:TInetSockAddrV;var srclen:integer):integer; virtual;
-
-      procedure handlefdtrigger(readtrigger,writetrigger:boolean); override;
-      function send(data:pointer;len:integer):integer;override;
-      procedure sendstr(const str : string);override;
-      function Receive(Buf:Pointer;BufSize:integer):integer; override;
-      function getpeername(var addr:tsockaddrin;addrlen:integer):integer; virtual;
-      procedure getXaddrbin(var binip:tbinip); virtual;
-      procedure getpeeraddrbin(var binip:tbinip); virtual;
-      function getXaddr:string; virtual;
-      function getpeeraddr:string; virtual;
-      function getXport:string; virtual;
-      function getpeerport:string; virtual;
-      constructor Create(AOwner: TComponent); override;
-
-      //this one has to be kept public for now because lcorewsaasyncselect calls it
-      procedure connectionfailedhandler(error:word);
-    private
-      procedure taskcallconnectionfailedhandler(wparam,lparam : longint);
-
-      procedure connecttimeouthandler(sender:tobject);
-      procedure connectsuccesshandler;
-      {$ifdef win32}
-        procedure myfdclose(fd : integer); override;
-        function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; override;
-        function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; override;
-      {$endif}
-    end;
-    tsocket=longint; // for compatibility with twsocket
-
-  twsocket=tlsocket; {easy}
-
-
-const
-  TCP_NODELAY=1;
-  IPPROTO_TCP=6;
-
-implementation
-{$include unixstuff.inc}
-
-
-function tlsocket.getaddrsize:integer;
-begin
-  result := inaddrsize(inaddr);
-end;
-
-
-procedure tlsocket.realconnect;
-var
-  a,b:integer;
-begin
-  //writeln('trying to connect to ',ipbintostr(biniplist_get(biniplist,currentip)),'#',port);
-  makeinaddrv(biniplist_get(biniplist,currentip),port,inaddr);
-  inc(currentip);
-  if (currentip >= biniplist_getcount(biniplist)) then trymoreips := false;
-
-  udp := false;
-  if (uppercase(proto) = 'UDP') then begin
-    b := IPPROTO_UDP;
-    a := SOCK_DGRAM;
-    udp := true;
-    dgram := true;
-  end else if (uppercase(proto) = 'TCP') or (uppercase(proto) = '') then begin
-    b := IPPROTO_TCP;
-    a := SOCK_STREAM;
-    dgram := false;
-  end else if (uppercase(proto) = 'ICMP') or (strtointdef(proto,256) < 256) then begin
-    b := strtointdef(proto,IPPROTO_ICMP);
-    a := SOCK_RAW;
-    dgram := true;
-  end else begin
-    raise ESocketException.create('unrecognised protocol');
-  end;
-
-  a := Socket(inaddr.inaddr.family,a,b);
-  //writeln(ord(inaddr.inaddr.family));
-  if a = -1 then begin
-    //unable to create socket, fire an error event (better to use an error event
-    //to avoid poor interaction with multilistener stuff.
-    //a socket value of -2 is a special value to say there is no socket but
-    //we want internalclose to act as if there was
-    fdhandlein := -2;
-    fdhandleout := -2;
-    tltask.create(taskcallconnectionfailedhandler,self,{$ifdef win32}wsagetlasterror{$else}socketerror{$endif},0);
-    exit;
-  end;
-  try
-    dup(a);
-    bindsocket;
-    if dgram then begin
-      {$ifndef win32}
-        SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));
-      {$else}
-        SetSockOpt(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));
-      {$endif}
-      state := wsconnected;
-      if assigned(onsessionconnected) then onsessionconnected(self,0);
-
-      eventcore.rmasterset(fdhandlein,false);
-      eventcore.wmasterclr(fdhandleout);
-    end else begin
-      state :=wsconnecting;
-      {$ifdef win32}
-        //writeln(inaddr.inaddr.port);
-        winsock.Connect(fdhandlein,winsock.psockaddr(@inADDR)^,getaddrsize);
-      {$else}
-        sockets.Connect(fdhandlein,inADDR,getaddrsize);
-      {$endif}
-      eventcore.rmasterset(fdhandlein,false);
-      eventcore.wmasterset(fdhandleout);
-      if trymoreips then connecttimeout.enabled := true;
-    end;
-    //sendq := '';
-  except
-    on e: exception do begin
-      fdcleanup;
-      raise; //reraise the exception
-    end;
-  end;
-
-end;
-
-procedure tlsocket.connecttimeouthandler(sender:tobject);
-begin
-  connecttimeout.enabled := false;
-  destroying := true; //hack to not cause handler to trigger
-  internalclose(0);
-  destroying := false;
-  realconnect;
-end;
-
-procedure tlsocket.connect;
-var
-  a:integer;
-  ip:tbinip;
-begin
-  if state <> wsclosed then close;
-  //prevtime := 0;
-  if isbiniplist(addr) then biniplist := addr else biniplist := forwardlookuplist(addr,0);
-  if biniplist_getcount(biniplist) = 0 then raise exception.create('unable to resolve '+addr);
-
-  //makeinaddrv(addr,port,inaddr);
-
-  currentip := 0;
-  if not assigned(connecttimeout) then begin
-    connecttimeout := tltimer.create(self);
-    connecttimeout.Tag := integer(self);
-    connecttimeout.ontimer := connecttimeouthandler;
-    connecttimeout.interval := 2500;
-    connecttimeout.enabled := false;
-  end;
-  realconnect;
-end;
-
-procedure tlsocket.sendstr(const str : string);
-begin
-  if dgram then begin
-    send(@str[1],length(str))
-  end else begin
-    inherited sendstr(str);
-  end;
-end;
-
-function tlsocket.send(data:pointer;len:integer):integer;
-begin
-  if dgram then begin
-//    writeln('sending to '+ipbintostr(inaddrvtobinip(inaddr)),' ',htons(inaddr.inaddr.port),' ',len,' bytes');
-    result := sendto(inaddr,getaddrsize,data,len);
-
-//    writeln('send result ',result);
-//    writeln('errno',errno);
-  end else begin
-    result := inherited send(data,len);
-  end;
-end;
-
-
-function tlsocket.receive(Buf:Pointer;BufSize:integer):integer;
-begin
-  if dgram then begin
-    {$ifdef secondlistener}
-    if lastsessionfromsecond then begin
-      result := secondlistener.receive(buf,bufsize);
-      lastsessionfromsecond := false;
-    end else
-    {$endif}
-      result := myfdread(self.fdhandlein,buf^,bufsize);
-  end else begin
-    result := inherited receive(buf,bufsize);
-  end;
-end;
-
-procedure tlsocket.bindsocket;
-var
-  a:integer;
-  inAddrtemp:TInetSockAddrV;
-  inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp;
-  inaddrtempsize:integer;
-begin
-  try
-    if (localaddr <> '') or (localport <> '') then begin
-      if localaddr = '' then begin
-        {$ifdef ipv6}
-        if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else
-        {$endif}
-        localaddr := '0.0.0.0';
-      end;
-      //gethostbyname(localaddr,host);
-      inaddrtempsize := makeinaddrv(forwardlookup(localaddr,0),localport,inaddrtemp);
-
-      If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin
-        state := wsclosed;
-        lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};
-        raise ESocketException.create('unable to bind on address '+localaddr+'#'+localport+', error '+inttostr(lasterror));
-      end;
-      state := wsbound;
-    end;
-  except
-    on e: exception do begin
-      fdcleanup;
-      raise; //reraise the exception
-    end;
-  end;
-end;
-
-procedure tlsocket.listen;
-var
-  yes:longint;
-  socktype:integer;
-  biniptemp:tbinip;
-  origaddr:string;
-begin
-  if state <> wsclosed then close;
-  udp := uppercase(proto) = 'UDP';
-  if udp then begin
-    socktype := SOCK_DGRAM;
-    dgram := true;
-  end else socktype := SOCK_STREAM;
-  origaddr := addr;
-
-  if addr = '' then begin
-    {$ifdef ipv6}
-    if not v4listendefault then begin
-      addr := '::';
-    end else
-    {$endif}
-    addr := '0.0.0.0';
-  end;
-  if isbiniplist(addr) then biniptemp := biniplist_get(addr,0) else biniptemp := forwardlookup(addr,10);
-  addr := ipbintostr(biniptemp);
-  fdhandlein := socket(biniptemp.family,socktype,0);
-  {$ifdef ipv6}
-  if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin
-    addr := '0.0.0.0';
-    fdhandlein := socket(AF_INET,socktype,0);
-  end;
-  {$endif}
-
-  if fdhandlein = -1 then raise ESocketException.create('unable to create socket'{$ifdef win32}+' error='+inttostr(wsagetlasterror){$endif});
-  dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things
-  //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup
-  state := wsclosed; // then set this back as it was an undesired side effect of dup
-
-  try
-    yes := $01010101;  {Copied this from existing code. Value is empiric,
-                    but works. (yes=true<>0) }
-    {$ifndef win32}
-      if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin
-        raise ESocketException.create('unable to set socket options');
-      end;
-    {$endif}
-    localaddr := addr;
-    localport := port;
-    bindsocket;
-
-    if not udp then begin
-      {!!! allow custom queue length? default 5}
-      if listenqueue = 0 then listenqueue := 5;
-      If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise
-esocketexception.create('unable to listen');
-      state := wsListening;
-    end else begin
-      {$ifndef win32}
-        SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));
-      {$else}
-        SetSockOpt(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));
-      {$endif}
-      state := wsconnected;
-    end;
-
-    {$ifdef secondlistener}
-    //listening on ::. try to listen on 0.0.0.0 as well for platforms which don't already do that
-    if addr = '::' then begin
-      secondlistener := tlsocket.create(nil);
-      secondlistener.proto := proto;
-      secondlistener.addr := '0.0.0.0';
-      secondlistener.port := port;
-      if udp then begin
-        secondlistener.ondataavailable := secondaccepthandler;
-      end else begin
-        secondlistener.onsessionAvailable := secondaccepthandler;
-      end;
-      try
-        secondlistener.listen;
-      except
-        secondlistener.destroy;
-        secondlistener := nil;
-      end;
-    end;
-    {$endif}
-  finally
-    if state = wsclosed then begin
-      if fdhandlein >= 0 then begin
-        {one *can* get here without fd -beware}
-        eventcore.rmasterclr(fdhandlein);
-        myfdclose(fdhandlein); // we musnt leak file discriptors
-        eventcore.setfdreverse(fdhandlein,nil);
-        fdhandlein := -1;
-      end;
-    end else begin
-      eventcore.rmasterset(fdhandlein,not udp);
-    end;
-    if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);
-  end;
-  //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein);
-end;
-
-{$ifdef secondlistener}
-procedure tlsocket.internalclose(error:word);
-begin
-  if assigned(secondlistener) then begin
-    secondlistener.destroy;
-    secondlistener := nil;
-  end;
-  inherited internalclose(error);
-end;
-
-procedure tlsocket.secondaccepthandler;
-begin
-  lastsessionfromsecond := true;
-  if udp then begin
-    ondataavailable(self,error);
-  end else begin
-    if assigned(onsessionavailable) then onsessionavailable(self,error);
-  end;
-end;
-{$endif}
-
-function tlsocket.accept : longint;
-var
-  FromAddrSize     : LongInt;        // i don't realy know what to do with these at this
-  FromAddr         : TInetSockAddrV;  // at this point time will tell :)
-  a:integer;
-begin
-  {$ifdef secondlistener}
-  if (lastsessionfromsecond) then begin
-    lastsessionfromsecond := false;
-    result := secondlistener.accept;
-    exit;
-  end;
-  {$endif}
-
-  FromAddrSize := Sizeof(FromAddr);
-  {$ifdef win32}
-    result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize);
-  {$else}
-    result := sockets.accept(fdhandlein,fromaddr,fromaddrsize);
-  {$endif}
-  //now we have accepted one request start monitoring for more again
-  eventcore.rmasterset(fdhandlein,true);
-
-  if result = -1 then begin
-    raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting');
-  end;
-  if result > absoloutemaxs then begin
-    myfdclose(result);
-    a := result;
-    result := -1;
-    raise esocketexception.create('file discriptor out of range: '+inttostr(a));
-  end;
-end;
-
-function tlsocket.sendto(dest:TInetSockAddrV;destlen:integer;data:pointer;len:integer):integer;
-var
-  destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute dest;
-begin
-  {$ifdef secondlistener}
-  if assigned(secondlistener) then if (dest.inaddr.family = AF_INET) then begin
-    result := secondlistener.sendto(dest,destlen,data,len);
-    exit;
-  end;
-  {$endif}
-  result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen);
-end;
-
-function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddrV;var srclen:integer):integer;
-var
-  tempsrc:TInetSockAddrV;
-  tempsrclen:integer;
-  srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute tempsrc;
-  biniptemp:tbinip;
-begin
-  {$ifdef secondlistener}
-  if assigned(secondlistener) then if lastsessionfromsecond then begin
-    lastsessionfromsecond := false;
-    result := secondlistener.receivefrom(data,len,src,srclen);
-    exit;
-  end;
-  {$endif}
-  tempsrclen := sizeof(tempsrc);
-  result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,tempsrclen);
-
-  {$ifdef ipv6}
-  biniptemp := inaddrvtobinip(tempsrc);
-  if needconverttov4(biniptemp) then begin
-    converttov4(biniptemp);
-    tempsrclen := makeinaddrv(biniptemp,inttostr(ntohs(tempsrc.InAddr.port)),tempsrc);
-  end;
-  {$endif}
-
-  move(tempsrc,src,srclen);
-  srclen := tempsrclen;
-end;
-
-procedure tlsocket.taskcallconnectionfailedhandler(wparam,lparam : longint);
-begin
-  connectionfailedhandler(wparam);
-end;
-
-procedure tlsocket.connectionfailedhandler(error:word);
-begin
-   if trymoreips then begin
-//     writeln('failed with error ',error);
-     connecttimeout.enabled := false;
-     destroying := true;
-     state := wsconnected;
-     self.internalclose(0);
-     destroying := false;
-     realconnect;
-   end else begin
-     state := wsconnected;
-     if assigned(onsessionconnected) then onsessionconnected(self,error);
-     self.internalclose(0);
-     recvq.del(maxlongint);
-   end;
-end;
-
-procedure tlsocket.connectsuccesshandler;
-begin
-   trymoreips := false;
-   connecttimeout.enabled := false;
-   if assigned(onsessionconnected) then onsessionconnected(self,0);
-end;
-
-
-procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean);
-var
-  tempbuf:array[0..receivebufsize-1] of byte;
-begin
-//  writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger,' state=',integer(state));
-  if (state =wslistening) and readtrigger then begin
-{    debugout('listening socket triggered on read');}
-    eventcore.rmasterclr(fdhandlein);
-    if assigned(onsessionAvailable) then onsessionAvailable(self,0);
-  end;
-  if dgram and readtrigger then begin
-    if assigned(ondataAvailable) then ondataAvailable(self,0);
-    {!!!test}
-    exit;
-  end;
-  if (state =wsconnecting) and writetrigger then begin
-    // code for dealing with the reults of a non-blocking connect is
-    // rather complex
-    // if just write is triggered it means connect suceeded
-    // if both read and write are triggered it can mean 2 things
-    // 1: connect ok and data availible
-    // 2: connect fail
-    // to find out which you must read from the socket and look for errors
-    // there if we read successfully we drop through into the code for fireing
-    // the read event
-    if not readtrigger then begin
-      state := wsconnected;
-      connectsuccesshandler;
-    end else begin
-      numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));
-      if numread <> -1 then begin
-        state := wsconnected;
-        connectsuccesshandler;
-        //connectread := true;
-        recvq.add(@tempbuf,numread);
-      end else begin
-        connectionfailedhandler({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});
-        exit;
-      end;
-      // if things went well here we are now in the state wsconnected with data sitting in our receive buffer
-      // so we drop down into the processing for data availible
-    end;
-    if fdhandlein >= 0 then begin
-      if state = wsconnected then begin
-        eventcore.rmasterset(fdhandlein,false);
-      end else begin
-        eventcore.rmasterclr(fdhandlein);
-      end;
-    end;
-    if fdhandleout >= 0 then begin
-      if sendq.size = 0 then begin
-        //don't clear the bit in fdswmaster if data is in the sendq
-        eventcore.wmasterclr(fdhandleout);
-      end;
-    end;
-
-  end;
-  inherited handlefdtrigger(readtrigger,writetrigger);
-end;
-
-constructor tlsocket.Create(AOwner: TComponent);
-begin
-  inherited create(aowner);
-  closehandles := true;
-  trymoreips := true;
-end;
-
-
-function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer;
-var
-  addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr;
-begin
-  result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen);
-end;
-
-procedure tlsocket.getxaddrbin(var binip:tbinip);
-var
-  addr:tinetsockaddrv;
-  i:integer;
-begin
-  i := sizeof(addr);
-  fillchar(addr,sizeof(addr),0);
-
-  {$ifdef win32}
-    winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i);
-  {$else}
-    sockets.getsocketname(self.fdhandlein,addr,i);
-  {$endif}
-  binip := inaddrvtobinip(addr);
-  converttov4(binip);
-end;
-
-procedure tlsocket.getpeeraddrbin(var binip:tbinip);
-var
-  addr:tinetsockaddrv;
-  i:integer;
-begin
-  i := sizeof(addr);
-  fillchar(addr,sizeof(addr),0);
-  {$ifdef win32}
-    winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i);
-  {$else}
-    sockets.getpeername(self.fdhandlein,addr,i);
-  {$endif}
-
-  binip := inaddrvtobinip(addr);
-  converttov4(binip);
-end;
-
-function tlsocket.getXaddr:string;
-var
-  biniptemp:tbinip;
-begin
-  getxaddrbin(biniptemp);
-  result := ipbintostr(biniptemp);
-  if result = '' then result := 'error';
-end;
-
-function tlsocket.getpeeraddr:string;
-var
-  biniptemp:tbinip;
-begin
-  getpeeraddrbin(biniptemp);
-  result := ipbintostr(biniptemp);
-  if result = '' then result := 'error';
-end;
-
-function tlsocket.getXport:string;
-var
-  addr:tinetsockaddrv;
-  i:integer;
-begin
-  i := sizeof(addr);
-  {$ifdef win32}
-    winsock.getsockname(self.fdhandlein,psockaddrin(@addr)^,i);
-
-  {$else}
-    sockets.getsocketname(self.fdhandlein,addr,i);
-
-  {$endif}
-  result := inttostr(htons(addr.InAddr.port));
-end;
-
-function tlsocket.getpeerport:string;
-var
-  addr:tinetsockaddrv;
-  i:integer;
-begin
-  i := sizeof(addr);
-  {$ifdef win32}
-    winsock.getpeername(self.fdhandlein,psockaddrin(@addr)^,i);
-
-  {$else}
-    sockets.getpeername(self.fdhandlein,addr,i);
-
-  {$endif}
-  result := inttostr(htons(addr.InAddr.port));
-end;
-
-{$ifdef win32}
-  procedure tlsocket.myfdclose(fd : integer);
-  begin
-    closesocket(fd);
-  end;
-  function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;
-  begin
-    result := winsock.send(fd,(@buf)^,size,0);
-  end;
-  function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;
-  begin
-    result := winsock.recv(fd,buf,size,0);
-  end;
-{$endif}
-
-end.
-

libwin/lcore/ltimevalstuff.inc

@@ -1,42 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-
-
-{add nn msec to tv}
-const
-  tv_invalidtimebig : ttimeval = (tv_sec:maxlongint;tv_usec:maxlongint);
-  //tv_invalidtimebig will always compare as greater than any valid timeval
-procedure tv_add(var tv:ttimeval;msec:integer);//{ $ifdef fpc}inline;{ $endif}
-begin
-  inc(tv.tv_usec,msec*1000);
-  inc(tv.tv_sec,tv.tv_usec div 1000000);
-  tv.tv_usec := tv.tv_usec mod 1000000;
-end;
-
-{tv1 >= tv2}
-function tv_compare(const tv1,tv2:ttimeval):boolean;//{ $ifdef fpc}inline;{ $endif}
-begin
-  if tv1.tv_sec = tv2.tv_sec then begin
-    result := tv1.tv_usec >= tv2.tv_usec;
-  end else result := tv1.tv_sec > tv2.tv_sec;
-end;
-
-procedure tv_substract(var tv:ttimeval;const tv2:ttimeval);//{ $ifdef fpc}inline;{ $endif}
-begin
-  dec(tv.tv_usec,tv2.tv_usec);
-  if tv.tv_usec < 0 then begin
-    inc(tv.tv_usec,1000000);
-    dec(tv.tv_sec)
-  end;
-  dec(tv.tv_sec,tv2.tv_sec);
-end;
-
-procedure msectotimeval(var tv:ttimeval;msec:integer);
-begin
-  tv.tv_sec := msec div 1000;
-  tv.tv_usec := (msec mod 1000)*1000;
-end;
-

libwin/lcore/pgtypes.pas

@@ -1,20 +0,0 @@
-{io core originally for linux bworld}
-
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-unit pgtypes;
-interface
-  type
-    {$ifdef cpu386}{$define i386}{$endif}
-    {$ifdef i386}
-      taddrint=longint;
-    {$else}
-      taddrint=sizeint;
-    {$endif}
-    paddrint=^taddrint;
-
-implementation
-end.

libwin/lcore/todo.txt

@@ -1 +0,0 @@
-* fixup dnsasync to perform retries and use multiple dns servers

libwin/lcore/uint32.inc

@@ -1,14 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-type
-  {delphi 3 and before do not have a 32 bits unsigned integer type,
-  but longint has the correct behavior - it doesn't on newer delphi versions}
-  {$ifndef fpc}
-    {$ifdef ver70}{$define pred4}{$endif} {tp7}
-    {$ifdef ver80}{$define pred4}{$endif} {delphi 1}
-    {$ifdef ver90}{$define pred4}{$endif} {delphi 2}
-    {$ifdef ver100}{$define pred4}{$endif} {delphi 3}
-  {$endif}
-  uint32={$ifdef pred4}longint{$else}longword{$endif};

libwin/lcore/unitfork.pas

@@ -1,114 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-    which is included in the package
-      ----------------------------------------------------------------------------- }
-unit unitfork;
-
-interface
-
-procedure dofork(const programname:string);
-procedure writepid;
-function checkpid(const filename:string):boolean;
-procedure deletepid;
-
-implementation
-
-uses
-  {$ifdef VER1_0}
-    linux,
-  {$else}
-    baseunix,unix,unixutil,
-  {$endif}
-  sysutils;
-
-{$include unixstuff.inc}
-
-const
-  F_WRLCK=2;
-
-var
-  pidfilename:string;
-  pidfile:text;
-
-procedure dofork(const programname:string);
-var
-  a:integer;
-begin
-  //writeln('dofork entered');
-  //if (paramstr(1) = 'foreground') or (paramstr(1)='debug') then exit; {no fork}
-  a := fork;
-  if a = 0 then exit; {i'm the child}
-  if a < 0 then begin
-    writeln('failed to run in background, try "'+programname+' foreground" if it doesnt work otherwise');
-    halt; {failed}
-  end;
-
-  halt; {i'm the parent}
-end;
-
-function checkpid;
-var
-  handle:thandle;
-
-begin
-  result := false;
-  pidfilename := '';
-  //debugout(filename);
-  assignfile(pidfile,filename);
-  filemode := 2;
-  {opening file to get a fd for it. can't rewrite because a lock appears to allow the rewrite}
-  {$i-}reset(pidfile);{$i+}
-  if ioresult <> 0 then begin
-    {$i-}rewrite(pidfile);{$i+}
-    if ioresult <> 0 then exit;
-  end;
-
-  handle := getfs(pidfile);
-
-  //debugout('got handle');
-  {check if locking is possible: it's not if other process still runs}
-  {$ifdef VER1_0}
-  if not flock(handle,LOCK_EX or LOCK_NB)
-  {$else}
-  if flock(handle,LOCK_EX or LOCK_NB) <> 0
-  {$endif}
-  then begin
-    //debugout('failed to lock pid file');
-    close(pidfile);
-    exit;
-  end;
-  rewrite(pidfile);
-  {lock again because the rewrite removes the lock}
-  {$ifdef VER1_0}
-  if not flock(handle,LOCK_EX or LOCK_NB)
-  {$else}
-  if flock(handle,LOCK_EX or LOCK_NB) <> 0
-  {$endif}
-  then raise exception.create('flock failed '+inttostr(linuxerror));
-  pidfilename := filename;
-  result := true;
-end;
-
-
-procedure writepid;
-begin
-  writeln(pidfile,getpid);
-  flush(pidfile);
-end;
-
-procedure deletepid;
-begin
-  if pidfilename = '' then exit;
-  try
-    {$i-}
-    closefile(pidfile);
-    erase(pidfile);
-    {$i+}
-    ioresult;
-  except
-    {}
-  end;
-  pidfilename := '';
-end;
-
-end.

libwin/lcore/unitsettc.pas

@@ -1,53 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-unit Unitsettc;
-
-interface
-
-procedure settc;
-procedure unsettc;
-
-implementation
-
-uses
-  windows,
-  sysutils;
-
-var
-  classpriority,threadpriority:integer;
-  refcount:integer=0;
-
-procedure settc;
-var
-  hprocess,hthread:integer;
-begin
-  if (refcount = 0) then begin
-    hProcess := GetCurrentProcess;
-    hThread := GetCurrentThread;
-    ClassPriority := GetPriorityClass(hProcess);
-    ThreadPriority := GetThreadPriority(hThread);
-    SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);
-    SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);
-  end;
-  inc(refcount);
-end;
-
-procedure unsettc;
-var
-  hprocess,hthread:integer;
-begin
-  dec(refcount);
-  if (refcount < 0) then refcount := 0;
-  if (refcount = 0) then begin
-    hProcess := GetCurrentProcess;
-    hThread := GetCurrentThread;
-    SetPriorityClass(hProcess, ClassPriority);
-    SetThreadPriority(hThread,  ThreadPriority);
-  end;
-end;
-
-end.
-

libwin/lcore/unitwindowobject.pas

@@ -1,128 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-unit unitwindowobject;
-
-interface
-
-uses
-  classes,
-  {$ifdef win32}
-    windows,messages,wmessages,
-  {$else}
-    lmessages,
-    {$macro on}
-    {$define windows := lmessages}
-  {$endif}
-  sysutils,
-  pgtypes;
-
-type
-  twindowobject=class(tobject)
-    hwndmain:hwnd;
-    onmsg:function(msg,wparam,lparam:taddrint):boolean of object;
-    exitloopflag:boolean;
-    function settimer(id,timeout:taddrint):integer;
-    function killtimer(id:taddrint):boolean;
-    procedure postmessage(msg,wparam,lparam:taddrint);
-    procedure messageloop;
-    {$ifdef win32}
-      procedure processmessages;
-      function processmessage:boolean;
-    {$endif}
-    constructor create;
-    destructor destroy; override;
-  end;
-
-implementation
-
-//uses safewriteln;
-
-function WindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
-var
-  i:taddrint;
-begin
-  ////swriteln('in unitwindowobject.windowproc');
-  Result := 0;  // This means we handled the message
-  if ahwnd <> hwnd(0) then i := getwindowlongptr(ahwnd,0) else i := 0;
-  if i <> 0 then begin
-    if assigned(twindowobject(i).onmsg) then begin
-      if not twindowobject(i).onmsg(aumsg,awparam,alparam) then i := 0;
-    end else i := 0
-  end;
-  if i = 0 then Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
-end;
-
-var
-  twindowobject_Class : TWndClass = (style:0; lpfnWndProc:@WindowProc;
-  cbClsExtra:0; cbWndExtra:sizeof(pointer); hInstance:thinstance(0); hIcon:hicon(0); hCursor:hcursor(0);
-  hbrBackground:hbrush(0);lpszMenuName:nil; lpszClassName:'twindowobject_class');
-
-function twindowobject.settimer;
-begin
-  result := windows.settimer(hwndmain,id,timeout,nil);
-end;
-
-function twindowobject.killtimer;
-begin
-  result := windows.killtimer(hwndmain,id);
-end;
-
-constructor twindowobject.create;
-begin
-  inherited;
-  //swriteln('in twindowobject.create, about to call registerclass');
-  Windows.RegisterClass(twindowobject_Class);
-  //swriteln('about to call createwindowex');
-  hWndMain := CreateWindowEx(WS_EX_TOOLWINDOW, twindowobject_Class.lpszClassName,
-    '', WS_POPUP, 0, 0,0, 0, hwnd(0), 0, HInstance, nil);
-  //swriteln('about to check result of createwindowex');
-  if hWndMain = hwnd(0) then raise exception.create('CreateWindowEx failed');
-  //swriteln('about to store reference to self in extra windo memory');
-  setwindowlongptr(hwndmain,0,taddrint(self));
-  //swriteln('finished twindowobject.create , hwndmain='+inttohex(taddrint(hwndmain),16));
-end;
-
-destructor twindowobject.destroy;
-begin
-  if hWndMain <> hwnd(0) then DestroyWindow(hwndmain);
-  inherited;
-end;
-
-procedure twindowobject.postmessage;
-begin
-  windows.postmessage(hwndmain,msg,wparam,lparam);
-end;
-
-{$ifdef win32}
-  function twindowobject.ProcessMessage : Boolean;
-  var
-    Msg : TMsg;
-  begin
-    Result := FALSE;
-    if PeekMessage(Msg, hwndmain, 0, 0, PM_REMOVE) then begin
-      Result := TRUE;
-      DispatchMessage(Msg);
-    end;
-  end;
-
-  procedure twindowobject.processmessages;
-  begin
-    while processmessage do;
-  end;
-{$endif}
-
-procedure twindowobject.messageloop;
-var
-  MsgRec : TMsg;
-begin
-  while GetMessage(MsgRec, hwnd(0), 0, 0) do begin
-    DispatchMessage(MsgRec);
-    if exitloopflag then exit;
-    {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}
-  end;
-end;
-
-end.

libwin/lcore/unixstuff.inc

@@ -1,113 +0,0 @@
-{$ifdef UNIX}
-  {$macro on}
-  {$ifdef VER1_0}
-    {$define tv_sec := sec}
-    {$define tv_usec := usec}
-    function dup(const original:integer):integer;inline;
-    begin
-      linux.dup(original,result);
-    end;
-    {$define gettimeofdaysec := gettimeofday}
-    const
-      IPPROTO_UDP=17;
-      IPPROTO_ICMP=1;
-    function ntohs(invalue:word):word;inline;
-    var
-      invaluebytes : array[0..1] of byte absolute invalue;
-      resultbytes : array[0..1] of byte absolute result;
-    begin
-      {$ifdef endian_little}
-	resultbytes[0] := invaluebytes[1];
-	resultbytes[1] := invaluebytes[0];
-      {$else}
-	result := invalue;
-      {$endif}
-    end;  
-  {$else}
-    
-    {$define sigprocmask := fpsigprocmask}
-    {$define sigaction   := fpsigaction}
-    {$define fdclose     := fpclose}
-    {$define fcntl       := fpfcntl}
-    {$define fdwrite     := fpwrite}
-    {$define fdread      := fpread}
-    {$define fdopen      := fpopen}
-    {$define select      := fpselect}
-    {$define linuxerror  := fpgeterrno}
-    {$define fork        := fpfork}
-    {$define getpid      := fpgetpid}
-    {$define getenv      := fpgetenv}
-    {$define chmod       := fpchmod}
-    {$define dup2        := fpdup2}
-    {$ifndef ver1_9_2}
-      {$define flock     := fpflock}
-      {$ifndef ver1_9_4}
-        procedure Execl(Todo:string);inline;
-	var
-	  p : ppchar;
-	begin
-	  p := unixutil.StringToPPChar(Todo,1);
-	  if (p=nil) or (p^=nil) then exit;
-	  fpexecv(p^,p);
-	end;
-      {$endif}
-    {$endif}
-    {$ifdef ver2_0}
-      const
-        IPPROTO_UDP=17;
-        IPPROTO_ICMP=1;
-    {$endif}
-    {$ifdef ver1_9}
-      const
-        IPPROTO_UDP=17;
-        IPPROTO_ICMP=1;
-      function ntohs(invalue:word):word;inline;
-      var
-        invaluebytes : array[0..1] of byte absolute invalue;
-	resultbytes : array[0..1] of byte absolute result;
-      begin
-        {$ifdef endian_little}
-	  resultbytes[0] := invaluebytes[1];
-	  resultbytes[1] := invaluebytes[0];
-	{$else}
-	  result := invalue;
-	{$endif}
-      end;
-    {$endif}
-    procedure gettimeofday(var tv:ttimeval);inline;
-    begin
-      fpgettimeofday(@tv,nil);    
-    end;
-    function gettimeofdaysec : longint;
-    var
-      tv:ttimeval;
-    begin
-      gettimeofday(tv);
-      result := tv.tv_sec;
-    end;
-
-    //a function is used here rather than a define to prevent issues with tlasio.dup
-    function dup(const original:integer):integer;inline;
-    begin
-      result := fpdup(original);
-    end;
-    function octal(invalue:longint):longint;
-    var
-      a : integer;
-      i : integer;
-    begin
-      i := 0;
-      result := 0;
-      while invalue <> 0 do begin
-        a := invalue mod 10;
-        result := result + (a shl (i*3));
-
-        invalue := invalue div 10;
-        inc(i);
-      end;
-    end;
-    const
-      sys_eintr=esyseintr;
-
-  {$endif}
-{$endif}

libwin/lcore/wcore.pas

@@ -1,382 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- }
-
-unit wcore;
-
-{
-lcore compatible interface for windows
-
-- messageloop
-
-- tltimer
-
-}
-//note: events after release are normal and are the apps responsibility to deal with safely
-interface
-
-  uses
-    classes,windows,mmsystem;
-
-  type
-    float=double;
-
-    tlcomponent = class(tcomponent)
-    public
-      released:boolean;
-      procedure release;
-      destructor destroy; override;
-    end;
-
-    tltimer=class(tlcomponent)
-    private
-      fenabled : boolean;
-      procedure setenabled(newvalue : boolean);
-    public
-      ontimer:tnotifyevent;
-      initialevent:boolean;
-      initialdone:boolean;
-      prevtimer:tltimer;
-      nexttimer:tltimer;
-      interval:integer;        {miliseconds, default 1000}
-      nextts:integer;
-      property enabled:boolean read fenabled write setenabled;
-      constructor create(aowner:tcomponent);override;
-      destructor destroy;override;
-    end;
-
-    ttaskevent=procedure(wparam,lparam:longint) of object;
-
-    tltask=class(tobject)
-    public
-      handler  : ttaskevent;
-      obj      : tobject;
-      wparam   : longint;
-      lparam   : longint;
-      nexttask : tltask;
-      constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-    end;
-
-procedure messageloop;
-procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-procedure disconnecttasks(aobj:tobject);
-procedure exitmessageloop;
-procedure processmessages;
-
-var
-  onshutdown:procedure(s:string);
-
-implementation
-
-uses
-  {$ifdef fpc}
-  bmessages;
-  {$else}
-  messages;
-  {$endif}
-
-
-const
-  WINMSG_TASK=WM_USER;
-
-var
-  hwndwcore:hwnd;
-  firsttimer:tltimer;
-  timesubstract:integer;
-  firsttask,lasttask,currenttask:tltask;
-
-procedure tlcomponent.release;
-begin
-  released := true;
-end;
-
-destructor tlcomponent.destroy;
-begin
-  disconnecttasks(self);
-  inherited destroy;
-end;
-
-{------------------------------------------------------------------------------}
-
-procedure tltimer.setenabled(newvalue : boolean);
-begin
-  fenabled := newvalue;
-  nextts := 0;
-  initialdone := false;
-end;
-
-constructor tltimer.create;
-begin
-  inherited create(AOwner);
-  nexttimer := firsttimer;
-  prevtimer := nil;
-
-  if assigned(nexttimer) then nexttimer.prevtimer := self;
-  firsttimer := self;
-
-  interval := 1000;
-  enabled := true;
-  released := false;
-end;
-
-destructor tltimer.destroy;
-begin
-  if prevtimer <> nil then begin
-    prevtimer.nexttimer := nexttimer;
-  end else begin
-    firsttimer := nexttimer;
-  end;
-  if nexttimer <> nil then begin
-    nexttimer.prevtimer := prevtimer;
-  end;
-  inherited destroy;
-end;
-
-{------------------------------------------------------------------------------}
-
-function wcore_timehandler:integer;
-const
-  rollover_bits=30;
-var
-  tv,tvnow:integer;
-  currenttimer,temptimer:tltimer;
-begin
-  if not assigned(firsttimer) then begin
-    result := 1000;
-    exit;
-  end;
-
-  tvnow := timegettime;
-  if (tvnow and ((-1) shl rollover_bits)) <> timesubstract then begin
-    currenttimer := firsttimer;
-    while assigned(currenttimer) do begin
-      dec(currenttimer.nextts,(1 shl rollover_bits));
-      currenttimer := currenttimer.nexttimer;
-    end;
-    timesubstract := tvnow and ((-1) shl rollover_bits);
-  end;
-  tvnow := tvnow and ((1 shl rollover_bits)-1);
-
-  currenttimer := firsttimer;
-  while assigned(currenttimer) do begin
-    if tvnow >= currenttimer.nextts then begin
-      if assigned(currenttimer.ontimer) then begin
-        if currenttimer.enabled then begin
-          if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);
-          currenttimer.initialdone := true;
-        end;
-      end;
-      currenttimer.nextts := tvnow+currenttimer.interval;
-    end;
-    temptimer := currenttimer;
-    currenttimer := currenttimer.nexttimer;
-    if temptimer.released then temptimer.free;
-  end;
-
-  tv := maxlongint;
-  currenttimer := firsttimer;
-  while assigned(currenttimer) do begin
-    if currenttimer.nextts < tv then tv := currenttimer.nextts;
-    currenttimer := currenttimer.nexttimer;
-  end;
-  result := tv-tvnow;
-  if result < 15 then result := 15;
-end;
-
-{------------------------------------------------------------------------------}
-
-constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-begin
-  inherited create;
-  handler   := ahandler;
-  obj       := aobj;
-  wparam    := awparam;
-  lparam    := alparam;
-  {nexttask  := firsttask;
-  firsttask := self;}
-  if assigned(lasttask) then begin
-    lasttask.nexttask := self;
-  end else begin
-    firsttask := self;
-    postmessage(hwndwcore,WINMSG_TASK,0,0);
-  end;
-  lasttask := self;
-  //ahandler(wparam,lparam);
-end;
-
-procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-begin
-  tltask.create(ahandler,aobj,awparam,alparam);
-end;
-
-procedure disconnecttasks(aobj:tobject);
-var
-  currenttasklocal : tltask ;
-  counter          : byte   ;
-begin
-  for counter := 0 to 1 do begin
-    if counter = 0 then begin
-      currenttasklocal := firsttask; //main list of tasks
-    end else begin
-      currenttasklocal := currenttask; //needed in case called from a task
-    end;
-    // note i don't bother to sestroy the links here as that will happen when
-    // the list of tasks is processed anyway
-    while assigned(currenttasklocal) do begin
-      if currenttasklocal.obj = aobj then begin
-        currenttasklocal.obj := nil;
-        currenttasklocal.handler := nil;
-      end;
-      currenttasklocal := currenttasklocal.nexttask;
-    end;
-  end;
-end;
-
-procedure dotasks;
-var
-  temptask:tltask;
-begin
-  if firsttask = nil then exit;
-
-  currenttask := firsttask;
-  firsttask := nil;
-  lasttask  := nil;
-  while assigned(currenttask) do begin
-    if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);
-    temptask := currenttask;
-    currenttask := currenttask.nexttask;
-    temptask.free;
-  end;
-  currenttask := nil;
-end;
-
-{------------------------------------------------------------------------------}
-
-procedure exitmessageloop;
-begin
-  postmessage(hwndwcore,WM_QUIT,0,0);
-end;
-
-  {$ifdef threadtimer}
-  'thread timer'
-  {$else}
-const timerid_wcore=$1000;
-  {$endif}
-
-function MyWindowProc(
-    ahWnd   : HWND;
-    auMsg   : Integer;
-    awParam : WPARAM;
-    alParam : LPARAM): Integer; stdcall;
-var
-    MsgRec : TMessage;
-    a:integer;
-begin
-  Result := 0;  // This means we handled the message
-
-  {MsgRec.hwnd    := ahWnd;}
-  MsgRec.wParam  := awParam;
-  MsgRec.lParam  := alParam;
-
-  dotasks;
-  case auMsg of
-    {$ifndef threadtimer}
-    WM_TIMER: begin
-      if msgrec.wparam = timerid_wcore then begin
-        a := wcore_timehandler;
-        killtimer(hwndwcore,timerid_wcore);
-        settimer(hwndwcore,timerid_wcore,a,nil);
-      end;
-    end;
-    {$endif}
-
-    {WINMSG_TASK:dotasks;}
-
-    WM_CLOSE: begin
-      {}
-    end;
-    WM_DESTROY: begin
-      {}
-    end;
-  else
-      Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
-  end;
-end;
-
-
-var
-  MyWindowClass : TWndClass = (style         : 0;
-                                 lpfnWndProc   : @MyWindowProc;
-                                 cbClsExtra    : 0;
-                                 cbWndExtra    : 0;
-                                 hInstance     : 0;
-                                 hIcon         : 0;
-                                 hCursor       : 0;
-                                 hbrBackground : 0;
-                                 lpszMenuName  : nil;
-                                 lpszClassName : 'wcoreClass');
-
-procedure messageloop;
-var
-  MsgRec : TMsg;
-begin
-
-  if Windows.RegisterClass(MyWindowClass) = 0 then halt;
-  //writeln('about to create wcore handle, hinstance=',hinstance);
-  hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,
-                               MyWindowClass.lpszClassName,
-                               '',        { Window name   }
-                               WS_POPUP,  { Window Style  }
-                               0, 0,      { X, Y          }
-                               0, 0,      { Width, Height }
-                               0,         { hWndParent    }
-                               0,         { hMenu         }
-                               HInstance, { hInstance     }
-                               nil);      { CreateParam   }
-
-  if hwndwcore = 0 then halt;
-
-  {$ifdef threadtimer}
-  'thread timer'
-  {$else}
-  if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;
-  {$endif}
-
-
-  while GetMessage(MsgRec, 0, 0, 0) do begin
-    TranslateMessage(MsgRec);
-    DispatchMessage(MsgRec);
-    {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}
-  end;
-
-  if hWndwcore <> 0 then begin
-    DestroyWindow(hwndwcore);
-    hWndwcore := 0;
-  end;
-
-  {$ifdef threadtimer}
-  'thread timer'
-  {$else}
-  killtimer(hwndwcore,timerid_wcore);
-  {$endif}
-end;
-
-function ProcessMessage : Boolean;
-var
-    Msg : TMsg;
-begin
-    Result := FALSE;
-    if PeekMessage(Msg, hwndwcore, 0, 0, PM_REMOVE) then begin
-      Result := TRUE;
-      DispatchMessage(Msg);
-    end;
-end;
-
-procedure processmessages;
-begin
-  while processmessage do;
-end;
-
-
-end.

libwin/lcore/wmessages.pas

@@ -1,40 +0,0 @@
-{ Copyright (C) 2005 Bas Steendijk and Peter Green
-  For conditions of distribution and use, see copyright notice in zlib_license.txt
-  which is included in the package
-  ----------------------------------------------------------------------------- } 
-      
-unit wmessages;
-//this unit contains varions functions and types to make it easier to write
-//code that works with both real windows messages and lmessages
-
-interface
-uses windows,messages,pgtypes;
-type
-  thinstance=thandle;
-  thevent=thandle;
-
-//according to MS you are supposed to use get/setwindowlongptr to get/set
-//pointers in extra window memory so your program can be built for win64, this
-//is also the only interface to window memory that lmessages offers but delphi
-//doesn't define it so alias it to getwindowlong here for win32.
-{$ifndef win64} //future proofing ;)
-  function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;
-  procedure setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint);
-{$endif}
-function WaitForSingleEvent(hHandle: THandle; dwMilliseconds: DWORD): DWORD; stdcall;
-implementation
-{$ifndef win64}
-  function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;
-  begin
-    result := getwindowlong(ahwnd,nindex);
-  end;
-  procedure setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint);
-  begin
-    setwindowlong(ahwnd,nindex,dwnewlong);
-  end;
-{$endif}
-function WaitForSingleEvent(hHandle: THandle; dwMilliseconds: DWORD): DWORD; stdcall;
-begin
-  result := waitforsingleobject(hhandle,dwmilliseconds);
-end;
-end.

libwin/lcore/zlib_license.txt

@@ -1,19 +0,0 @@
-Copyright (c) 2005 Bas Steendijk and Peter Green
-
-This software is provided 'as-is', without any express or implied warranty.
-In no event will the authors be held liable for any damages arising from the
-use of this software.
-
-Permission is granted to anyone to use this software for any purpose, including
-commercial applications, and to alter it and redistribute it freely, subject to
-the following restrictions:
-
-    1. The origin of this software must not be misrepresented; you must not
-       claim that you wrote the original software. If you use this software in a
-       product, an acknowledgment in the product documentation would be
-       appreciated but is not required.
-
-    2. Altered source versions must be plainly marked as such, and must not be
-       misrepresented as being the original software.
-
-    3. This notice may not be removed or altered from any source distribution.

libwin/shared.pas

@@ -1,199 +0,0 @@
-{*
- * Shared methods / classes / functions between Windows programs
- *
- * This application launches DMDirc on windows and passes control to the
- * update engine as necessary.
- *
- * DMDirc - Open Source IRC Client
- * Copyright (c) 2006-2010 Chris Smith, Shane Mc Cormack, Gregory Holmes,
- * Michael Nixon
- *
- * Permission is hereby granted, free of charge, to any person obtaining a copy
- * of this software and associated documentation files (the "Software"), to deal
- * in the Software without restriction, including without limitation the rights
- * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
- * copies of the Software, and to permit persons to whom the Software is
- * furnished to do so, subject to the following conditions:
- *
- * The above copyright notice and this permission notice shall be included in
- * all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
- * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
- * SOFTWARE.
- *}
-unit shared;
-
-interface
-
-uses Windows, SysUtils, Vista;
-
-function nicesize(dsize: extended): string;
-function askQuestion(Question: String; Title: string): boolean;
-procedure showmessage(message: String; Title: string; context:String = 'Information');
-procedure showError(ErrorMessage: String; Title: string; addFooter: boolean = true; includeDescInXP: boolean = true);
-function Launch(sProgramToRun: String; hide: boolean = false): TProcessInformation;
-function ExecAndWait(sProgramToRun: String; hide: boolean = false): Longword;
-procedure RunProgram(sProgramToRun: String; wait: boolean);
-function RunJava(arguments: String): Longword;
-{ ---------------------------------------------------------------------------- }
-
-implementation
-
-{ ----------------------------------------------------------------------------
-  Takes a size, <dsize> in bytes, and converts it a human readable string with
-  a suffix (MB or GB).
-  ---------------------------------------------------------------------------- }
-function nicesize(dsize: extended): string;
-var
-  kbytes: single;
-  mbytes: single;
-  gbytes: single;
-begin
-  kbytes := dsize / 1024;
-  mbytes := kbytes / 1024;
-  gbytes := mbytes / 1024;
-
-  if kbytes < 1024 then begin
-    result := FloatToStrF(kbytes, ffFixed, 10, 2) + ' kB';
-    exit;
-  end;
-
-  if mbytes < 1024 then begin
-    result := FloatToStrF(mbytes, ffFixed, 10, 2) + ' MB';
-    exit;
-  end;
-
-  result := FloatToStrF(gbytes, ffFixed, 10, 2) + ' GB';
-  exit;
-end;
-
-{ ----------------------------------------------------------------------------
-  Ask a question and return True for YES and False for NO
-  Uses nifty vista task dialog if available
-  ---------------------------------------------------------------------------- }
-function askQuestion(Question: String; Title: string): boolean;
-begin
-  Result := TaskDialog(0, Title, 'Question', Question, TD_ICON_QUESTION, TD_BUTTON_YES + TD_BUTTON_NO) = mrYes;
-end;
-
-{ ----------------------------------------------------------------------------
-  Show a message box (information)
-  Uses nifty vista task dialog if available
-  ---------------------------------------------------------------------------- }
-procedure showmessage(message: String; Title: string; context:String = 'Information');
-begin
-  TaskDialog(0, Title, context, message, TD_ICON_INFORMATION, TD_BUTTON_OK);
-end;
-
-{ ----------------------------------------------------------------------------
-  Show an error message
-  Uses nifty vista task dialog if available
-  ---------------------------------------------------------------------------- }
-procedure showError(ErrorMessage: String; Title: string; addFooter: boolean = true; includeDescInXP: boolean = true);
-begin
-  if addFooter then begin
-    ErrorMessage := ErrorMessage+#13#10;
-    ErrorMessage := ErrorMessage+#13#10+'If you feel this is incorrect, or you require some further assistance,';
-    if not IsWindowsVista then ErrorMessage := ErrorMessage+#13#10;
-    ErrorMessage := ErrorMessage+'please feel free to contact us.';
-  end;
-  TaskDialog(0, Title, 'Sorry, ' + Title + ' is unable to continue.', ErrorMessage, TD_ICON_ERROR, TD_BUTTON_OK, includeDescInXP, false);
-end;
-
-{ ----------------------------------------------------------------------------
-  Launch a process (hidden if requested) and immediately return control to
-  the current thread
-  ---------------------------------------------------------------------------- }
-function Launch(sProgramToRun: String; hide: boolean = false): TProcessInformation;
-var
-  StartupInfo: TStartupInfo;
-begin
-  FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
-  with StartupInfo do begin
-    cb := SizeOf(TStartupInfo);
-    dwFlags := STARTF_USESHOWWINDOW;
-    if hide then wShowWindow := SW_HIDE
-    else wShowWindow := SW_SHOWNORMAL;
-  end;
-
-  CreateProcess(nil, PChar(sProgramToRun), nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, Result);
-end;
-
-{ ----------------------------------------------------------------------------
-  Launch a process (hidden if requested) and wait for it to finish
-  ---------------------------------------------------------------------------- }
-function ExecAndWait(sProgramToRun: String; hide: boolean = false): Longword;
-var
-  ProcessInfo: TProcessInformation;
-begin
-  ProcessInfo := Launch(sProgramToRun, hide);
-  getExitCodeProcess(ProcessInfo.hProcess, Result);
-
-  while Result = STILL_ACTIVE do begin
-    sleep(1000);
-    GetExitCodeProcess(ProcessInfo.hProcess, Result);
-  end;
-end;
-
-{ ----------------------------------------------------------------------------
-  Launch a process and either waits for it or returns control immediately
-  ---------------------------------------------------------------------------- }
-procedure RunProgram(sProgramToRun: String; wait: boolean);
-begin
-  if wait then ExecAndWait(sProgramToRun)
-  else Launch(sProgramToRun);
-end;
-
-{ ----------------------------------------------------------------------------
-  Launch java, allowing for 64 bit windows to be really shit.
-  ---------------------------------------------------------------------------- }
-function RunJava(arguments: String): Longword;
-type
-	TEnableRedirection = function(dwThreadId: Pointer): BOOL; stdcall;
-	TDisableRedirection = function(dwThreadId: Pointer): BOOL; stdcall;
-var
-	K32Handle: THandle;
-	EnableRedirection: TEnableRedirection;
-	DisableRedirection: TDisableRedirection;
-	hasWow64: boolean = false;
-	
-	javaCommand: String = 'javaw.exe';
-begin
-	K32Handle := GetModuleHandle('kernel32.dll');
-	if (K32Handle > 0) then begin
-		@DisableRedirection := GetProcAddress(K32Handle, 'Wow64DisableWow64FsRedirection');
-		@EnableRedirection := GetProcAddress(K32Handle, 'Wow64RevertWow64FsRedirection');
-		
-		hasWow64 := Assigned(DisableRedirection) and Assigned(EnableRedirection);
-	end;
-	
-	javaCommand := javaCommand+' '+arguments;
-	
-	if hasWow64 then begin
-		// Look for 64Bit Java.
-		DisableRedirection(nil);
-		result := ExecAndWait(javaCommand);
-		EnableRedirection(nil);
-		// If it didn't work, try 32 bit.
-		// Ideally we should only perform this check if the failure was caused
-		// by the file not being found, which I think is error codes 2 and/or 3.
-//		if ((result = 2) or (result = 3)) then begin
-		if (result <> 0) then begin
-			result := ExecAndWait(javaCommand);
-		end;
-	end
-	else begin
-		// 32Bit Windows just uses 32bit
-		result := ExecAndWait(javaCommand);
-	end;
-end;
-
-{ ----------------------------------------------------------------------------
-  ---------------------------------------------------------------------------- }
-end.
-