Index: freexp/crc.pas
===================================================================
RCS file: /server/cvs/freexp/crc.pas,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- freexp/crc.pas 1 Jan 2005 11:16:27 -0000 1.6
+++ freexp/crc.pas 7 Oct 2005 10:46:14 -0000 1.7
@@ -8,7 +8,7 @@
{ Die Nutzungsbedingungen fuer diesen Quelltext finden Sie in der }
{ Datei SLIZENZ.TXT oder auf www.crosspoint.de/oldlicense.html. }
{ --------------------------------------------------------------- }
-{ $Id: crc.pas,v 1.6 2005/01/01 11:16:27 mw Exp $ }
+{ $Id: crc.pas,v 1.7 2005/10/07 10:46:14 mw Exp $ }
UNIT CRC;
{$I XPDEFINE.INC }
@@ -32,6 +32,20 @@
function CRC32Block(var data; size: word): longint;
function CRC32Str(s: string): longint;
+{ Routinen fuer CRC64 }
+type
+ TCRC64 = packed record
+ lo32, hi32: longint;
+ end;
+
+procedure CRC64Init(var CRC: TCRC64); {-CRC64
initialization}
+
+procedure CRC64Update(var CRC: TCRC64; Msg: pointer; Len: word); {-update
CRC64 with Msg data}
+
+procedure CRC64Final(var CRC: TCRC64); {-CRC64:
finalize calculation}
+
+procedure CRC64Full(var CRC: TCRC64; Msg: pointer; Len: word); {-CRC64 of
Msg with init/update/final}
+
implementation
var
@@ -216,10 +230,265 @@
CRC32block := CRC_Reg;
end;
+(*----------------------------- CRC64 Routinen -----------------------------*)
+(*--------------------------------------------------------------------------
+ (C) Copyright 2005 Martin Wodrich
+
+ Modifikation um ohne Assembler-Abschnitte, lange Define-Abschnitte
+ und Includes auszukommen (Erleichtert die Itegration in bestehende
+ Pascal-Units von FreeXP und OpenXP).
+
+ Der Code an sich ist Copyright 2002-2004 Wolfgang Ehrhardt
+----------------------------------------------------------------------------*)
+
+(*-------------------------------------------------------------------------
+ (C) Copyright 2002-2004 Wolfgang Ehrhardt
+
+ This software is provided 'as-is', without any express or implied warranty.
+ In no event will the authors be held liable for any damages arising from
+ the use of this software.
+
+ Permission is granted to anyone to use this software for any purpose,
+ including commercial applications, and to alter it and redistribute it
+ freely, subject to the following restrictions:
+
+ 1. The origin of this software must not be misrepresented; you must not
+ claim that you wrote the original software. If you use this software in
+ a product, an acknowledgment in the product documentation would be
+ appreciated but is not required.
+
+ 2. Altered source versions must be plainly marked as such, and must not be
+ misrepresented as being the original software.
+
+ 3. This notice may not be removed or altered from any source distribution.
+----------------------------------------------------------------------------*)
+
+CONST Mask64 : TCRC64 = (lo32:-1; hi32:-1);
+
+{$ifdef FPC}
+{$ifndef VER1_0}
+ {$warnings off}
+ {$R-} {avoid D9 errors!}
+{$endif}
+{$endif}
+
+(*************************************************************************
+T_CTab64 - CRC64 table calculation (c) 2002-2004 W.Ehrhardt
+
+Calculate CRC64 tables for polynomial:
+
+x^64 + x^62 + x^57 + x^55 + x^54 + x^53 + x^52 + x^47 + x^46 + x^45 +
+x^40 + x^39 + x^38 + x^37 + x^35 + x^33 + x^32 + x^31 + x^29 + x^27 +
+x^24 + x^23 + x^22 + x^21 + x^19 + x^17 + x^13 + x^12 + x^10 + x^9 +
+x^7 + x^4 + x^1 + 1
+
+const
+ PolyLo = $A9EA3693;
+ PolyHi = $42F0E1EB;
+*************************************************************************)
+
+
+const Tab64lo : array[0..255] of longint = (
+ $00000000, $A9EA3693, $53D46D26, $FA3E5BB5,
+ $0E42ECDF, $A7A8DA4C, $5D9681F9, $F47CB76A,
+ $1C85D9BE, $B56FEF2D, $4F51B498, $E6BB820B,
+ $12C73561, $BB2D03F2, $41135847, $E8F96ED4,
+ $90E185EF, $390BB37C, $C335E8C9, $6ADFDE5A,
+ $9EA36930, $37495FA3, $CD770416, $649D3285,
+ $8C645C51, $258E6AC2, $DFB03177, $765A07E4,
+ $8226B08E, $2BCC861D, $D1F2DDA8, $7818EB3B,
+ $21C30BDE, $88293D4D, $721766F8, $DBFD506B,
+ $2F81E701, $866BD192, $7C558A27, $D5BFBCB4,
+ $3D46D260, $94ACE4F3, $6E92BF46, $C77889D5,
+ $33043EBF, $9AEE082C, $60D05399, $C93A650A,
+ $B1228E31, $18C8B8A2, $E2F6E317, $4B1CD584,
+ $BF6062EE, $168A547D, $ECB40FC8, $455E395B,
+ $ADA7578F, $044D611C, $FE733AA9, $57990C3A,
+ $A3E5BB50, $0A0F8DC3, $F031D676, $59DBE0E5,
+ $EA6C212F, $438617BC, $B9B84C09, $10527A9A,
+ $E42ECDF0, $4DC4FB63, $B7FAA0D6, $1E109645,
+ $F6E9F891, $5F03CE02, $A53D95B7, $0CD7A324,
+ $F8AB144E, $514122DD, $AB7F7968, $02954FFB,
+ $7A8DA4C0, $D3679253, $2959C9E6, $80B3FF75,
+ $74CF481F, $DD257E8C, $271B2539, $8EF113AA,
+ $66087D7E, $CFE24BED, $35DC1058, $9C3626CB,
+ $684A91A1, $C1A0A732, $3B9EFC87, $9274CA14,
+ $CBAF2AF1, $62451C62, $987B47D7, $31917144,
+ $C5EDC62E, $6C07F0BD, $9639AB08, $3FD39D9B,
+ $D72AF34F, $7EC0C5DC, $84FE9E69, $2D14A8FA,
+ $D9681F90, $70822903, $8ABC72B6, $23564425,
+ $5B4EAF1E, $F2A4998D, $089AC238, $A170F4AB,
+ $550C43C1, $FCE67552, $06D82EE7, $AF321874,
+ $47CB76A0, $EE214033, $141F1B86, $BDF52D15,
+ $49899A7F, $E063ACEC, $1A5DF759, $B3B7C1CA,
+ $7D3274CD, $D4D8425E, $2EE619EB, $870C2F78,
+ $73709812, $DA9AAE81, $20A4F534, $894EC3A7,
+ $61B7AD73, $C85D9BE0, $3263C055, $9B89F6C6,
+ $6FF541AC, $C61F773F, $3C212C8A, $95CB1A19,
+ $EDD3F122, $4439C7B1, $BE079C04, $17EDAA97,
+ $E3911DFD, $4A7B2B6E, $B04570DB, $19AF4648,
+ $F156289C, $58BC1E0F, $A28245BA, $0B687329,
+ $FF14C443, $56FEF2D0, $ACC0A965, $052A9FF6,
+ $5CF17F13, $F51B4980, $0F251235, $A6CF24A6,
+ $52B393CC, $FB59A55F, $0167FEEA, $A88DC879,
+ $4074A6AD, $E99E903E, $13A0CB8B, $BA4AFD18,
+ $4E364A72, $E7DC7CE1, $1DE22754, $B40811C7,
+ $CC10FAFC, $65FACC6F, $9FC497DA, $362EA149,
+ $C2521623, $6BB820B0, $91867B05, $386C4D96,
+ $D0952342, $797F15D1, $83414E64, $2AAB78F7,
+ $DED7CF9D, $773DF90E, $8D03A2BB, $24E99428,
+ $975E55E2, $3EB46371, $C48A38C4, $6D600E57,
+ $991CB93D, $30F68FAE, $CAC8D41B, $6322E288,
+ $8BDB8C5C, $2231BACF, $D80FE17A, $71E5D7E9,
+ $85996083, $2C735610, $D64D0DA5, $7FA73B36,
+ $07BFD00D, $AE55E69E, $546BBD2B, $FD818BB8,
+ $09FD3CD2, $A0170A41, $5A2951F4, $F3C36767,
+ $1B3A09B3, $B2D03F20, $48EE6495, $E1045206,
+ $1578E56C, $BC92D3FF, $46AC884A, $EF46BED9,
+ $B69D5E3C, $1F7768AF, $E549331A, $4CA30589,
+ $B8DFB2E3, $11358470, $EB0BDFC5, $42E1E956,
+ $AA188782, $03F2B111, $F9CCEAA4, $5026DC37,
+ $A45A6B5D, $0DB05DCE, $F78E067B, $5E6430E8,
+ $267CDBD3, $8F96ED40, $75A8B6F5, $DC428066,
+ $283E370C, $81D4019F, $7BEA5A2A, $D2006CB9,
+ $3AF9026D, $931334FE, $692D6F4B, $C0C759D8,
+ $34BBEEB2, $9D51D821, $676F8394, $CE85B507);
+
+const Tab64hi : array[0..255] of longint = (
+ $00000000, $42F0E1EB, $85E1C3D7, $C711223C,
+ $49336645, $0BC387AE, $CCD2A592, $8E224479,
+ $9266CC8A, $D0962D61, $17870F5D, $5577EEB6,
+ $DB55AACF, $99A54B24, $5EB46918, $1C4488F3,
+ $663D78FF, $24CD9914, $E3DCBB28, $A12C5AC3,
+ $2F0E1EBA, $6DFEFF51, $AAEFDD6D, $E81F3C86,
+ $F45BB475, $B6AB559E, $71BA77A2, $334A9649,
+ $BD68D230, $FF9833DB, $388911E7, $7A79F00C,
+ $CC7AF1FF, $8E8A1014, $499B3228, $0B6BD3C3,
+ $854997BA, $C7B97651, $00A8546D, $4258B586,
+ $5E1C3D75, $1CECDC9E, $DBFDFEA2, $990D1F49,
+ $172F5B30, $55DFBADB, $92CE98E7, $D03E790C,
+ $AA478900, $E8B768EB, $2FA64AD7, $6D56AB3C,
+ $E374EF45, $A1840EAE, $66952C92, $2465CD79,
+ $3821458A, $7AD1A461, $BDC0865D, $FF3067B6,
+ $711223CF, $33E2C224, $F4F3E018, $B60301F3,
+ $DA050215, $98F5E3FE, $5FE4C1C2, $1D142029,
+ $93366450, $D1C685BB, $16D7A787, $5427466C,
+ $4863CE9F, $0A932F74, $CD820D48, $8F72ECA3,
+ $0150A8DA, $43A04931, $84B16B0D, $C6418AE6,
+ $BC387AEA, $FEC89B01, $39D9B93D, $7B2958D6,
+ $F50B1CAF, $B7FBFD44, $70EADF78, $321A3E93,
+ $2E5EB660, $6CAE578B, $ABBF75B7, $E94F945C,
+ $676DD025, $259D31CE, $E28C13F2, $A07CF219,
+ $167FF3EA, $548F1201, $939E303D, $D16ED1D6,
+ $5F4C95AF, $1DBC7444, $DAAD5678, $985DB793,
+ $84193F60, $C6E9DE8B, $01F8FCB7, $43081D5C,
+ $CD2A5925, $8FDAB8CE, $48CB9AF2, $0A3B7B19,
+ $70428B15, $32B26AFE, $F5A348C2, $B753A929,
+ $3971ED50, $7B810CBB, $BC902E87, $FE60CF6C,
+ $E224479F, $A0D4A674, $67C58448, $253565A3,
+ $AB1721DA, $E9E7C031, $2EF6E20D, $6C0603E6,
+ $F6FAE5C0, $B40A042B, $731B2617, $31EBC7FC,
+ $BFC98385, $FD39626E, $3A284052, $78D8A1B9,
+ $649C294A, $266CC8A1, $E17DEA9D, $A38D0B76,
+ $2DAF4F0F, $6F5FAEE4, $A84E8CD8, $EABE6D33,
+ $90C79D3F, $D2377CD4, $15265EE8, $57D6BF03,
+ $D9F4FB7A, $9B041A91, $5C1538AD, $1EE5D946,
+ $02A151B5, $4051B05E, $87409262, $C5B07389,
+ $4B9237F0, $0962D61B, $CE73F427, $8C8315CC,
+ $3A80143F, $7870F5D4, $BF61D7E8, $FD913603,
+ $73B3727A, $31439391, $F652B1AD, $B4A25046,
+ $A8E6D8B5, $EA16395E, $2D071B62, $6FF7FA89,
+ $E1D5BEF0, $A3255F1B, $64347D27, $26C49CCC,
+ $5CBD6CC0, $1E4D8D2B, $D95CAF17, $9BAC4EFC,
+ $158E0A85, $577EEB6E, $906FC952, $D29F28B9,
+ $CEDBA04A, $8C2B41A1, $4B3A639D, $09CA8276,
+ $87E8C60F, $C51827E4, $020905D8, $40F9E433,
+ $2CFFE7D5, $6E0F063E, $A91E2402, $EBEEC5E9,
+ $65CC8190, $273C607B, $E02D4247, $A2DDA3AC,
+ $BE992B5F, $FC69CAB4, $3B78E888, $79880963,
+ $F7AA4D1A, $B55AACF1, $724B8ECD, $30BB6F26,
+ $4AC29F2A, $08327EC1, $CF235CFD, $8DD3BD16,
+ $03F1F96F, $41011884, $86103AB8, $C4E0DB53,
+ $D8A453A0, $9A54B24B, $5D459077, $1FB5719C,
+ $919735E5, $D367D40E, $1476F632, $568617D9,
+ $E085162A, $A275F7C1, $6564D5FD, $27943416,
+ $A9B6706F, $EB469184, $2C57B3B8, $6EA75253,
+ $72E3DAA0, $30133B4B, $F7021977, $B5F2F89C,
+ $3BD0BCE5, $79205D0E, $BE317F32, $FCC19ED9,
+ $86B86ED5, $C4488F3E, $0359AD02, $41A94CE9,
+ $CF8B0890, $8D7BE97B, $4A6ACB47, $089A2AAC,
+ $14DEA25F, $562E43B4, $913F6188, $D3CF8063,
+ $5DEDC41A, $1F1D25F1, $D80C07CD, $9AFCE626);
+
+{$ifdef FPC}
+{$ifndef VER1_0}
+ {$warnings on}
+ {$ifdef RangeChecks_on}
+ {$R+}
+ {$endif}
+{$endif}
+{$endif}
+
+{---------------------------------------------------------------------------}
+procedure CRC64Update(var CRC: TCRC64; Msg: pointer; Len: word);
+ {-update CRC64 with Msg data}
+type
+ PByte = ^byte;
+var
+ i,it: word;
+ clo,chi: longint;
+type
+ BR = packed record
+ b0,b1,b2,b3: byte;
+ end;
+begin
+ clo := CRC.lo32;
+ chi := CRC.hi32;
+ for i:=1 to Len do begin
+ {c64 := Tab64[(c64 shr 56) xor Msg^] xor (c64 shl 8)}
+ it := BR(chi).b3 xor PByte(Msg)^; {index in tables}
+ chi := chi shl 8;
+ BR(chi).b0 := BR(clo).b3;
+ chi := chi xor Tab64Hi[it];
+ clo := (clo shl 8) xor Tab64Lo[it];
+ inc(longint(Msg));
+ end;
+ CRC.lo32 := clo;
+ CRC.hi32 := chi;
+end;
+
+{---------------------------------------------------------------------------}
+procedure CRC64Init(var CRC: TCRC64);
+ {-CRC64 initialization}
+begin
+ CRC := Mask64;
+end;
+
+{---------------------------------------------------------------------------}
+procedure CRC64Final(var CRC: TCRC64);
+ {-CRC64: finalize calculation}
+begin
+ CRC.lo32 := CRC.lo32 xor Mask64.lo32;
+ CRC.hi32 := CRC.hi32 xor Mask64.hi32;
+end;
+
+{---------------------------------------------------------------------------}
+procedure CRC64Full(var CRC: TCRC64; Msg: pointer; Len: word);
+ {-CRC64 of Msg with init/update/final}
+begin
+ CRC64Init(CRC);
+ CRC64Update(CRC, Msg, Len);
+ CRC64Final(CRC);
+end;
+
end.
{
$Log: crc.pas,v $
+ Revision 1.7 2005/10/07 10:46:14 mw
+ MW: - Hinzufügen von Routinen zur CRC64
+ (Vorbereitung auf Umstellung der Bezugsverkettung auf CRC64)
+
Revision 1.6 2005/01/01 11:16:27 mw
MW: - Willkommen im Jahr 2005
Index: freexp/Trial/crc64_openxp.diff
===================================================================
RCS file: freexp/Trial/crc64_openxp.diff
diff -N freexp/Trial/crc64_openxp.diff
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ freexp/Trial/crc64_openxp.diff 7 Oct 2005 12:21:22 -0000 1.1
@@ -0,0 +1,579 @@
+Index: crc.pas
+===================================================================
+--- crc.pas (revision 7024)
++++ crc.pas (working copy)
+@@ -38,6 +38,8 @@
+
+ procedure CRC64Full(var CRC: TCRC64; Msg: pointer; Len: word); {-CRC64 of
Msg with init/update/final}
+
++function CRC64Str(s: string): Int64;
++
+ implementation
+
+ var
+@@ -234,7 +236,7 @@
+
+ (*----------------------------- CRC64 Routinen -----------------------------*)
+ (*--------------------------------------------------------------------------
+- (C) Copyright 2005 Martin Wodrich
++ (C) Copyright 2005 Martin Wodrich
+
+ Modifikation um ohne Assembler-Abschnitte, lange Define-Abschnitte
+ und Includes auszukommen (Erleichtert die Itegration in bestehende
+@@ -290,7 +292,7 @@
+ *************************************************************************)
+
+
+-const Tab64lo : array[0..255] of longint = (
++const Tab64lo : array[0..255] of Cardinal = (
+ $00000000, $A9EA3693, $53D46D26, $FA3E5BB5,
+ $0E42ECDF, $A7A8DA4C, $5D9681F9, $F47CB76A,
+ $1C85D9BE, $B56FEF2D, $4F51B498, $E6BB820B,
+@@ -356,7 +358,7 @@
+ $3AF9026D, $931334FE, $692D6F4B, $C0C759D8,
+ $34BBEEB2, $9D51D821, $676F8394, $CE85B507);
+
+-const Tab64hi : array[0..255] of longint = (
++const Tab64hi : array[0..255] of Cardinal = (
+ $00000000, $42F0E1EB, $85E1C3D7, $C711223C,
+ $49336645, $0BC387AE, $CCD2A592, $8E224479,
+ $9266CC8A, $D0962D61, $17870F5D, $5577EEB6,
+@@ -483,4 +485,15 @@
+ CRC64Final(CRC);
+ end;
+
++function CRC64Str(s: string): Int64;
++var
++ CRC: TCRC64;
++begin
++ CRC64Init(CRC);
++ CRC64Update(CRC, @s[1], Length(s));
++ CRC64Final(CRC);
++ // !! Check if result is a 'real' Int64 or the byte order is reversed
++ Result := Int64(CRC);
++end;
++
+ end.
+Index: database.pas
+===================================================================
+--- database.pas (revision 7024)
++++ database.pas (working copy)
+@@ -87,6 +87,7 @@
+ function dbFound:boolean;
+ function dbIntStr(i:integer16):string;
+ function dbLongStr(l:longint):string;
++function dbInt64Str(l: Int64):string;
+
+ {--------------------------------------------- Daten lesen/schreiben ---}
+
+@@ -103,6 +104,7 @@
+ function dbReadStrN(dbp:DB; feldnr:integer):string;
+ function dbReadInt(dbp:DB; const feld:dbFeldStr):longint;
+ function dbReadIntN(dbp:DB; feldnr:integer):longint;
++function dbReadInt64N(dbp:DB; Feldnr: Integer): Int64;
+
+ function dbXsize (dbp:DB; const feld:dbFeldStr):longint;
+ procedure dbReadX (dbp:DB; const feld:dbFeldStr; var size:integer; var data);
+@@ -1192,12 +1194,13 @@
+ if (feldnr<0) or (feldnr>hd.felder) then error('ReadN: ungültige
Feldnr.');
+ with feldp^.feld[feldnr] do
+ case ftyp of
+- 1 : begin
++ dbTypeString: begin
+ bb:=recbuf^[fofs]+1;
+ if bb>fsize then bb:=fsize;
+ move(recbuf^[fofs],data,bb);
+ end;
+- 2,3,4,5 : if (fsize > 0) then
++ dbTypeInt, dbTypeReal, dbTypeDatum, // dbUntypedExt = 6 fehlt ??
++ dbUntyped, dbTypeInt64: if (fsize > 0) then
+ move(recbuf^[fofs],data,fsize);
+ end;
+ end;
+@@ -1240,10 +1243,20 @@
+
+ function dbReadIntN(dbp:DB; Feldnr: Integer):longint;
+ begin
+- Result :=0;
++ Result :=0;
++{$IFDEF Debug }
++ if dp(dbp)^.feldp^.feld[feldnr].ftyp = dbTypeInt64 then
++ raise Exception.Create('Trying to read Int64 with dbReadIntN fails');
++{$ENDIF }
+ dbReadN(dbp,feldnr, Result); { 1/2/4 Bytes }
+ end;
+
++function dbReadInt64N(dbp:DB; Feldnr: Integer): Int64;
++begin
++ Result :=0;
++ dbReadN(dbp,feldnr, Result); { 8 Bytes }
++end;
++
+ { 'data' in Feld mit Nr. 'feldnr' schreiben }
+
+ procedure dbWriteN(dbp:DB; feldnr:integer; const data);
+@@ -1254,13 +1267,14 @@
+ if (feldnr<0) or (feldnr>hd.felder) then error('WriteN: ungültige
Feldnr.');
+ with feldp^.feld[feldnr] do
+ case ftyp of
+- 1 : begin
++ dbTypeString: begin
+ bb:=byte(data)+1;
+ if bb>fsize then bb:=fsize;
+ move(data,recbuf^[fofs],bb);
+ recbuf^[fofs]:=bb-1;
+ end;
+- 2,3,4,5 : move(data,recbuf^[fofs],fsize);
++ dbTypeInt, dbTypeReal, dbTypeDatum, // dbUntypedExt = 6 fehlt ??
++ dbUntyped, dbTypeInt64: move(data,recbuf^[fofs],fsize);
+ end;
+ flushed:=false;
+ end;
+Index: xpmaus.pas
+===================================================================
+--- xpmaus.pas (revision 7024)
++++ xpmaus.pas (working copy)
+@@ -57,7 +57,8 @@
+ var t,t2 : text;
+ fn, tfn, s, anew, old, msgid, empf : string;
+ stop : boolean;
+- l : longint;
++ l : Longint;
++ crc: Int64;
+ hdp : THeader;
+ hds : longint;
+ f : file;
+Index: databaso.pas
+===================================================================
+--- databaso.pas (revision 7024)
++++ databaso.pas (working copy)
+@@ -123,10 +123,13 @@
+ for i:=1 to felder do begin
+ if flp^.feld[i].ftyp=1 then inc(flp^.feld[i].fsize);
+ case flp^.feld[i].ftyp of
+- 1,2,5 : inc(size,flp^.feld[i].fsize);
+- 3 : inc(size,6); { Real }
+- 4 : inc(size,4); { Datum }
+- 6 : begin
++ dbTypeString,
++ dbTypeInt,
++ dbUntyped : inc(size,flp^.feld[i].fsize);
++ dbTypeReal : inc(size, 6);
++ dbTypeDatum : inc(size, 4);
++ dbTypeInt64 : inc(size, 8);
++ dbUntypedExt : begin
+ inc(size,8); { externes Feld: Zeiger + Grösse }
+ xflag:=true;
+ end;
+Index: xp4o.inc
+===================================================================
+--- xp4o.inc (revision 7024)
++++ xp4o.inc (working copy)
+@@ -459,12 +459,12 @@
+ domove:=true;
+ if dbReadInt(mbase,'netztyp') shr 24>0 then begin { CrossPosting }
+ rec:=dbRecno(mbase);
+- mid:=LeftStr(dbReadStrN(mbase,mb_msgid),4);
++ mid:=LeftStr(dbReadStrN(mbase,mb_msgid),8);
+ domove:=not MsgOk;
+ if domove then begin
+ dbSeek(bezbase,beiMsgid,mid);
+ if dbFound then begin
+- while not dbEOF(bezbase) and
(dbLongStr(dbReadIntN(bezbase,bezb_msgid))=mid)
++ while not dbEOF(bezbase) and
(dbInt64Str(dbReadInt64N(bezbase,bezb_msgid))=mid)
+ do begin
+ mpos:=dbReadIntN(bezbase,bezb_msgpos);
+ if (mpos<>rec) and not dbDeleted(mbase,mpos) then begin
+Index: xp4w.inc
+===================================================================
+--- xp4w.inc (revision 7024)
++++ xp4w.inc (working copy)
+@@ -637,13 +637,14 @@
+ if rflag then begin
+ b:=1;
+ dbWriteN(mbase,mb_gelesen,b);
+- if dbReadInt(mbase,'netztyp') shr 24<>0 then begin { Crossposting }
++ if dbReadInt(mbase,'netztyp') shr 24<>0 then
++ begin { Crossposting }
+ rec:=dbRecno(mbase);
+- crc:=LeftStr(dbReadStrN(mbase,mb_msgid),4);
++ crc:=LeftStr(dbReadStrN(mbase,mb_msgid),8);
+ mi:=dbGetIndex(bezbase); dbSetIndex(bezbase,beiMsgID);
+ dbSeek(bezbase,beiMsgID,crc); { alle Kopien auf 'gelesen' }
+ if dbFound then begin
+- while not dbEOF(bezbase) and
(dbLongStr(dbReadIntN(bezbase,bezb_msgid))=crc)
++ while not dbEOF(bezbase) and
(dbInt64Str(dbReadInt64N(bezbase,bezb_msgid))=crc)
+ do begin
+ dbReadN(bezbase,bezb_msgpos,rec2);
+ if (rec2<>rec) and not dbDeleted(mbase,rec2) then begin
+Index: databas2.inc
+===================================================================
+--- databas2.inc (revision 7024)
++++ databas2.inc (working copy)
+@@ -235,6 +235,15 @@
+ dbLongStr:=s;
+ end;
+
++function dbInt64Str(l: Int64):string;
++type ca = array[1..8] of char;
++var s : string[8];
++ i : integer;
++begin
++ s[0]:=#8;
++ for i:=1 to 8 do s[i]:=ca(l)[9-i];
++ dbInt64Str := s;
++end;
+
+ { Die Indexversion wird von OpenIndex.CreateIndex }
+ { in den Indexheader geschrieben }
+Index: xp1.pas
+===================================================================
+--- xp1.pas (revision 7024)
++++ xp1.pas (working copy)
+@@ -198,7 +198,7 @@
+ function fuser(const s:string):string; { Spaces vor/hinter '@' }
+ function aufnahme_string:string;
+
+-function MsgidIndex(mid:string):longint; { case-insensitive CRC32 }
++function MsgidIndex(mid:string): Int64 ; { case-insensitive CRC64 }
+
+ function getb(const su, v:string; var b:byte):boolean; { PARSER }
+ function getc(const su, v:string; var c:char):boolean;
+@@ -1970,9 +1970,9 @@
+ writeln;
+ end;
+
+-{ rechten Teil der ID in LowerCase umwandeln und CRC32 bilden }
++{ rechten Teil der ID in LowerCase umwandeln und CRC64 bilden }
+
+-function MsgidIndex(mid:string):longint;
++function MsgidIndex(mid:string): Int64;
+ var p : integer;
+ begin
+ p:=cposx('@',mid)+1;
+@@ -1980,7 +1980,7 @@
+ mid[p]:=system.upcase(mid[p]);
+ inc(p);
+ end;
+- MsgidIndex:=CRC32Str(mid);
++ MsgidIndex:=CRC64Str(mid);
+ end;
+
+ const cm = false;
+Index: xp1o.pas
+===================================================================
+--- xp1o.pas (revision 7024)
++++ xp1o.pas (working copy)
+@@ -66,7 +66,7 @@
+ procedure AddBezug(var hd:Theader; dateadd:byte);
+ procedure DelBezug;
+ function GetBezug(const ref:string):longint;
+-procedure AddNewBezug(MsgPos, MsgId, Ref, Datum: Integer);
++procedure AddNewBezug(MsgPos: Integer; MsgId, Ref: Int64; Datum: Integer);
+ { HJT 11.00.05: Reference Normalisieren }
+ function NormalizeBezug(const ref:string):string;
+ function KK:boolean;
+@@ -625,7 +625,7 @@
+ UniExtract:=true;
+ end;
+
+-procedure AddNewBezug(MsgPos, MsgId, Ref, Datum: Integer);
++procedure AddNewBezug(MsgPos: Integer; MsgId, Ref: Int64; Datum: Integer);
+ begin
+ Debug.DebugLog('xp1o',Format(
+ 'adding reference: msg no. %d (id=%4x, refid=%4x, date=%d)',
+@@ -672,7 +672,7 @@
+ end;
+
+ procedure AddBezug(var hd:Theader; dateadd:byte);
+-var c1,c2 : longint;
++var c1,c2 : Int64;
+ satz : longint;
+ datum : longint;
+ empfnr: byte;
+@@ -717,7 +717,7 @@
+
+ function HasRef:boolean;
+ begin
+- dbSeek(bezbase,beiRef,LeftStr(dbReadStrN(mbase,mb_msgid),4));
++ dbSeek(bezbase,beiRef,LeftStr(dbReadStrN(mbase,mb_msgid),8));
+ HasRef:=dbFound;
+ end;
+
+@@ -731,7 +731,7 @@
+
+ function MidOK:boolean;
+ begin
+- MidOK:=(dbLongStr(dbReadIntN(bezbase,bezb_msgid))=crc);
++ MidOK:=(dbInt64Str(dbReadInt64N(bezbase,bezb_msgid))=crc);
+ end;
+
+ function DatOK:boolean;
+@@ -742,7 +742,7 @@
+ begin
+ if KK then begin
+ pos:=dbRecno(mbase);
+- crc:=LeftStr(dbReadStrN(mbase,mb_msgid),4);
++ crc:=LeftStr(dbReadStrN(mbase,mb_msgid),8);
+ mi:=dbGetIndex(bezbase); dbSetIndex(bezbase,beiMsgid);
+ dbSeek(bezbase,beiMsgid,crc);
+ ok:=dbfound;
+@@ -772,12 +772,12 @@
+ end;
+
+
+-function GetBezug(const ref:string):longint;
++function GetBezug(const ref:string): longint;
+ var pos : longint;
+ begin
+ { HJT 11.05.05 Bezug normalisieren }
+ { dbSeek(bezbase,beiMsgid,dbLongStr(MsgidIndex(ref))); }
+- dbSeek(bezbase,beiMsgid,dbLongStr(MsgidIndex(NormalizeBezug(ref))));
++ dbSeek(bezbase,beiMsgid,dbInt64Str(MsgidIndex(NormalizeBezug(ref))));
+ if dbFound then begin
+ pos:=dbReadIntN(bezbase,bezb_msgpos);
+ dbGo(mbase,pos);
+Index: version.inc
+===================================================================
+--- version.inc (revision 7024)
++++ version.inc (working copy)
+@@ -1 +1 @@
+-version_build = 6996;
++version_build = 7022;
+Index: xp3o.inc
+===================================================================
+--- xp3o.inc (revision 7024)
++++ xp3o.inc (working copy)
+@@ -220,7 +220,7 @@
+ end;
+
+ procedure bearbeiteMsg(var id,abs,sender:string; cancel:boolean);
+- var crc : longint;
++ var crc : Int64;
+ hdp2 : THeader;
+ hds : longint;
+ rec : longint;
+@@ -266,9 +266,9 @@
+ crc:=MsgidIndex(id);
+ hdp2 := THeader.Create;
+ if cancel then mrec:=dbRecno(mbase); { Position der Cancel-Mail merken }
+- dbSeek(bezbase,beiMsgId,dbLongStr(crc));
++ dbSeek(bezbase,beiMsgId,dbInt64Str(crc));
+ if dbFound then
+- while (not dbEOF(bezbase)) and (dbReadIntN(bezbase,bezb_msgid)=crc) do
begin
++ while (not dbEOF(bezbase)) and (dbReadInt64N(bezbase,bezb_msgid)=crc)
do begin
+ repeat;
+ hdp2.msgid:='';
+ rec:=dbReadIntN(bezbase,bezb_msgpos);
+@@ -277,7 +277,7 @@
+ Readheader(hdp2,hds,false);
+ end;
+ dbNext(bezbase);
+- until (hdp2.msgid=id) or dbEOF(bezbase) or
(dbReadIntN(bezbase,bezb_msgid)<>crc);
++ until (hdp2.msgid=id) or dbEOF(bezbase) or
(dbReadInt64N(bezbase,bezb_msgid)<>crc);
+ { HJT 10.09.05, die ausloesende ERSETZT-Nachricht nicht auf loeschen
setzen }
+ { if okay then DelMsg; } { zu löschende/zu ersetzende Nachricht
löschen }
+ if okay and (cancel or (hdp2.msgid <> hdp2.ersetzt)) then DelMsg; {
zu löschende/zu ersetzende Nachricht löschen }
+@@ -644,7 +644,7 @@
+ MsgPos: Integer;
+ begin
+ result:= false;
+- dbSeek(bezbase,beiMsgID,dbLongStr(MsgidIndex(Hdp.msgid)));
++ dbSeek(bezbase,beiMsgID,dbInt64Str(MsgidIndex(Hdp.msgid)));
+ if dbFound and not dbDeleted(bezbase, dbRecNo(bezbase)) then
+ begin
+ // message with same msgid found in db
+Index: xp2db.pas
+===================================================================
+--- xp2db.pas (revision 7024)
++++ xp2db.pas (working copy)
+@@ -875,8 +875,8 @@
+ if not FileExists(BezugFile+dbExt) then begin { BEZUEGE:
Kommentarbaum }
+ initflp(4);
+ AppX('MsgPos',dbTypeInt,4,10);
+- AppX('MsgID',dbTypeInt,4,10);
+- AppX('Ref',dbTypeInt,4,10);
++ AppX('MsgID',dbTypeInt64,8,10);
++ AppX('Ref',dbTypeInt64,8,10);
+ AppX('Datum',dbTypeInt,4,10);
+ dbCreate(BezugFile,flp);
+ dbReleaseFL(flp);
+Index: datadef.pas
+===================================================================
+--- datadef.pas (revision 7024)
++++ datadef.pas (working copy)
+@@ -49,6 +49,7 @@
+ dbTypeDatum = 4; { Datum 4 Bytes t/m/jj == LongInt }
+ dbUntyped = 5; { untypisiert, feste Länge }
+ dbUntypedExt = 6; { bis 32K Länge, 4Byte-Zeiger auf DBD-File }
++ dbTypeInt64 = 7; { 64 Bit Integer }
+
+ dbFlagIndexed = 1; { Flag für dbOpen }
+
+Index: xpsendmessage_unsent.pas
+===================================================================
+--- xpsendmessage_unsent.pas (revision 7024)
++++ xpsendmessage_unsent.pas (working copy)
+@@ -311,9 +311,9 @@
+ if empfnr>0 then begin
+ dbReadN(mbase,mb_ablage,ablage); { alle Crosspostings auf loe. + !UV }
+ dbReadN(mbase,mb_adresse,madr);
+- crc:=LeftStr(dbReadStrN(mbase,mb_msgid),4);
++ crc:=LeftStr(dbReadStrN(mbase,mb_msgid),8);
+ dbSeek(bezbase,beiMsgID,crc);
+- while not dbEOF(bezbase) and
(dbLongStr(dbReadIntN(bezbase,bezb_msgid))=crc) do begin
++ while not dbEOF(bezbase) and
(dbInt64Str(dbReadInt64N(bezbase,bezb_msgid))=crc) do begin
+ if dbReadIntN(bezbase,bezb_msgpos)<>rec then begin
+ dbGo(mbase,dbReadIntN(bezbase,bezb_msgpos));
+ if (dbReadInt(mbase,'ablage')=ablage) and
(dbReadInt(mbase,'adresse')=madr) then
+Index: xp4o2.pas
+===================================================================
+--- xp4o2.pas (revision 7024)
++++ xp4o2.pas (working copy)
+@@ -281,11 +281,12 @@
+ end;
+
+ function BezNr:byte; { 1 = erster Crossposting-Empfänger, sonst 2 }
+- var mcrc,dat : longint;
++ var mcrc: Int64;
++ dat : longint;
+ nr : byte;
+ begin
+ mcrc:=MsgidIndex(hd.msgid);
+- dbSeek(bezbase,beiMsgID,dbLongStr(mcrc));
++ dbSeek(bezbase,beiMsgID,dbInt64Str(mcrc));
+ if not dbFound then
+ BezNr:=1
+ else begin
+@@ -305,7 +306,7 @@
+ end;
+ end;
+ dbNext(bezbase);
+- until (nr<>0) or dbEOF(bezbase) or
(dbReadIntN(bezbase,bezb_msgid)<>mcrc);
++ until (nr<>0) or dbEOF(bezbase) or
(dbReadInt64N(bezbase,bezb_msgid)<>mcrc);
+ BezNr:=nr;
+ end;
+ end;
+@@ -402,7 +403,7 @@
+ bez,n : longint;
+ mi : shortint;
+ brett : string;
+- nullid : longint;
++ nullid : Int64;
+ xlines : kommLines;
+
+ procedure RecurBez(ebene: Integer; rec: LongInt; Spuren: KommLines;
last:boolean;
+@@ -413,8 +414,8 @@
+ dat : longint;
+ end;
+ blist = array[1..bmax] of brec;
+- var id : longint;
+- ida : array[0..3] of char absolute id;
++ var id : Int64;
++ ida : array[0..7] of char absolute id;
+ ba,ba2 : ^blist;
+ anz : longint;
+ i,j : integer;
+@@ -423,7 +424,7 @@
+ newbetr: string;
+ _brett : string;
+ r : brec;
+- mid : longint;
++ mid : Int64;
+ spnr,
+ spb : Cardinal;
+
+@@ -461,24 +462,24 @@
+ if nullid=0 then
+ mid:= dbReadNStr(mbase,mb_msgid)
+ else begin
+- mid:=dbLongStr(nullid); nullid:=0;
++ mid:=dbInt64Str(nullid); nullid:=0;
+ end;
+- if Length(mid) >=4 then
++ if Length(mid) >=8 then
+ begin
+- dbSeek(bezbase,beiRef,LeftStr(mid,4));
+- for i:=0 to 3 do
+- ida[i]:=mid[4-i];
++ dbSeek(bezbase,beiRef,LeftStr(mid,8));
++ for i:=0 to 7 do
++ ida[i]:=mid[8-i];
+ end;
+ end;
+
+ function _last:boolean;
+ begin
+- _last:=dbEOF(bezbase) or (dbReadIntN(bezbase,bezb_ref)<>ID);
++ _last:=dbEOF(bezbase) or (dbReadInt64N(bezbase,bezb_ref)<>ID);
+ end;
+
+ procedure AddD0; { erste (noch) vorhandene Kopie hinzufügen }
+- begin
+- while not _last and (dbReadIntN(bezbase,bezb_msgid)=mid) do begin
++ begin
q
++ while not _last and (dbReadInt64N(bezbase,bezb_msgid)=mid) do begin
+ if dbReadIntN(bezbase,bezb_datum) and 3<>2 then begin
+ inc(anz);
+ dbReadN(bezbase,bezb_msgpos,ba^[anz].pos);
+@@ -494,7 +495,7 @@
+ begin
+ rec:=dbRecno(bezbase);
+ found:=false;
+- while not _last and (dbReadIntN(bezbase,bezb_msgid)=mid) do begin
++ while not _last and (dbReadInt64N(bezbase,bezb_msgid)=mid) do begin
+ dbReadN(bezbase,bezb_msgpos,rec2);
+ if not found and not dbDeleted(mbase,rec2) then begin
+ dbGo(mbase,rec2);
+@@ -524,7 +525,7 @@
+ getmem(ba,sizeof(brec)*bmax);
+ anz:=0;
+ while not _last and (anz<bmax) do begin
+- dbReadN(bezbase,bezb_msgid, mid);
++ mid := dbReadInt64N(bezbase,bezb_msgid);
+ if dbReadIntN(bezbase,bezb_datum) and 3=0 then
+ AddD0
+ else
+@@ -685,7 +686,7 @@
+ BezSeekKommentar:=false;
+ mi:=dbGetIndex(bezbase);
+ dbSetIndex(bezbase,beiRef);
+- mid:=LeftStr(dbReadStrN(mbase,mb_msgid),4);
++ mid:=LeftStr(dbReadStrN(mbase,mb_msgid),8);
+ dbSeek(bezbase,beiRef,mid);
+ if dbFound then begin
+ dbReadN(bezbase,bezb_ref,ref);
+@@ -710,7 +711,8 @@
+ var hdp : theader;
+ hds : longint;
+ rec,dat : longint;
+- ref,dat0 : longint;
++ Ref: Int64;
++ dat0 : longint;
+ mi : shortint;
+ vor : boolean;
+ begin
+@@ -723,12 +725,12 @@
+ if hds>1 then
+ begin
+ up:=(hdp.References.Count > 0);
+- dbSeek(bezbase,beiRef,LeftStr(dbReadStrN(mbase,mb_msgid),4));
++ dbSeek(bezbase,beiRef,LeftStr(dbReadStrN(mbase,mb_msgid),8));
+ down:=dbFound;
+ if hdp.References.Count > 0 then
+ begin
+ ref:=MsgidIndex(hdp.GetLastReference);
+- dbSeek(bezbase,beiRef,dbLongStr(ref));
++ dbSeek(bezbase,beiRef,dbInt64Str(ref));
+ if dbFound then begin
+ vor:=true;
+ dbReadN(bezbase,bezb_ref,ref);
+@@ -742,7 +744,7 @@
+ if smdl(dat0,dat) or (not vor and (dat=dat0)) then _right:=true;
+ end;
+ dbSkip(bezbase,1);
+- until dbEOF(bezbase) or (dbReadIntN(bezbase,bezb_ref)<>ref) or
++ until dbEOF(bezbase) or (dbReadInt64N(bezbase,bezb_ref)<>ref) or
+ (_left and _right);
+ end;
+ end;
Index: freexp/Trial/xp_ntvdm.dll
===================================================================
RCS file: freexp/Trial/xp_ntvdm.dll
diff -N freexp/Trial/xp_ntvdm.dll
Binary files /tmp/cvsmxSBxJ and /dev/null differ
Index: freexp/Trial/xp_ntvdm.pas
===================================================================
RCS file: freexp/Trial/xp_ntvdm.pas
diff -N freexp/Trial/xp_ntvdm.pas
--- freexp/Trial/xp_ntvdm.pas 28 May 2005 11:57:13 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,375 +0,0 @@
-{ --------------------------------------------------------------- }
-{ Dieser Quelltext ist urheberrechtlich geschuetzt. }
-{ (c) 2000-2001 OpenXP-Team & Claus Faerber }
-{ (c) 2002-2005 FreeXP, http://www.freexp.de }
-{ CrossPoint ist eine eingetragene Marke von Peter Mandrella. }
-{ }
-{ Die Nutzungsbedingungen fuer diesen Quelltext finden Sie in der }
-{ Datei SLIZENZ.TXT oder auf www.crosspoint.de/oldlicense.html. }
-{ --------------------------------------------------------------- }
-{ $Id: xp_ntvdm.pas,v 1.1 2005/05/28 11:57:13 mw Exp $ }
-
-Library xp_ntvdm;
-
-uses windows,dos,strings;
-
-const xp_ntvdm_version=$2;
- xp_simdisk=1234567890;
-
-var SecurityAttributes: LPSECURITY_ATTRIBUTES;
- Over: POVERLAPPED;
-
-{ --- Imports from ntvdm.exe ------------------------------------ }
-
- procedure setEAX(para:ULONG); external 'ntvdm.exe'; { function
getEAX:ULONG; external 'ntvdm.exe'; }
-{ procedure setAX(para:USHORT); external 'ntvdm.exe'; } { function
getAX:USHORT; external 'ntvdm.exe'; }
-{ procedure setAL(para:UCHAR); external 'ntvdm.exe'; } { function
getAL:UCHAR; external 'ntvdm.exe'; }
-{ procedure setAH(para:UCHAR); external 'ntvdm.exe'; } { function
getAH:UCHAR; external 'ntvdm.exe'; }
-
-{ procedure setEBX(para:ULONG); external 'ntvdm.exe'; } { function
getEBX:ULONG; external 'ntvdm.exe'; }
-{ procedure setBX(para:USHORT); external 'ntvdm.exe'; } { function
getBX:USHORT; external 'ntvdm.exe'; }
-{ procedure setBL(para:UCHAR); external 'ntvdm.exe'; } { function
getBL:UCHAR; external 'ntvdm.exe'; }
-{ procedure setBH(para:UCHAR); external 'ntvdm.exe'; } { function
getBH:UCHAR; external 'ntvdm.exe'; }
-
-{ procedure setECX(para:ULONG); external 'ntvdm.exe'; } function
getECX:ULONG; external 'ntvdm.exe';
-{ procedure setCX(para:USHORT); external 'ntvdm.exe'; } { function
getCX:USHORT; external 'ntvdm.exe'; }
-{ procedure setCL(para:UCHAR); external 'ntvdm.exe'; } function
getCL:UCHAR; external 'ntvdm.exe';
-{ procedure setCH(para:UCHAR); external 'ntvdm.exe'; } function
getCH:UCHAR; external 'ntvdm.exe';
-
-{ procedure setEDX(para:ULONG); external 'ntvdm.exe'; } { function
getEDX:ULONG; external 'ntvdm.exe'; }
-{ procedure setDX(para:USHORT); external 'ntvdm.exe'; } function
getDX:USHORT; external 'ntvdm.exe';
-{ procedure setDH(para:UCHAR); external 'ntvdm.exe'; } { function
getDH:UCHAR; external 'ntvdm.exe'; }
-{ procedure setDL(para:UCHAR); external 'ntvdm.exe'; } { function
getDL:UCHAR; external 'ntvdm.exe'; }
-
-{ procedure setESP(para:ULONG); external 'ntvdm.exe'; } { function
getESP:ULONG; external 'ntvdm.exe'; }
-{ procedure setSP(para:USHORT); external 'ntvdm.exe'; } { function
getSP:USHORT; external 'ntvdm.exe'; }
-
-{ procedure setEBP(para:ULONG); external 'ntvdm.exe'; } { function
getEBP:ULONG; external 'ntvdm.exe'; }
-{ procedure setBP(para:USHORT); external 'ntvdm.exe'; } { function
getBP:USHORT; external 'ntvdm.exe'; }
-
-{ procedure setESI(para:ULONG); external 'ntvdm.exe'; } function
getESI:ULONG; external 'ntvdm.exe';
-{ procedure setSI(para:USHORT); external 'ntvdm.exe'; } { function
getSI:USHORT; external 'ntvdm.exe'; }
-
-{ procedure setEDI(para:ULONG); external 'ntvdm.exe'; } function
getEDI:ULONG; external 'ntvdm.exe';
-{ procedure setDI(para:USHORT); external 'ntvdm.exe'; } { function
getDI:USHORT; external 'ntvdm.exe'; }
-
-{ procedure setEIP(para:ULONG); external 'ntvdm.exe'; } { function
getEIP:ULONG; external 'ntvdm.exe'; }
-{ procedure setIP(para:USHORT); external 'ntvdm.exe'; } { function
getIP:USHORT; external 'ntvdm.exe'; }
-
-{ procedure setCS(para:USHORT); external 'ntvdm.exe'; } { function
getCS:USHORT; external 'ntvdm.exe'; }
-{ procedure setSS(para:USHORT); external 'ntvdm.exe'; } { function
getSS:USHORT; external 'ntvdm.exe'; }
-{ procedure setDS(para:USHORT); external 'ntvdm.exe'; } { function
getDS:USHORT; external 'ntvdm.exe'; }
-{ procedure setES(para:USHORT); external 'ntvdm.exe'; } { function
getES:USHORT; external 'ntvdm.exe'; }
-{ procedure setFS(para:USHORT); external 'ntvdm.exe'; } { function
getFS:USHORT; external 'ntvdm.exe'; }
-{ procedure setGS(para:USHORT); external 'ntvdm.exe'; } { function
getGS:USHORT; external 'ntvdm.exe'; }
-
- procedure setCF(para:ULONG); external 'ntvdm.exe'; { function
getCF:ULONG; external 'ntvdm.exe'; }
-{ procedure setPF(para:ULONG); external 'ntvdm.exe'; } { function
getPF:ULONG; external 'ntvdm.exe'; }
-{ procedure setAF(para:ULONG); external 'ntvdm.exe'; } { function
getAF:ULONG; external 'ntvdm.exe'; }
-{ procedure setZF(para:ULONG); external 'ntvdm.exe'; } { function
getZF:ULONG; external 'ntvdm.exe'; }
-{ procedure setSF(para:ULONG); external 'ntvdm.exe'; } { function
getSF:ULONG; external 'ntvdm.exe'; }
-{ procedure setIF(para:ULONG); external 'ntvdm.exe'; } { function
getIF:ULONG; external 'ntvdm.exe'; }
-
-{ procedure setDF(para:ULONG); external 'ntvdm.exe'; }
-{ procedure setOF(para:ULONG); external 'ntvdm.exe'; }
-{ procedure setMSW(para:USHORT); external 'ntvdm.exe'; }
-
-function GetVDMAddress(Address,Size:ULONG; ProtectedMode:BOOL):Pointer;
external 'ntvdm.exe' name 'MGetVdmPointer';
-function FreeVDMPointer(Address:ULONG; Size:USHORT; Buffer:Pointer;
ProtectedMode:BOOL):BOOL; begin FreeVDMPointer := true; end;
-
-{ --- Exact Windows Version ------------------------------------- }
-
-procedure get_windows_version;
-begin
- setEAX(GetVersion);
-end;
-
-{ --- Clipboard functions --------------------------------------- }
-
-procedure clip_to_string;
-var maxlen: integer;
- len: integer;
- i: integer;
- oneline: boolean;
- sp: ^shortstring;
- ch: HANDLE;
- cp: PChar;
-begin
- maxlen := getCL;
- oneline:= getCH<>0;
- sp := GetVDMAddress(GetEDI,maxlen,false);
- setCF(1);
-
- OpenClipboard(0);
- ch := GetClipboardData(CF_OEMTEXT);
- if ch<> 0 then
- begin
- cp := GlobalLock(ch);
- if cp <> nil then
- begin
- len := StrLen(cp);
- if len>255 then len:=255;
- if len>maxlen then len:=maxlen;
- MoveMemory(PChar(Pointer(sp))+1,cp,len);
- sp^[0]:=Char(Byte(len));
- end;
- if oneline then
- for i:=1 to len do
- if sp^[i]<#32 then
- sp^[i]:=#32;
- setCF(0);
-
- GlobalUnlock(ch);
- end;
- CloseClipboard;
-
- FreeVDMPointer(GetEDI,maxlen,sp,false);
-end;
-
-procedure mem_to_clip;
-var cp: PChar;
- cl: ULONG;
- hm: HANDLE;
- pm: PChar;
-begin
- cl := GetECX;
- cp := GetVDMAddress(GetESI,cl,false);
-
- SetCF(1);
-
- if OpenClipboard(0) then
- begin
- hm := GlobalAlloc(GMEM_MOVEABLE,cl+1);
- if hm <> 0 then
- begin
- pm := GlobalLock(hm);
- if pm <> nil then
- begin
- MoveMemory(pm,cp,cl);
- (PChar(pm)+cl)^ := #0;
- GlobalUnLock(hm);
-
- EmptyClipboard;
- SetClipboardData(CF_OEMTEXT,hm);
- SetCF(0);
- end;
- end;
- CloseClipboard;
- end;
-
- FreeVDMPointer(GetESI,cl,cp,false);
-end;
-
-procedure clip_to_file;
-var fn: PChar;
- fh: Handle;
- ch: Handle;
- cp: LPTSTR;
- wr: DWORD;
-begin
- fn:=GetVDMAddress(GetESI,$10000,false);
- setCF(1);
-
- OpenClipboard(0);
- ch := GetClipboardData(CF_OEMTEXT);
- if ch<> 0 then
- begin
- cp := GlobalLock(ch);
- if cp <> nil then
- begin
- fh:=CreateFile(fn,GENERIC_WRITE,0,SecurityAttributes,CREATE_ALWAYS,
- FILE_FLAG_SEQUENTIAL_SCAN,0);
- if fh<>INVALID_HANDLE_VALUE then
- begin
- WriteFile(fh,cp^,StrLen(cp),wr,Over);
- CloseHandle(fh);
- setCF(0);
- end;
- GlobalUnlock(ch);
- end;
- end;
- CloseClipboard;
-
- FreeVDMPointer(GetESI,0,fn,false);
-end;
-
-procedure file_to_clip;
-var fn: PChar;
- fh: Handle;
- ln: DWORD;
- mh: HANDLE;
- mp: PChar;
-begin
- fn:=GetVDMAddress(GetESI,$10000,false);
- setCF(1);
-
- fh:=CreateFile(fn,GENERIC_READ,0,SecurityAttributes,OPEN_EXISTING,
- FILE_FLAG_SEQUENTIAL_SCAN,0);
- if fh<>INVALID_HANDLE_VALUE then
- begin
- ln := GetFileSize(fh,nil);
- mh := GlobalAlloc(GMEM_MOVEABLE,ln+1);
- if mh <> 0 then
- begin
- mp := GlobalLock(mh);
- if mp <> nil then
- begin
- ReadFile(fh,mp^,ln,ln,nil);
- (PChar(mp)+ln)^ := #0;
- GlobalUnlock(mh);
-
- if OpenClipboard(0) then
- begin
- EmptyClipboard;
- SetClipboardData(CF_OEMTEXT,mh);
- CloseClipboard;
- end;
- setCF(0);
- end else
- GlobalFree(mh);
- CloseHandle(fh);
- end;
- end;
-
- FreeVDMPointer(GetESI,0,fn,false);
-end;
-
-{ --- Calls for DiskFree/DiskSize ------------------------------- }
-procedure NTDiskFree;
-var a:longint;
- b:integer;
-begin
- b:=GetCL;
- a:=(DiskFree(b) DIV 1048576);
- SetEAX(a);
-end;
-
-procedure NTDiskSize;
-var a:longint;
- b:integer;
-begin
- b:=GetCL;
- a:=(DiskSize(b) DIV 1048576);
- SetEAX(a);
-end;
-
-procedure SimDisk;
-begin
- SetEAX(xp_simdisk);
-end;
-
-{ --- NTDiskType ------------------------------------------------ }
-procedure NTDiskType;
-var p :pchar;
-begin
- p:=Stralloc(4);
- StrPCopy(p,chr(GetCL+64)+':\');
- SetEAX(GetDriveTypeA(p));
-end;
-
-{ --- XP_NTVDM_VER ---------------------------------------------- }
-procedure XP_NTVDM_VER;
-begin
- SetEAX(xp_ntvdm_version);
-end;
-
-{ --- VDD calls ------------------------------------------------- }
-
-procedure FREEXP_CALL; stdcall; export;
-begin
- case getDX of
- {Versionsinfos}
- $0000: get_windows_version;
- $0001: XP_NTVDM_VER;
- {Clipboardfunktionen}
- $0101: clip_to_string;
- $0102: mem_to_clip;
- $0103: clip_to_file;
- $0104: file_to_clip;
- {Datentraegerfunktionen}
- $0200: NTDiskFree;
- $0201: NTDiskSize;
- $0202: SimDisk;
- $0203: NTDiskType;
- end;
-end;
-
-procedure FREEXP_INIT; stdcall; export;
-begin
-end;
-
-{ --- DLL exports ----------------------------------------------- }
-
-exports FREEXP_INIT;
-exports FREEXP_CALL;
-
-end.
-
-{
- $Log: xp_ntvdm.pas,v $
- Revision 1.1 2005/05/28 11:57:13 mw
- MW: - XP_NTVDM muß an FPC 2.0 angepasst werden.
-
- Revision 1.10 2005/05/28 09:25:45 mw
- MW: - Anpassung an FreePascal 2.0 (kleine Ungenauigkeiten werden bei
- FPC 2.0 nicht mehr verziehen).
-
- Revision 1.9 2005/01/01 11:16:31 mw
- MW: - Willkommen im Jahr 2005
-
- Revision 1.8 2004/01/09 16:18:59 mw
- MW: - Wir haben jetzt 2004!!
-
- Revision 1.7 2003/08/30 08:56:39 mw
- MW: - Fehler im letzten Commit korregiert.
-
- Revision 1.6 2003/08/30 08:42:49 mw
- MW: - Neue RAM-Disk-Erkennung für WinNT eingebaut.
- Via XP_NTVDM.DLL (also Win32-API) wird jetzt festgestellt,
- ob es eine RAM-Disk ist.
-
- Revision 1.5 2003/08/18 07:30:57 mw
- MW: - Vervollständigung von NTDiskFree/NTDiskSize
- - XP_NTVDM hat jetzt eine Revisionsnummer
- - Simdisk erlaubt Tests der Rechnereien zur schönen Anzeige
- der ermittelten Werte bei beliebig großen Platten
- - OPENXP_CALL/OPENXP_INIT heißt jetzt FREEXP_CALL/FREEXP_INIT
-
- Revision 1.4 2003/08/17 22:19:18 mw
- MW: - neue Funktionen NTDiskFree/NTDiskSize (zeigen korrekte Diskettengröße
- unter WinNT an).
- Achtung: Derzeit nur bis 64 GB und noch nich unbedingt korrekt
- formatiert.
-
- Revision 1.3 2003/07/30 23:09:50 my
- MY:- Source-Header auf "FreeXP" aktualisiert, einige Detailkorrekturen
- an CVS-Logs vorgenommen und hier und da CVS-Loginfos implementiert.
-
- Revision 1.2 2003/06/25 17:29:56 tw
- auto-de-branching
-
- Revision 1.1.2.8 2003/03/01 16:55:59 cl
- - fixed last commit
-
- Revision 1.1.2.7 2003/03/01 16:28:46 cl
- - next try for xp_ntvdm.dll
-
- Revision 1.1.2.6 2002/04/12 14:52:07 cl
- - removed sysutils unit
-
- Revision 1.1.2.5 2002/04/12 14:50:11 cl
- - fixed GetVDMAddress
- - fixed mem_to_clip (called by String2Clip)
-
- Revision 1.1.2.4 2001/07/18 20:13:19 cl
- - removed unnecessary imports from NTVDM.EXE
-
- Revision 1.1.2.3 2001/07/04 01:33:12 my
- - changed ANSI-Umlaut to ASCII-Umlaut (please no ANSI, guys :-))
-
- Revision 1.1.2.2 2001/07/02 21:11:09 mk
- - removed unused units
-
- Revision 1.1.2.1 2001/07/02 20:43:04 mk
- - NTVDM Interface
-}
\ No newline at end of file
------------------------------------------------------------------------
FreeXP CVS-Mailingliste
CVS-List@freexp.de
http://www.freexp.de/cgi-bin/mailman/listinfo/cvs-list
