paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-03 10:38:45 +02:00
Code Issues Packages Projects Releases Wiki Activity

* merge revs

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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/tests/fclbase-unittests.lpi 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/tchashlist.pp svneol=native#text/plain
packages/fcl-base/tests/tcinifile.pp svneol=native#text/plain

594
packages/fcl-base/src/bufstream.pp
View File

@ -3,6 +3,7 @@
Copyright (c) 1999-2000 by the Free Pascal development team
Implement a buffered stream.
TBufferedFileStream contributed by José Mejuto, bug ID 30549.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -27,8 +28,10 @@ Const
Type
{ ---------------------------------------------------------------------
TBufStream - simple read or write buffer, for sequential reading/writing
---------------------------------------------------------------------}
{ TBufStream }
TBufStream = Class(TOwnerStream)
Private
FTotalPos : Int64;
@ -70,12 +73,83 @@ Type
Function Write(Const ABuffer; ACount : LongInt) : Integer; override;
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
Resourcestring
SErrCapacityTooSmall = 'Capacity is less than actual buffer size.';
SErrCapacityTooSmall = 'Capacity is less than actual buffer size.';
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 }
@ -257,4 +331,518 @@ begin
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.

6
packages/fcl-base/src/csvreadwrite.pp
View File

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

11
packages/fcl-base/src/inifiles.pp
View File

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

3
packages/fcl-base/src/maskutils.pp
View File

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

56
packages/fcl-base/src/streamex.pp
View File

@ -181,35 +181,33 @@ type
TStreamHelper = class helper for TStream
function ReadWordLE :word;
function ReadDWordLE:dword;
function ReadQWordLE:qword;
procedure WriteWordLE (w:word);
procedure WriteDWordLE(dw:dword);
procedure WriteQWordLE(dq:qword);
function ReadWordBE :word;
function ReadDWordBE:dword;
function ReadQWordBE:qword;
procedure WriteWordBE (w:word);
procedure WriteDWordBE(dw:dword);
procedure WriteQWordBE(dq:qword);
function ReadSingle:Single;
function ReadDouble:Double;
procedure WriteSingle(s:Single);
procedure WriteDouble(d:double);
{$ifndef FPC}
function ReadByte : Byte;
function ReadWord : Word;
function ReadDWord : DWord;
function ReadQWord : QWord;
procedure WriteByte (b : Byte);
procedure WriteWord (b : word);
procedure WriteDWord (b : DWord);
procedure WriteQWord (b : QWord);
{$endif}
end;
function ReadWordLE :word;
function ReadDWordLE:dword;
function ReadQWordLE:qword;
procedure WriteWordLE (w:word);
procedure WriteDWordLE(dw:dword);
procedure WriteQWordLE(dq:qword);
function ReadWordBE :word;
function ReadDWordBE:dword;
function ReadQWordBE:qword;
procedure WriteWordBE (w:word);
procedure WriteDWordBE(dw:dword);
procedure WriteQWordBE(dq:qword);
function ReadSingle:Single;
function ReadDouble:Double;
procedure WriteSingle(s:Single);
procedure WriteDouble(d:double);
{$ifndef FPC}
function ReadByte : Byte;
function ReadWord : Word;
function ReadDWord : DWord;
function ReadQWord : QWord;
procedure WriteByte (b : Byte);
procedure WriteWord (b : word);
procedure WriteDWord (b : DWord);
procedure WriteQWord (b : QWord);
{$endif}
end;
Implementation

26
packages/fcl-base/tests/fclbase-unittests.lpi
View File

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

2
packages/fcl-base/tests/fclbase-unittests.pp
View File

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

393
packages/fcl-base/tests/tcbufferedfilestream.pp Normal file
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.

36
packages/fcl-net/src/netdb.pp
View File

@ -1033,7 +1033,7 @@ begin
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
@ -1056,13 +1056,29 @@ begin
I:=0;
While (I<=MaxAnswer) and NextRR(Ans.Payload,AnsStart,AnsLen,RR) do
begin
if (Ntohs(RR.AType)=DNSQRY_PTR) and (1=NtoHS(RR.AClass)) then
begin
Names[i]:=BuildName(Ans.Payload,AnsStart,AnsLen);
inc(Result);
RR.RDLength := ntohs(RR.RDLength);
Inc(AnsStart,RR.RDLength);
end;
Case Ntohs(RR.AType) of
DNSQRY_PTR:
if (1=NtoHS(RR.AClass)) then
begin
Names[i]:=BuildName(Ans.Payload,AnsStart,AnsLen);
inc(Result);
RR.RDLength := ntohs(RR.RDLength);
Inc(AnsStart,RR.RDLength);
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);
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]]);
While (Result=0) and (I<=high(DNSServers)) do
begin
Result:=ResolveAddressAt(I,S,Addresses);
Result:=ResolveAddressAt(I,S,Addresses,1);
Inc(I);
end;
end;
@ -1111,7 +1127,7 @@ begin
I := 0;
While (Result=0) and (I<=high(DNSServers)) do
begin
Result:=ResolveAddressAt(I,S,Addresses);
Result:=ResolveAddressAt(I,S,Addresses,1);
Inc(I);
end;
end;

4
packages/openssl/src/openssl.pas
View File

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

12
utils/fpdoc/dw_html.pp
View File

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

12
utils/fpdoc/dw_latex.pp
View File

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

12
utils/fpdoc/dw_linrtf.pp
View File

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

13
utils/fpdoc/dw_man.pp
View File

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

10
utils/fpdoc/dw_txt.pp
View File

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

8
utils/fpdoc/dwriter.pp
View File

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