pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

fpspreadsheet: Unit tests for hyperlinks. Some issues left.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4002 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2015-03-08 00:50:10 +00:00
parent 6d2e993c22
commit 2d76afb541
11 changed files with 218 additions and 131 deletions
Download Patch File Download Diff File Expand all files Collapse all files

93
components/fpspreadsheet/fpsopendocument.pas
View File

@ -23,7 +23,7 @@ AUTHORS: Felipe Monteiro de Carvalho / Jose Luis Jurado Rincon
unit fpsopendocument; unit fpsopendocument;
{$ifdef fpc} {$ifdef fpc}
{$mode delphi}{$H+} {$mode objfpc}{$H+}
{$endif} {$endif}
{.$define FPSPREADDEBUG} //used to be XLSDEBUG {.$define FPSPREADDEBUG} //used to be XLSDEBUG
@ -205,7 +205,7 @@ type
implementation implementation
uses uses
StrUtils, Variants, URIParser, StrUtils, Variants, LazFileUtils, URIParser,
fpsPatches, fpsStrings, fpsStreams, fpsExprParser; fpsPatches, fpsStrings, fpsStreams, fpsExprParser;
const const
@ -383,7 +383,7 @@ function TsSpreadOpenDocNumFormatParser.BuildDateTimeXMLAsString(ASection: Integ
var var
el: Integer; el: Integer;
s: String; s: String;
prevToken: TsNumFormatToken; prevTok: TsNumFormatToken;
begin begin
Result := ''; Result := '';
AIsTimeOnly := true; AIsTimeOnly := true;
@ -396,7 +396,7 @@ begin
case Elements[el].Token of case Elements[el].Token of
nftYear: nftYear:
begin begin
prevToken := Elements[el].Token; prevTok := Elements[el].Token;
AIsTimeOnly := false; AIsTimeOnly := false;
s := IfThen(Elements[el].IntValue > 2, 'number:style="long" ', ''); s := IfThen(Elements[el].IntValue > 2, 'number:style="long" ', '');
Result := Result + Result := Result +
@ -405,7 +405,7 @@ begin
nftMonth: nftMonth:
begin begin
prevToken := Elements[el].Token; prevTok := Elements[el].Token;
AIsTimeOnly := false; AIsTimeOnly := false;
case Elements[el].IntValue of case Elements[el].IntValue of
1: s := ''; 1: s := '';
@ -419,7 +419,7 @@ begin
nftDay: nftDay:
begin begin
prevToken := Elements[el].Token; prevTok := Elements[el].Token;
AIsTimeOnly := false; AIsTimeOnly := false;
case Elements[el].IntValue of case Elements[el].IntValue of
1: s := 'day '; 1: s := 'day ';
@ -433,7 +433,7 @@ begin
nftHour, nftMinute, nftSecond: nftHour, nftMinute, nftSecond:
begin begin
prevToken := Elements[el].Token; prevTok := Elements[el].Token;
case Elements[el].Token of case Elements[el].Token of
nftHour : s := 'hours '; nftHour : s := 'hours ';
nftMinute: s := 'minutes '; nftMinute: s := 'minutes ';
@ -460,7 +460,7 @@ begin
s := Elements[el].TextValue; s := Elements[el].TextValue;
if (s = '/') then if (s = '/') then
begin begin
if prevToken in [nftYear, nftMonth, nftDay] then if prevTok in [nftYear, nftMonth, nftDay] then
s := FWorkbook.FormatSettings.DateSeparator s := FWorkbook.FormatSettings.DateSeparator
else else
s := FWorkbook.FormatSettings.TimeSeparator; s := FWorkbook.FormatSettings.TimeSeparator;
@ -1461,52 +1461,51 @@ var
styleName: String; styleName: String;
childnode: TDOMNode; childnode: TDOMNode;
subnode: TDOMNode; subnode: TDOMNode;
spanNode: TDOMNode;
nodeName: String; nodeName: String;
s: String; s: String;
cell: PCell; cell: PCell;
hyperlink: string; hyperlink: string;
procedure AddToCellText(AText: String);
begin
if cellText = ''
then cellText := AText
else cellText := cellText + AText;
end;
begin begin
{ We were forced to activate PreserveWhiteSpace in the DOMParser in order to { We were forced to activate PreserveWhiteSpace in the DOMParser in order to
catch the spaces inserted in formatting texts. However, this adds lots of catch the spaces inserted in formatting texts. However, this adds lots of
garbage into the cellText if is is read by means of above statement. Done garbage into the cellText if is is read by means of above statement. Done
like below is much better: } like below is much better: }
cellText := ''; cellText := '';
hyperlink := '';
childnode := ACellNode.FirstChild; childnode := ACellNode.FirstChild;
while Assigned(childnode) do while Assigned(childnode) do
begin begin
nodeName := childNode.NodeName; nodeName := childNode.NodeName;
hyperlink := '';
if nodeName = 'text:p' then begin if nodeName = 'text:p' then begin
// Each 'text:p' node is a paragraph --> we insert a line break after the first paragraph
if cellText <> '' then
cellText := cellText + LineEnding;
subnode := childnode.FirstChild; subnode := childnode.FirstChild;
while Assigned(subnode) do while Assigned(subnode) do
begin begin
nodename := subnode.NodeName; nodename := subnode.NodeName;
if nodename = 'text:a' then begin case nodename of
s := GetAttrValue(subnode, 'xlink:type'); '#text' :
if s = 'simple' then AddToCellText(subnode.TextContent);
'text:a': // "hyperlink anchor"
begin
hyperlink := GetAttrValue(subnode, 'xlink:href'); hyperlink := GetAttrValue(subnode, 'xlink:href');
AddToCellText(subnode.TextContent);
end;
'text:span':
AddToCellText(subnode.TextContent);
end; end;
subnode := subnode.NextSibling; subnode := subnode.NextSibling;
end; end;
s := childNode.TextContent;
if s <> '' then
begin
if cellText = '' then cellText := s else cellText := cellText + LineEnding + s;
end; end;
spanNode := childNode.FirstChild;
while spanNode <> nil do begin
nodeName := spanNode.NodeName;
if nodeName = 'text:span' then
begin
s := spanNode.TextContent;
if cellText = '' then cellText := s else cellText := cellText + ' ' + s;
end;
spanNode := spanNode.NextSibling;
end;
end;
childnode := childnode.NextSibling; childnode := childnode.NextSibling;
end; end;
@ -1519,7 +1518,14 @@ begin
FWorkSheet.WriteUTF8Text(cell, cellText); FWorkSheet.WriteUTF8Text(cell, cellText);
if hyperlink <> '' then if hyperlink <> '' then
begin
// ODS sees relative paths relative to the internal own file structure
// --> we must remove 1 level-up to be at the same level where fps expects
// the file.
if pos('../', hyperlink) = 1 then
Delete(hyperlink, 1, Length('../'));
FWorksheet.WriteHyperlink(cell, hyperlink); FWorksheet.WriteHyperlink(cell, hyperlink);
end;
styleName := GetAttrValue(ACellNode, 'table:style-name'); styleName := GetAttrValue(ACellNode, 'table:style-name');
ApplyStyleToCell(cell, stylename); ApplyStyleToCell(cell, stylename);
@ -4153,7 +4159,7 @@ var
spannedStr: String; spannedStr: String;
r1,c1,r2,c2: Cardinal; r1,c1,r2,c2: Cardinal;
txt: ansistring; txt: ansistring;
textp, target, comment: String; textp, target, bookmark, comment: String;
fmt: TsCellFormat; fmt: TsCellFormat;
hyperlink: PsHyperlink; hyperlink: PsHyperlink;
u: TUri; u: TUri;
@ -4191,6 +4197,30 @@ begin
if FWorksheet.HasHyperlink(ACell) then if FWorksheet.HasHyperlink(ACell) then
begin begin
hyperlink := FWorksheet.FindHyperlink(ACell); hyperlink := FWorksheet.FindHyperlink(ACell);
SplitHyperlink(hyperlink^.Target, target, bookmark);
if (target = '') and (bookmark <> '') then
target := '#' + bookmark
else
if (pos('file:', target) = 0) then
begin
u := ParseURI(target);
if u.Protocol = '' then
target := '../' + target;
end;
{
u := ParseURI(hyperlink^.Target);
if u.Protocol = '' then // relative file name, or internal link
begin
if target <> '' then target := '../' + target;
if bookmark <> '' then target := target + '#' + bookmark;
end else
target := hyperlink^.Target;
}
ValidXMLText(target);
{
target := hyperlink^.Target; target := hyperlink^.Target;
if target[1] <> '#' then if target[1] <> '#' then
begin begin
@ -4202,6 +4232,7 @@ begin
// if not IsAbsoluteURI(target) then target := '..\' + target; // if not IsAbsoluteURI(target) then target := '..\' + target;
end; end;
end; end;
}
textp := Format( textp := Format(
'<text:p>'+ '<text:p>'+
'<text:a xlink:href="%s" xlink:type="simple">%s</text:a>'+ '<text:a xlink:href="%s" xlink:type="simple">%s</text:a>'+

70
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -593,8 +593,6 @@ type
class function GetFormatFromFileHeader(const AFileName: TFileName; class function GetFormatFromFileHeader(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean; out SheetType: TsSpreadsheetFormat): Boolean;
class function GetFormatFromFileName(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
function CreateSpreadReader(AFormat: TsSpreadsheetFormat): TsBasicSpreadReader; function CreateSpreadReader(AFormat: TsSpreadsheetFormat): TsBasicSpreadReader;
function CreateSpreadWriter(AFormat: TsSpreadsheetFormat): TsBasicSpreadWriter; function CreateSpreadWriter(AFormat: TsSpreadsheetFormat): TsBasicSpreadWriter;
procedure ReadFromFile(AFileName: string; AFormat: TsSpreadsheetFormat); overload; procedure ReadFromFile(AFileName: string; AFormat: TsSpreadsheetFormat); overload;
@ -781,7 +779,7 @@ procedure DumpFontsToFile(AWorkbook: TsWorkbook; AFileName: String);
implementation implementation
uses uses
Math, StrUtils, TypInfo, lazutf8, URIParser, Math, StrUtils, TypInfo, lazutf8, lazFileUtils, URIParser,
fpsPatches, fpsStrings, uvirtuallayer_ole, fpsPatches, fpsStrings, uvirtuallayer_ole,
fpsUtils, fpsreaderwriter, fpsCurrency, fpsExprParser, fpsUtils, fpsreaderwriter, fpsCurrency, fpsExprParser,
fpsNumFormat, fpsNumFormatParser; fpsNumFormat, fpsNumFormatParser;
@ -1464,13 +1462,14 @@ end;
Checks whether the passed string represents a valid hyperlink target Checks whether the passed string represents a valid hyperlink target
@param AValue String to be checked. Must be either a fully qualified URI, @param AValue String to be checked. Must be either a fully qualified URI,
or a # followed by a cell address in the current workbook a local relative (!) file name, or a # followed by a cell
address in the current workbook
@param AErrMsg Error message in case that the string is not correct. @param AErrMsg Error message in case that the string is not correct.
@returns TRUE if the string is correct, FALSE otherwise @returns TRUE if the string is correct, FALSE otherwise
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.ValidHyperlink(AValue: String; out AErrMsg: String): Boolean; function TsWorksheet.ValidHyperlink(AValue: String; out AErrMsg: String): Boolean;
var var
uri: TUri; u: TUri;
sheet: TsWorksheet; sheet: TsWorksheet;
r, c: Cardinal; r, c: Cardinal;
begin begin
@ -1491,12 +1490,24 @@ begin
end; end;
end else end else
begin begin
uri := ParseURI(AValue); u := ParseURI(AValue);
if SameText(uri.Protocol, 'mailto') then if SameText(u.Protocol, 'mailto') then
begin begin
Result := true; // To do: Check email address here... Result := true; // To do: Check email address here...
exit; exit;
end else end else
if SameText(u.Protocol, 'file') then
begin
if FilenameIsAbsolute(u.Path + u.Document) then
begin
Result := true;
exit;
end else
begin
AErrMsg := Format(rsLocalfileHyperlinkAbs, [AValue]);
exit;
end;
end else
begin begin
Result := true; Result := true;
exit; exit;
@ -1530,8 +1541,9 @@ end;
@param ACell Pointer to the cell considered @param ACell Pointer to the cell considered
@param ATarget Hyperlink address given as a fully qualitifed URI for @param ATarget Hyperlink address given as a fully qualitifed URI for
external links, or as a # followed by a cell address external links, or as a # followed by a cell address
for internal links. An existing hyperlink is removed if for internal links. Local files can be specified also
ATarget is empty. by their name relative to the workbook.
An existing hyperlink is removed if ATarget is empty.
@param ATooltip Text for popup tooltip hint used by Excel @param ATooltip Text for popup tooltip hint used by Excel
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
procedure TsWorksheet.WriteHyperlink(ACell: PCell; ATarget: String; procedure TsWorksheet.WriteHyperlink(ACell: PCell; ATarget: String;
@ -1539,7 +1551,7 @@ procedure TsWorksheet.WriteHyperlink(ACell: PCell; ATarget: String;
var var
hyperlink: PsHyperlink; hyperlink: PsHyperlink;
fmt: TsCellFormat; fmt: TsCellFormat;
fn: String; target, bm, fn, displayTxt: String;
begin begin
if ACell = nil then if ACell = nil then
exit; exit;
@ -1554,11 +1566,15 @@ begin
if ACell^.ContentType = cctEmpty then if ACell^.ContentType = cctEmpty then
begin begin
SplitHyperlink(ATarget, target, bm);
displayTxt := ATarget;
if pos('file:', lowercase(displayTxt))=1 then
begin
Delete(displayTxt, 1, Length('file:///'));
if bm <> '' then displayTxt := fn + '#' + bm;
end;
ACell^.ContentType := cctUTF8String; ACell^.ContentType := cctUTF8String;
if (hyperlink^.Target[1] <> '#') and UriToFileName(hyperlink^.Target, fn) then ACell^.UTF8StringValue := displayTxt;
ACell^.UTF8StringValue := fn
else
ACell^.UTF8StringValue := hyperlink^.Target;
end; end;
fmt := ReadCellFormat(ACell); fmt := ReadCellFormat(ACell);
@ -3622,6 +3638,8 @@ begin
begin begin
hyperlink := ReadHyperlink(ACell); hyperlink := ReadHyperlink(ACell);
AText := hyperlink.Target; AText := hyperlink.Target;
if pos('file:', hyperlink.Target)=1 then
Delete(AText, 1, Length('file:///'));
end; end;
if (AText = '') then if (AText = '') then
@ -6238,30 +6256,6 @@ begin
end; end;
end; end;
{@@ ----------------------------------------------------------------------------
Helper method for determining the spreadsheet type from the file type extension
@param AFileName Name of the file to be considered
@param SheetType File format found from analysis of the extension (output)
@return True if the file matches any of the known formats, false otherwise
-------------------------------------------------------------------------------}
class function TsWorkbook.GetFormatFromFileName(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
var
suffix: String;
begin
Result := True;
suffix := Lowercase(ExtractFileExt(AFileName));
if suffix = STR_EXCEL_EXTENSION then SheetType := sfExcel8
else if suffix = STR_OOXML_EXCEL_EXTENSION then SheetType := sfOOXML
else if suffix = STR_OPENDOCUMENT_CALC_EXTENSION then SheetType := sfOpenDocument
else if suffix = STR_COMMA_SEPARATED_EXTENSION then SheetType := sfCSV
else if suffix = STR_WIKITABLE_PIPES then SheetType := sfWikiTable_Pipes
else if suffix = STR_WIKITABLE_WIKIMEDIA then SheetType := sfWikiTable_WikiMedia
else Result := False;
end;
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Convenience method which creates the correct reader object for a given Convenience method which creates the correct reader object for a given
spreadsheet format. spreadsheet format.

9
components/fpspreadsheet/fpsreaderwriter.pas
View File

@ -123,15 +123,8 @@ type
public public
constructor Create(AWorkbook: TsWorkbook); override; constructor Create(AWorkbook: TsWorkbook); override;
destructor Destroy; override; destructor Destroy; override;
{ General writing methods } { General writing methods }
{
procedure IterateThroughCells(AStream: TStream; ACells: TsCells;
ACallback: TCellsCallback);
procedure IterateThroughComments(AStream: TStream; AComments: TsComments;
ACallback: TCommentsCallback);
procedure IterateThroughHyperlinks(AStream: TStream; AHyperlinks: TsHyperlinks;
ACallback: THyperlinksCallback);
}
procedure WriteToFile(const AFileName: string; procedure WriteToFile(const AFileName: string;
const AOverwriteExisting: Boolean = False); override; const AOverwriteExisting: Boolean = False); override;
procedure WriteToStream(AStream: TStream); override; procedure WriteToStream(AStream: TStream); override;

2
components/fpspreadsheet/fpsstrings.pas
View File

@ -58,6 +58,8 @@ resourcestring
rsNoValidHyperlinkInternal = 'The hyperlink "%s" is not a valid cell address.'; rsNoValidHyperlinkInternal = 'The hyperlink "%s" is not a valid cell address.';
rsNoValidHyperlinkURI = 'The hyperlink "%s" is not a valid URI.'; rsNoValidHyperlinkURI = 'The hyperlink "%s" is not a valid URI.';
rsLocalFileHyperlinkAbs = 'The hyperlink "%s" points to a local file. ' +
'In case of an absolute path the protocol "file:" must be specified.';
rsEmptyHyperlink = 'The hyperlink is not specified.'; rsEmptyHyperlink = 'The hyperlink is not specified.';
rsODSHyperlinksOfTextCellsOnly = 'Cell %s: OpenDocument supports hyperlinks for text cells only.'; rsODSHyperlinksOfTextCellsOnly = 'Cell %s: OpenDocument supports hyperlinks for text cells only.';
rsStdHyperlinkTooltip = 'Press the left mouse button a bit longer to activate the hyperlink.'; rsStdHyperlinkTooltip = 'Press the left mouse button a bit longer to activate the hyperlink.';

4
components/fpspreadsheet/fpstypes.pas
View File

@ -29,9 +29,9 @@ const
{@@ Default extension of <b>comma-separated-values</b> file } {@@ Default extension of <b>comma-separated-values</b> file }
STR_COMMA_SEPARATED_EXTENSION = '.csv'; STR_COMMA_SEPARATED_EXTENSION = '.csv';
{@@ Default extension of <b>wikitable files</b> in <b>pipes</b> format} {@@ Default extension of <b>wikitable files</b> in <b>pipes</b> format}
STR_WIKITABLE_PIPES = '.wikitable_pipes'; STR_WIKITABLE_PIPES_EXTENSION = '.wikitable_pipes';
{@@ Default extension of <b>wikitable files</b> in <b>wikimedia</b> format } {@@ Default extension of <b>wikitable files</b> in <b>wikimedia</b> format }
STR_WIKITABLE_WIKIMEDIA = '.wikitable_wikimedia'; STR_WIKITABLE_WIKIMEDIA_EXTENSION = '.wikitable_wikimedia';
{@@ Maximum count of worksheet columns} {@@ Maximum count of worksheet columns}
MAX_COL_COUNT = 65535; MAX_COL_COUNT = 65535;

49
components/fpspreadsheet/fpsutils.pas
View File

@ -88,6 +88,9 @@ function GetCellRangeString(ARange: TsCellRange;
function GetErrorValueStr(AErrorValue: TsErrorValue): String; function GetErrorValueStr(AErrorValue: TsErrorValue): String;
function GetFileFormatName(AFormat: TsSpreadsheetFormat): string; function GetFileFormatName(AFormat: TsSpreadsheetFormat): string;
function GetFileFormatExt(AFormat: TsSpreadsheetFormat): String;
function GetFormatFromFileName(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
function IfThen(ACondition: Boolean; AValue1,AValue2: TsNumberFormat): TsNumberFormat; overload; function IfThen(ACondition: Boolean; AValue1,AValue2: TsNumberFormat): TsNumberFormat; overload;
@ -866,6 +869,52 @@ begin
end; end;
end; end;
{@@ ----------------------------------------------------------------------------
Returns the default extension of each spreadsheet file format
@param AFormat Identifier of the file format
@retur File extension
-------------------------------------------------------------------------------}
function GetFileFormatExt(AFormat: TsSpreadsheetFormat): String;
begin
case AFormat of
sfExcel2,
sfExcel5,
sfExcel8 : Result := STR_EXCEL_EXTENSION;
sfOOXML : Result := STR_OOXML_EXCEL_EXTENSION;
sfOpenDocument : Result := STR_OPENDOCUMENT_CALC_EXTENSION;
sfCSV : Result := STR_COMMA_SEPARATED_EXTENSION;
sfWikiTable_Pipes : Result := STR_WIKITABLE_PIPES_EXTENSION;
sfWikiTable_WikiMedia : Result := STR_WIKITABLE_WIKIMEDIA_EXTENSION;
else raise Exception.Create(rsUnknownSpreadsheetFormat);
end;
end;
{@@ ----------------------------------------------------------------------------
Determines the spreadsheet type from the file type extension
@param AFileName Name of the file to be considered
@param SheetType File format found from analysis of the extension (output)
@return True if the file matches any of the known formats, false otherwise
-------------------------------------------------------------------------------}
function GetFormatFromFileName(const AFileName: TFileName;
out SheetType: TsSpreadsheetFormat): Boolean;
var
suffix: String;
begin
Result := true;
suffix := Lowercase(ExtractFileExt(AFileName));
case suffix of
STR_EXCEL_EXTENSION : SheetType := sfExcel8;
STR_OOXML_EXCEL_EXTENSION : SheetType := sfOOXML;
STR_OPENDOCUMENT_CALC_EXTENSION : SheetType := sfOpenDocument;
STR_COMMA_SEPARATED_EXTENSION : SheetType := sfCSV;
STR_WIKITABLE_PIPES_EXTENSION : SheetType := sfWikiTable_Pipes;
STR_WIKITABLE_WIKIMEDIA_EXTENSION : SheetType := sfWikiTable_WikiMedia;
else Result := False;
end;
end;
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Helper function to reduce typing: "if a conditions is true return the first Helper function to reduce typing: "if a conditions is true return the first
number format, otherwise return the second format" number format, otherwise return the second format"

7
components/fpspreadsheet/tests/commenttests.pas
View File

@ -1,11 +1,12 @@
{ Comment tests
These unit tests are writing out to and reading back from file.
}
unit commenttests; unit commenttests;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
{ Color tests
This unit tests writing out to and reading back from files.
}
uses uses
// Not using Lazarus package as the user may be working with multiple versions // Not using Lazarus package as the user may be working with multiple versions

7
components/fpspreadsheet/tests/spreadtestgui.lpi
View File

@ -40,7 +40,7 @@
<PackageName Value="FCL"/> <PackageName Value="FCL"/>
</Item4> </Item4>
</RequiredPackages> </RequiredPackages>
<Units Count="23"> <Units Count="24">
<Unit0> <Unit0>
<Filename Value="spreadtestgui.lpr"/> <Filename Value="spreadtestgui.lpr"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
@ -140,6 +140,11 @@
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="enumeratortests"/> <UnitName Value="enumeratortests"/>
</Unit22> </Unit22>
<Unit23>
<Filename Value="hyperlinktests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="hyperlinktests"/>
</Unit23>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>

3
components/fpspreadsheet/tests/spreadtestgui.lpr
View File

@ -12,7 +12,8 @@ uses
manualtests, testsutility, internaltests, formattests, colortests, fonttests, manualtests, testsutility, internaltests, formattests, colortests, fonttests,
optiontests, numformatparsertests, formulatests, rpnFormulaUnit, optiontests, numformatparsertests, formulatests, rpnFormulaUnit,
emptycelltests, errortests, virtualmodetests, insertdeletetests, emptycelltests, errortests, virtualmodetests, insertdeletetests,
celltypetests, sortingtests, copytests, commenttests, enumeratortests; celltypetests, sortingtests, copytests, commenttests, enumeratortests,
hyperlinktests;
begin begin
{$IFDEF HEAPTRC} {$IFDEF HEAPTRC}

76
components/fpspreadsheet/xlsbiff8.pas
View File

@ -119,9 +119,6 @@ type
{ TsSpreadBIFF8Writer } { TsSpreadBIFF8Writer }
TsSpreadBIFF8Writer = class(TsSpreadBIFFWriter) TsSpreadBIFF8Writer = class(TsSpreadBIFFWriter)
private
procedure WriteHyperlinksCallback(AHyperlink: PsHyperlink; AStream: TStream);
protected protected
{ Record writing methods } { Record writing methods }
procedure WriteBOF(AStream: TStream; ADataType: Word); procedure WriteBOF(AStream: TStream; ADataType: Word);
@ -261,7 +258,7 @@ var
implementation implementation
uses uses
Math, lconvencoding, URIParser, Math, lconvencoding, LazFileUtils, URIParser,
fpsStrings, fpsStreams, fpsReaderWriter, fpsExprParser, xlsEscher; fpsStrings, fpsStreams, fpsReaderWriter, fpsExprParser, xlsEscher;
const const
@ -1496,12 +1493,12 @@ begin
SetLength(ansiStr, len); SetLength(ansiStr, len);
AStream.ReadBuffer(ansiStr[1], len*SizeOf(ansiChar)); AStream.ReadBuffer(ansiStr[1], len*SizeOf(ansiChar));
SetLength(ansistr, len-1); // Remove trailing zero SetLength(ansistr, len-1); // Remove trailing zero
linkDos := AnsiToUTF8(ansiStr);
while dirUpCount > 0 do while dirUpCount > 0 do
begin begin
linkDos := '..\' + linkDos; ansistr := '..' + PathDelim + ansistr;
dec(dirUpCount); dec(dirUpCount);
end; end;
linkDos := AnsiToUTF8(ansiStr);
// 6 unknown DWord values // 6 unknown DWord values
AStream.ReadDWord; AStream.ReadDWord;
AStream.ReadDWord; AStream.ReadDWord;
@ -1523,11 +1520,13 @@ begin
// no Unicode string header, always 16-bit characters, not zero-terminated // no Unicode string header, always 16-bit characters, not zero-terminated
SetLength(wideStr, len); SetLength(wideStr, len);
AStream.ReadBuffer(wideStr[1], size); AStream.ReadBuffer(wideStr[1], size);
SetLength(link, size); link := UTF8Encode(wideStr);
len := System.UnicodeToUTF8(PChar(link), PWideChar(widestr), size);
SetLength(link, len);
end else end else
link := linkDos; link := linkDos;
// An absolute path must be a fully qualified URI to be compatible with fps
if flags and MASK_HLINK_ABSOLUTE <> 0 then
link := 'file:///' + link;
end; end;
end; end;
@ -2395,8 +2394,10 @@ var
flags: DWord; flags: DWord;
size: Integer; size: Integer;
cell: PCell; cell: PCell;
isInternal: Boolean;
target, bookmark: String; target, bookmark: String;
u: TUri;
isInternal: Boolean;
dirUpCounter: Integer;
begin begin
cell := AWorksheet.FindCell(AHyperlink^.Row, AHyperlink^.Col); cell := AWorksheet.FindCell(AHyperlink^.Row, AHyperlink^.Col);
if (cell = nil) or (AHyperlink^.Target='') then if (cell = nil) or (AHyperlink^.Target='') then
@ -2404,7 +2405,17 @@ begin
descr := AWorksheet.ReadAsUTF8Text(cell); // Hyperlink description descr := AWorksheet.ReadAsUTF8Text(cell); // Hyperlink description
SplitHyperlink(AHyperlink^.Target, target, bookmark); SplitHyperlink(AHyperlink^.Target, target, bookmark);
isInternal := (target = ''); u := ParseURI(AHyperlink^.Target);
isInternal := (target = '') and (bookmark <> '');
fn := ''; // Name of local file
if target <> '' then
begin
if (u.Protocol='') then
fn := target
else
UriToFileName(target, fn);
ForcePathDelims(fn);
end;
// Since the length of the record is not known in the first place we write // Since the length of the record is not known in the first place we write
// the data to a temporary stream at first. // the data to a temporary stream at first.
@ -2428,7 +2439,9 @@ begin
if isInternal then if isInternal then
flags := MASK_HLINK_TEXTMARK or MASK_HLINK_DESCRIPTION flags := MASK_HLINK_TEXTMARK or MASK_HLINK_DESCRIPTION
else else
flags := MASK_HLINK_LINK or MASK_HLINK_ABSOLUTE; flags := MASK_HLINK_LINK;
if SameText(u.Protocol, 'file') then
flags := flags or MASK_HLINK_ABSOLUTE;
if descr <> AHyperlink^.Target then if descr <> AHyperlink^.Target then
flags := flags or MASK_HLINK_DESCRIPTION; // has description flags := flags or MASK_HLINK_DESCRIPTION; // has description
if bookmark <> '' then if bookmark <> '' then
@ -2447,16 +2460,22 @@ begin
if target <> '' then if target <> '' then
begin begin
if URIToFilename(target, fn) then // URI is a local file if (fn <> '') then // URI is a local file
begin begin
{ GUID of file moniker } { GUID of file moniker }
guid := StringToGuid('{00000303-0000-0000-C000-000000000046}'); guid := StringToGuid('{00000303-0000-0000-C000-000000000046}');
temp.WriteBuffer(guid, SizeOf(guid)); temp.WriteBuffer(guid, SizeOf(guid));
{ Directory-up level counter - we only use absolute paths. } { Convert to ansi - should be DOS 8.3, but this is not necessary }
temp.WriteWord(WordToLE(0)); ansistr := UTF8ToAnsi(fn);
{ Convert to DOS 8.3 format } { Directory-up level counter }
ansistr := UTF8ToAnsi(fn); // Don't use FCodePage here - this is utf8 in case of BIFF8, but we need at true ansi string dirUpCounter := 0;
//GetShortName(ansistr); if not FileNameIsAbsolute(ansistr) then
while (pos ('..' + PathDelim, ansistr) = 1) do
begin
inc(dirUpCounter);
Delete(ansistr, 1, Length('..'+PathDelim));
end;
temp.WriteWord(WordToLE(dirUpCounter));
{ Character count of file name incl trailing zero } { Character count of file name incl trailing zero }
temp.WriteDWord(DWordToLe(Length(ansistr)+1)); temp.WriteDWord(DWordToLe(Length(ansistr)+1));
{ Character array of file name (8-bit characters), plus trailing zero } { Character array of file name (8-bit characters), plus trailing zero }
@ -2525,24 +2544,13 @@ procedure TsSpreadBIFF8Writer.WriteHyperlinks(AStream: TStream;
var var
hyperlink: PsHyperlink; hyperlink: PsHyperlink;
begin begin
for hyperlink in AWorksheet.Hyperlinks do for hyperlink in AWorksheet.Hyperlinks do begin
WriteHyperlink(AStream, hyperlink, AWorksheet);
// IterateThroughHyperlinks(AStream, AWorksheet.Hyperlinks, WriteHyperlinksCallback);
end;
{@@ ----------------------------------------------------------------------------
Callback procedure called for each hyperlink of the current worksheet when
all hyperlinks are written out
-------------------------------------------------------------------------------}
procedure TsSpreadBIFF8Writer.WriteHyperlinksCallback(AHyperlink: PsHyperlink;
AStream: TStream);
begin
{ Write HYPERLINK record } { Write HYPERLINK record }
WriteHyperlink(AStream, AHyperlink, FWorksheet); WriteHyperlink(AStream, hyperlink, AWorksheet);
{ Write HYPERLINK TOOLTIP record } { Write HYPERLINK TOOLTIP record }
if AHyperlink^.Tooltip <> '' then if hyperlink^.Tooltip <> '' then
WriteHyperlinkTooltip(AStream, AHyperlink^.Row, AHyperlink^.Col, AHyperlink^.Tooltip); WriteHyperlinkTooltip(AStream, hyperlink^.Row, hyperlink^.Col, hyperlink^.Tooltip);
end;
end; end;
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------

23
components/fpspreadsheet/xlsxooxml.pas
View File

@ -109,10 +109,6 @@ type
TsSpreadOOXMLWriter = class(TsCustomSpreadWriter) TsSpreadOOXMLWriter = class(TsCustomSpreadWriter)
private private
FNext_rId: Integer; FNext_rId: Integer;
{
procedure WriteCommentsCallback(AComment: PsComment;
ACommentIndex: Integer; AStream: TStream);
}
procedure WriteVmlDrawingsCallback(AComment: PsComment; procedure WriteVmlDrawingsCallback(AComment: PsComment;
ACommentIndex: Integer; AStream: TStream); ACommentIndex: Integer; AStream: TStream);
@ -209,7 +205,7 @@ var
implementation implementation
uses uses
variants, fileutil, strutils, math, lazutf8, variants, fileutil, strutils, math, lazutf8, uriparser,
{%H-}fpsPatches, fpsStrings, fpsStreams, fpsNumFormatParser; {%H-}fpsPatches, fpsStrings, fpsStreams, fpsNumFormatParser;
const const
@ -2281,13 +2277,16 @@ begin
s := Format('%s r:id="rId%d"', [s, FNext_rId]); s := Format('%s r:id="rId%d"', [s, FNext_rId]);
inc(FNext_rId); inc(FNext_rId);
end; end;
if target = '' then if bookmark <> '' then //target = '' then
s := Format('%s location="%s"', [s, bookmark]); s := Format('%s location="%s"', [s, bookmark]);
txt := AWorksheet.ReadAsUTF8Text(hyperlink^.Row, hyperlink^.Col); txt := AWorksheet.ReadAsUTF8Text(hyperlink^.Row, hyperlink^.Col);
if (txt <> '') and (txt <> hyperlink^.Target) then if (txt <> '') and (txt <> hyperlink^.Target) then
s := Format('%s display="%s"', [s, txt]); s := Format('%s display="%s"', [s, txt]);
if hyperlink^.ToolTip <> '' then if hyperlink^.ToolTip <> '' then begin
s := Format('%s tooltip="%s"', [s, hyperlink^.Tooltip]); txt := hyperlink^.Tooltip;
ValidXMLText(txt);
s := Format('%s tooltip="%s"', [s, txt]);
end;
AppendToStream(AStream, AppendToStream(AStream,
'<hyperlink ' + s + ' />'); '<hyperlink ' + s + ' />');
AVLNode := AWorksheet.Hyperlinks.FindSuccessor(AVLNode); AVLNode := AWorksheet.Hyperlinks.FindSuccessor(AVLNode);
@ -2767,6 +2766,7 @@ var
AVLNode: TAVLTreeNode; AVLNode: TAVLTreeNode;
hyperlink: PsHyperlink; hyperlink: PsHyperlink;
s: String; s: String;
target, bookmark: String;
begin begin
// Extend stream array // Extend stream array
SetLength(FSSheetRels, FCurSheetNum + 1); SetLength(FSSheetRels, FCurSheetNum + 1);
@ -2808,10 +2808,13 @@ begin
while Assigned(AVLNode) do while Assigned(AVLNode) do
begin begin
hyperlink := PsHyperlink(AVLNode.Data); hyperlink := PsHyperlink(AVLNode.Data);
if hyperlink^.Target <> '' then SplitHyperlink(hyperlink^.Target, target, bookmark);
if target <> '' then
begin begin
if (pos('file:', target) = 0) and FileNameIsAbsolute(target) then
target := 'file:///' + target;
s := Format('Id="rId%d" Type="%s" Target="%s" TargetMode="External"', s := Format('Id="rId%d" Type="%s" Target="%s" TargetMode="External"',
[FNext_rId, SCHEMAS_HYPERLINKS, hyperlink^.Target]); [FNext_rId, SCHEMAS_HYPERLINKS, target]);
AppendToStream(FSSheetRels[FCurSheetNum], AppendToStream(FSSheetRels[FCurSheetNum],
'<Relationship ' + s + ' />'); '<Relationship ' + s + ' />');
inc(FNext_rId); inc(FNext_rId);