* merge revs

git-svn-id: branches/fixes_3_2@43196 -
This commit is contained in:
marco 2019-10-14 13:58:40 +00:00
parent 1e9677e20e
commit 65ae9d2413
17 changed files with 1131 additions and 68 deletions

1
.gitattributes vendored
View File

@ -2005,6 +2005,7 @@ packages/fcl-base/src/wince/fileinfo.pp svneol=native#text/plain
packages/fcl-base/src/wtex.pp svneol=native#text/plain packages/fcl-base/src/wtex.pp svneol=native#text/plain
packages/fcl-base/tests/fclbase-unittests.lpi svneol=native#text/plain packages/fcl-base/tests/fclbase-unittests.lpi svneol=native#text/plain
packages/fcl-base/tests/fclbase-unittests.pp svneol=native#text/plain packages/fcl-base/tests/fclbase-unittests.pp svneol=native#text/plain
packages/fcl-base/tests/tcbufferedfilestream.pp svneol=native#text/plain
packages/fcl-base/tests/tccsvreadwrite.pp svneol=native#text/plain packages/fcl-base/tests/tccsvreadwrite.pp svneol=native#text/plain
packages/fcl-base/tests/tchashlist.pp svneol=native#text/plain packages/fcl-base/tests/tchashlist.pp svneol=native#text/plain
packages/fcl-base/tests/tcinifile.pp svneol=native#text/plain packages/fcl-base/tests/tcinifile.pp svneol=native#text/plain

View File

@ -3,6 +3,7 @@
Copyright (c) 1999-2000 by the Free Pascal development team Copyright (c) 1999-2000 by the Free Pascal development team
Implement a buffered stream. Implement a buffered stream.
TBufferedFileStream contributed by José Mejuto, bug ID 30549.
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
for details about the copyright. for details about the copyright.
@ -27,8 +28,10 @@ Const
Type Type
{ ---------------------------------------------------------------------
TBufStream - simple read or write buffer, for sequential reading/writing
---------------------------------------------------------------------}
{ TBufStream }
TBufStream = Class(TOwnerStream) TBufStream = Class(TOwnerStream)
Private Private
FTotalPos : Int64; FTotalPos : Int64;
@ -70,6 +73,72 @@ Type
Function Write(Const ABuffer; ACount : LongInt) : Integer; override; Function Write(Const ABuffer; ACount : LongInt) : Integer; override;
end; end;
{ ---------------------------------------------------------------------
TBufferedFileStream -
Multiple pages buffer for random access reading/writing in file.
---------------------------------------------------------------------}
TBufferedFileStream = class(TFileStream)
private
const
TSTREAMCACHEPAGE_SIZE_DEFAULT=4*1024;
TSTREAMCACHEPAGE_MAXCOUNT_DEFAULT=8;
type
TStreamCacheEntry=record
IsDirty: Boolean;
LastTick: NativeUInt;
PageBegin: int64;
PageRealSize: integer;
Buffer: Pointer;
end;
PStreamCacheEntry=^TStreamCacheEntry;
private
FCachePages: array of PStreamCacheEntry;
FCacheLastUsedPage: integer;
FCacheStreamPosition: int64;
FCacheStreamSize: int64;
FOpCounter: NativeUInt;
FStreamCachePageSize: integer;
FStreamCachePageMaxCount: integer;
FEmergencyFlag: Boolean;
procedure ClearCache;
procedure WriteDirtyPage(const aPage: PStreamCacheEntry);
procedure WriteDirtyPage(const aIndex: integer);
procedure WriteDirtyPages;
procedure EmergencyWriteDirtyPages;
procedure FreePage(const aPage: PStreamCacheEntry; const aFreeBuffer: Boolean); inline;
function LookForPositionInPages: Boolean;
function ReadPageForPosition: Boolean;
function ReadPageBeforeWrite: Boolean;
function FreeOlderInUsePage(const aFreeBuffer: Boolean=false): PStreamCacheEntry;
function GetOpCounter: NativeUInt; inline;
function DoCacheRead(var Buffer; Count: Longint): Longint;
function DoCacheWrite(const Buffer; Count: Longint): Longint;
protected
function GetPosition: Int64; override;
procedure SetPosition(const Pos: Int64); override;
function GetSize: Int64; override;
procedure SetSize64(const NewSize: Int64); override;
procedure SetSize(NewSize: Longint); override;overload;
procedure SetSize(const NewSize: Int64); override;overload;
public
// Warning using Mode=fmOpenWrite because the write buffer
// needs to read, as this class is a cache system not a dumb buffer.
constructor Create(const AFileName: string; Mode: Word);
constructor Create(const AFileName: string; Mode: Word; Rights: Cardinal);
destructor Destroy; override;
function Seek(Offset: Longint; Origin: Word): Longint; override; overload;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; overload;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
// Flush write-cache content to disk
procedure Flush;
// re-initialize the cache with aCacheBlockCount block
// of aCacheBlockSize bytes in each block.
procedure InitializeCache(const aCacheBlockSize: integer; const aCacheBlockCount: integer);
end;
implementation implementation
Resourcestring Resourcestring
@ -77,6 +146,11 @@ Resourcestring
SErrCouldNotFLushBuffer = 'Could not flush buffer'; SErrCouldNotFLushBuffer = 'Could not flush buffer';
SErrInvalidSeek = 'Invalid buffer seek operation'; SErrInvalidSeek = 'Invalid buffer seek operation';
SErrCacheUnexpectedPageDiscard ='CACHE: Unexpected behaviour. Discarded page.';
SErrCacheUnableToReadExpected = 'CACHE: Unable to read expected bytes (Open for write only ?). Expected: %d, effective read: %d';
SErrCacheUnableToWriteExpected ='CACHE: Unable to write expected bytes (Open for read only ?). Expected: %d, effective write: %d';
SErrCacheInternal = 'CACHE: Internal error.';
{ TBufStream } { TBufStream }
procedure TBufStream.SetCapacity(const AValue: Integer); procedure TBufStream.SetCapacity(const AValue: Integer);
@ -257,4 +331,518 @@ begin
end; end;
{ ---------------------------------------------------------------------
TBufferedFileStream
---------------------------------------------------------------------}
procedure TBufferedFileStream.ClearCache;
var
j: integer;
pStream: PStreamCacheEntry;
begin
try
WriteDirtyPages;
finally
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
pStream:=FCachePages[j];
if Assigned(pStream) then begin
if Assigned(pStream^.Buffer) then Freemem(pStream^.Buffer);
Dispose(pStream);
FCachePages[j]:=nil;
end;
end;
end;
end;
procedure TBufferedFileStream.WriteDirtyPage(const aPage: PStreamCacheEntry);
var
lEffectiveBytesWrite: integer;
begin
inherited Seek(aPage^.PageBegin,soBeginning);
lEffectiveBytesWrite:=inherited Write(aPage^.Buffer^,aPage^.PageRealSize);
if lEffectiveBytesWrite<>aPage^.PageRealSize then begin
EmergencyWriteDirtyPages;
Raise EStreamError.CreateFmt(SErrCacheUnableToWriteExpected,[aPage^.PageRealSize,lEffectiveBytesWrite,IntToStr(aPage^.PageBegin)]);
end;
aPage^.IsDirty:=False;
aPage^.LastTick:=GetOpCounter;
end;
procedure TBufferedFileStream.WriteDirtyPage(const aIndex: integer);
var
pCache: PStreamCacheEntry;
begin
pCache:=FCachePages[aIndex];
if Assigned(pCache) then begin
WriteDirtyPage(pCache);
end;
end;
procedure TBufferedFileStream.WriteDirtyPages;
var
j: integer;
pCache: PStreamCacheEntry;
begin
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
pCache:=FCachePages[j];
if Assigned(pCache) then begin
if pCache^.IsDirty then begin
WriteDirtyPage(pCache);
end;
end;
end;
end;
procedure TBufferedFileStream.EmergencyWriteDirtyPages;
var
j: integer;
pCache: PStreamCacheEntry;
begin
// Are we already in a emergency write dirty pages ??
if FEmergencyFlag then exit;
FEmergencyFlag:=true;
// This procedure tries to save all dirty pages inconditional
// because a write fail happens, so everything in cache will
// be dumped to stream if possible, trying to save as much
// information as possible.
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
pCache:=FCachePages[j];
if Assigned(pCache) then begin
if pCache^.IsDirty then begin
try
WriteDirtyPage(pCache);
except on e: Exception do begin
// Do nothing, eat exception if happen.
// This way the cache still holds data to be
// written (that fails) and can be written later
// if write fail conditions change.
end;
end;
end;
end;
end;
FEmergencyFlag:=False;
end;
procedure TBufferedFileStream.FreePage(const aPage: PStreamCacheEntry;
const aFreeBuffer: Boolean);
begin
aPage^.PageBegin:=0;
aPage^.PageRealSize:=0;
aPage^.LastTick:=0;
aPage^.IsDirty:=false;
if aFreeBuffer then begin
FreeMem(aPage^.Buffer);
aPage^.Buffer:=nil;
end;
end;
function TBufferedFileStream.LookForPositionInPages: Boolean;
var
j: integer;
pCache: PStreamCacheEntry;
begin
Result:=false;
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
pCache:=FCachePages[j];
if Assigned(pCache^.Buffer) then begin
if (FCacheStreamPosition>=pCache^.PageBegin) and (FCacheStreamPosition<pCache^.PageBegin+pCache^.PageRealSize) then begin
FCacheLastUsedPage:=j;
Result:=true;
exit;
end;
end;
end;
end;
function TBufferedFileStream.ReadPageForPosition: Boolean;
var
j: integer;
pCache: PStreamCacheEntry=nil;
lStreamPosition: int64;
begin
// Find free page entry
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
if not Assigned(FCachePages[j]^.Buffer) then begin
pCache:=FCachePages[j];
FCacheLastUsedPage:=j;
break;
end;
end;
if not Assigned(pCache) then begin
// Free last used page
pCache:=FreeOlderInUsePage(false);
end;
if not Assigned(pCache^.Buffer) then begin
Getmem(pCache^.Buffer,FStreamCachePageSize);
end;
lStreamPosition:=(FCacheStreamPosition div FStreamCachePageSize)*FStreamCachePageSize;
inherited Seek(lStreamPosition,soBeginning);
pCache^.PageBegin:=lStreamPosition;
pCache^.PageRealSize:=inherited Read(pCache^.Buffer^,FStreamCachePageSize);
if pCache^.PageRealSize=FStreamCachePageSize then begin
pCache^.LastTick:=GetOpCounter;
Result:=true;
end else begin
if FCacheStreamPosition<lStreamPosition+pCache^.PageRealSize then begin
pCache^.LastTick:=GetOpCounter;
Result:=true;
end else begin
Result:=false;
end;
end;
end;
function TBufferedFileStream.ReadPageBeforeWrite: Boolean;
var
j: integer;
pCache: PStreamCacheEntry=nil;
lStreamPosition: int64;
lExpectedBytesToRead: integer;
lEffectiveRead: integer;
begin
// Find free page entry
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
if not Assigned(FCachePages[j]^.Buffer) then begin
pCache:=FCachePages[j];
FCacheLastUsedPage:=j;
break;
end;
end;
if not Assigned(pCache) then begin
// Free last used page
pCache:=FreeOlderInUsePage(false);
end;
if not Assigned(pCache^.Buffer) then begin
Getmem(pCache^.Buffer,FStreamCachePageSize);
end;
lStreamPosition:=(FCacheStreamPosition div FStreamCachePageSize)*FStreamCachePageSize;
inherited Seek(lStreamPosition,soBeginning);
if (lStreamPosition+FStreamCachePageSize) > FCacheStreamSize then begin
lExpectedBytesToRead:=FCacheStreamSize-lStreamPosition;
end else begin
lExpectedBytesToRead:=FStreamCachePageSize;
end;
pCache^.PageBegin:=lStreamPosition;
pCache^.PageRealSize:=inherited Read(pCache^.Buffer^,FStreamCachePageSize);
if pCache^.PageRealSize<>lExpectedBytesToRead then begin
lEffectiveRead:=pCache^.PageRealSize;
pCache^.IsDirty:=false;
pCache^.LastTick:=0;
pCache^.PageBegin:=0;
pCache^.PageRealSize:=0;
Freemem(pCache^.Buffer);
pCache^.Buffer:=nil;
Raise EStreamError.CreateFmt(SErrCacheUnableToReadExpected,[lExpectedBytesToRead,lEffectiveRead]);
end;
pCache^.LastTick:=GetOpCounter;
Result:=true;
end;
function TBufferedFileStream.FreeOlderInUsePage(const aFreeBuffer: Boolean
): PStreamCacheEntry;
var
j: integer;
lOlderTick: int64=High(int64);
lOlderEntry: integer=-1;
begin
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
Result:=FCachePages[j];
if Assigned(Result^.Buffer) then begin
if Result^.LastTick<lOlderTick then begin
lOlderTick:=Result^.LastTick;
lOlderEntry:=j;
end;
end;
end;
if lOlderEntry=-1 then begin
Raise Exception.Create(SErrCacheInternal);
end;
Result:=FCachePages[lOlderEntry];
FCacheLastUsedPage:=lOlderEntry;
if Result^.IsDirty then begin
WriteDirtyPage(Result);
end;
FreePage(Result,aFreeBuffer);
end;
function TBufferedFileStream.GetOpCounter: NativeUInt;
begin
Result:=FOpCounter;
{$PUSH}
{$Q-}
inc(FOpCounter);
{$POP}
end;
function TBufferedFileStream.DoCacheRead(var Buffer; Count: Longint): Longint;
var
pCache: PStreamCacheEntry;
lAvailableInThisPage: integer;
lPositionInPage: integer;
lNewBuffer: PBYTE;
begin
pCache:=FCachePages[FCacheLastUsedPage];
if Assigned(pCache) then begin
// Check if FCacheStreamPosition is in range
if Assigned(pCache^.Buffer) then begin
if (FCacheStreamPosition>=pCache^.PageBegin) and (FCacheStreamPosition<pCache^.PageBegin+pCache^.PageRealSize) then begin
// Position is in range, so read available data from this page up to count or page end
lPositionInPage:=(FCacheStreamPosition-pCache^.PageBegin);
lAvailableInThisPage:=pCache^.PageRealSize - lPositionInPage;
if lAvailableInThisPage>=Count then begin
move((PBYTE(pCache^.Buffer)+lPositionInPage)^,Buffer,Count);
inc(FCacheStreamPosition,Count);
Result:=Count;
pCache^.LastTick:=GetOpCounter;
exit;
end else begin
move((PBYTE(pCache^.Buffer)+lPositionInPage)^,Buffer,lAvailableInThisPage);
inc(FCacheStreamPosition,lAvailableInThisPage);
if pCache^.PageRealSize=FStreamCachePageSize then begin
lNewBuffer:=PBYTE(@Buffer)+lAvailableInThisPage;
Result:=lAvailableInThisPage+DoCacheRead(lNewBuffer^,Count-lAvailableInThisPage);
end else begin
// This cache page is not filled, so it is the last one
// in the file, nothing more to read...
pCache^.LastTick:=GetOpCounter;
Result:=lAvailableInThisPage;
end;
exit;
end;
end else begin
// The position is in other cache page or not in cache at all, so look for
// position in cached pages or allocate a new page.
if LookForPositionInPages then begin
Result:=DoCacheRead(Buffer,Count);
exit;
end else begin
if ReadPageForPosition then begin
Result:=DoCacheRead(Buffer,Count);
end else begin
Result:=0;
end;
exit;
end;
end;
end else begin
if ReadPageForPosition then begin
Result:=DoCacheRead(Buffer,Count);
end else begin
Result:=0;
end;
exit;
end;
end else begin
// The page has been discarded for some unknown reason
Raise EStreamError.Create(SErrCacheUnexpectedPageDiscard);
end;
end;
function TBufferedFileStream.DoCacheWrite(const Buffer; Count: Longint): Longint;
var
pCache: PStreamCacheEntry;
lAvailableInThisPage: integer;
lPositionInPage: integer;
lNewBuffer: PBYTE;
begin
pCache:=FCachePages[FCacheLastUsedPage];
if Assigned(pCache) then begin
// Check if FCacheStreamPosition is in range
if Assigned(pCache^.Buffer) then begin
if (FCacheStreamPosition>=pCache^.PageBegin) and (FCacheStreamPosition<pCache^.PageBegin+FStreamCachePageSize) then begin
// Position is in range, so write data up to end of page
lPositionInPage:=(FCacheStreamPosition-pCache^.PageBegin);
lAvailableInThisPage:=FStreamCachePageSize - lPositionInPage;
if lAvailableInThisPage>=Count then begin
move(Buffer,(PBYTE(pCache^.Buffer)+lPositionInPage)^,Count);
if not pCache^.IsDirty then pCache^.IsDirty:=true;
inc(FCacheStreamPosition,Count);
// Update page size
if lPositionInPage+Count > pCache^.PageRealSize then pCache^.PageRealSize:=lPositionInPage+Count;
// Update file size
if FCacheStreamPosition>FCacheStreamSize then FCacheStreamSize:=FCacheStreamPosition;
Result:=Count;
pCache^.LastTick:=GetOpCounter;
exit;
end else begin
move(Buffer,(PBYTE(pCache^.Buffer)+lPositionInPage)^,lAvailableInThisPage);
if not pCache^.IsDirty then pCache^.IsDirty:=true;
inc(FCacheStreamPosition,lAvailableInThisPage);
// Update page size
if lPositionInPage+Count > pCache^.PageRealSize then pCache^.PageRealSize:=lPositionInPage+lAvailableInThisPage;
// Update file size
if FCacheStreamPosition>FCacheStreamSize then FCacheStreamSize:=FCacheStreamPosition;
Assert(pCache^.PageRealSize=FStreamCachePageSize,'This must not happend');
lNewBuffer:=PBYTE(@Buffer)+lAvailableInThisPage;
Result:=lAvailableInThisPage+DoCacheWrite(lNewBuffer^,Count-lAvailableInThisPage);
exit;
end;
end else begin
// The position is in other cache page or not in cache at all, so look for
// position in cached pages or allocate a new page.
if LookForPositionInPages then begin
Result:=DoCacheWrite(Buffer,Count);
exit;
end else begin
if ReadPageBeforeWrite then begin
Result:=DoCacheWrite(Buffer,Count);
end else begin
Result:=0;
end;
exit;
end;
end;
end else begin
if ReadPageBeforeWrite then begin
Result:=DoCacheWrite(Buffer,Count);
end else begin
Result:=0;
end;
exit;
end;
end else begin
// The page has been discarded for some unknown reason
Raise EStreamError.Create(SErrCacheUnexpectedPageDiscard);
end;
end;
function TBufferedFileStream.GetPosition: Int64;
begin
Result:=FCacheStreamPosition;
end;
procedure TBufferedFileStream.SetPosition(const Pos: Int64);
begin
if Pos<0 then begin
FCacheStreamPosition:=0;
end else begin
FCacheStreamPosition:=Pos;
end;
end;
function TBufferedFileStream.GetSize: Int64;
begin
Result:=FCacheStreamSize;
end;
procedure TBufferedFileStream.SetSize64(const NewSize: Int64);
var
j: integer;
pCache: PStreamCacheEntry;
begin
WriteDirtyPages;
inherited SetSize64(NewSize);
FCacheStreamSize:=inherited Seek(0,soFromEnd);
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
pCache:=FCachePages[j];
if Assigned(pCache^.Buffer) and (pCache^.PageRealSize+pCache^.PageBegin>FCacheStreamSize) then begin
// This page is out of bounds the new file size
// so discard it.
FreePage(pCache,True);
break;
end;
end;
end;
procedure TBufferedFileStream.SetSize(NewSize: Longint);
begin
SetSize64(NewSize);
end;
procedure TBufferedFileStream.SetSize(const NewSize: Int64);
begin
SetSize64(NewSize);
end;
constructor TBufferedFileStream.Create(const AFileName: string; Mode: Word);
begin
// Initialize with 8 blocks of 4096 bytes
InitializeCache(TSTREAMCACHEPAGE_SIZE_DEFAULT,TSTREAMCACHEPAGE_MAXCOUNT_DEFAULT);
inherited Create(AFileName,Mode);
FCacheStreamSize:=inherited Seek(int64(0),soEnd);
end;
constructor TBufferedFileStream.Create(const AFileName: string; Mode: Word;
Rights: Cardinal);
begin
// Initialize with 8 blocks of 4096 bytes
InitializeCache(TSTREAMCACHEPAGE_SIZE_DEFAULT,TSTREAMCACHEPAGE_MAXCOUNT_DEFAULT);
inherited Create(AFileName,Mode,Rights);
FCacheStreamSize:=inherited Seek(int64(0),soEnd);
end;
function TBufferedFileStream.Read(var Buffer; Count: Longint): Longint;
begin
Result:=DoCacheRead(Buffer,Count);
end;
function TBufferedFileStream.Write(const Buffer; Count: Longint): Longint;
begin
Result:=DoCacheWrite(Buffer,Count);
end;
procedure TBufferedFileStream.Flush;
begin
WriteDirtyPages;
end;
function TBufferedFileStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
Result:=Seek(int64(OffSet),TSeekOrigin(Origin));
end;
function TBufferedFileStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
lNewOffset: int64;
begin
Case Origin of
soEnd:
begin
lNewOffset:=FCacheStreamSize+Offset;
end;
soBeginning:
begin
lNewOffset:=0+Offset;
end;
soCurrent:
begin
lNewOffset:=FCacheStreamPosition+Offset;
end;
end;
if lNewOffset>0 then begin
FCacheStreamPosition:=lNewOffset;
Result:=lNewOffset;
end else begin
// This is compatible with FPC stream
// as it returns the negative value :-?
// but in fact does not move the read pointer.
Result:=-1;
end;
end;
procedure TBufferedFileStream.InitializeCache(const aCacheBlockSize: integer;
const aCacheBlockCount: integer);
var
j: integer;
begin
ClearCache;
FStreamCachePageSize:=aCacheBlockSize;
FStreamCachePageMaxCount:=aCacheBlockCount;
FCacheStreamSize:=inherited Seek(0,soEnd);
SetLength(FCachePages,FStreamCachePageMaxCount);
for j := 0 to Pred(FStreamCachePageMaxCount) do begin
FCachePages[j]:=New(PStreamCacheEntry);
FillByte(FCachePages[j]^,Sizeof(PStreamCacheEntry^),0);
end;
end;
destructor TBufferedFileStream.Destroy;
begin
ClearCache;
inherited Destroy;
end;
end. end.

View File

@ -124,7 +124,7 @@ Type
// simple parsing // simple parsing
procedure ParseValue; procedure ParseValue;
public public
constructor Create; constructor Create; override;
destructor Destroy; override; destructor Destroy; override;
// Source data stream // Source data stream
procedure SetSource(AStream: TStream); overload; procedure SetSource(AStream: TStream); overload;
@ -161,7 +161,7 @@ Type
procedure AppendStringToStream(const AString: String; AStream: TStream); procedure AppendStringToStream(const AString: String; AStream: TStream);
function QuoteCSVString(const AValue: String): String; function QuoteCSVString(const AValue: String): String;
public public
constructor Create; constructor Create; override;
destructor Destroy; override; destructor Destroy; override;
// Set output/destination stream. // Set output/destination stream.
// If not called, output is sent to DefaultOutput // If not called, output is sent to DefaultOutput
@ -455,6 +455,7 @@ var
b: packed array[0..2] of byte; b: packed array[0..2] of byte;
n: Integer; n: Integer;
begin begin
B[0]:=0; B[1]:=0; B[2]:=0;
ClearOutput; ClearOutput;
FSourceStream.Seek(0, soFromBeginning); FSourceStream.Seek(0, soFromBeginning);
if FDetectBOM then if FDetectBOM then
@ -533,6 +534,7 @@ begin
if StreamSize > 0 then if StreamSize > 0 then
begin begin
SetLength(Result, StreamSize); SetLength(Result, StreamSize);
FDefaultOutput.Position:=0;
FDefaultOutput.ReadBuffer(Result[1], StreamSize); FDefaultOutput.ReadBuffer(Result[1], StreamSize);
end; end;
end; end;

View File

@ -1382,15 +1382,8 @@ begin
slLines.LoadFromFile(FFileName) slLines.LoadFromFile(FFileName)
else else
begin begin
slLines.DefaultEncoding := FEncoding; slLines.DefaultEncoding := FEncoding; // TStrings clones the encoding.
slLines.LoadFromFile(FFileName, nil); slLines.LoadFromFile(FFileName, nil);
if FEncoding <> slLines.Encoding then
begin
if FOwnsEncoding then
FEncoding.Free;
FEncoding := slLines.Encoding;
FOwnsEncoding := not TEncoding.IsStandardEncoding(FEncoding);
end;
end; end;
FillSectionList(slLines); FillSectionList(slLines);
finally finally

View File

@ -308,7 +308,6 @@ end;
// Clear (virtually) a single char in position Position // Clear (virtually) a single char in position Position
function TMaskUtils.ClearChar(Position: Integer): Char; function TMaskUtils.ClearChar(Position: Integer): Char;
begin begin
Result := FMask[Position];
//For Delphi compatibilty, only literals remain, all others will be blanked //For Delphi compatibilty, only literals remain, all others will be blanked
case CharToMask(FMask[Position]) Of case CharToMask(FMask[Position]) Of
Char_Number, Char_Number,
@ -334,6 +333,8 @@ begin
Char_AllFixedDownCase: Result := FSpaceChar; Char_AllFixedDownCase: Result := FSpaceChar;
Char_HourSeparator: Result := DefaultFormatSettings.TimeSeparator; Char_HourSeparator: Result := DefaultFormatSettings.TimeSeparator;
Char_DateSeparator: Result := DefaultFormatSettings.DateSeparator; Char_DateSeparator: Result := DefaultFormatSettings.DateSeparator;
else
Result := FMask[Position];
end; end;
end; end;

View File

@ -181,7 +181,6 @@ type
TStreamHelper = class helper for TStream TStreamHelper = class helper for TStream
function ReadWordLE :word; function ReadWordLE :word;
function ReadDWordLE:dword; function ReadDWordLE:dword;
function ReadQWordLE:qword; function ReadQWordLE:qword;
@ -198,7 +197,6 @@ type
function ReadDouble:Double; function ReadDouble:Double;
procedure WriteSingle(s:Single); procedure WriteSingle(s:Single);
procedure WriteDouble(d:double); procedure WriteDouble(d:double);
{$ifndef FPC} {$ifndef FPC}
function ReadByte : Byte; function ReadByte : Byte;
function ReadWord : Word; function ReadWord : Word;

View File

@ -1,14 +1,15 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<CONFIG> <CONFIG>
<ProjectOptions> <ProjectOptions>
<Version Value="9"/> <Version Value="12"/>
<General> <General>
<Flags> <Flags>
<SaveOnlyProjectUnits Value="True"/>
<MainUnitHasCreateFormStatements Value="False"/> <MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/> <MainUnitHasTitleStatement Value="False"/>
<CompatibilityMode Value="True"/>
</Flags> </Flags>
<SessionStorage Value="InProjectDir"/> <SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="fclbase-unittests"/> <Title Value="fclbase-unittests"/>
<UseAppBundle Value="False"/> <UseAppBundle Value="False"/>
<ResourceType Value="res"/> <ResourceType Value="res"/>
@ -16,28 +17,29 @@
<i18n> <i18n>
<EnableI18N LFM="False"/> <EnableI18N LFM="False"/>
</i18n> </i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1"> <BuildModes Count="1">
<Item1 Name="Default" Default="True"/> <Item1 Name="Default" Default="True"/>
</BuildModes> </BuildModes>
<PublishOptions> <PublishOptions>
<Version Value="2"/> <Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions> </PublishOptions>
<RunParams> <RunParams>
<local> <local>
<FormatVersion Value="1"/>
<CommandLineParams Value="--suite=TTestCSVReadWrite.TestInlineQuotedLine"/> <CommandLineParams Value="--suite=TTestCSVReadWrite.TestInlineQuotedLine"/>
</local> </local>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default">
<local>
<CommandLineParams Value="--suite=TTestCSVReadWrite.TestInlineQuotedLine"/>
</local>
</Mode0>
</Modes>
</RunParams> </RunParams>
<Units Count="6"> <Units Count="7">
<Unit0> <Unit0>
<Filename Value="fclbase-unittests.pp"/> <Filename Value="fclbase-unittests.pp"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="fclbase_unittests"/>
</Unit0> </Unit0>
<Unit1> <Unit1>
<Filename Value="tchashlist.pp"/> <Filename Value="tchashlist.pp"/>
@ -59,6 +61,10 @@
<Filename Value="tccsvreadwrite.pp"/> <Filename Value="tccsvreadwrite.pp"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
</Unit5> </Unit5>
<Unit6>
<Filename Value="tcbufferedfilestream.pp"/>
<IsPartOfProject Value="True"/>
</Unit6>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>

View File

@ -4,7 +4,7 @@ program fclbase_unittests;
uses uses
Classes, consoletestrunner, tests_fptemplate, tchashlist, Classes, consoletestrunner, tests_fptemplate, tchashlist,
testexprpars, tcmaskutils, tcinifile, tccsvreadwrite; testexprpars, tcmaskutils, tcinifile, tccsvreadwrite,tcbufferedfilestream;
var var
Application: TTestRunner; Application: TTestRunner;

View File

@ -0,0 +1,393 @@
unit tcbufferedfilestream;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testregistry, bufstream;
type
{ TTestBufferedFileStream }
TTestBufferedFileStream= class(TTestCase)
private
const
TEST_RANDOM_READS=10000;
TEST_SEQUENTIAL_READS=1000000;
TEST_FILENAME='testfile.bin';
TEST_WRITEC_FILE='testwritecache.bin';
TEST_WRITEF_FILE='testwritedirec.bin';
private
function CompareStreams(const aStream1: TStream; const aStream2: TStream): Boolean;
protected
procedure SetUp; override;
procedure TearDown; override;
published
procedure TestCacheRead;
procedure TestCacheWrite;
procedure TestCacheSeek;
end;
implementation
procedure TTestBufferedFileStream.TestCacheRead;
var
lBufferedStream: TBufferedFileStream;
lStream: TFileStream;
b: array [0..10000-1] of char;
j,k: integer;
lBytesToRead: integer;
lEffectiveRead: integer;
{$IFDEF CHECK_AGAINST_FILE}
lEffectiveRead2: integer;
{$ENDIF}
lReadPosition: int64;
lCheckInitV: integer;
lTick: QWord;
begin
b[0]:=#0; // Avoid initalization hint
lBufferedStream:=TBufferedFileStream.Create(TEST_FILENAME,fmOpenRead or fmShareDenyWrite);
lStream:=TFileStream.Create(TEST_FILENAME,fmOpenRead or fmShareDenyWrite);
try
RandSeed:=1;
Randomize;
lTick:=GetTickCount64;
for j := 0 to Pred(TEST_RANDOM_READS) do begin
lBytesToRead:=Random(10000);
lReadPosition:=Random(lBufferedStream.Size);
lBufferedStream.Position:=lReadPosition;
lEffectiveRead:=lBufferedStream.Read(b,lBytesToRead);
{$IFDEF CHECK_AGAINST_FILE}
// Now read without cache
lStream.Position:=lReadPosition;
lEffectiveRead2:=lStream.Read(b2,lBytesToRead);
if lEffectiveRead<>lEffectiveRead2 then begin
FAIL('Read length mismatch');
end;
if not CompareMem(@b[0],@b2[0],lEffectiveRead) then begin
FAIL('Compare buffer data error');
end;
F.Position:=0;
{$ELSE}
lCheckInitV:=lReadPosition mod 10;
for k := 0 to Pred(lEffectiveRead) do begin
if b[k]<>char(ord('0')+lCheckInitV mod 10) then begin
FAIL('Expected data error');
end;
inc(lCheckInitV);
end;
{$ENDIF}
end;
// Writeln('CACHE ',TEST_RANDOM_READS,' random reads in ',GetTickCount64-lTick,' ms.');
RandSeed:=1;
Randomize;
// Writeln('Same operation without cache');
lTick:=GetTickCount64;
for j := 0 to Pred(TEST_RANDOM_READS) do begin
lBytesToRead:=Random(10000);
lReadPosition:=Random(lBufferedStream.Size);
lStream.Position:=lReadPosition;
lEffectiveRead:=lStream.Read(b,lBytesToRead);
lCheckInitV:=lReadPosition mod 10;
for k := 0 to Pred(lEffectiveRead) do begin
if b[k]<>char(ord('0')+lCheckInitV mod 10) then begin
FAIL('Expected data error');
end;
inc(lCheckInitV);
end;
end;
// Writeln('FILE ',TEST_RANDOM_READS,' random reads in ',GetTickCount64-lTick,' ms.');
// Writeln('Check sequential read');
RandSeed:=1;
Randomize;
lTick:=GetTickCount64;
lBytesToRead:=1;
lReadPosition:=0;
lBufferedStream.Position:=lReadPosition;
lStream.Position:=lReadPosition;
for j := 0 to Pred(TEST_SEQUENTIAL_READS) do begin
lEffectiveRead:=lBufferedStream.Read(b,lBytesToRead);
{$IFDEF CHECK_AGAINST_FILE}
// Now read without cache
lEffectiveRead2:=lStream.Read(b2,lBytesToRead);
if lEffectiveRead<>lEffectiveRead2 then begin
FAIL('Read length mismatch');
end;
if not CompareMem(@b[0],@b2[0],lEffectiveRead) then begin
FAIL('Compare buffer data error');
end;
F.Position:=0;
{$ELSE}
lCheckInitV:=lReadPosition mod 10;
for k := 0 to Pred(lEffectiveRead) do begin
if b[k]<>char(ord('0')+lCheckInitV mod 10) then begin
FAIL('Expected data error');
end;
inc(lCheckInitV);
end;
{$ENDIF}
inc(lReadPosition,lBytesToRead);
end;
// Writeln('CACHE ',TEST_SEQUENTIAL_READS,' byte sequential reads in ',GetTickCount64-lTick,' ms.');
RandSeed:=1;
Randomize;
lTick:=GetTickCount64;
lBytesToRead:=1;
lReadPosition:=0;
lStream.Position:=lReadPosition;
for j := 0 to Pred(TEST_SEQUENTIAL_READS) do begin
lEffectiveRead:=lStream.Read(b,lBytesToRead);
lCheckInitV:=lReadPosition mod 10;
for k := 0 to Pred(lEffectiveRead) do begin
if b[k]<>char(ord('0')+lCheckInitV mod 10) then begin
FAIL('Expected data error');
end;
inc(lCheckInitV);
end;
inc(lReadPosition,lBytesToRead);
end;
// Writeln('FILE ',TEST_SEQUENTIAL_READS,' byte sequential reads in ',GetTickCount64-lTick,' ms.');
// Writeln('CACHE Trying read beyond limits');
lBufferedStream.Position:=lBufferedStream.Size-1;
lEffectiveRead:=lBufferedStream.Read(b,2);
if lEffectiveRead<>1 then begin
FAIL('Read beyond limits, returned bytes: '+inttostr(lEffectiveRead));
end else begin
// Writeln('CACHE OK, read beyond limits returns 0 bytes.');
end;
finally
lBufferedStream.Free;
lStream.Free;
end;
end;
procedure TTestBufferedFileStream.TestCacheWrite;
const
EXPECTED_SIZE=10000000;
TEST_ROUNDS=100000;
var
lBufferedStream: TBufferedFileStream;
lStream: TFileStream;
lVerifyStream1,lVerifyStream2: TFileStream;
b: array [0..10000-1] of char;
j: integer;
lBytesToWrite: integer;
lWritePosition: int64;
begin
// Writeln('Testing write cache');
// All test should return the same random sequence
RandSeed:=1;
Randomize;
for j := 0 to Pred(10000) do begin
b[j]:='0';
end;
lBufferedStream:=TBufferedFileStream.Create(TEST_WRITEC_FILE,fmCreate);
lStream:=TFileStream.Create(TEST_WRITEF_FILE,fmCreate);
try
for j := 0 to Pred(EXPECTED_SIZE div Sizeof(b)) do begin
lBufferedStream.Write(b,sizeof(b));
lStream.Write(b,sizeof(b));
end;
for j := 0 to Pred(Sizeof(b)) do begin
b[j]:=char(ord('0')+j mod 10);
end;
finally
lBufferedStream.Free;
lStream.Free;
end;
lBufferedStream:=TBufferedFileStream.Create(TEST_WRITEC_FILE,fmOpenReadWrite);
lStream:=TFileStream.Create(TEST_WRITEF_FILE,fmOpenWrite);
try
for j := 0 to Pred(TEST_ROUNDS) do begin
if lStream.Size<>lBufferedStream.Size then begin
FAIL('Mismatched lengths');
end;
lWritePosition:=Random(EXPECTED_SIZE);
lBytesToWrite:=Random(sizeof(b));
lBufferedStream.Position:=lWritePosition;
lStream.Position:=lWritePosition;
lBufferedStream.Write(b,lBytesToWrite);
lStream.Write(b,lBytesToWrite);
// if j mod 1273 = 0 then write(j,' / ',TEST_ROUNDS,#13);
end;
// Writeln(TEST_ROUNDS,' / ',TEST_ROUNDS);
if lStream.Size<>lBufferedStream.Size then begin
FAIL('Mismatched lengths');
end;
finally
lBufferedStream.Free;
lStream.Free;
end;
// Verify both generated files are identical.
lVerifyStream1:=TFileStream.Create(TEST_WRITEC_FILE,fmOpenRead or fmShareDenyWrite);
lVerifyStream2:=TFileStream.Create(TEST_WRITEF_FILE,fmOpenRead or fmShareDenyWrite);
try
if not CompareStreams(lVerifyStream1,lVerifyStream2) then begin
FAIL('Streams are different!!');
end else begin
// Writeln('Streams are identical. OK.');
end;
finally
lVerifyStream1.Free;
lVerifyStream2.Free;
end;
end;
procedure TTestBufferedFileStream.TestCacheSeek;
var
lBufferedStream: TBufferedFileStream;
lStream: TFileStream;
bBuffered: array [0..10000] of BYTE;
bStream: array [0..10000] of BYTE;
bread : Integer;
begin
bBuffered[0]:=0; // Avoid initalization hint
bStream[0]:=0; // Avoid initalization hint
lBufferedStream:=TBufferedFileStream.Create(TEST_FILENAME,fmOpenRead or fmShareDenyWrite);
lStream:=TFileStream.Create(TEST_FILENAME,fmOpenRead or fmShareDenyWrite);
try
// Writeln('Set position=-1');
lStream.Position:=-1;
// Writeln('TFileStream position=',lStream.Position);
lBufferedStream.Position:=-1;
// Writeln('Buffered position=',lBufferedStream.Position);
if lStream.Position<>lBufferedStream.Position then begin
FAIL('Positions are not the same.');
end else begin
// Writeln('Positions are the same.');
end;
// Writeln('Read data when position=-1');
bread:=lStream.Read(bBuffered[0],10);
// Writeln('TFileStream read bytes : ',bread);
// Writeln('TFileStream end position: ',lStream.Position);
bread:=lBufferedStream.Read(bStream[0],10);
// Writeln('Buffered read bytes: ',bread);
// Writeln('Buffered end position: ',lBufferedStream.Position);
if (not CompareMem(@bBuffered[0],@bStream[0],10)) or (lStream.Position<>lBufferedStream.Position) then begin
FAIL('Read data or positions are not the same.');
end else begin
// Writeln('Read data at -1 is the same.');
end;
// Writeln('Testing Seek operations');
// Writeln('Seek -1 from beginning');
bread:=lStream.Seek(-1,soBeginning);
// Writeln('Stream seek result : ',bread);
bread:=lBufferedStream.Seek(-1,soBeginning);
// Writeln('Buffered seek result: ',);
// Writeln('Read data when Seek -1');
bread:=lStream.Read(bBuffered[0],10);
// Writeln('TFileStream read bytes : ',bread);
// Writeln('TFileStream end position: ',lStream.Position);
bread:=lBufferedStream.Read(bStream[0],10);
// Writeln('Buffered read bytes: ',bread);
// Writeln('Buffered end position: ',lBufferedStream.Position);
if (not CompareMem(@bBuffered[0],@bStream[0],10)) or (lStream.Position<>lBufferedStream.Position) then begin
FAIL('Read data or positions are not the same.');
end else begin
// Writeln('Read data at -1 is the same.');
end;
// Writeln('Seek -current*2 from current');
bread:=lStream.Seek(lStream.Position*-2,soCurrent);
// Writeln('Stream seek result : ',bread);
bread:=lBufferedStream.Seek(lBufferedStream.Position*-2,soCurrent);
// Writeln('Buffered seek result: ',bread);
// Writeln('Read data when Seek from current -current*2');
bread:=lStream.Read(bBuffered[0],10);
// Writeln('TFileStream read bytes : ',bread);
// Writeln('TFileStream end position: ',lStream.Position);
bread:=lBufferedStream.Read(bStream[0],10);
// Writeln('Buffered read bytes: ',);
// Writeln('Buffered end position: ',lBufferedStream.Position);
if (not CompareMem(@bBuffered[0],@bStream[0],10)) or (lStream.Position<>lBufferedStream.Position) then begin
FAIL('Read data or positions are not the same.');
end else begin
// Writeln('Read data at -current*2 is the same.');
end;
finally
lBufferedStream.Free;
lStream.Free;
end;
end;
procedure TTestBufferedFileStream.SetUp;
var
F: TFileStream;
b: array [0..10000-1] of char;
j: integer;
begin
for j := 0 to Pred(10000) do begin
b[j]:=char(ord('0')+j mod 10);
end;
F:=TFileStream.Create(TEST_FILENAME,fmCreate);
for j := 0 to Pred(1000) do begin
F.Write(b,sizeof(b));
end;
F.Free;
end;
procedure TTestBufferedFileStream.TearDown;
begin
DeleteFile(TEST_FILENAME);
DeleteFile(TEST_WRITEC_FILE);
DeleteFile(TEST_WRITEF_FILE);
end;
function TTestBufferedFileStream.CompareStreams(const aStream1: TStream;
const aStream2: TStream): Boolean;
const
BUFFER_SIZE=5213; // Odd number
var
b1: array [0..BUFFER_SIZE-1] of BYTE;
b2: array [0..BUFFER_SIZE-1] of BYTE;
lReadBytes: integer;
lAvailable: integer;
lEffectiveRead1: integer;
lEffectiveRead2: integer;
begin
b1[0]:=0; // Avoid initalization hint
b2[0]:=0; // Avoid initalization hint
Result:=false;
if aStream1.Size<>aStream2.Size then exit;
aStream1.Position:=0;
aStream2.Position:=0;
while aStream1.Position<aStream1.Size do begin
lAvailable:=aStream1.Size-aStream1.Position;
if lAvailable>=BUFFER_SIZE then begin
lReadBytes:=BUFFER_SIZE;
end else begin
lReadBytes:=aStream1.Size-aStream1.Position;
end;
lEffectiveRead1:=aStream1.Read(b1[0],lReadBytes);
lEffectiveRead2:=aStream2.Read(b2[0],lReadBytes);
if lEffectiveRead1<>lEffectiveRead2 then exit;
if not CompareMem(@b1[0],@b2[0],lEffectiveRead1) then exit;
end;
Result:=true;
end;
initialization
RegisterTest(TTestBufferedFileStream);
end.

View File

@ -1033,7 +1033,7 @@ begin
end; end;
end; end;
Function ResolveAddressAt(Resolver : Integer; Address : String; Var Names : Array of String) : Integer; Function ResolveAddressAt(Resolver : Integer; Address : String; Var Names : Array of String; Recurse: Integer) : Integer;
Var Var
@ -1056,13 +1056,29 @@ begin
I:=0; I:=0;
While (I<=MaxAnswer) and NextRR(Ans.Payload,AnsStart,AnsLen,RR) do While (I<=MaxAnswer) and NextRR(Ans.Payload,AnsStart,AnsLen,RR) do
begin begin
if (Ntohs(RR.AType)=DNSQRY_PTR) and (1=NtoHS(RR.AClass)) then Case Ntohs(RR.AType) of
DNSQRY_PTR:
if (1=NtoHS(RR.AClass)) then
begin begin
Names[i]:=BuildName(Ans.Payload,AnsStart,AnsLen); Names[i]:=BuildName(Ans.Payload,AnsStart,AnsLen);
inc(Result); inc(Result);
RR.RDLength := ntohs(RR.RDLength); RR.RDLength := ntohs(RR.RDLength);
Inc(AnsStart,RR.RDLength); Inc(AnsStart,RR.RDLength);
end; end;
DNSQRY_CNAME:
begin
if Recurse >= MaxRecursion then
begin
Result := -1;
exit;
end;
rr.rdlength := ntohs(rr.rdlength);
setlength(Address, rr.rdlength);
address := stringfromlabel(ans.payload, ansstart);
Result := ResolveAddressAt(Resolver, Address, Names, Recurse+1);
exit;
end;
end;
Inc(I); Inc(I);
end; end;
end; end;
@ -1084,7 +1100,7 @@ begin
S:=Format('%d.%d.%d.%d.in-addr.arpa',[nt.s_bytes[4],nt.s_bytes[3],nt.s_bytes[2],nt.s_bytes[1]]); S:=Format('%d.%d.%d.%d.in-addr.arpa',[nt.s_bytes[4],nt.s_bytes[3],nt.s_bytes[2],nt.s_bytes[1]]);
While (Result=0) and (I<=high(DNSServers)) do While (Result=0) and (I<=high(DNSServers)) do
begin begin
Result:=ResolveAddressAt(I,S,Addresses); Result:=ResolveAddressAt(I,S,Addresses,1);
Inc(I); Inc(I);
end; end;
end; end;
@ -1111,7 +1127,7 @@ begin
I := 0; I := 0;
While (Result=0) and (I<=high(DNSServers)) do While (Result=0) and (I<=high(DNSServers)) do
begin begin
Result:=ResolveAddressAt(I,S,Addresses); Result:=ResolveAddressAt(I,S,Addresses,1);
Inc(I); Inc(I);
end; end;
end; end;

View File

@ -1156,7 +1156,7 @@ var
procedure ErrClearError; procedure ErrClearError;
procedure ErrFreeStrings; procedure ErrFreeStrings;
procedure ErrRemoveState(pid: cInt); procedure ErrRemoveState(pid: cInt);
procedure RandScreen; procedure RandScreen; deprecated 'Deprecated as of 1.1+';
function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr;
function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): cInt; function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): cInt;
procedure PKCS12free(p12: SslPtr); procedure PKCS12free(p12: SslPtr);
@ -5663,8 +5663,6 @@ begin
_SslLoadErrorStrings; _SslLoadErrorStrings;
if assigned(_OPENSSLaddallalgorithms) then if assigned(_OPENSSLaddallalgorithms) then
_OPENSSLaddallalgorithms; _OPENSSLaddallalgorithms;
if assigned(_RandScreen) then
_RandScreen;
if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then
InitLocks; InitLocks;
SSLloaded := True; SSLloaded := True;

View File

@ -145,6 +145,8 @@ type
procedure DescrEndItalic; override; procedure DescrEndItalic; override;
procedure DescrBeginEmph; override; procedure DescrBeginEmph; override;
procedure DescrEndEmph; override; procedure DescrEndEmph; override;
procedure DescrBeginUnderline; override;
procedure DescrEndUnderline; override;
procedure DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); override; procedure DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); override;
procedure DescrWriteFileEl(const AText: DOMString); override; procedure DescrWriteFileEl(const AText: DOMString); override;
procedure DescrWriteKeywordEl(const AText: DOMString); override; procedure DescrWriteKeywordEl(const AText: DOMString); override;
@ -1101,6 +1103,16 @@ begin
PopOutputNode; PopOutputNode;
end; end;
procedure THTMLWriter.DescrBeginUnderline;
begin
PushOutputNode(CreateEl(CurOutputNode, 'u'));
end;
procedure THTMLWriter.DescrEndUnderline;
begin
PopOutputNode;
end;
procedure THTMLWriter.DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); procedure THTMLWriter.DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString);
Var Var

View File

@ -87,6 +87,8 @@ Type
procedure DescrEndItalic; override; procedure DescrEndItalic; override;
procedure DescrBeginEmph; override; procedure DescrBeginEmph; override;
procedure DescrEndEmph; override; procedure DescrEndEmph; override;
procedure DescrBeginUnderline; override;
procedure DescrEndUnderline; override;
procedure DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); override; procedure DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); override;
procedure DescrWriteFileEl(const AText: DOMString); override; procedure DescrWriteFileEl(const AText: DOMString); override;
procedure DescrWriteKeywordEl(const AText: DOMString); override; procedure DescrWriteKeywordEl(const AText: DOMString); override;
@ -287,6 +289,16 @@ begin
Write('}'); Write('}');
end; end;
procedure TLaTeXWriter.DescrBeginUnderline;
begin
Write('\underline{');
end;
procedure TLaTeXWriter.DescrEndUnderline;
begin
Write('}');
end;
procedure TLaTeXWriter.DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); procedure TLaTeXWriter.DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString);
Var Var

View File

@ -121,6 +121,8 @@ type
procedure DescrEndItalic; override; procedure DescrEndItalic; override;
procedure DescrBeginEmph; override; procedure DescrBeginEmph; override;
procedure DescrEndEmph; override; procedure DescrEndEmph; override;
procedure DescrBeginUnderline; override;
procedure DescrEndUnderline; override;
procedure DescrWriteFileEl(const AText: DOMString); override; procedure DescrWriteFileEl(const AText: DOMString); override;
procedure DescrWriteKeywordEl(const AText: DOMString); override; procedure DescrWriteKeywordEl(const AText: DOMString); override;
procedure DescrWriteVarEl(const AText: DOMString); override; procedure DescrWriteVarEl(const AText: DOMString); override;
@ -344,6 +346,16 @@ begin
Write('}') Write('}')
end; end;
procedure TRTFWriter.DescrBeginUnderline;
begin
Write('{\ul ');
end;
procedure TRTFWriter.DescrEndUnderline;
begin
Write('}');
end;
procedure TRTFWriter.DescrWriteFileEl(const AText: DOMString); procedure TRTFWriter.DescrWriteFileEl(const AText: DOMString);
begin begin
Write('{\f0 '); Write('{\f0 ');

View File

@ -138,6 +138,8 @@ Type
procedure DescrEndItalic; override; procedure DescrEndItalic; override;
procedure DescrBeginEmph; override; procedure DescrBeginEmph; override;
procedure DescrEndEmph; override; procedure DescrEndEmph; override;
procedure DescrBeginUnderline; override;
procedure DescrEndUnderline; override;
procedure DescrWriteFileEl(const AText: DOMString); override; procedure DescrWriteFileEl(const AText: DOMString); override;
procedure DescrWriteKeywordEl(const AText: DOMString); override; procedure DescrWriteKeywordEl(const AText: DOMString); override;
procedure DescrWriteVarEl(const AText: DOMString); override; procedure DescrWriteVarEl(const AText: DOMString); override;
@ -425,6 +427,17 @@ begin
NewLine; NewLine;
end; end;
procedure TManWriter.DescrBeginUnderline;
begin
NewLine;
Write('.I '); //use ITALIC!
end;
procedure TManWriter.DescrEndUnderline;
begin
NewLine;
end;
procedure TManWriter.DescrWriteFileEl(const AText: DOMString); procedure TManWriter.DescrWriteFileEl(const AText: DOMString);
Var Var

View File

@ -89,6 +89,8 @@ Type
procedure DescrEndItalic; override; procedure DescrEndItalic; override;
procedure DescrBeginEmph; override; procedure DescrBeginEmph; override;
procedure DescrEndEmph; override; procedure DescrEndEmph; override;
procedure DescrBeginUnderline; override;
procedure DescrEndUnderline; override;
procedure DescrWriteFileEl(const AText: DOMString); override; procedure DescrWriteFileEl(const AText: DOMString); override;
procedure DescrWriteKeywordEl(const AText: DOMString); override; procedure DescrWriteKeywordEl(const AText: DOMString); override;
procedure DescrWriteVarEl(const AText: DOMString); override; procedure DescrWriteVarEl(const AText: DOMString); override;
@ -270,6 +272,14 @@ procedure TTXTWriter.DescrEndEmph;
begin begin
end; end;
procedure TTXTWriter.DescrBeginUnderline;
begin
end;
procedure TTXTWriter.DescrEndUnderline;
begin
end;
procedure TTXTWriter.DescrWriteFileEl(const AText: DOMString); procedure TTXTWriter.DescrWriteFileEl(const AText: DOMString);
begin begin
DescrWriteText(AText); DescrWriteText(AText);

View File

@ -117,6 +117,8 @@ type
procedure DescrEndBold; virtual; abstract; procedure DescrEndBold; virtual; abstract;
procedure DescrBeginItalic; virtual; abstract; procedure DescrBeginItalic; virtual; abstract;
procedure DescrEndItalic; virtual; abstract; procedure DescrEndItalic; virtual; abstract;
procedure DescrBeginUnderline; virtual; abstract;
procedure DescrEndUnderline; virtual; abstract;
procedure DescrBeginEmph; virtual; abstract; procedure DescrBeginEmph; virtual; abstract;
procedure DescrEndEmph; virtual; abstract; procedure DescrEndEmph; virtual; abstract;
procedure DescrWriteImageEl(const AFileName, ACaption,ALinkName : DOMString); virtual; procedure DescrWriteImageEl(const AFileName, ACaption,ALinkName : DOMString); virtual;
@ -637,6 +639,12 @@ begin
ConvertBaseShortList(AContext, Node, False); ConvertBaseShortList(AContext, Node, False);
DescrEndEmph; DescrEndEmph;
end else end else
if Node.NodeName = 'u' then
begin
DescrBeginUnderline;
ConvertBaseShortList(AContext, Node, False);
DescrEndUnderline;
end else
if Node.NodeName = 'file' then if Node.NodeName = 'file' then
DescrWriteFileEl(ConvertTextContent) DescrWriteFileEl(ConvertTextContent)
else if Node.NodeName = 'kw' then else if Node.NodeName = 'kw' then