lazarus/components/turbopower_ipro/iphtml.pas
2008-01-25 18:23:06 +00:00

18645 lines
527 KiB
ObjectPascal

{******************************************************************}
{* IPHTML.PAS - HTML Browser and associated classes *}
{******************************************************************}
{ $Id$ }
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is Turbo Power Internet Professional
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 2000-2002
* the Initial Developer. All Rights Reserved.
*
* 09/29/2007 DefaultTypeFace and FixedTypeFace are enabled
* FactBAParag: Incremental factor for space between lines
* default value is 1,
* proof it with values of 0.5 = {... margin-top: 0.5em; margin-bottom: 0.5em; }
* Delphi: adjustments
* 10/01/2007 TextWidth of an anchor (<a name="XXXX">), before = TextWidth (' ') now is only 1
* Delphi: adjustments (crush when TIpHtmlPanelH was run-time created)
* 10/03/2007 Delphi: supports jpg, png, etc
*
* Contributor(s):
*
* adem baba <adembaba@users.sourceforge.net>
*
* ***** END LICENSE BLOCK ***** *)
{ Global defines potentially affecting this unit }
{$I IPDEFINE.INC}
unit IpHtml;
interface
uses
{$IFDEF IP_LAZARUS}
//MemCheck,
Types,
LCLType,
LCLPRoc,
GraphType,
LCLIntf,
LResources,
LMessages,
LCLMemManager,
{$ELSE}
Windows,
{$ENDIF}
Messages,
SysUtils,
Classes,
Graphics,
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
GifImage,
{$ELSE}
IpAnim,
{$IFDEF AndersGIFImage }
IpAnAGif,
{$ENDIF}
{$IFDEF ImageLibGIFImage }
IpAnImgL,
{$ENDIF}
{$ENDIF}
{$IFDEF UsePNGGraphic}
IpPNGImg,
{$ENDIF}
{$ELSE}
GIFImage,
JPeg,
{$ENDIF}
Controls,
StdCtrls,
ExtCtrls,
Buttons,
Forms,
ClipBrd,
IpConst,
IpStrms,
IpUtils,
Dialogs,
IpMsg,
TypInfo; {!!.10}
type
{$IFNDEF IP_LAZARUS} //JMN
PtrInt = Longint;
{$ENDIF}
{Note: Some of the code below relies on the fact that
the end tag (when present) immediately follows the
start tag.}
TIpHtmlToken = (
IpHtmlTagEof,
IpHtmlTagUnknown, IpHtmlTagText,
IpHtmlTagHtml, IpHtmlTagHtmlend,
IpHtmlTagHEAD, IpHtmlTagHEADend,
IpHtmlTagTITLE, IpHtmlTagTITLEend,
IpHtmlTagSTYLE, IpHtmlTagSTYLEend,
IpHtmlTagSCRIPT, IpHtmlTagSCRIPTend,
IpHtmlTagNOSCRIPT, IpHtmlTagNOSCRIPTend,
IpHtmlTagISINDEX,
IpHtmlTagBASE,
IpHtmlTagMETA,
IpHtmlTagLINK,
IpHtmlTagBODY, IpHtmlTagBODYend,
IpHtmlTagH1, IpHtmlTagH1end,
IpHtmlTagH2, IpHtmlTagH2end,
IpHtmlTagH3, IpHtmlTagH3end,
IpHtmlTagH4, IpHtmlTagH4end,
IpHtmlTagH5, IpHtmlTagH5end,
IpHtmlTagH6, IpHtmlTagH6end,
IpHtmlTagFONT, IpHtmlTagFONTend,
IpHtmlTagP, IpHtmlTagPend,
IpHtmlTagUL, IpHtmlTagULen,
IpHtmlTagOL, IpHtmlTagOLend,
IpHtmlTagLI, IpHtmlTagLIend,
IpHtmlTagDL, IpHtmlTagDLend,
IpHtmlTagDT, IpHtmlTagDTend,
IpHtmlTagDD, IpHtmlTagDDend,
IpHtmlTagDIR, IpHtmlTagDIRend,
IpHtmlTagMENU, IpHtmlTagMENUend,
IpHtmlTagPRE, IpHtmlTagPREend,
IpHtmlTagDIV, IpHtmlTagDIVend,
IpHtmlTagSPAN, IpHtmlTagSPANend,
IpHtmlTagCENTER, IpHtmlTagCENTERend,
IpHtmlTagLEFT, IpHtmlTagLEFTend,
IpHtmlTagRIGHT, IpHtmlTagRIGHTend,
IpHtmlTagBLINK, IpHtmlTagBLINKend,
IpHtmlTagBLOCKQUOTE, IpHtmlTagBLOCKQUOTEend,
IpHtmlTagQ, IpHtmlTagQend,
IpHtmlTagHR,
IpHtmlTagTT, IpHtmlTagTTend,
IpHtmlTagI, IpHtmlTagIend,
IpHtmlTagB, IpHtmlTagBend,
IpHtmlTagU, IpHtmlTagUend,
IpHtmlTagSTRIKE, IpHtmlTagSTRIKEend,
IpHtmlTagS, IpHtmlTagSend,
IpHtmlTagBIG, IpHtmlTagBIGend,
IpHtmlTagSMALL, IpHtmlTagSMALLend,
IpHtmlTagSUB, IpHtmlTagSUBend,
IpHtmlTagSUP, IpHtmlTagSUPend,
IpHtmlTagEM, IpHtmlTagEMend,
IpHtmlTagSTRONG, IpHtmlTagSTRONGend,
IpHtmlTagDFN, IpHtmlTagDFNend,
IpHtmlTagCODE, IpHtmlTagCODEend,
IpHtmlTagSAMP, IpHtmlTagSAMPend,
IpHtmlTagKBD, IpHtmlTagKBDend,
IpHtmlTagVAR, IpHtmlTagVARend,
IpHtmlTagCITE, IpHtmlTagCITEend,
IpHtmlTagABBR, IpHtmlTagABBRend,
IpHtmlTagACRONYM, IpHtmlTagACRONYMend,
IpHtmlTagA, IpHtmlTagAend,
IpHtmlTagIMG,
IpHtmlTagAPPLET, IpHtmlTagAPPLETend,
IpHtmlTagOBJECT, IpHtmlTagOBJECTend,
IpHtmlTagPARAM,
IpHtmlTagBASEFONT,
IpHtmlTagBR,
IpHtmlTagNOBR, IpHtmlTagNOBRend,
IpHtmlTagMAP, IpHtmlTagMAPend,
IpHtmlTagAREA,
IpHtmlTagDOCTYPE,
IpHtmlTagCOMMENT,
IpHtmlTagADDRESS, IpHtmlTagADDRESSend,
IpHtmlTagFORM, IpHtmlTagFORMend,
IpHtmlTagTABLE, IpHtmlTagTABLEend,
IpHtmlTagCAPTION, IpHtmlTagCAPTIONend,
IpHtmlTagTR, IpHtmlTagTRend,
IpHtmlTagTH, IpHtmlTagTHend,
IpHtmlTagTD, IpHtmlTagTDend,
IpHtmlTagTBODY, IpHtmlTagTBODYend,
IpHtmlTagTHEAD, IpHtmlTagTHEADend,
IpHtmlTagTFOOT, IpHtmlTagTFOOTend,
IpHtmlTagCOLGROUP, IpHtmlTagCOLGROUPend,
IpHtmlTagCOL,
IpHtmlTagINPUT,
IpHtmlTagBUTTON, IpHtmlTagBUTTONend,
IpHtmlTagSELECT, IpHtmlTagSELECTend,
IpHtmlTagOPTGROUP, IpHtmlTagOPTGROUPend,
IpHtmlTagOPTION, IpHtmlTagOPTIONend,
IpHtmlTagTEXTAREA, IpHtmlTagTEXTAREAend,
IpHtmlTagLABEL, IpHtmlTagLABELend,
IpHtmlTagFIELDSET, IpHtmlTagFIELDSETend,
IpHtmlTagLEGEND, IpHtmlTagLEGENDend,
IpHtmlTagINS, IpHtmlTagINSend,
IpHtmlTagDEL, IpHtmlTagDELend,
IpHtmlTagFRAMESET, IpHtmlTagFRAMESETend,
IpHtmlTagFRAME,
IpHtmlTagNOFRAMES, IpHtmlTagNOFRAMESend,
IpHtmlTagIFRAME, IpHtmlTagIFRAMEend
);
TIpHtmlTokenSet = set of TIpHtmlToken;
const
IpEndTokenSet : TIpHtmlTokenSet = [
IpHtmlTagHtmlend,
IpHtmlTagHEADend,
IpHtmlTagTITLEend,
IpHtmlTagSTYLEend,
IpHtmlTagSCRIPTend,
IpHtmlTagNOSCRIPTend,
IpHtmlTagBODYend,
IpHtmlTagH1end,
IpHtmlTagH2end,
IpHtmlTagH3end,
IpHtmlTagH4end,
IpHtmlTagH5end,
IpHtmlTagH6end,
IpHtmlTagFONTend,
IpHtmlTagPend,
IpHtmlTagULen,
IpHtmlTagOLend,
IpHtmlTagLIend,
IpHtmlTagDLend,
IpHtmlTagDDend,
IpHtmlTagDIRend,
IpHtmlTagMENUend,
IpHtmlTagPREend,
IpHtmlTagDIVend,
IpHtmlTagSPANend,
IpHtmlTagCENTERend,
IpHtmlTagLEFTend,
IpHtmlTagRIGHTend,
IpHtmlTagBLINKend,
IpHtmlTagBLOCKQUOTEend,
IpHtmlTagQend,
IpHtmlTagTTend,
IpHtmlTagIend,
IpHtmlTagBend,
IpHtmlTagUend,
IpHtmlTagSTRIKEend,
IpHtmlTagSend,
IpHtmlTagBIGend,
IpHtmlTagSMALLend,
IpHtmlTagSUBend,
IpHtmlTagSUPend,
IpHtmlTagEMend,
IpHtmlTagSTRONGend,
IpHtmlTagDFNend,
IpHtmlTagCODEend,
IpHtmlTagSAMPend,
IpHtmlTagKBDend,
IpHtmlTagVARend,
IpHtmlTagCITEend,
IpHtmlTagABBRend,
IpHtmlTagACRONYMend,
IpHtmlTagAend,
IpHtmlTagAPPLETend,
IpHtmlTagOBJECTend,
IpHtmlTagNOBRend,
IpHtmlTagMAPend,
IpHtmlTagADDRESSend,
IpHtmlTagFORMend,
IpHtmlTagTABLEend,
IpHtmlTagCAPTIONend,
IpHtmlTagTRend,
IpHtmlTagTHend,
IpHtmlTagTDend,
IpHtmlTagTBODYend,
IpHtmlTagTHEADend,
IpHtmlTagTFOOTend,
IpHtmlTagCOLGROUPend,
IpHtmlTagBUTTONend,
IpHtmlTagSELECTend,
IpHtmlTagOPTGROUPend,
IpHtmlTagOPTIONend,
IpHtmlTagTEXTAREAend,
IpHtmlTagLABELend,
IpHtmlTagFIELDSETend,
IpHtmlTagLEGENDend,
IpHtmlTagINSend,
IpHtmlTagDELend,
IpHtmlTagFRAMESETend,
IpHtmlTagNOFRAMESend,
IpHtmlTagIFRAMEend
];
IpHtmlTokens : array[TIpHtmlToken] of PAnsiChar = (
'<eof>',
'<unknown>',
'<text>',
'HTML', '/HTML',
'HEAD', '/HEAD',
'TITLE', '/TITLE',
'STYLE', '/STYLE',
'SCRIPT', '/SCRIPT',
'NOSCRIPT','/NOSCRIPT',
'ISINDEX',
'BASE',
'META',
'LINK',
'BODY','/BODY',
'H1','/H1',
'H2','/H2',
'H3','/H3',
'H4','/H4',
'H5','/H5',
'H6','/H6',
'FONT', '/FONT',
'P','/P',
'UL','/UL',
'OL','/OL',
'LI','/LI',
'DL','/DL',
'DT', '/DT',
'DD', '/DD',
'DIR','/DIR',
'MENU','/MENU',
'PRE','/PRE',
'DIV','/DIV',
'SPAN','/SPAN',
'CENTER','/CENTER',
'LEFT', '/LEFT',
'RIGHT', '/RIGHT',
'BLINK', '/BLINK',
'BLOCKQUOTE','/BLOCKQUOTE',
'Q', '/Q',
'HR',
'TT', '/TT',
'I', '/I',
'B', '/B',
'U', '/U',
'STRIKE', '/STRIKE',
'S', '/S',
'BIG', '/BIG',
'SMALL', '/SMALL',
'SUB', '/SUB',
'SUP', '/SUP',
'EM', '/EM',
'STRONG', '/STRONG',
'DFN', '/DFN',
'CODE', '/CODE',
'SAMP', '/SAMP',
'KBD', '/KBD',
'VAR', '/VAR',
'CITE', '/CITE',
'ABBR','/ABBR',
'ACRONYM','/ACRONYM',
'A', '/A',
'IMG',
'APPLET','/APPLET',
'OBJECT','/OBJECT',
'PARAM',
'BASEFONT',
'BR',
'NOBR', '/NOBR',
'MAP','/MAP',
'AREA',
'!DOCTYPE',
'!--',
'ADDRESS','/ADDRESS',
'FORM','/FORM',
'TABLE','/TABLE',
'CAPTION','/CAPTION',
'TR','/TR',
'TH','/TH',
'TD','/TD',
'TBODY','/TBODY',
'THEAD','/THEAD',
'TFOOT','/TFOOT',
'COLGROUP','/COLGROUP',
'COL',
'INPUT',
'BUTTON', '/BUTTON',
'SELECT','/SELECT',
'OPTGROUP','/OPTGROUP',
'OPTION', '/OPTION',
'TEXTAREA','/TEXTAREA',
'LABEL','/LABEL',
'FIELDSET','/FIELDSET',
'LEGEND','/LEGEND',
'INS','/INS',
'DEL','/DEL',
'FRAMESET','/FRAMESET',
'FRAME',
'NOFRAMES','/NOFRAMES',
'IFRAME', '/IFRAME'
);
const
IPMAXFRAMES = 256; {maximum number of frames in a single frameset}
MAXINTS = 4096; {buffer size - this should be way more than needed}
TINTARRGROWFACTOR = 64;
DEFAULT_PRINTMARGIN = 0.5; {inches} {!!.10}
type
{$IFDEF IP_LAZARUS}
TIpEnumItemsMethod = TLCLEnumItemsMethod;
TIpHtmlPoolManager = class(TLCLNonFreeMemManager)
public
constructor Create(TheItemSize, MaxItems : DWord);
function NewItm : Pointer;
end;
{$ELSE}
TIpEnumItemsMethod = procedure(Item: Pointer) of object;
TIpHtmlPoolManager = class
private
Root : Pointer;
{Top : Pointer;} {!!.12}
NextPage : Pointer;
Next : Pointer;
InternalSize : DWord;
Critical : TRtlCriticalSection;
procedure Grow;
public
constructor Create(ItemSize, MaxItems : DWord);
destructor Destroy; override;
function NewItm : Pointer;
procedure EnumerateItems(Method: TIpEnumItemsMethod);
end;
{$ENDIF}
TIpHtml = class;
{$IFDEF IP_LAZARUS}
TIpAbstractHtmlDataProvider = class;
{$DEFINE CSS_INTERFACE}
{$I ipcss.inc}
{$UNDEF CSS_INTERFACE}
{$ENDIF}
TIpHtmlAlign = (haDefault, haLeft, haCenter, haRight, haJustify, haChar);
TIpHtmlVAlign = (hvaTop, hvaMiddle, hvaBottom);
TIpHtmlVAlign3 = (hva3Top, hva3Middle, hva3Bottom, hva3Baseline, hva3Default);
TIpHtmlInteger = class(TPersistent)
{!!.10 new - Integer property which can be scaled}
private
FValue : Integer;
FChange: TNotifyEvent;
procedure DoChange;
function GetValue: Integer;
procedure SetValue(const Value: Integer);
public
constructor Create(AValue: Integer);
property Value: Integer read GetValue write SetValue;
property OnChange: TNotifyEvent read FChange write FChange;
end;
TIpHtmlPixelsType = (hpUndefined, hpAbsolute);
TIpHtmlPixels = class(TPersistent)
private
FValue : Integer;
FPixelsType : TIpHtmlPixelsType;
FChange: TNotifyEvent;
procedure DoChange;
function GetValue: Integer;
procedure SetPixelsType(const Value: TIpHtmlPixelsType);
procedure SetValue(const Value: Integer); {record} {!!.10}
public
property Value: Integer read GetValue write SetValue;
property PixelsType: TIpHtmlPixelsType read FPixelsType write SetPixelsType;
property OnChange: TNotifyEvent read FChange write FChange;
end;
TIpHtmlLengthType = (hlUndefined, hlAbsolute, hlPercent);
TIpHtmlLength = class(TPersistent)
private
FLengthValue: Integer;
FLengthType: TIpHtmlLengthType;
FChange: TNotifyEvent;
procedure SetLengthType(const Value: TIpHtmlLengthType);
procedure SetLengthValue(const Value: Integer);
function GetLengthValue: Integer;{record} {!!.10}
procedure DoChange;
public
property LengthValue : Integer read GetLengthValue write SetLengthValue;
property LengthType : TIpHtmlLengthType read FLengthType write SetLengthType;
property OnChange: TNotifyEvent read FChange write FChange;
end;
TIpHtmlMultiLengthType = (hmlUndefined, hmlAbsolute, hmlPercent, hmlRelative);
TIpHtmlMultiLength = class(TPersistent)
private
FLengthValue : Integer;
FLengthType : TIpHtmlMultiLengthType;
function GetLengthValue: Integer;{record} {!!.10}
public
property LengthValue: Integer read GetLengthValue write FLengthValue;
property LengthType: TIpHtmlMultiLengthType read FLengthType write FLengthType;
end;
TIpHtmlMultiLengthList = class(TPersistent)
private
{Entries : Integer;} {!!.10}
{Values : array[0..Pred(IPMAXFRAMES)] of TIpHtmlMultiLength;} {!!.10}
List: TList; {!!.10}
function GetEntries: Integer;
function GetValues(Index: Integer): TIpHtmlMultiLength;{record} {!!.10}
public
constructor Create;
destructor Destroy; override;
property Values[Index: Integer]: TIpHtmlMultiLength read GetValues;
procedure AddEntry(Value: TIpHtmlMultiLength);
procedure Clear;
property Entries: Integer read GetEntries;
end;
TIpHtmlRelSizeType = (hrsUnspecified, hrsAbsolute, hrsRelative); {!!.10}
TIpHtmlRelSize = class(TPersistent)
private
FChange: TNotifyEvent;
FSizeType : TIpHtmlRelSizeType;
FValue : Integer;
procedure SetSizeType(const Value: TIpHtmlRelSizeType);
procedure SetValue(const Value: Integer); {record} {!!.10}
procedure DoChange;
public
property SizeType : TIpHtmlRelSizeType read FSizeType write SetSizeType;
property Value : Integer read FValue write SetValue;
property OnChange: TNotifyEvent read FChange write FChange;
end;
TIpHtmlNode = class;
TIpHtmlNodeBlock = class;
{display properties that affect the font size}
TIpHtmlPropA = class
private
FKnownSizeOfSpace: TSize;
FBaseFontSize: Integer;
FFontSize: Integer;
FFontName: string;
FFontStyle: TFontStyles;
FUseCount: Integer;
FSizeOfSpaceKnown : Boolean;
procedure SetBaseFontSize(const Value: Integer);
procedure SetFontName(const Value: string);
procedure SetFontSize(const Value: Integer);
procedure SetFontStyle(const Value: TFontStyles);
public
KnownSizeOfHyphen : TSize;
tmAscent,
tmDescent,
tmHeight : Integer;
property SizeOfSpaceKnown: Boolean read FSizeOfSpaceKnown;
procedure SetKnownSizeOfSpace(const Size:TSize);
property KnownSizeOfSpace : TSize read FKnownSizeOfSpace;
property BaseFontSize : Integer read FBaseFontSize
write SetBaseFontSize;
property FontName : string read FFontName
write SetFontName;
property FontSize : Integer read FFontSize
write SetFontSize;
property FontStyle : TFontStyles read FFontStyle
write SetFontStyle;
property UseCount : Integer read FUseCount
write FUseCount;
procedure Assign(const Source: TIpHtmlPropA);
procedure DecUse;
procedure IncUse;
constructor CreateCopy(Source: TIpHtmlPropA);
end;
{display properties that don't affect the font size}
TIpHtmlPropB = class
private
FFontBaseline: Integer;
FAlignment: TIpHtmlAlign;
FFontColor: TColor;
FVAlignment: TIpHtmlVAlign3;
FLinkColor : TColor;
FVLinkColor : TColor;
FALinkColor : TColor;
FBgColor : TColor;
FPreformatted : Boolean;
FNoBreak : Boolean;
FUseCount: Integer;
FOwner: TIpHtml;
public
property FontBaseline : Integer read FFontBaseline write FFontBaseline;
property FontColor : TColor read FFontColor write FFontColor;
property Alignment : TIpHtmlAlign read FAlignment write FAlignment;
property VAlignment : TIpHtmlVAlign3 read FVAlignment write FVAlignment;
property LinkColor : TColor read FLinkColor write FLinkColor;
property VLinkColor : TColor read FVLinkColor write FVLinkColor;
property ALinkColor : TColor read FALinkColor write FALinkColor;
property BgColor : TColor read FBgColor write FBgColor;
property Preformatted : Boolean read FPreformatted write FPreformatted;
property NoBreak : Boolean read FNoBreak write FNoBreak;
property UseCount : Integer read FUseCount write FUseCount;
procedure Assign(const Source: TIpHtmlPropB);
procedure DecUse;
procedure IncUse;
constructor CreateCopy(Owner: TIpHtml; Source: TIpHtmlPropB);
constructor Create(Owner: TIpHtml);
end;
{ TIpHtmlProps }
TIpHtmlProps = class
{-class for holding the currently active style attributes}
private
function GetAlignment: TIpHtmlAlign;
function GetALinkColor: TColor;
function GetBaseFontSize: Integer;
function GetBgColor: TColor;
function GetFontBaseline: Integer;
function GetFontColor: TColor;
function GetFontName: string;
function GetFontSize: Integer;
function GetFontStyle: TFontStyles;
function GetLinkColor: TColor;
function GetPreformatted: Boolean;
function GetVAlignment: TIpHtmlVAlign3;
function GetVLinkColor: TColor;
procedure SetAlignment(const Value: TIpHtmlAlign);
procedure SetALinkColor(const Value: TColor);
procedure SetBaseFontSize(const Value: Integer);
procedure SetBgColor(const Value: TColor);
procedure SetFontBaseline(const Value: Integer);
procedure SetFontColor(const Value: TColor);
procedure SetFontName(const Value: string);
procedure SetFontSize(const Value: Integer);
procedure SetFontStyle(const Value: TFontStyles);
procedure SetLinkColor(const Value: TColor);
procedure SetPreformatted(const Value: Boolean);
procedure SetVAlignment(const Value: TIpHtmlVAlign3);
procedure SetVLinkColor(const Value: TColor);
function GetNoBreak: Boolean;
procedure SetNoBreak(const Value: Boolean);
protected
FOwner : TIpHtml;
PropA : TIpHtmlPropA;
PropB : TIpHtmlPropB;
public
constructor Create(Owner: TIpHtml);
destructor Destroy; override;
procedure Assign(Source : TIpHtmlProps);
function IsEqualTo(Compare: TIpHtmlProps): Boolean;
function AIsEqualTo(Compare: TIpHtmlProps): Boolean;
function BIsEqualTo(Compare: TIpHtmlProps): Boolean;
property BaseFontSize : Integer read GetBaseFontSize write SetBaseFontSize;
property FontName : string read GetFontName write SetFontName;
property FontSize : Integer read GetFontSize write SetFontSize;
property FontBaseline : Integer read GetFontBaseline write SetFontBaseline;
property FontStyle : TFontStyles read GetFontStyle write SetFontStyle;
property FontColor : TColor read GetFontColor write SetFontColor;
property Alignment : TIpHtmlAlign read GetAlignment write SetAlignment;
property VAlignment : TIpHtmlVAlign3 read GetVAlignment write SetVAlignment;
property LinkColor : TColor read GetLinkColor write SetLinkColor;
property VLinkColor : TColor read GetVLinkColor write SetVLinkColor;
property ALinkColor : TColor read GetALinkColor write SetALinkColor;
property BgColor : TColor read GetBgColor write SetBgColor;
property Preformatted : Boolean read GetPreformatted write SetPreformatted;
property NoBreak : Boolean read GetNoBreak write SetNoBreak;
end;
TIpHtmlNodeAlignInline = class;
TElementType = (etWord, etObject, etSoftLF, etHardLF, etClearLeft,
etClearRight, etClearBoth, etIndent, etOutdent, etSoftHyphen);
TIpHtmlElement = record
ElementType : TElementType;
AnsiWord: string;
IsBlank : Integer;
SizeProp: TIpHtmlPropA;
Size: TSize;
WordRect2 : TRect;
Props : TIpHtmlProps;
Owner : TIpHtmlNode;
{$IFDEF IP_LAZARUS}
IsSelected: boolean;
{$ENDIF}
end;
PIpHtmlElement = ^TIpHtmlElement;
TRectMethod = procedure(const R : TRect) of object;
TIpHtmlNodeEnumProc = procedure(Node: TIpHtmlNode; const UserData: Pointer) of object;
{abstract base node}
TIpHtmlNode = class(TPersistent)
protected
FOwner : TIpHtml;
FParentNode : TIpHtmlNode;
function PageRectToScreen(const Rect : TRect; var ScreenRect: TRect): Boolean;
procedure ScreenLine(
StartPoint, EndPoint : TPoint;
const Width : Integer;
const Color : TColor);
procedure ScreenRect(
R : TRect;
const Color : TColor);
{$IFDEF IP_LAZARUS}
procedure ScreenFrame(
R : TRect;
Raised: boolean);
{$ENDIF}
procedure ScreenPolygon(
Points : array of TPoint;
const Color : TColor);
function PagePtToScreen(const Pt: TPoint): TPoint;
procedure Enqueue; virtual;
procedure SetProps(const RenderProps: TIpHtmlProps); virtual;
procedure EnqueueElement(const Entry: PIpHtmlElement); virtual;
function ElementQueueIsEmpty: Boolean; virtual; {!!.10}
procedure ReportDrawRects(M : TRectMethod); virtual;
procedure ReportCurDrawRects(Owner: TIpHtmlNode; M : TRectMethod); virtual;
procedure ReportMapRects(M : TRectMethod); virtual;
procedure Invalidate; virtual;
procedure InvalidateSize; virtual;
procedure SubmitRequest; virtual;
procedure ResetRequest; virtual;
function GetHint: string; virtual;
procedure CreateControl(Parent : TWinControl); virtual;
procedure MakeVisible; virtual;
procedure UnmarkControl; virtual;
procedure HideUnmarkedControl; virtual;
procedure EnumChildren(EnumProc: TIpHtmlNodeEnumProc; UserData: Pointer); virtual;
procedure AppendSelection(var S : string); virtual;
function ExpParentWidth: Integer; virtual;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Owner : TIpHtml read FOwner;
procedure ImageChange(NewPicture : TPicture); virtual;
procedure GetAttributes(Target: TStrings; IncludeValues,
IncludeBlanks: Boolean); {!!.10}
procedure SetAttributeValue(const AttrName, NewValue: string); {!!.10}
end;
TIpHtmlNodeNv = class(TIpHtmlNode)
protected
procedure EnqueueElement(const Entry: PIpHtmlElement); override;
function ElementQueueIsEmpty: Boolean; override; {!!.10}
procedure ReportDrawRects(M : TRectMethod); override;
procedure Invalidate; override;
procedure InvalidateSize; override;
procedure Enqueue; override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
end;
TIpHtmlNodeMulti = class(TIpHtmlNode)
private
FChildren : TList;
function GetChildNode(Index: Integer): TIpHtmlNode;
function GetChildCount: Integer;
protected
procedure Enqueue; override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
procedure ReportDrawRects(M : TRectMethod); override;
procedure ReportMapRects(M : TRectMethod); override;
procedure AppendSelection(var S : string); override;
procedure EnumChildren(EnumProc: TIpHtmlNodeEnumProc; UserData: Pointer); override;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property ChildCount : Integer read GetChildCount;
property ChildNode[Index : Integer] : TIpHtmlNode read GetChildNode;
end;
{ TIpHtmlNodeCore }
TIpHtmlNodeCore = class(TIpHtmlNodeMulti)
private
{$IFDEF IP_LAZARUS}
FCSS: TCSSProps;
FElementName: String;
{$ENDIF}
FStyle: string;
FClassId: string;
FTitle: string;
FId: string;
protected
procedure ParseBaseProps(Owner : TIpHtml); {virtual;} {!!.12}
{$IFDEF IP_LAZARUS}
procedure LoadCSSProps(Owner : TIpHtml; var Element: TCSSProps; const Props: TIpHtmlProps); virtual;
function ElementName: String;
function GetFontSizeFromCSS(CurrentFontSize:Integer; aFontSize: string):Integer;
{$ENDIF}
public {!!.10}
{$IFDEF IP_LAZARUS}
destructor Destroy; override;
{$ENDIF}
property ClassId : string read FClassId write FClassId;
property Id : string read FId write FId;
property Style : string read FStyle write FStyle;
property Title : string read FTitle write FTitle;
{$IFDEF IP_LAZARUS}
property CSS: TCSSProps read FCSS write FCSS;
{$ENDIF}
end;
TIpHtmlNodeInline = class(TIpHtmlNodeCore)
protected
procedure EnqueueElement(const Entry: PIpHtmlElement); override;
function ElementQueueIsEmpty: Boolean; override; {!!.10}
procedure Invalidate; override;
end;
TIpHtmlImageAlign = (hiaTop, hiaMiddle, hiaBottom, hiaLeft, hiaRight, hiaCenter);
TIpHtmlNodeAlignInline = class(TIpHtmlNodeInline)
private
FAlignment: TIpHtmlImageAlign;
protected
Props : TIpHtmlProps;
Element : PIpHtmlElement;
procedure Enqueue; override;
procedure Draw(Block: TIpHtmlNodeBlock); virtual; abstract;
procedure SetRect(TargetRect: TRect); virtual;
function GetDim(ParentWidth: Integer): TSize; virtual; abstract;
procedure CalcMinMaxWidth(var Min, Max: Integer); virtual; abstract;
procedure SetAlignment(const Value: TIpHtmlImageAlign);
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Align : TIpHtmlImageAlign read FAlignment write SetAlignment; {!!.10}
end;
TIpHtmlNodeControl = class(TIpHtmlNodeAlignInline)
protected
FControl : TWinControl;
Shown : Boolean;
procedure Draw(Block: TIpHtmlNodeBlock); override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
function GetDim(ParentWidth: Integer): TSize; override;
procedure CalcMinMaxWidth(var Min, Max: Integer); override;
procedure HideUnmarkedControl; override;
procedure UnmarkControl; override;
procedure AddValues(NameList, ValueList : TStringList); virtual; abstract;
procedure Reset; virtual; abstract;
function Successful: Boolean; virtual; abstract;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
end;
TIpHtmlNodeBlock = class(TIpHtmlNodeCore)
protected
FPageRect : TRect;
ElementQueue : TList;
FMin, FMax : Integer;
Props : TIpHtmlProps;
LastW, LastH : Integer;
procedure RenderQueue;
procedure CalcMinMaxQueueWidth(const RenderProps: TIpHtmlProps;
var Min, Max: Integer);
procedure EnqueueElement(const Entry: PIpHtmlElement); override;
function ElementQueueIsEmpty: Boolean; override; {!!.10}
procedure Render(const RenderProps: TIpHtmlProps); virtual;
procedure Layout(const RenderProps: TIpHtmlProps;
const TargetRect : TRect); virtual;
procedure RelocateQueue(const dx, dy: Integer);
procedure LayoutQueue(const RenderProps: TIpHtmlProps;
const TargetRect : TRect);
procedure CalcMinMaxWidth(const RenderProps: TIpHtmlProps;
var Min, Max: Integer); virtual;
procedure ClearWordList;
procedure Invalidate; override;
function GetHeight(const RenderProps: TIpHtmlProps;
const Width: Integer): Integer; {virtual;} {!!.12}
procedure InvalidateSize; override;
function Level0: Boolean;
procedure ReportCurDrawRects(Owner: TIpHtmlNode; M : TRectMethod); override;
property PageRect : TRect read FPageRect;
procedure AppendSelection(var S : string); override;
procedure UpdateCurrent(Start: Integer; CurProps : TIpHtmlProps);
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
end;
TIpHtmlDirection = (hdLTR, hdRTL);
TIpHtmlNodeHEAD = class(TIpHtmlNodeMulti)
private
FProfile: string;
FLang: string;
FDir: TIpHtmlDirection;
public {!!.10}
property Dir : TIpHtmlDirection read FDir write FDir;
property Lang : string read FLang write FLang;
property Profile : string read FProfile write FProfile;
end;
TIpHtmlNodeText = class(TIpHtmlNode)
private
FEscapedText : string;
function GetAnsiText: string;
procedure SetAnsiText(const Value: string);
procedure SetEscapedText(const Value: string);
protected
PropsR : TIpHtmlProps; {reference}
procedure ReportDrawRects(M : TRectMethod); override;
procedure BuildWordList;
procedure Enqueue; override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
procedure EnqueueElement(const Entry: PIpHtmlElement); override;
function ElementQueueIsEmpty: Boolean; override; {!!.10}
public
property ANSIText : string read GetAnsiText write SetAnsiText;
property EscapedText : string read FEscapedText write SetEscapedText;
end;
{ TIpHtmlNodeGenInline }
TIpHtmlNodeGenInline = class(TIpHtmlNodeInline)
protected
Props: TIpHtmlProps;
procedure ApplyProps(const RenderProps: TIpHtmlProps); virtual; abstract;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
end;
TIpHtmlNodeFONT = class(TIpHtmlNodeGenInline)
private
FSize: TIpHtmlRelSize;
FFace: string;
FColor: TColor;
procedure SetColor(const Value: TColor);
procedure SetFace(const Value: string);
protected
procedure ApplyProps(const RenderProps: TIpHtmlProps); override;
procedure SizeChanged(Sender: TObject);
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Color : TColor read FColor write SetColor;
property Face : string read FFace write SetFace;
property Size : TIpHtmlRelSize read FSize write FSize;
end;
TIpHtmlNodeSTYLE = class(TIpHtmlNodeMulti)
private
FMedia: string;
FTitle: string;
{$IFDEF IP_LAZARUS}
FType: string;
{$ENDIF}
protected
procedure EnqueueElement(const Entry: PIpHtmlElement); override;
function ElementQueueIsEmpty: Boolean; override; {!!.10}
public {!!.10}
property Media : string read FMedia write FMedia;
property Title : string read FTitle write FTitle;
{$IFDEF IP_LAZARUS}
property Type_ : string read FType write FType;
{$ENDIF}
end;
TIpHtmlNodeSCRIPT = class(TIpHtmlNodeNv);
TIpHtmlNodeNOSCRIPT = class(TIpHtmlNodeInline);
TIpHtmlHeaderSize = 1..6;
TIpHtmlNodeHeader = class(TIpHtmlNodeInline)
private
FAlign : TIpHtmlAlign;
FSize : TIpHtmlHeaderSize;
Props : TIpHtmlProps;
protected
procedure Enqueue; override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Align : TIpHtmlAlign read FAlign write FAlign;
property Size : TIpHtmlHeaderSize read FSize write FSize;
end;
TIpHtmlNodeP = class(TIpHtmlNodeInline)
private
FAlign : TIpHtmlAlign;
procedure SetAlign(const Value: TIpHtmlAlign);
protected
Props : TIpHtmlProps;
procedure Enqueue; override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Align : TIpHtmlAlign read FAlign write SetAlign;
end;
TIpHtmlNodeADDRESS = class(TIpHtmlNodeInline);
TIpHtmlULType = (ulDisc, ulSquare, ulCircle);
TIpHtmlNodeList = class(TIpHtmlNodeInline)
private
FCompact : Boolean;
FListType : TIpHtmlULType;
procedure SetListType(const Value: TIpHtmlULType);
protected
procedure Enqueue; override;
public {!!.10}
property Compact : Boolean read FCompact write FCompact;
property ListType : TIpHtmlULType read FListType write SetListType;
end;
TIpHtmlNodeUL = class(TIpHtmlNodeList);
TIpHtmlNodeDIR = class(TIpHtmlNodeList);
TIpHtmlNodeMENU = class(TIpHtmlNodeList);
TIpHtmlOLStyle = (olArabic, olLowerAlpha, olUpperAlpha, olLowerRoman, olUpperRoman);
TIpHtmlNodeOL = class(TIpHtmlNodeInline)
private
FCompact : Boolean;
FStart : Integer;
FStyle : TIpHtmlOLStyle;
procedure SetStart(const Value: Integer);
procedure SetStyle(const Value: TIpHtmlOLStyle);
protected
Counter : Integer;
procedure Enqueue; override;
function GetNumString : string;
public {!!.10}
property Compact : Boolean read FCompact write FCompact;
property Start : Integer read FStart write SetStart;
property Style : TIpHtmlOLStyle read FStyle write SetStyle;
end;
TIpHtmlNodeLI = class(TIpHtmlNodeAlignInline)
private
FCompact: Boolean;
{FDefListType,} {!!.12}
FListType : TIpHtmlULType;
FValue : Integer;
procedure SetListType(const Value: TIpHtmlULType);
procedure SetValue(const Value: Integer);
protected
WordEntry : PIpHtmlElement;
procedure Draw(Block: TIpHtmlNodeBlock); override;
function GrossDrawRect: TRect;
procedure Enqueue; override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
function GetDim(ParentWidth: Integer): TSize; override;
procedure CalcMinMaxWidth(var Min, Max: Integer); override;
{property DefListType: TIpHtmlULType read FListType write FDefListType;} {!!.12}
public
constructor Create(ParentNode : TIpHtmlNode);
property Compact : Boolean read FCompact write FCompact;
property ListType : TIpHtmlULType read FListType write SetListType;
property Value : Integer read FValue write SetValue;
end;
TIpHtmlFormMethod = (hfmGet, hfmPost);
TIpHtmlNodeFORM = class(TIpHtmlNodeInline)
private
FAccept: string;
FAcceptCharset: string;
FName: string;
FEnctype: string;
FAction: string;
FMethod: TIpHtmlFormMethod;
protected
Props : TIpHtmlProps;
procedure AddChild(Node: TIpHtmlNode; const UserData: Pointer);
procedure ResetControl(Node: TIpHtmlNode; const UserData: Pointer);
procedure ResetForm;
procedure ResetRequest; override;
{$IFNDEF HtmlWithoutHttp}
procedure SubmitForm;
procedure SubmitRequest; override;
{$ENDIF}
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Accept : string read FAccept write FAccept;
property AcceptCharset : string read FAcceptCharset write FAcceptCharset;
property Action : string read FAction write FAction;
property Enctype : string read FEnctype write FEnctype;
property Method : TIpHtmlFormMethod read FMethod write FMethod;
property Name : string read FName write FName;
end;
TIpHtmlNodeHtml = class(TIpHtmlNodeMulti)
private
FLang: string;
FVersion: string;
FDir: TIpHtmlDirection;
protected
function HasBodyNode : Boolean; {!!.12}
procedure Render(const RenderProps: TIpHtmlProps);
procedure CalcMinMaxWidth(const RenderProps: TIpHtmlProps;
var Min, Max: Integer);
function GetHeight(const RenderProps: TIpHtmlProps;
const Width: Integer): Integer;
procedure Layout(const RenderProps: TIpHtmlProps;
const TargetRect : TRect);
public {!!.10}
property Dir : TIpHtmlDirection read FDir write FDir;
property Lang : string read FLang write FLang;
property Version : string read FVersion write FVersion;
end;
TIpHtmlNodeTITLE = class(TIpHtmlNodeNv)
private
FTitle: string;
public {!!.10}
property Title : string read FTitle write FTitle;
end;
{ TIpHtmlNodeBODY }
TIpHtmlNodeBODY = class(TIpHtmlNodeBlock)
private
FBgColor : TColor;
FText : TColor;
FLink : TColor;
FVLink : TColor;
FALink : TColor;
FBackground : string;
procedure SetBackground(const Value: string);
procedure SetAlink(const Value: TColor);
procedure SetBgColor(const Value: TColor);
procedure SetLink(const Value: TColor);
procedure SetText(const Value: TColor);
procedure SetVlink(const Value: TColor);
protected
BGPicture : TPicture;
procedure Render(const RenderProps: TIpHtmlProps); override;
{$IFDEF IP_LAZARUS}
procedure LoadCSSProps(Owner : TIpHtml; var Element: TCSSProps; const Props: TIpHtmlProps); override;
{$ENDIF}
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
procedure ImageChange(NewPicture : TPicture); override;
property Background : string read FBackground write SetBackground;
property ALink : TColor read Falink write SetAlink;
property BgColor : TColor read FBgColor write SetBgColor;
property Link : TColor read FLink write SetLink;
property Text : TColor read FText write SetText;
property VLink : TColor read FVLink write SetVlink;
end;
TIpHtmlNodeNOFRAMES = class(TIpHtmlNodeCore);
TIpHtmlNodeFRAMESET = class(TIpHtmlNodeCore)
private
FCols: TIpHtmlMultiLengthList;
FRows: TIpHtmlMultiLengthList;
public
destructor Destroy; override;
property Cols : TIpHtmlMultiLengthList read FCols write FCols;
property Rows : TIpHtmlMultiLengthList read FRows write FRows;
end;
TIpHtmlFrameScrolling = (hfsAuto, hfsYes, hfsNo);
TIpHtmlNodeFRAME = class(TIpHtmlNodeCore)
private
FFrameBorder: Integer;
FLongDesc: string;
FMarginHeight: Integer;
FMarginWidth: Integer;
FName: string;
FNoResize: Boolean;
FScrolling: TIpHtmlFrameScrolling;
FSrc: string;
procedure SetFrameBorder(const Value: Integer);
procedure SetMarginHeight(const Value: Integer);
procedure SetMarginWidth(const Value: Integer);
procedure SetScrolling(const Value: TIpHtmlFrameScrolling);
public {!!.10}
property FrameBorder : Integer read FFrameBorder write SetFrameBorder;
property LongDesc : string read FLongDesc write FLongDesc;
property MarginHeight : Integer read FMarginHeight write SetMarginHeight;
property MarginWidth : Integer read FMarginWidth write SetMarginWidth;
property Name : string read FName write FName;
property NoResize : Boolean read FNoResize write FNoResize;
property Scrolling : TIpHtmlFrameScrolling read FScrolling write SetScrolling;
property Src : string read FSrc write FSrc;
end;
TIpHtmlFrame = class;
TIpHtmlNodeIFRAME = class(TIpHtmlNodeControl)
private
FAlign: TIpHtmlAlign;
FFrameBorder: Integer;
FHeight: TIpHtmlLength;
FLongDesc: string;
FMarginHeight: Integer;
FMarginWidth: Integer;
FName: string;
FScrolling: TIpHtmlFrameScrolling;
FSrc: string;
FWidth: TIpHtmlLength;
FFrame : TIpHtmlFrame;
procedure SetAlign(const Value: TIpHtmlAlign);
procedure SetFrameBorder(const Value: Integer);
procedure SetMarginHeight(const Value: Integer);
procedure SetMarginWidth(const Value: Integer);
procedure SetScrolling(const Value: TIpHtmlFrameScrolling);
protected
procedure CreateControl(Parent : TWinControl); override;
function Successful: Boolean; override;
procedure AddValues(NameList, ValueList : TStringList); override;
procedure Reset; override;
procedure WidthChanged(Sender: TObject); {!!.10}
public
destructor Destroy; override;
property Align : TIpHtmlAlign read FAlign write SetAlign;
property Frame: TIpHtmlFrame read FFrame;
property FrameBorder : Integer read FFrameBorder write SetFrameBorder;
property Height : TIpHtmlLength read FHeight write FHeight;
property LongDesc : string read FLongDesc write FLongDesc;
property MarginHeight : Integer read FMarginHeight write SetMarginHeight;
property MarginWidth : Integer read FMarginWidth write SetMarginWidth;
property Name : string read FName write FName;
property Scrolling : TIpHtmlFrameScrolling read FScrolling write SetScrolling;
property Src : string read FSrc write FSrc;
property Width : TIpHtmlLength read FWidth write FWidth;
end;
TIpHtmlNodeDL = class(TIpHtmlNodeInline)
private
FCompact : Boolean;
protected
procedure Enqueue; override; {!!.16}
public {!!.10}
property Compact : Boolean read FCompact write FCompact;
end;
TIpHtmlNodeDT = class(TIpHtmlNodeInline)
protected
procedure Enqueue; override;
end;
TIpHtmlNodeDD = class(TIpHtmlNodeInline)
protected
procedure Enqueue; override;
end;
TIpHtmlNodePRE = class(TIpHtmlNodeInline)
private
Props : TIpHtmlProps;
protected
procedure Enqueue; override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
end;
TIpHtmlNodeDIV = class(TIpHtmlNodeInline)
private
FAlign : TIpHtmlAlign;
Props : TIpHtmlProps;
protected
procedure Enqueue; override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Align : TIpHtmlAlign read FAlign write FAlign;
end;
{ TIpHtmlNodeSPAN }
TIpHtmlNodeSPAN = class(TIpHtmlNodeGenInline)
private
FAlign : TIpHtmlAlign;
protected
procedure ApplyProps(const RenderProps: TIpHtmlProps); override;
public {!!.10}
property Align : TIpHtmlAlign read FAlign write FAlign;
end;
TIpHtmlNodeBLINK = class(TIpHtmlNodeInline);
TIpHtmlNodeBLOCKQUOTE = class(TIpHtmlNodeInline)
protected
procedure Enqueue; override;
end;
TIpHtmlNodeQ = class(TIpHtmlNodeInline);
TIpHtmlNodeINS = class(TIpHtmlNodeGenInline)
private
FCite: string;
FDateTime: string;
protected
procedure ApplyProps(const RenderProps: TIpHtmlProps); override;
public {!!.10}
property Cite : string read FCite write FCite;
property DateTime : string read FDateTime write FDateTime;
end;
TIpHtmlNodeDEL = class(TIpHtmlNodeGenInline)
private
FCite: string;
FDateTime: string;
protected
procedure ApplyProps(const RenderProps: TIpHtmlProps); override;
public {!!.10}
property Cite : string read FCite write FCite;
property DateTime : string read FDateTime write FDateTime;
end;
TIpHtmlFontStyles = (hfsTT, hfsI, hfsB, hfsU, hfsSTRIKE, hfsS,
hfsBIG, hfsSMALL, hfsSUB, hfsSUP);
TIpHtmlNodeFontStyle = class(TIpHtmlNodeGenInline)
private
FStyle : TIpHtmlFontStyles;
protected
procedure ApplyProps(const RenderProps: TIpHtmlProps); override;
public {!!.10}
property Style : TIpHtmlFontStyles read FStyle write FStyle;
end;
TIpHtmlPhraseStyle = (hpsEM, hpsSTRONG, hpsDFN, hpsCODE, hpsSAMP,
hpsKBD, hpsVAR, hpsCITE, hpsABBR, hpsACRONYM);
TIpHtmlNodePhrase = class(TIpHtmlNodeGenInline)
private
FStyle : TIpHtmlPhraseStyle;
protected
procedure ApplyProps(const RenderProps: TIpHtmlProps); override;
public {!!.10}
property Style : TIpHtmlPhraseStyle read FStyle write FStyle;
end;
TIpHtmlNodeHR = class(TIpHtmlNodeAlignInline)
private
FColor: TColor;
FNoShade : Boolean;
FSize : TIpHtmlInteger; {!!.10}
FWidth : TIpHtmlLength;
protected
SizeWidth : TIpHtmlPixels;
FDim : TSize;
procedure Draw(Block: TIpHtmlNodeBlock); override;
function GetDim(ParentWidth: Integer): TSize; override;
function GrossDrawRect: TRect;
procedure CalcMinMaxWidth(var Min, Max: Integer); override;
procedure Enqueue; override;
procedure WidthChanged(Sender: TObject); {!!.10}
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Color : TColor read FColor write FColor;
property NoShade : Boolean read FNoShade write FNoShade;
property Size : TIpHtmlInteger read FSize write FSize; {!!.10}
property Width : TIpHtmlLength read FWidth write FWidth;
end;
TIpHtmlBreakClear = (hbcNone, hbcLeft, hbcRight, hbcAll);
TIpHtmlNodeBR = class(TIpHtmlNodeInline)
private
FClassId: string;
FClear: TIpHtmlBreakClear;
FStyle: string;
FTitle: string;
FId: string;
protected
procedure Enqueue; override;
procedure SetClear(const Value: TIpHtmlBreakClear);
public {!!.10}
property ClassId : string read FClassId write FClassId;
property Clear : TIpHtmlBreakClear read FClear write SetClear;
property Id : string read FId write FId;
property Style : string read FStyle write FStyle;
property Title : string read FTitle write FTitle;
end;
TIpHtmlNodeNOBR = class(TIpHtmlNodeGenInline)
protected
procedure ApplyProps(const RenderProps: TIpHtmlProps); override;
public
end;
TIpHtmlMapShape = (hmsDefault, hmsRect, hmsCircle, hmsPoly);
TIpHtmlNodeA = class(TIpHtmlNodeInline)
private
FHRef: string;
FName: string;
FRel: string;
FRev: string;
FShape: TIpHtmlMapShape;
FTabIndex: Integer;
FTarget: string;
procedure SetHRef(const Value: string);
procedure SetName(const Value: string);
protected
AreaList : TList;
FHasRef : Boolean;
FHot: Boolean;
MapAreaList : TList;
Props : TIpHtmlProps;
{FHasFocus : Boolean;} {!!.12}
procedure ClearAreaList;
function PtInRects(const P : TPoint) : Boolean;
function RelMapPoint(const P: TPoint): TPoint;
procedure SetHot(const Value: Boolean);
procedure AddArea(const R: TRect);
procedure BuildAreaList;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
procedure AddMapArea(const R: TRect);
function GetHint: string; override;
procedure DoOnFocus;
procedure DoOnBlur;
property HasRef : Boolean read FHasRef;
property Hot : Boolean read FHot write SetHot;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
procedure MakeVisible; override;
property HRef : string read FHRef write SetHRef;
property Name : string read FName write SetName;
property Rel : string read FRel write FRel;
property Rev : string read FRev write FRev;
property Shape : TIpHtmlMapShape read FShape write FShape;
property TabIndex : Integer read FTabIndex write FTabIndex;
property Target: string read FTarget write FTarget;
end;
TIpHtmlNodeIMG = class(TIpHtmlNodeAlignInline)
private
FAlt: string;
FBorder: Integer;
FHeight: TIpHtmlPixels{Integer}; {!!.10}
FHSpace: Integer;
FIsMap: Boolean;
FLongDesc: string;
FName: string;
FPicture : TPicture;
FSrc: string;
FUseMap: string;
FVSpace: Integer;
FWidth: TIpHtmlLength;
{$IFDEF IP_LAZARUS}
function GetBorder: Integer;
{$ENDIF}
procedure SetBorder(const Value: Integer);
procedure SetUseMap(const Value: string);
procedure SetHSpace(const Value: Integer);
procedure SetVSpace(const Value: Integer);
protected
FSize : TSize;
NetDrawRect : TRect;
SizeWidth : TIpHtmlPixels;
procedure Draw(Block: TIpHtmlNodeBlock); override;
procedure ReportDrawRects(M : TRectMethod); override;
procedure ReportMapRects(M : TRectMethod); override;
procedure LoadImage;
procedure UnloadImage; {!!.02}
function GrossDrawRect: TRect;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
function GetDim(ParentWidth: Integer): TSize; override;
procedure CalcMinMaxWidth(var Min, Max: Integer); override;
function GetHint: string; override;
procedure DimChanged(Sender: TObject); {!!.10}
procedure InvalidateSize; override;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
procedure ImageChange(NewPicture : TPicture); override;
property Alt : string read FAlt write FAlt;
{$IFDEF IP_LAZARUS}
property Border : Integer read GetBorder write SetBorder;
{$ELSE}
property Border : Integer read FBorder write SetBorder;
{$ENDIF}
property Height : TIpHtmlPixels{Integer} read FHeight write FHeight; {!!.10}
property HSpace : Integer read FHSpace write SetHSpace;
property IsMap : Boolean read FIsMap write FIsMap;
property LongDesc : string read FLongDesc write FLongDesc;
property Name : string read FName write FName;
property Picture : TPicture read FPicture;
property Src : string read FSrc write FSrc;
property UseMap : string read FUseMap write SetUseMap;
property VSpace : Integer read FVSpace write SetVSpace;
property Width : TIpHtmlLength read FWidth write FWidth;
end;
TIpHtmlNodeAPPLET = class(TIpHtmlNodeInline)
private
FArchive: string;
FClassID: string;
FStyle: string;
FObjectCode: string;
FTitle: string;
FId: string;
FVSpace: Integer;
FHSpace: Integer;
FHeight: Integer;
FWidth: TIpHtmlLength;
FName: string;
FCodebase: string;
FCode: string;
FAlt: string;
FAlignment: TIpHtmlImageAlign;
protected
function GetHint: string; override;
procedure WidthChanged(Sender: TObject);
public
destructor Destroy; override;
property Align : TIpHtmlImageAlign read FAlignment write FAlignment;
property Archive : string read FArchive write FArchive;
property Alt : string read FAlt write FAlt;
property ClassID : string read FClassID write FClassID;
property Code : string read FCode write FCode;
property Codebase : string read FCodebase write FCodebase;
property Height : Integer read FHeight write FHeight;
property HSpace : Integer read FHSpace write FHSpace;
property Id : string read FId write FId;
property Name : string read FName write FName;
property ObjectCode : string read FObjectCode write FObjectCode;
property Style : string read FStyle write FStyle;
property Title : string read FTitle write FTitle;
property VSpace : Integer read FVSpace write FVSpace;
property Width : TIpHtmlLength read FWidth write FWidth;
end;
TIpHtmlNodeOBJECT = class(TIpHtmlNodeInline)
private
FAlignment: TIpHtmlImageAlign;
FArchive: string;
FBorder: Integer;
FClassID: string;
FCodebase: string;
FCodeType: string;
FData: string;
FDeclare: Boolean;
FHeight: Integer;
FHSpace: Integer;
FName: string;
FStandby: string;
FUseMap: string;
FVSpace: Integer;
FWidth: TIpHtmlLength;
protected
procedure WidthChanged(Sender: TObject); {!!.10}
public
destructor Destroy; override;
property Align : TIpHtmlImageAlign read FAlignment write FAlignment;
property Archive : string read FArchive write FArchive;
property Border : Integer read FBorder write FBorder;
property ClassID : string read FClassID write FClassID;
property Codebase : string read FCodebase write FCodebase;
property CodeType : string read FCodeType write FCodeType;
property Data : string read FData write FData;
property Declare : Boolean read FDeclare write FDeclare;
property Height : Integer read FHeight write FHeight;
property HSpace : Integer read FHSpace write FHSpace;
property Name : string read FName write FName;
property Standby : string read FStandby write FStandby;
property UseMap : string read FUseMap write FUseMap;
property VSpace : Integer read FVSpace write FVSpace;
property Width : TIpHtmlLength read FWidth write FWidth;
end;
TIpHtmlObjectValueType = (hovtData, hovtRef, hovtObject);
TIpHtmlNodePARAM = class(TIpHtmlNodeNv)
private
FId: string;
FValueType: TIpHtmlObjectValueType;
FValue: string;
FName: string;
public {!!.10}
property Id : string read FId write FId;
property Name : string read FName write FName;
property Value : string read FValue write FValue;
property ValueType : TIpHtmlObjectValueType read FValueType write FValueType;
end;
TIpHtmlNodeBASEFONT = class(TIpHtmlNodeGenInline)
private
FSize: Integer;
protected
procedure ApplyProps(const RenderProps: TIpHtmlProps); override;
public {!!.10}
property Size : Integer read FSize write FSize;
end;
TIpHtmlNodeMAP = class(TIpHtmlNodeCore)
private
FName : string;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Name : string read FName write FName;
end;
TIpHtmlNodeAREA = class(TIpHtmlNodeCore)
private
FShape: TIpHtmlMapShape;
FTabIndex: Integer;
FTarget: string;
protected
FNoHRef: Boolean;
FHRef: string;
FCoords: string;
FAlt: string;
FRect : TRect;
FRgn : HRgn;
procedure Reset;
function GetHint: string; override;
function PtInRects(const P : TPoint) : Boolean;
public
destructor Destroy; override; {!!.10}
{$IFDEF CBuilder}
property Rect : TRect read FRect;
{$ENDIF}
{$IFDEF IP_LAZARUS}
property Rect : TRect read FRect;
{$ENDIF}
property Alt : string read FAlt write FAlt;
property Coords : string read FCoords write FCoords;
property HRef : string read FHRef write FHRef;
property NoHRef : Boolean read FNoHRef write FNoHRef;
{$IFNDEF CBuilder}
{$IFNDEF IP_LAZARUS}
property Rect : TRect read FRect;
{$ENDIF}
{$ENDIF}
property Shape : TIpHtmlMapShape read FShape write FShape;
property TabIndex : Integer read FTabIndex write FTabIndex;
property Target: string read FTarget write FTarget;
end;
TIpHtmlNodeMETA = class(TIpHtmlNodeNv)
private
FScheme: string;
FContent: string;
FHttpEquiv: string;
FName: string;
public {!!.10}
property Content : string read FContent write FContent;
property HttpEquiv: string read FHttpEquiv write FHttpEquiv;
property Name : string read FName write FName;
property Scheme : string read FScheme write FScheme;
end;
TIpHtmlNodeLINK = class(TIpHtmlNodeCore)
private
FTitle: string;
FHRef: string;
FRev: string;
FRel: string;
{$IFDEF IP_LAZARUS}
FType: string;
{$ENDIF}
public {!!.10}
property HRef : string read FHRef write FHRef;
property Rel : string read FRel write FRel;
property Rev : string read FRev write FRev;
property Title : string read FTitle write FTitle;
{$IFDEF IP_LAZARUS}
property Type_ : string read FType write FType;
{$ENDIF}
end;
TIpHtmlVAlignment2 = (hva2Top, hva2Bottom, hva2Left, hva2Right);
TIpHtmlNodeCAPTION = class(TIpHtmlNodeBlock)
private
FAlign: TIpHtmlVAlignment2;
public {!!.10}
property Align : TIpHtmlVAlignment2 read FAlign write FAlign;
end;
TIpHtmlFrameProp = (hfVoid, hfAbove, hfBelow, hfHSides, hfLhs, hfRhs,
hfvSides, hfBox, hfBorder);
TIpHtmlRules = (hrNone, hrGroups, hrRows, hrCols, hrAll);
{TIntArr = array [0..Pred(MAXINTS)] of Integer;}
TInternalIntArr = array [0..Pred(MAXINTS)] of Integer;
PInternalIntArr = ^TInternalIntArr;
TIntArr = class
private
InternalIntArr : PInternalIntArr;
IntArrSize : Integer;
function GetValue(Index: Integer): Integer;
procedure SetValue(Index, Value: Integer);
public
destructor Destroy; override;
property Value[Index: Integer]: Integer read GetValue write SetValue; default;
end;
TInternalRectArr = array [0..Pred(MAXINTS)] of PRect;
PInternalRectArr = ^TInternalRectArr;
TRectArr = class
private
InternalRectArr : PInternalRectArr;
IntArrSize : Integer;
function GetValue(Index: Integer): PRect;
procedure SetValue(Index: Integer; Value: PRect);
public
destructor Destroy; override;
property Value[Index: Integer]: PRect read GetValue write SetValue; default;
end;
TInternalRectRectArr = array [0..Pred(MAXINTS)] of TRectArr;
PInternalRectRectArr = ^TInternalRectRectArr;
TRectRectArr = class
protected
InternalRectRectArr : PInternalRectRectArr;
IntArrSize : Integer;
function GetValue(Index: Integer): TRectArr;
public
destructor Destroy; override;
property Value[Index: Integer]: TRectArr read GetValue; default;
procedure Delete(Index: Integer);
end;
{ TIpHtmlNodeTABLE }
TIpHtmlNodeTABLE = class(TIpHtmlNodeAlignInline)
private
FBgColor: TColor;
FBorder: Integer;
FCellSpacing: Integer;
FCellPadding: Integer;
FFrame: TIpHtmlFrameProp;
FRules: TIpHtmlRules;
FSummary: string;
FTableWidth: Integer;
procedure SetBorder(const Value: Integer);
procedure SetCellPadding(const Value: Integer);
procedure SetCellSpacing(const Value: Integer);
procedure SetFrame(const Value: TIpHtmlFrameProp);
procedure SetRules(const Value: TIpHtmlRules);
protected
FWidth: TIpHtmlLength;
CellOverhead, {sum of col widths + CellOverhead = TableWidth}
FColCount : Integer;
ColTextWidth : TIntArr; {actual column widths}
ColStart : TIntArr; {start of each column relative to table's left}
ColTextWidthMin,
ColTextWidthMax : TIntArr; {min and max column widths}
RowSp : TIntArr; {dynamic flag used for row spanning}
FCaption : TIpHtmlNodeCAPTION;
BorderRect : TRect;
BorderRect2 : TRect; {includes caption if any}
RUH, RUV : Integer; {ruler width hor/vert}
BL, BR, BT, BB : Integer; {border width, left, right, top, bottom}
{$IFNDEF IP_LAZARUS}
CS2 : Integer; {cell space div 2}
{$ENDIF}
SizeWidth : TIpHtmlPixels; {last computed width of table}
FMin, FMax : Integer;
procedure CalcMinMaxColTableWidth(const RenderProps: TIpHtmlProps;
var Min, Max: Integer);
procedure CalcSize(const ParentWidth: Integer;
const RenderProps: TIpHtmlProps);
procedure Draw(Block: TIpHtmlNodeBlock); override;
procedure SetRect(TargetRect: TRect); override;
procedure SetProps(const RenderProps: TIpHtmlProps); override;
function GetDim(ParentWidth: Integer): TSize; override;
procedure CalcMinMaxWidth(var Min, Max: Integer); override;
procedure InvalidateSize; override;
function GetColCount: Integer;
procedure Enqueue; override;
property ColCount : Integer read GetColCount;
procedure WidthChanged(Sender: TObject); {!!.10}
function ExpParentWidth: Integer; override; {!!.10}
{$IFDEF IP_LAZARUS}
procedure LoadCSSProps(Owner : TIpHtml; var Element: TCSSProps; const Props: TIpHtmlProps); override;
{$ENDIF}
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property BgColor : TColor read FBgColor write FBgColor;
property Border : Integer read FBorder write SetBorder; {!!.10}
property CalcMinWidth: Integer read FMin; {!!.10}
property CalcMaxWidth: Integer read FMax; {!!.10}
property CalcTableWidth: Integer read FTableWidth; {!!.10}
property CellPadding : Integer
read FCellPadding write SetCellPadding; {!!.10}
property CellSpacing : Integer
read FCellSpacing write SetCellSpacing; {!!.10}
property Frame : TIpHtmlFrameProp read FFrame write SetFrame; {!!.10}
property Rules : TIpHtmlRules read FRules write SetRules; {!!.10}
property Summary : string read FSummary write FSummary;
property Width : TIpHtmlLength read FWidth write FWidth;
end;
TIpHtmlNodeTHeadFootBody = class(TIpHtmlNodeCore);
TIpHtmlNodeTABLEHEADFOOTBODYClass = class of TIpHtmlNodeTHeadFootBody;
TIpHtmlNodeTHEAD = class(TIpHtmlNodeTHeadFootBody)
private
FAlign: TIpHtmlAlign;
FVAlign: TIpHtmlVAlign3;
public
constructor Create(ParentNode : TIpHtmlNode);
property Align : TIpHtmlAlign read FAlign write FAlign;
property VAlign : TIpHtmlVAlign3 read FVAlign write FVAlign;
end;
TIpHtmlNodeTFOOT = class(TIpHtmlNodeTHeadFootBody)
private
FAlign: TIpHtmlAlign;
FVAlign: TIpHtmlVAlign3;
public {!!.10}
property Align : TIpHtmlAlign read FAlign write FAlign;
property VAlign : TIpHtmlVAlign3 read FVAlign write FVAlign;
end;
TIpHtmlNodeTBODY = class(TIpHtmlNodeTHeadFootBody)
private
FAlign: TIpHtmlAlign;
FVAlign: TIpHtmlVAlign3;
public
constructor Create(ParentNode : TIpHtmlNode);
property Align : TIpHtmlAlign read FAlign write FAlign;
property VAlign : TIpHtmlVAlign3 read FVAlign write FVAlign;
end;
TIpHtmlNodeCOLGROUP = class(TIpHtmlNodeCore)
private
FAlign: TIpHtmlAlign;
FSpan: Integer;
FVAlign: TIpHtmlVAlign3;
FWidth: TIpHtmlMultiLength;
public
destructor Destroy; override; {!!.10}
property Align : TIpHtmlAlign read FAlign write FAlign;
property Span : Integer read FSpan write FSpan;
property VAlign : TIpHtmlVAlign3 read FVAlign write FVAlign;
property Width : TIpHtmlMultiLength read FWidth write FWidth;
end;
TIpHtmlNodeCOL = class(TIpHtmlNodeCore)
private
FAlign: TIpHtmlAlign;
FVAlign: TIpHtmlVAlign3;
FSpan: Integer;
FWidth: TIpHtmlMultiLength;
public
destructor Destroy; override;
property Align : TIpHtmlAlign read FAlign write FAlign;
property Span : Integer read FSpan write FSpan;
property VAlign : TIpHtmlVAlign3 read FVAlign write FVAlign;
property Width : TIpHtmlMultiLength read FWidth write FWidth;
end;
TIpHtmlNodeTR = class(TIpHtmlNodeCore)
private
FAlign: TIpHtmlAlign;
FVAlign: TIpHtmlVAlign;
public
constructor Create(ParentNode : TIpHtmlNode);
property Align : TIpHtmlAlign read FAlign write FAlign;
property VAlign : TIpHtmlVAlign read FVAlign write FVAlign;
end;
TIpHtmlCellScope = (hcsUnspec, hcsRow, hcsCol, hcsRowGroup, hcsColGroup);
TIpHtmlNodeTableHeaderOrCell = class(TIpHtmlNodeBlock)
private
FAlign: TIpHtmlAlign;
FBgColor : TColor;
FCalcWidthMin: Integer; {!!.10}
FCalcWidthMax: Integer; {!!.10}
FColspan: Integer;
FHeight: TIpHtmlPixels{Integer}; {!!.10}
FNowrap: Boolean;
FRowspan: Integer;
FWidth: TIpHtmlLength;
FVAlign: TIpHtmlVAlign3;
protected
FPadRect : TRect;
procedure Render( const RenderProps: TIpHtmlProps); override;
procedure Layout(const RenderProps: TIpHtmlProps; const TargetRect : TRect); override;
procedure CalcMinMaxWidth(const RenderProps: TIpHtmlProps;
var Min, Max: Integer); override;
property PadRect : TRect read FPadRect;
procedure DimChanged(Sender: TObject); {!!.10}
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property Align : TIpHtmlAlign read FAlign write FAlign;
property BgColor : TColor read FBgColor write FBgColor;
property CalcWidthMin: Integer read FCalcWidthMin; {!!.10}
property CalcWidthMax: Integer read FCalcWidthMax; {!!.10}
property Colspan : Integer read FColspan write FColspan;
property Height : TIpHtmlPixels{Integer} read FHeight write FHeight; {!!.10}
property Nowrap : Boolean read FNowrap write FNowrap;
property Rowspan : Integer read FRowspan write FRowspan;
property VAlign : TIpHtmlVAlign3 read FVAlign write FVAlign;
property Width : TIpHtmlLength read FWidth write FWidth;
end;
TIpHtmlNodeTH = class(TIpHtmlNodeTableHeaderOrCell);
TIpHtmlNodeTD = class(TIpHtmlNodeTableHeaderOrCell);
TIpHtmlInputType = (hitText, hitPassword, hitCheckbox, hitRadio,
hitSubmit, hitReset, hitFile, hitHidden, hitImage, hitButton);
TIpHtmlNodeINPUT = class(TIpHtmlNodeControl)
private
FAlt: string;
FChecked: Boolean;
FDisabled: Boolean;
FInputType: TIpHtmlInputType;
FMaxLength: Integer;
FName: string;
FReadOnly: Boolean;
FTabIndex: Integer;
FSize: Integer;
FSrc: string;
FValue: string;
protected
FPicture : TPicture;
FFileEdit : TEdit;
FFileSelect : TButton;
procedure Draw(Block: TIpHtmlNodeBlock); override;
procedure SubmitClick(Sender: TObject);
procedure ResetClick(Sender: TObject);
procedure FileSelect(Sender: TObject);
procedure ButtonClick(Sender: TObject);
function GetHint: string; override;
procedure SetImageGlyph(Picture: TPicture);
procedure CreateControl(Parent : TWinControl); override;
function Successful: Boolean; override;
procedure AddValues(NameList, ValueList : TStringList); override;
procedure Reset; override;
public
destructor Destroy; override;
procedure ImageChange(NewPicture : TPicture); override;
property Alt : string read FAlt write FAlt;
property Checked : Boolean read FChecked write FChecked;
property Disabled : Boolean read FDisabled write FDisabled;
property InputType : TIpHtmlInputType read FInputType write FInputType;
property MaxLength : Integer read FMaxLength write FMaxLength;
property Name : string read FName write FName;
property ReadOnly : Boolean read FReadOnly write FReadOnly;
property Size : Integer read FSize write FSize;
property Src : string read FSrc write FSrc;
property TabIndex : Integer read FTabIndex write FTabIndex;
property Value : string read FValue write FValue;
end;
TIpHtmlButtonType = (hbtSubmit, hbtReset, hbtButton);
TIpHtmlNodeBUTTON = class(TIpHtmlNodeControl)
private
FDisabled: Boolean;
FTabIndex: Integer;
FValue: string;
FName: string;
FInputType: TIpHtmlButtonType;
protected
procedure SubmitClick(Sender: TObject);
procedure ResetClick(Sender: TObject);
procedure ButtonClick(Sender: TObject);
function Successful: Boolean; override;
procedure AddValues(NameList, ValueList : TStringList); override;
procedure CreateControl(Parent : TWinControl); override;
procedure Reset; override;
public
constructor Create(ParentNode : TIpHtmlNode);
destructor Destroy; override;
property ButtonType : TIpHtmlButtonType read FInputType write FInputType;
property Disabled : Boolean read FDisabled write FDisabled;
property Name : string read FName write FName;
property TabIndex : Integer read FTabIndex write FTabIndex;
property Value : string read FValue write FValue;
end;
TIpHtmlNodeSELECT = class(TIpHtmlNodeControl)
private
FDisabled: Boolean;
FMultiple: Boolean;
FName: string;
FSize: Integer;
FTabIndex: Integer;
protected
procedure CreateControl(Parent : TWinControl); override;
function Successful: Boolean; override;
procedure Reset; override;
procedure ButtonClick(Sender: TObject); {!!.01}
public
procedure AddValues(NameList, ValueList : TStringList); override;
property Disabled : Boolean read FDisabled write FDisabled;
property Multiple : Boolean read FMultiple write FMultiple;
property Name : string read FName write FName;
property Size : Integer read FSize write FSize;
property TabIndex : Integer read FTabIndex write FTabIndex;
end;
TIpHtmlNodeOPTION = class(TIpHtmlNodeCore)
private
FDisabled: Boolean;
FOptionLabel: string;
FSelected: Boolean;
FValue: string;
public {!!.10}
property Disabled : Boolean read FDisabled write FDisabled;
property OptionLabel : string read FOptionLabel write FOptionLabel;
property Selected : Boolean read FSelected write FSelected;
property Value : string read FValue write FValue;
end;
TIpHtmlNodeOPTGROUP = class(TIpHtmlNodeCore)
private
FDisabled: Boolean;
FGroupLabel: string;
public {!!.10}
property Disabled : Boolean read FDisabled write FDisabled;
property GroupLabel : string read FGroupLabel write FGroupLabel;
end;
TIpHtmlNodeTEXTAREA = class(TIpHtmlNodeControl)
private
FDisabled: Boolean;
FReadOnly: Boolean;
FTabIndex: Integer;
FCols: Integer;
FRows: Integer;
FName: string;
protected
procedure CreateControl(Parent : TWinControl); override;
function Successful: Boolean; override;
procedure AddValues(NameList, ValueList : TStringList); override;
procedure Reset; override;
public {!!.10}
property Cols : Integer read FCols write FCols;
property Disabled : Boolean read FDisabled write FDisabled;
property Name : string read FName write FName;
property ReadOnly : Boolean read FReadOnly write FReadOnly;
property Rows : Integer read FRows write FRows;
property TabIndex : Integer read FTabIndex write FTabIndex;
end;
TInvalidateEvent = procedure(Sender : TIpHtml; const Rect : TRect) of object;
TIpHtmlNodeLABEL = class(TIpHtmlNodeInline)
private
FLabelFor: string;
public
constructor Create(ParentNode: TIpHtmlNode);
destructor Destroy; override;
property LabelFor : string read FLabelFor write FLabelFor;
end;
TIpHtmlNodeFIELDSET = class(TIpHtmlNodeCore);
TIpHtmlNodeLEGEND = class(TIpHtmlNodeCore)
private
FAlign: TIpHtmlVAlignment2;
public {!!.10}
property Align : TIpHtmlVAlignment2 read FAlign write FAlign;
end;
TWriteCharProvider = procedure(C : AnsiChar) of object;
TIpHtmlDataGetImageEvent =
procedure(Sender: TIpHtmlNode; const URL: string; var Picture: TPicture)
of object;
TIpHtmlScrollEvent =
procedure(Sender: TIpHtml; const R: TRect) of object;
TGetEvent =
procedure(Sender: TIpHtml; const URL: string) of object;
TPostEvent =
procedure(Sender: TIpHtml; const URL: string;
FormData: TIpFormDataEntity) of object; {!!.12}
TIFrameCreateEvent =
procedure(Sender: TIpHtml; Parent: TWinControl;
Frame: TIpHtmlNodeIFRAME;
var Control: TWinControl) of object;
TURLCheckEvent =
procedure(Sender: TIpHtml; const URL: string;
var Visited: Boolean) of object;
TReportURLEvent =
procedure(Sender: TIpHtml; const URL: string) of object;
TIpHtmlRectListEntry = record
Rect : TRect;
Node : PIpHtmlElement;
Block : TIpHtmlNodeBlock;
end;
PIpHtmlRectListEntry = ^TIpHtmlRectListEntry;
TControlEvent = procedure(Sender: TIpHtml; Node: TIpHtmlNodeControl)
of object;
TIpHtml = class
private
FHotNode : TIpHtmlNode;
FCurElement : PIpHtmlElement;
FHotPoint : TPoint;
FOnInvalidateRect : TInvalidateEvent;
FTarget : TCanvas;
FVLinkColor: TColor;
FLinkColor: TColor;
FALinkColor: TColor;
FTextColor: TColor;
FBgColor: TColor; //JMN
FHasFrames : Boolean;
FOnGetImageX : TIpHtmlDataGetImageEvent;
FOnScroll : TIpHtmlScrollEvent;
FOnInvalidateSize : TNotifyEvent;
FOnGet: TGetEvent;
FOnPost: TPostEvent;
FOnIFrameCreate : TIFrameCreateEvent;
FOnURLCheck: TURLCheckEvent;
FOnReportURL: TReportURLEvent;
FControlClick : TControlEvent;
FControlCreate : TControlEvent;
CurFrameSet : TIpHtmlNodeFRAMESET;
FCanPaint : Boolean;
FMarginHeight: Integer;
FMarginWidth: Integer;
{$IFDEF IP_LAZARUS}
FDataProvider: TIpAbstractHtmlDataProvider;
FCSS: TCSSGlobalProps;
{$ENDIF}
protected
CharStream : TStream;
CurToken : TIpHtmlToken;
ParmList, ValueList : TStringList;
FHtml : TIpHtmlNodeHtml;
CharStack : array [0..7] of AnsiChar;
LastWasSpace: Boolean; {!!.10}
LastWasClose: Boolean; {!!.10}
CharSP : Integer;
FFlagErrors : Boolean;
IndexPhrase : string;
{Base : string;} {!!.12}
{IsIndexPresent : Boolean;} {!!.12}
TokenBuffer : TIpHtmlToken;
FPageRect : TRect;
HaveToken : Boolean;
PageViewRect : TRect; {the current section of the page}
ClientRect : TRect; {the coordinates of the paint rectangle}
DefaultProps : TIpHtmlProps;
Body : TIpHtmlNodeBODY;
FTitleNode : TIpHtmlNodeTITLE;
{$IFDEF IP_LAZARUS}
{$IFDEF UseGifImageUnit}
GifImages : TList;
{$ELSE}
AnimationFrames : TList;
{$ENDIF}
{$ELSE}
GifImages : TList;
OtherImages: TList; //JMN
{$ENDIF}
LIndent, LOutdent : PIpHtmlElement;
SoftLF,
HardLF, HardLFClearLeft, SoftHyphen,
HardLFClearRight, HardLFClearBoth : PIpHtmlElement;
NameList : TStringList;
{PanelWidth : Integer;} {!!.12}
GifQueue : TList;
InPre : Integer;
InBlock : Integer;
MapList : TList;
AreaList : TList;
DefaultImage : TPicture;
MapImgList : TList;
GlobalPos, LineNumber, LineOffset : Integer;
PaintBufferBitmap : TBitmap;
PaintBuffer : TCanvas;
TokenStringBuf : PChar; {array[16383] of AnsiChar;} {!!.01}
TBW : Integer;
Destroying : Boolean;
AllSelected : Boolean;
HtmlTokenList : TStringList;
RectList : TList;
FStartSel, FEndSel : TPoint;
ElementPool : TIpHtmlPoolManager;
AnchorList : TList;
ControlList : TList;
CURURL : string;
DoneLoading : Boolean;
ListLevel : Integer;
PropACache : TList;
PropBCache : TList;
DummyA : TIpHtmlPropA;
DummyB : TIpHtmlPropB;
RenderCanvas : TCanvas;
PageHeight : Integer;
StartPos : Integer;
FFixedTypeface: string; {!!.10}
FDefaultTypeFace: string;
ParmBuf: PChar; {!!.12}
ParmBufSize: Integer; {!!.12}
procedure ResetCanvasData;
procedure ResetCache;
procedure ResetWordLists;
procedure ResetBlocks(Node: TIpHtmlNode);
procedure ResetImages(Node: TIpHtmlNode); {!!.02}
procedure ResetElementMetrics(P: Pointer);
function FindPropA(const pFontName: string; const pFontSize: Integer;
const pFontStyle: TFontStyles;
const pBaseFontSize: Integer): TIpHtmlPropA;
function FindPropB(const pFontBaseline: Integer;
const pFontColor: TColor; const pAlignment: TIpHtmlAlign;
const pVAlignment: TIpHtmlVAlign3; const pLinkColor, pVLinkColor,
pALinkColor: TColor; const pBgColor: TColor; const pPreformatted,
pNoBreak: Boolean): TIpHtmlPropB;
procedure ClearCache;
function CheckKnownURL(URL: string): boolean;
procedure ReportReference(URL: string);
procedure PaintSelection;
function PageRectToScreen(const Rect: TRect;
var ScreenRect: TRect): Boolean;
function IsWhiteSpace: Boolean;
function GetTokenString: string;
procedure ReportError(const ErrorMsg: string);
procedure ReportExpectedError(const ErrorMsg: string);
procedure ReportExpectedToken(const Token: TIpHtmlToken);
procedure EnsureClosure(const EndToken: TIpHtmlToken;
const EndTokens: TIpHtmlTokenSet);
function NewElement(EType : TElementType; Own: TIpHtmlNode) : PIpHtmlElement;
function BuildStandardEntry(EType: TElementType): PIpHtmlElement;
function ParseDir: TIpHtmlDirection;
procedure ParseSPAN(Parent: TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseQ(Parent: TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseINS(Parent: TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseDEL(Parent: TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseTableBody(Parent: TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseTableRows(Parent: TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseColGroup(Parent: TIpHtmlNode);
function ParseFrameScrollingProp: TIpHtmlFrameScrolling;
function ParseObjectValueType: TIpHtmlObjectValueType;
procedure ParseFrameSet(Parent: TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseFrame(Parent : TIpHtmlNode);
procedure ParseIFrame(Parent : TIpHtmlNode);
procedure ParseNOFRAMES(Parent : TIpHtmlNode);
function ParseButtonType: TIpHtmlButtonType;
procedure ParseNoscript(Parent: TIpHtmlNode);
procedure ParseLEFT(Parent : TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseBLINK(Parent : TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseRIGHT(Parent : TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure PutToken(Token: TIpHtmlToken);
procedure ParseParagraph(Parent : TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseListItems(Parent : TIpHtmlNodeCore;
EndToken: TIpHtmlToken; const EndTokens : TIpHtmlTokenSet;
DefaultListStyle : TIpHtmlULType);
procedure ParseUnorderedList(Parent: TIpHtmlNode;
EndToken : TIpHtmlToken; const EndTokens: TIpHtmlTokenSet);
procedure ParseOrderedList(Parent: TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
procedure ParseDefinitionList(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
procedure ParseDefListItems(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
procedure ParsePre(ParentNode : TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseDIV(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
procedure ParseCENTER(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
procedure ParseBLOCKQUOTE(Parent : TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseHR(Parent: TIpHtmlNode);
procedure ParseFontStyle(Parent: TIpHtmlNode;
StartToken : TIpHtmlToken; const EndTokens: TIpHtmlTokenSet);
procedure ParsePhraseElement(Parent: TIpHtmlNode;
StartToken, EndToken: TIpHtmlToken; const EndTokens: TIpHtmlTokenSet);
procedure ParseAnchor(Parent: TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
procedure ParseIMG(Parent : TIpHtmlNode);
procedure ParseApplet(Parent: TIpHtmlNode; const EndTokens : TIpHtmlTokenSet);
procedure ParseOBJECT(Parent : TIpHtmlNode);
procedure ParseBasefont(Parent: TIpHtmlNode);
procedure ParseBR(Parent : TIpHtmlNode);
procedure ParseNOBR(Parent: TIpHtmlNode);
procedure ParseMAP(Parent: TIpHtmlNode; const EndTokens: TIpHtmlTokenSet);
procedure ParseTABLE(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
function FindAttribute(const AttrName: string): string;
function ColorFromString(S: string): TColor;
function ParseAlignment: TIpHtmlAlign;
function ParseCellAlign(Default : TIpHtmlAlign) : TIpHtmlAlign;
function ParseFrameProp(Default: TIpHtmlFrameProp) : TIpHtmlFrameProp;
function ParseRules(Default : TIpHtmlRules) : TIpHtmlRules;
function ParseULStyle(Default : TIpHtmlULType): TIpHtmlULType;
function ParseBoolean(const AttrName: string): Boolean;
function ParseInteger(const AttrName: string;
Default: Integer): Integer;
function ParseHtmlInteger(const AttrName: string;
Default: Integer): TIpHtmlInteger; {!!.10}
function ParsePixels(const AttrName, Default: string): TIpHtmlPixels; {!!.10}
function ParseHyperLength(const AttrName: string;
const Default: string): TIpHtmlLength;
function ParseHyperMultiLength(const AttrName: string;
const Default: string): TIpHtmlMultiLength;
function ParseHyperMultiLengthList(const AttrName: string;
const Default: string): TIpHtmlMultiLengthList; {!!.10}
function ParseOLStyle(Default: TIpHtmlOLStyle): TIpHtmlOLStyle;
function ParseImageAlignment(const Default: string): TIpHtmlImageAlign;
function ParseVAlignment : TIpHtmlVAlign;
function ParseVAlignment2 : TIpHtmlVAlignment2;
function ParseVAlignment3 : TIpHtmlVAlign3;
function ParseRelSize{(const Default: string)}: TIpHtmlRelSize; {!!.10}
function ParseBRClear: TIpHtmlBreakClear;
function ParseShape: TIpHtmlMapShape;
function NextChar : AnsiChar;
procedure Parse;
{procedure ParseDocType;}
procedure ParseHtml;
function GetChar: AnsiChar;
procedure NextToken;
procedure PutChar(Ch: AnsiChar);
procedure ParseHead(Parent : TIpHtmlNode);
procedure ParseHeadItems(Parent : TIpHtmlNode);
procedure ParseTitle(Parent: TIpHtmlNode);
procedure ParseScript(Parent : TIpHtmlNode; const EndTokens : TIpHtmlTokenSet);
procedure ParseStyle(ParentNode : TIpHtmlNode);
procedure ParseIsIndex;
procedure ParseBase;
procedure ParseLink(Parent : TIpHtmlNode);
procedure ParseMeta(Parent : TIpHtmlNode);
procedure ParseBody(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
{$IFDEF IP_LAZARUS}
procedure ParseStyleSheet(Parent: TIpHtmlNode; HRef: String);
{$ENDIF}
procedure ParseBodyText(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
procedure ParseBlock(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
procedure ParseInline(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
procedure ParseHeader(Parent : TIpHtmlNode;
EndToken : TIpHtmlToken; Size : Integer);
procedure ParseText(const EndTokens: TIpHtmlTokenSet;
Parent: TIpHtmlNode);
procedure ParseFont(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
procedure ParseAddress(Parent: TIpHtmlNode);
procedure ParseForm(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
function ParseMethod: TIpHtmlFormMethod;
procedure ParseTableRow(Parent: TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
function ParseInputType : TIpHtmlInputType;
procedure ParseFormFields(Parent: TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
procedure InvalidateRect(R : TRect);
procedure SetDefaultProps;
function BuildPath(const Ext: string): string;
procedure MakeVisible(const R: TRect);
procedure InvalidateSize;
procedure AddGifQueue(Graphic: TGraphic; const R: TRect);
procedure ClearGifQueue;
procedure StartGifPaint(Target: TCanvas);
procedure ClearAreaLists;
function PagePtToScreen(const Pt: TPoint): TPoint;
procedure NextRealToken;
procedure SkipTextTokens;
procedure BuildAreaList;
procedure ClearAreaList;
procedure NextNonBlankToken;
procedure Get(const URL: string);
procedure Post(const URL: string; FormData: TIpFormDataEntity); {!!.12}
procedure ClearRectList;
procedure AddRect(const R: TRect; Node: PIpHtmlElement;
Block: TIpHtmlNodeBlock);
procedure CreateIFrame(Parent: TWinControl; Frame: TIpHtmlNodeIFRAME;
var Control: TWinControl);
procedure FinalizeRecs(P: Pointer);
function LinkVisited(const URL: string): Boolean;
procedure AddWord(Value: string; Props: TIpHtmlProps;
Owner: TIpHtmlNode);
procedure AddWordEntry(const Value: string; Props: TIpHtmlProps;
Owner: TIpHtmlNode);
function FindElement(const Name: string): TIpHtmlNode;
procedure Clear; {clear any contents}
procedure Home;
function GetPageRect(TargetCanvas: TCanvas; Width, Height : Integer): TRect;
procedure MouseMove(Pt : TPoint);
{$IFDEF IP_LAZARUS}
procedure DeselectAllItems(Item: Pointer);
{$ENDIF}
procedure SetSelection(StartPoint, EndPoint: TPoint);
function HaveSelection: Boolean;
procedure CopyToClipboard;
procedure ReportReferences(Node: TIpHtmlNode);
procedure RequestImageNodes(Node: TIpHtmlNode);
procedure SelectAll;
procedure DeselectAll;
procedure ControlClick(Sender: TIpHtmlNodeControl);
procedure ControlCreate(Sender: TIpHtmlNodeControl);
property HotNode : TIpHtmlNode read FHotNode;
property CurElement : PIpHtmlElement read FCurElement write FCurElement;
property HotPoint : TPoint read FHotPoint;
property OnInvalidateRect : TInvalidateEvent
read FOnInvalidateRect write FOnInvalidateRect;
property Target : TCanvas read FTarget;
property TextColor : TColor read FTextColor write FTextColor;
property LinkColor : TColor read FLinkColor write FLinkColor;
property VLinkColor : TColor read FVLinkColor write FVLinkColor;
property ALinkColor : TColor read FALinkColor write FALinkColor;
property BgColor : TColor read FBgColor write FBgColor;
property HasFrames : Boolean read FHasFrames;
property OnGetImageX : TIpHtmlDataGetImageEvent
read FOnGetImageX write FOnGetImageX;
property OnScroll : TIpHtmlScrollEvent
read FOnScroll write FOnScroll;
property OnInvalidateSize : TNotifyEvent
read FOnInvalidateSize write FOnInvalidateSize;
property OnGet : TGetEvent
read FOnGet write FOnGet;
property OnPost : TPostEvent
read FOnPost write FOnPost;
property OnIFrameCreate : TIFrameCreateEvent
read FOnIFrameCreate write FOnIFrameCreate;
property OnURLCheck : TURLCheckEvent
read FOnURLCheck write FOnURLCheck;
property OnReportURL: TReportURLEvent
read FOnReportURL write FOnReportURL;
property OnControlClick : TControlEvent
read FControlClick write FControlClick;
property OnControlCreate : TControlEvent
read FControlCreate write FControlCreate;
property FrameSet : TIpHtmlNodeFRAMESET read CurFrameSet;
property CanPaint : Boolean read FCanPaint;
property MarginWidth : Integer
read FMarginWidth write FMarginWidth default 20;
property MarginHeight : Integer
read FMarginHeight write FMarginHeight default 20;
procedure DoGetImage(Sender: TIpHtmlNode; const URL: string;
var Picture: TPicture);
{$IFOPT C+}
procedure CheckImage(Picture: TPicture);
{$ENDIF}
{$IFDEF IP_LAZARUS}
function GetSelectionBlocks(out StartSelIndex,EndSelIndex: Integer): boolean;
property CSS: TCSSGlobalProps read FCSS write FCSS;
{$ENDIF}
public
constructor Create;
destructor Destroy; override;
property FlagErrors : Boolean read FFlagErrors write FFlagErrors;
property FixedTypeface: string read FFixedTypeface write FFixedTypeface;
property DefaultTypeFace: string read FDefaultTypeFace write FDefaultTypeFace;
property HtmlNode : TIpHtmlNodeHtml read FHtml;
procedure LoadFromStream(S : TStream);
procedure Render(TargetCanvas: TCanvas; TargetPageRect : TRect;
UsePaintBuffer: Boolean; const TopLeft: TPoint); {!!.10}
property TitleNode : TIpHtmlNodeTITLE read FTitleNode;
{$IFDEF IP_LAZARUS_DBG}
procedure DebugChild(Node: TIpHtmlNode; const UserData: Pointer);
procedure DebugAll;
{$ENDIF}
end;
TIpHtmlFocusRect = class(TCustomControl)
private
FAnchor : TIpHtmlNodeA;
protected
{HaveFocus : Boolean;} {!!.12}
procedure CreateParams(var Params: TCreateParams); override;
{$IFDEF IP_LAZARUS}
procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
procedure WMKillFocus(var Message: TLMKillFocus); message LM_KILLFOCUS;
{$ELSE}
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
property Anchor : TIpHtmlNodeA read FAnchor write FAnchor;
end;
TIpHtmlInternalPanel = class;
TIpHtmlScrollBar = class
private
FKind: TScrollBarKind;
FIncrement: TScrollBarInc;
FPosition: Integer;
FRange: Integer;
FTracking: Boolean;
FVisible: Boolean;
procedure SetPosition(Value: Integer);
procedure SetVisible(Value: Boolean);
protected
FControl: TIpHtmlInternalPanel;
FPageIncrement: TScrollbarInc;
FCalcRange: Integer;
{FDelay: Integer;} {!!.12}
{FColor: TColor;} {!!.12}
{FParentColor: Boolean;} {!!.12}
{FPageDiv: Integer;} {!!.12}
{FLineDiv: Integer;} {!!.12}
FUpdateNeeded: Boolean;
procedure CalcAutoRange;
function ControlSize(ControlSB, AssumeSB: Boolean): Integer;
procedure DoSetRange(Value: Integer);
function NeedsScrollBarVisible: Boolean;
procedure ScrollMessage(var Msg: TWMScroll);
procedure Update(ControlSB, AssumeSB: Boolean);
public
constructor Create(AControl: TIpHtmlInternalPanel; AKind: TScrollBarKind);
property Kind: TScrollBarKind read FKind;
property Increment: TScrollBarInc
read FIncrement write FIncrement stored False default 8;
property Position: Integer read FPosition write SetPosition default 0;
property Range: Integer
read FRange {write SetRange stored IsRangeStored default 0};
property Tracking: Boolean read FTracking write FTracking default False;
property Visible: Boolean read FVisible write SetVisible default True;
end;
TIpHtmlCustomPanel = class;
{ TIpHtmlInternalPanel }
TIpHtmlInternalPanel = class(
{$IFDEF IP_LAZARUS}TCustomControl{$ELSE}TCustomPanel{$ENDIF})
private
FHyper : TIpHtml;
FPageRect : TRect;
FAutoScroll: Boolean;
FOnHotChange : TNotifyEvent;
FOnCurElementChange : TNotifyEvent;
FOnHotClick : TNotifyEvent;
FOnClick : TNotifyEvent;
procedure SetHtml(const Value: TIpHtml);
procedure SetPageRect(const Value: TRect);
protected
FUpdatingScrollbars : Boolean;
InPrint: Integer; {!!.10}
SettingPageRect : Boolean;
MouseDownX, MouseDownY : Integer;
HaveSelection,
MouseIsDown,
NewSelection : Boolean;
SelStart, SelEnd : TPoint;
HintWindow : THintWindow;
CurHint : string;
HintX, HintY : Integer;
HintShownHere : Boolean;
Printed: Boolean; {!!.10}
procedure UpdateScrollBars;
procedure ClearSelection;
procedure SetSelection;
procedure ScrollPtInView(P: TPoint);
procedure ShowHintNow(const NewHint: string); {!!.12}
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
{$IFDEF IP_LAZARUS}
procedure AsyncHotInvoke(data: ptrint);
{$ENDIF}
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure DoHotChange;
procedure DoCurElementChange;
procedure DoHotInvoke;
procedure DoClick;
procedure Resize; override;
procedure ScrollInView(R : TRect);
procedure ScrollInViewRaw(R : TRect);
function PagePtToScreen(const Pt : TPoint): TPoint;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt);
procedure HideHint;
function HtmlPanel: TIpHtmlCustomPanel;
procedure BeginPrint; {!!.10}
procedure EndPrint; {!!.10}
public
ViewTop, ViewLeft : Integer;
HScroll,
VScroll : TIpHtmlScrollBar;
PrintPageRect : TRect;
PrintWidth, PrintHeight: Integer; {!!.10}
PrintTopLeft: TPoint; {!!.10}
{PrintBottomRight: TPoint;} {!!.10}{!!.12}
PageCount: Integer; {!!.10}
procedure InvalidateSize;
property Hyper : TIpHtml read FHyper write SetHtml;
property PageRect : TRect read FPageRect write SetPageRect;
constructor Create(AOwner: TComponent); override;
property AutoScroll: Boolean read FAutoScroll write FAutoScroll;
property OnHotChange : TNotifyEvent read FOnHotChange write FOnHotChange;
property OnCurElementChange: TNotifyEvent
read FOnCurElementChange write FOnCurElementChange;
property OnHotClick : TNotifyEvent read FOnHotClick write FOnHotClick;
property OnClick : TNotifyEvent read FOnClick write FOnClick;
destructor Destroy; override;
procedure ScrollRequest(Sender: TIpHtml; const R: TRect);
{$IFDEF Version4}
procedure MouseWheelHandler(var Message: TMessage); override;
{$ENDIF}
function GetPrintPageCount: Integer;
procedure PrintPages(FromPage, ToPage: Integer);
procedure PrintPreview;
procedure EraseBackground(DC: HDC); {$IFDEF IP_LAZARUS} override; {$ENDIF} //JMN
end;
TIpAbstractHtmlDataProvider = class(TIpBaseComponent)
protected
function DoGetHtmlStream(const URL: string;
PostData: TIpFormDataEntity) : TStream; virtual; abstract;
{$IFDEF IP_LAZARUS}
function DoGetStream(const URL: string): TStream; virtual; abstract;
{$ENDIF}
{-provider assumes ownership of returned TStream and will free it when
done using it.}
function DoCheckURL(const URL: string;
var ContentType: string): Boolean; virtual; abstract;
procedure DoLeave(Html: TIpHtml); virtual; abstract;
procedure DoReference(const URL: string); virtual; abstract;
procedure DoGetImage(Sender: TIpHtmlNode; const URL: string;
var Picture: TPicture); virtual; abstract;
function CanHandle(const URL: string): Boolean; virtual; abstract;
// renamed New,Old for IP_LAZARUS to NewURL, OldURL
function BuildURL(const OldURL, NewURL: string): string; virtual; abstract;
end;
TIpHtmlEnumerator = procedure(Document: TIpHtml) of object;
TIpScrollAction = (hsaHome, hsaEnd, hsaPgUp, hsaPgDn,
hsaLeft, hsaRight, hsaUp, hsaDown);
TIpHtmlFrame = class
protected
CURURL : string;
CurAnchor : string;
FViewer: TIpHtmlCustomPanel;
FNoScroll: Boolean;
FramePanel : TPanel;
Pnl : array[0..Pred(IPMAXFRAMES)] of TPanel;
FMarginWidth, FMarginHeight : Integer;
FFlagErrors : Boolean;
PostData : TIpFormDataEntity;
Html : TIpHtml;
HyperPanel : TIpHtmlInternalPanel;
FrameCount : Integer;
Frames : array[0..Pred(IPMAXFRAMES)] of TIpHtmlFrame;
FDataProvider : TIpAbstractHtmlDataProvider;
FParent : TCustomPanel;
Name : string;
InOpen: Boolean; {!!.10}
procedure InvalidateRect(Sender: TIpHtml; const R : TRect);
procedure FramePanelResize(Sender: TObject);
procedure AlignPanels;
procedure InvalidateSize(Sender: TObject);
procedure Get(Sender: TIpHtml; const URL: string);
procedure Post(Sender: TIpHtml; const URL: string; FormData: TIpFormDataEntity); {!!.12}
procedure IFrameCreate(Sender: TIpHtml; Parent: TWinControl;
Frame: TIpHtmlNodeIFRAME;
var Control: TWinControl);
procedure InitHtml;
procedure EnumDocuments(Enumerator: TIpHtmlEnumerator);
procedure ControlClick(Sender: TIpHtml; Node: TIpHtmlNodeControl);
procedure ControlCreate(Sender: TIpHtml; Node: TIpHtmlNodeControl);
procedure OpenRelativeURL(const URL: string);
procedure SelectAll;
procedure DeselectAll; {!!.10}
procedure CopyToClipboard;
function HaveSelection: Boolean;
function FindFrame(const FrameName: string): TIpHtmlFrame;
procedure MakeAnchorVisible(const URL: string);
procedure Scroll(Action: TIpScrollAction);
procedure Home;
function IsExternal(const URL: string): Boolean;
procedure SetHtml(NewHtml : TIpHtml);
procedure Stop;
public
constructor Create(Viewer: TIpHtmlCustomPanel; Parent: TCustomPanel;
DataProvider : TIpAbstractHtmlDataProvider; FlagErrors, NoScroll: Boolean;
MarginWidth, MarginHeight: Integer);
destructor Destroy; override;
procedure OpenURL(const URL: string; Delayed: Boolean);
end;
TIpHtmlCustomScanner = class;
TIpHtmlNVFrame = class
protected
CURURL : string;
CurAnchor : string;
FScanner: TIpHtmlCustomScanner;
FFlagErrors : Boolean;
PostData : TIpFormDataEntity;
Html : TIpHtml;
FrameCount : Integer;
Frames : array[0..Pred(IPMAXFRAMES)] of TIpHtmlNVFrame;
FDataProvider : TIpAbstractHtmlDataProvider;
Name : string;
procedure InitHtml;
procedure EnumDocuments(Enumerator: TIpHtmlEnumerator);
procedure OpenRelativeURL(const URL: string);
procedure SelectAll;
procedure CopyToClipboard;
function HaveSelection: Boolean;
function FindFrame(const FrameName: string): TIpHtmlNvFrame;
procedure MakeAnchorVisible(const URL: string);
procedure Home;
procedure Stop;
public
constructor Create(Scanner: TIpHtmlCustomScanner;
DataProvider : TIpAbstractHtmlDataProvider; FlagErrors: Boolean);
destructor Destroy; override;
procedure OpenURL(const URL: string);
end;
TIpHtmlControlEvent = procedure(Sender: TIpHtmlCustomPanel;
Frame: TIpHtmlFrame; Html: TIpHtml; Node: TIpHtmlNodeControl)
of object;
{!!.10 new}
TIpHtmlPrintSettings = class(TPersistent)
private
FMarginTop: Double;
FMarginLeft: Double;
FMarginBottom: Double;
FMarginRight: Double;
public
constructor Create;
destructor Destroy; override;
published
property MarginLeft: Double read FMarginLeft write FMarginLeft;
property MarginTop: Double read FMarginTop write FMarginTop;
property MarginRight: Double read FMarginRight write FMarginRight;
property MarginBottom: Double read FMarginBottom write FMarginBottom;
end;
{ TIpHtmlCustomPanel }
TIpHtmlCustomPanel = class(TCustomPanel)
private
FHotChange : TNotifyEvent;
FHotClick : TNotifyEvent;
FControlClick : TIpHtmlControlEvent;
FControlCreate : TIpHtmlControlEvent;
FCurElementChange: TNotifyEvent; {!!.10}
FDocumentOpen: TNotifyEvent; {!!.10}
FAllowTextSelect: Boolean;
FCurElement : PIpHtmlElement;
FPrintSettings: TIpHtmlPrintSettings; {!!.10}
FFactBAParag: Real; //JMN
procedure SetFactBAParag(const Value: Real); //JMN
function FactBAParagNotIs1: Boolean;
function GetVScrollPos: Integer; //JMN
procedure SetVScrollPos(const Value: Integer); //JMN
protected
FFlagErrors: Boolean;
FFixedTypeface: string; {!!.10}
FDefaultTypeFace: string;
FHotURL: string;
FDataProvider: TIpAbstractHtmlDataProvider;
URLStack : TStringList;
TargetStack : TStringList;
Stp : Integer;
{CurURL : string;} {!!.12}
VisitedList : TStringList;
FVLinkColor: TColor;
FLinkColor: TColor;
FALinkColor: TColor;
FTextColor: TColor;
FBgColor: TColor; //JMN
FShowHints: Boolean;
FMarginHeight: Integer;
FMarginWidth: Integer;
MasterFrame : TIpHtmlFrame;
FHotNode : TIpHtmlNode; {!!.12}
GetURL : string;
PostURL : string;
PostData : TIpFormDataEntity;
procedure Push(const Target, URL: string);
function GetTitle: string;
procedure InternalOpenURL(const Target, HRef: string);
procedure URLCheck(Sender: TIpHtml; const URL: string;
var Visited: Boolean);
procedure ReportURL(Sender: TIpHtml; const URL: string);
procedure Paint; override;
procedure HotChange(Sender: TObject);
procedure CurElementChange(Sender: TObject);
procedure HotClick(Sender: TObject);
procedure ClientClick(Sender: TObject);
procedure DoHotChange;
procedure DoHotClick;
procedure DoOnMouseWheel(Shift: TShiftState; Delta, XPos, YPos: SmallInt); {!!.16}
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure CMIpHttpGetRequest(var Message: TMessage); message CM_IpHttpGetRequest;
procedure ControlClick(Frame: TIpHtmlFrame; Html: TIpHtml;
Node: TIpHtmlNodeControl);
procedure ControlCreate(Frame: TIpHtmlFrame; Html: TIpHtml;
Node: TIpHtmlNodeControl);
function GetVersion : string;
procedure SetVersion(const Value : string);
procedure SetDefaultTypeFace(const Value: string);
public
function GetPrintPageCount: Integer;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure EraseBackground(DC: HDC); {$IFDEF IP_LAZARUS} override; {$ENDIF} //JMN
procedure CopyToClipboard;
procedure EnumDocuments(Enumerator: TIpHtmlEnumerator);
procedure GoBack;
function canGoBack : boolean;
procedure GoForward;
function canGoForward : boolean;
function HaveSelection: Boolean;
property HotNode : TIpHtmlNode read FHotNode; {!!.12}
function IsURLHtml(const URL: string): Boolean;
procedure MakeAnchorVisible(const Name: string);
{$IFDEF VERSION4}
procedure MouseWheelHandler(Var Message: TMessage); Override; {!!.16}
{$ENDIF}
procedure OpenURL(const URL: string);
procedure Scroll(Action: TIpScrollAction);
procedure SelectAll;
procedure DeselectAll; {!!.10}
procedure SetHtml(NewHtml : TIpHtml);
procedure Stop;
procedure Print(FromPg, ToPg: LongInt);
procedure PrintPreview; {!!.10}
property VScrollPos: Integer
read GetVScrollPos write SetVScrollPos; //JMN
property BgColor : TColor
read FBgColor write FBgColor default clWhite; //JMN
property ALinkColor : TColor
read FALinkColor write FALinkColor default clRed;
property AllowTextSelect: Boolean
read FAllowTextSelect write FAllowTextSelect
default True;
property CurElement : PIpHtmlElement read FCurElement;
property DataProvider: TIpAbstractHtmlDataProvider
read FDataProvider write FDataProvider;
property FactBAParag: Real
read FFactBAParag write SetFactBAParag stored FactBAParagNotIs1; //JMN
property FlagErrors : Boolean
read FFlagErrors write FFlagErrors;
property FixedTypeface: string
read FFixedTypeface write FFixedTypeface; {!!.10}
property DefaultTypeFace: string
read FDefaultTypeFace write SetDefaultTypeFace;
property HotURL : string read FHotURL;
property LinkColor : TColor
read FLinkColor write FLinkColor default clBlue;
property MarginHeight : Integer
read FMarginHeight write FMarginHeight default 10;
property MarginWidth : Integer
read FMarginWidth write FMarginWidth default 10;
property PrintSettings : TIpHtmlPrintSettings {!!.10}
read FPrintSettings write FPrintSettings; {!!.10}
property ShowHints: Boolean
read FShowHints write FShowHints default True;
property TextColor : TColor
read FTextColor write FTextColor default clBlack;
property Title : string read GetTitle;
property VLinkColor : TColor
read FVLinkColor write FVLinkColor default clMaroon;
property OnControlClick : TIpHtmlControlEvent
read FControlClick write FControlClick;
property OnControlCreate : TIpHtmlControlEvent
read FControlCreate write FControlCreate;
property OnCurElementChange: TNotifyEvent
read FCurElementChange write FCurElementChange; {!!.10}
property OnDocumentOpen: TNotifyEvent
read FDocumentOpen write FDocumentOpen; {!!.10}
property OnHotChange : TNotifyEvent
read FHotChange write FHotChange;
property OnHotClick : TNotifyEvent
read FHotClick write FHotClick;
published
property Version : string
read GetVersion write SetVersion stored False;
end;
TIpHtmlPanel = class(TIpHtmlCustomPanel)
published
property Align;
property ALinkColor;
property AllowTextSelect;
{$IFDEF VERSION4}
property Anchors; {!!.10}
{$ENDIF}
property BorderWidth; {!!.10}
property BorderStyle; {!!.10}
{$IFDEF VERSION4}
property Constraints; {!!.10}
{$ENDIF}
property DataProvider;
property Enabled; {!!.10}
property FixedTypeface; {!!.10}
property DefaultTypeFace;
property FactBAParag; //JMN
property FlagErrors;
property LinkColor;
property MarginHeight;
property MarginWidth;
property PopupMenu;
property PrintSettings; {!!.10}
property ShowHints;
property TextColor;
property Visible; {!!.10}
property VLinkColor;
{$IFDEF VERSION4}
property OnCanResize; {!!.10}
{$ENDIF}
property OnClick;
{$IFDEF VERSION4}
property OnConstrainedResize; {!!.10}
{$ENDIF}
{$IFDEF VERSION5}
property OnContextPopup; {!!.10}
{$ENDIF}
property OnControlClick;
property OnControlCreate;
property OnCurElementChange; {!!.10}
property OnDocumentOpen; {!!.10}
property OnEnter; {!!.10}
property OnExit; {!!.10}
property OnHotChange;
property OnHotClick;
end;
TIpHtmlCustomScanner = class(TComponent)
private
FDataProvider: TIpAbstractHtmlDataProvider;
FFlagErrors: Boolean;
function GetTitle: string;
function GetVersion : string; {!!.14}
procedure SetVersion(const Value : string); {!!.14}
protected
URLStack : TStringList;
TargetStack : TStringList;
Stp : Integer;
CurURL : string;
MasterFrame : TIpHtmlNVFrame;
procedure Push(const Target, URL: string);
procedure InternalOpenURL(const Target, HRef: string);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure EnumDocuments(Enumerator: TIpHtmlEnumerator);
function IsURLHtml(const URL: string): Boolean;
procedure OpenURL(const URL: string);
procedure Stop;
property DataProvider: TIpAbstractHtmlDataProvider
read FDataProvider write FDataProvider;
property FlagErrors : Boolean
read FFlagErrors write FFlagErrors;
property Title : string read GetTitle;
{Begin !!.14}
published
property Version : string
read GetVersion write SetVersion stored False;
{End !!.14}
end;
TIpHtmlScanner = class(TIpHtmlCustomScanner)
published
property DataProvider;
property FlagErrors;
end;
var
ScaleFonts : Boolean = False; {true during print preview only} {!!.10}
{public to let print preview unit access it}
function MaxI2(const I1, I2: Integer) : Integer;
function MinI2(const I1, I2: Integer) : Integer;
function CalcMultiLength(const List: TIpHtmlMultiLengthList;
Avail: Integer; var Sections: Integer): TIntArr; {!!.10}
procedure Register;
implementation
uses
Printers,
IpHtmlPv; {!!.10}
{$IFNDEF IP_LAZARUS}
{$R *.res}
{$ENDIF}
{$IFDEF IP_LAZARUS}
{$I ipcss.inc}
{$ENDIF}
var
FlatSB_GetScrollInfo: function(hWnd: HWND; BarFlag: Integer;
var ScrollInfo: TScrollInfo): BOOL; stdcall;
FlatSB_GetScrollPos: function(hWnd: HWND; nBar: Integer): Integer; stdcall;
FlatSB_SetScrollPos: function(hWnd: HWND; nBar, nPos: Integer;
bRedraw: BOOL): Integer; stdcall;
FlatSB_SetScrollProp: function(p1: HWND; index: Integer; newValue: Integer;
p4: Bool): Bool; stdcall;
FlatSB_SetScrollInfo: function(hWnd: HWND; BarFlag: Integer;
const ScrollInfo: TScrollInfo; Redraw: BOOL): Integer; stdcall;
const
MaxElements = 1024*1024;
ShyChar = #1; {character used to represent soft-hyphen in strings}
NbspChar = #2; {character used to represent no-break space in strings}
NAnchorChar = #3 ; {character used to represent an Anchor }
WheelDelta = 8;
const
WSB_PROP_CYVSCROLL = $00000001;
WSB_PROP_CXHSCROLL = $00000002;
WSB_PROP_CYHSCROLL = $00000004;
WSB_PROP_CXVSCROLL = $00000008;
WSB_PROP_CXHTHUMB = $00000010;
WSB_PROP_CYVTHUMB = $00000020;
WSB_PROP_VBKGCOLOR = $00000040;
WSB_PROP_HBKGCOLOR = $00000080;
WSB_PROP_VSTYLE = $00000100;
WSB_PROP_HSTYLE = $00000200;
WSB_PROP_WINSTYLE = $00000400;
WSB_PROP_PALETTE = $00000800;
WSB_PROP_MASK = $00000FFF;
FSB_FLAT_MODE = 2;
FSB_ENCARTA_MODE = 1;
FSB_REGULAR_MODE = 0;
var
ScaleBitmaps : Boolean = False; {!!.02}
BWPrinter: Boolean; {!!.10}
Aspect : Double; {!!.02}
FactBAParagG: Real; //JMN
{$IFDEF IP_LAZARUS}
procedure DebugBox(Canvas: TCanvas; R: Trect; cl:TColor; dbg:boolean=false);
var
OldPenColor: TColor;
begin
OldPenColor := Canvas.Pen.Color;
Canvas.Pen.Color := cl;
Canvas.Moveto(r.left+(r.right-r.left) div 2, r.top);
Canvas.Lineto(r.left+(r.right-r.left) div 2, r.bottom);
Canvas.MoveTo(r.Left, r.top+(r.bottom-r.top) div 2);
Canvas.LineTo(r.right, r.top+(r.bottom-r.top) div 2);
if Dbg then
DebugLn(dbgs(R));
Canvas.Pen.Color := OldPenColor;
end;
{$ENDIF}
procedure Register;
begin
RegisterComponents('IPro', [TIpHtmlPanel]);
end;
{!!.14 new}
{$IFNDEF VERSION3ONLY}
type
THtmlRadioButton = class(TRadioButton)
protected
FChecked: Boolean;
procedure SetChecked(Value: Boolean); override;
function GetChecked: Boolean; override;
procedure CreateWnd; override;
end;
procedure THtmlRadioButton.CreateWnd;
begin
inherited CreateWnd;
{$IFNDEF IP_LAZARUS}
SendMessage(Handle, BM_SETCHECK, Integer(FChecked), 0);
{$ENDIF}
end;
function THtmlRadioButton.GetChecked: Boolean;
begin
Result := FChecked;
end;
procedure THtmlRadioButton.SetChecked(Value: Boolean);
{$IFDEF IP_LAZARUS}
begin
inherited SetChecked(Value);
end;
{$ELSE IP_LAZARUS}
procedure TurnSiblingsOff;
var
I: Integer;
Sibling: TControl;
begin
if Parent <> nil then
with Parent do
for I := 0 to ControlCount - 1 do begin
Sibling := Controls[I];
if (Sibling <> Self)
and (Sibling is THtmlRadioButton)
and (Sibling.Tag = Self.Tag) then
with THtmlRadioButton(Sibling) do
SetChecked(False);
end;
end;
begin
if FChecked <> Value then begin
FChecked := Value;
TabStop := Value;
if HandleAllocated then
SendMessage(Handle, BM_SETCHECK, Integer(FChecked), 0);
if Value then begin
TurnSiblingsOff;
inherited Changed;
if not ClicksDisabled then
Click;
end;
end;
end;
{$ENDIF IP_LAZARUS}
{$ENDIF}
{!!.02 new}
procedure GetRelativeAspect(PrinterDC : hDC);
var
ScreenDC : hDC;
begin
ScreenDC := GetDC(0);
try
Aspect := GetDeviceCaps(PrinterDC, LOGPIXELSX)
/ GetDeviceCaps(ScreenDC, LOGPIXELSX);
finally
ReleaseDC(0, ScreenDC);
end;
end;
{$IFDEF IP_LAZARUS}
constructor TIpHtmlPoolManager.Create(TheItemSize, MaxItems : DWord);
begin
inherited Create(TheItemSize);
ClearOnCreate:=true;
end;
function TIpHtmlPoolManager.NewItm : Pointer;
begin
Result:=NewItem;
end;
{$ELSE IP_LAZARUS}
constructor TIpHtmlPoolManager.Create(ItemSize, MaxItems : DWord);
begin
InitializeCriticalSection(Critical);
EnterCriticalSection(Critical);
try
InternalSize := ItemSize;
while 4096 mod InternalSize <> 0 do
Inc(InternalSize);
Root := VirtualAlloc(nil, InternalSize * MaxItems,
MEM_RESERVE, PAGE_NOACCESS);
NextPage := Root;
Next := Root;
finally
LeaveCriticalSection(Critical);
end;
{Top := Pointer(DWord(Root) + InternalSize * MaxItems);} {!!.12}
end;
destructor TIpHtmlPoolManager.Destroy;
begin
EnterCriticalSection(Critical);
try
if Root <> nil then
VirtualFree(Root, 0, MEM_RELEASE);
inherited Destroy;
finally
LeaveCriticalSection(Critical);
end;
DeleteCriticalSection(Critical);
end;
function TIpHtmlPoolManager.NewItm : Pointer;
begin
EnterCriticalSection(Critical);
if Next = NextPage then
Grow;
Result := Next;
Inc(DWord(Next), InternalSize);
LeaveCriticalSection(Critical);
end;
procedure TIpHtmlPoolManager.Grow;
var {!!.10}
P: Pointer; {!!.10}
begin
P := VirtualAlloc(NextPage, 4096, MEM_COMMIT, PAGE_READWRITE); {!!.10}
if P = nil then {!!.10}
raise Exception.Create('Out of memory'); {!!.10}
Inc(DWord(NextPage),4096);
end;
procedure TIpHtmlPoolManager.EnumerateItems(Method: TIpEnumItemsMethod);
var
P : Pointer;
begin
P := Root;
while DWord(P) < DWord(Next) do begin
Method(P);
Inc(DWord(P), InternalSize);
end;
end;
{$ENDIF IP_LAZARUS}
{$IFNDEF IP_LAZARUS}
// workaround for fpc bug: local string constants
function ParseConstant(const S: string): AnsiChar;
{$ENDIF}
Const
CodeCount = 125; //JMN
{Sorted by Size where size is Length(Name).
Make sure you respect this when adding new items}
Codes: array[0..Pred(CodeCount)] of record
Size: Integer;
Name: String;
Value: AnsiChar;
end = (
(Size: 2; Name: 'gt'; Value: '>'),
(Size: 2; Name: 'lt'; Value: '<'),
(Size: 3; Name: 'amp'; Value: '&'),
(Size: 3; Name: 'deg'; Value: #176),
(Size: 3; Name: 'ETH'; Value: #208),
(Size: 3; Name: 'eth'; Value: #240),
(Size: 3; Name: 'not'; Value: #172),
(Size: 3; Name: 'reg'; Value: #174),
(Size: 3; Name: 'shy'; Value: ShyChar),
(Size: 3; Name: 'uml'; Value: #168),
(Size: 3; Name: 'yen'; Value: #165),
(Size: 4; Name: 'Auml'; Value: #196),
(Size: 4; Name: 'auml'; Value: #228),
(Size: 4; Name: 'bull'; Value: #149),
(Size: 4; Name: 'cent'; Value: #162),
(Size: 4; Name: 'circ'; Value: '^'),
(Size: 4; Name: 'copy'; Value: #169),
(Size: 4; Name: 'Euml'; Value: #203),
(Size: 4; Name: 'euml'; Value: #235),
(Size: 4; Name: 'fnof'; Value: #131),
(Size: 4; Name: 'Iuml'; Value: #207),
(Size: 4; Name: 'iuml'; Value: #239),
(Size: 4; Name: 'macr'; Value: #175),
(Size: 4; Name: 'nbsp'; Value: NbspChar),
(Size: 4; Name: 'ordf'; Value: #170),
(Size: 4; Name: 'ordm'; Value: #186),
(Size: 4; Name: 'Ouml'; Value: #214),
(Size: 4; Name: 'ouml'; Value: #246),
(Size: 4; Name: 'para'; Value: #182),
(Size: 4; Name: 'quot'; Value: '"'),
(Size: 4; Name: 'sect'; Value: #167),
(Size: 4; Name: 'sup1'; Value: #185),
(Size: 4; Name: 'sup2'; Value: #178),
(Size: 4; Name: 'sup3'; Value: #179),
(Size: 4; Name: 'Uuml'; Value: #220),
(Size: 4; Name: 'uuml'; Value: #252),
(Size: 4; Name: 'Yuml'; Value: #159),
(Size: 4; Name: 'yuml'; Value: #255),
(Size: 5; Name: 'Acirc'; Value: #194),
(Size: 5; Name: 'acirc'; Value: #226),
(Size: 5; Name: 'acute'; Value: #180),
(Size: 5; Name: 'AElig'; Value: #198),
(Size: 5; Name: 'aelig'; Value: #230),
(Size: 5; Name: 'Aring'; Value: #197),
(Size: 5; Name: 'aring'; Value: #229),
(Size: 5; Name: 'cedil'; Value: #184),
(Size: 5; Name: 'Ecirc'; Value: #202),
(Size: 5; Name: 'ecirc'; Value: #234),
(Size: 5; Name: 'frasl'; Value: '/'),
(Size: 5; Name: 'Icirc'; Value: #206),
(Size: 5; Name: 'icirc'; Value: #238),
(Size: 5; Name: 'iexcl'; Value: #161),
(Size: 5; Name: 'laquo'; Value: #171),
(Size: 5; Name: 'ldquo'; Value: #147),
(Size: 5; Name: 'lsquo'; Value: #145),
(Size: 5; Name: 'mdash'; Value: #151),
(Size: 5; Name: 'micro'; Value: #181),
(Size: 5; Name: 'minus'; Value: '-'),
(Size: 5; Name: 'ndash'; Value: #150),
(Size: 5; Name: 'Ocirc'; Value: #212),
(Size: 5; Name: 'ocirc'; Value: #244),
(Size: 5; Name: 'OElig'; Value: #140),
(Size: 5; Name: 'oelig'; Value: #156),
(Size: 5; Name: 'pound'; Value: #163),
(Size: 5; Name: 'raquo'; Value: #187),
(Size: 5; Name: 'rdquo'; Value: #148),
(Size: 5; Name: 'rsquo'; Value: #146),
(Size: 5; Name: 'szlig'; Value: #223),
(Size: 5; Name: 'THORN'; Value: #222),
(Size: 5; Name: 'thorn'; Value: #254),
(Size: 5; Name: 'tilde'; Value: '~'),
(Size: 5; Name: 'times'; Value: #215),
(Size: 5; Name: 'trade'; Value: #153),
(Size: 5; Name: 'Ucirc'; Value: #219),
(Size: 5; Name: 'ucirc'; Value: #251),
(Size: 6; Name: 'Aacute'; Value: #193),
(Size: 6; Name: 'aacute'; Value: #225),
(Size: 6; Name: 'Agrave'; Value: #192),
(Size: 6; Name: 'agrave'; Value: #224),
(Size: 6; Name: 'Atilde'; Value: #195),
(Size: 6; Name: 'atilde'; Value: #227),
(Size: 6; Name: 'brvbar'; Value: #166),
(Size: 6; Name: 'Ccedil'; Value: #199),
(Size: 6; Name: 'ccedil'; Value: #231),
(Size: 6; Name: 'curren'; Value: #164),
(Size: 6; Name: 'dagger'; Value: #134),
(Size: 6; Name: 'Dagger'; Value: #135),
(Size: 6; Name: 'divide'; Value: #247),
(Size: 6; Name: 'Eacute'; Value: #201),
(Size: 6; Name: 'eacute'; Value: #233),
(Size: 6; Name: 'Egrave'; Value: #200),
(Size: 6; Name: 'egrave'; Value: #232),
(Size: 6; Name: 'frac12'; Value: #189),
(Size: 6; Name: 'frac14'; Value: #188),
(Size: 6; Name: 'frac34'; Value: #190),
(Size: 6; Name: 'hellip'; Value: #133),
(Size: 6; Name: 'Iacute'; Value: #205),
(Size: 6; Name: 'iacute'; Value: #237),
(Size: 6; Name: 'Igrave'; Value: #204),
(Size: 6; Name: 'igrave'; Value: #236),
(Size: 6; Name: 'iquest'; Value: #191),
(Size: 6; Name: 'lsaquo'; Value: #139),
(Size: 6; Name: 'middot'; Value: #183),
(Size: 6; Name: 'Ntilde'; Value: #209),
(Size: 6; Name: 'ntilde'; Value: #241),
(Size: 6; Name: 'Oacute'; Value: #211),
(Size: 6; Name: 'oacute'; Value: #243),
(Size: 6; Name: 'Ograve'; Value: #210),
(Size: 6; Name: 'ograve'; Value: #242),
(Size: 6; Name: 'Oslash'; Value: #216),
(Size: 6; Name: 'oslash'; Value: #248),
(Size: 6; Name: 'Otilde'; Value: #213),
(Size: 6; Name: 'otilde'; Value: #245),
(Size: 6; Name: 'permil'; Value: #137),
(Size: 6; Name: 'plusmn'; Value: #177),
(Size: 6; Name: 'rsaquo'; Value: #155),
(Size: 6; Name: 'Scaron'; Value: #138),
(Size: 6; Name: 'scaron'; Value: #154),
(Size: 6; Name: 'Uacute'; Value: #218),
(Size: 6; Name: 'uacute'; Value: #250),
(Size: 6; Name: 'Ugrave'; Value: #217),
(Size: 6; Name: 'ugrave'; Value: #249),
(Size: 6; Name: 'Yacute'; Value: #221),
(Size: 6; Name: 'yacute'; Value: #253),
(Size: 6; Name: 'xxxxxx'; Value: NAnchorChar) //JMN
);
{$IFDEF IP_LAZARUS}
function ParseConstant(const S: string): AnsiChar;
{$ENDIF}
var
Error: Integer;
Index1: Integer;
Index2: Integer;
Size1: Integer;
Found: Boolean;
begin {'Complete boolean eval' must be off}
Result := ' ';
Size1 := Length(S);
if Size1 = 0 then Exit;
if (S[1] in ['$', '0'..'9']) then
begin
Val(S, Index1, Error);
if (Error = 0) and (Index1 >= 32) and (Index1 <= 255) then
Result := Chr(Index1);
end else
begin
Index1 := 0;
repeat
if Size1 = Codes[Index1].Size then
begin
Found := True;
Index2 := 1;
while Index2 <= Size1 do
begin
if S[Index2] <> Codes[Index1].Name[Index2] then
begin
Found := False;
Break;
end;
Inc(Index2);
end;
if Found then
begin
Result := Codes[Index1].Value;
Break;
end;
end;
Inc(Index1);
until (Index1 >= CodeCount) or (Codes[Index1].Size > Size1);
end;
end;
procedure ExpandEscapes(var S: string);
{- returns the string with & escapes expanded}
var
i, j : Integer;
Co : string;
Ch : AnsiChar;
begin
i := length(S);
while i > 0 do begin
if S[i] = '&' then begin
j := i;
while (j < length(S)) and not (S[j] in [';',' ']) do
Inc(j);
Co := copy(S, i + 1, j - i - 1);
if Co <> '' then begin
if Co[1] = '#' then begin
Delete(Co, 1, 1);
if UpCase(Co[1]) = 'X' then begin
Delete(Co, 1, 1);
Insert('$', Co, 1);
end;
end;
Ch := ParseConstant(Co);
Delete(S, i, j - i + 1);
Insert(Ch, S, i);
end;
end;
Dec(i);
end;
end;
function EscapeToAnsi(const S: string): string;
var
P : Integer;
begin
Result := S;
P := CharPos('&', S);
if P <> 0 then
ExpandEscapes(Result);
end;
function NoBreakToSpace(const S: string): string;
var
P : Integer;
begin
Result := S;
for P := length(Result) downto 1 do
if Result[P] = NbspChar then
Result[P] := ' ';
end;
procedure SetRawWordValue(Entry: PIpHtmlElement; const Value: string);
var
L : Integer;
begin
Entry.AnsiWord := EscapeToAnsi(Value);
Entry.IsBlank := 0;
L := length(Entry.AnsiWord);
while Entry.IsBlank < L do
if Entry.AnsiWord[Entry.IsBlank + 1] = ' ' then
Inc(Entry.IsBlank)
else
break;
if Entry.IsBlank < L then
Entry.IsBlank := 0;
end;
procedure SetWordRect(Element: PIpHtmlElement; const Value: TRect);
begin
Element.WordRect2 := Value;
if Element.ElementType = etObject then begin
if (Value.Left < Value.Right)
and (Value.Bottom > Value.Top)
and (Value.Left >= 0) and (Value.Top >= 0) then
TIpHtmlNodeAlignInline(Element.Owner).SetRect(Value);
end;
end;
type
TFriendPanel = class(TCustomPanel) end;
const
LF = #10;
CR = #13; {!!.10}
{StdIndent = 16;} {!!.10}
NullRect : TRect = (Left:0; Top:0; Right:0; Bottom:0);
{$IFNDEF IP_LAZARUS}
//{$R IpHtml.res} // JMN
{$EndIf}
{!!.10 new}
function StdIndent: Integer;
begin
if ScaleBitmaps and (Aspect > 0) then {!!.12}
Result := round(16 * Aspect)
else
Result := 16;
end;
function SizeRec(cx, cy: Integer): TSize;
begin
Result.cx := cx;
Result.cy := cy;
end;
function MaxI2(const I1, I2: Integer) : Integer;
begin
Result := I1;
if I2 > I1 then
Result := I2;
end;
function MaxI3(const I1, I2, I3: Integer) : Integer;
begin
if I2 > I1 then
if I3 > I2 then
Result := I3
else
Result := I2
else
if I3 > I1 then
Result := I3
else
Result := I1;
end;
function MinI2(const I1, I2: Integer) : Integer;
begin
Result := I1;
if I2 < I1 then
Result := I2;
end;
function SameDimensions(const R1, R2 : TRect): Boolean;
begin
Result :=
(
((R1.Bottom - R1.Top) = (R2.Bottom - R2.Top))
or (R1.Top = R2.Top))
and
((R1.Right - R1.Left) = (R2.Right - R2.Left));
end;
function FirstString(const S: string): string;
{- returns first string if a list - otherwise the string itself}
var
P : Integer;
begin
P := CharPos(',', S);
if P = 0 then
Result := S
else
Result := copy(S, 1, P - 1);
end;
{ TIpHtmlInteger }
constructor TIpHtmlInteger.Create(AValue: Integer);
begin
FValue := AValue;
end;
procedure TIpHtmlInteger.DoChange;
begin
if assigned(FChange) then
FChange(Self);
end;
function TIpHtmlInteger.GetValue: Integer;
begin
if ScaleBitmaps then
Result := round(FValue * Aspect)
else
Result := FValue;
end;
procedure TIpHtmlInteger.SetValue(const Value: Integer);
begin
if Value <> FValue then begin
FValue := Value;
DoChange;
end;
end;
{ TIpHtmlPixels }
procedure TIpHtmlPixels.DoChange;
begin
if assigned(FChange) then
FChange(Self);
end;
function TIpHtmlPixels.GetValue: Integer;
begin
if (PixelsType = hpAbsolute) and ScaleBitmaps then
Result := round(FValue * Aspect)
else
Result := FValue;
end;
procedure TIpHtmlPixels.SetPixelsType(const Value: TIpHtmlPixelsType);
begin
if Value <> FPixelsType then begin
FPixelsType := Value;
DoChange;
end;
end;
procedure TIpHtmlPixels.SetValue(const Value: Integer);
begin
if Value <> FValue then begin
FValue := Value;
DoChange;
end;
end;
{ TIpHtmlRelSize }
procedure TIpHtmlRelSize.DoChange;
begin
if assigned(FChange) then
FChange(Self);
end;
procedure TIpHtmlRelSize.SetSizeType(const Value: TIpHtmlRelSizeType);
begin
if Value <> FSizeType then begin
FSizeType := Value;
DoChange;
end;
end;
procedure TIpHtmlRelSize.SetValue(const Value: Integer);
begin
if Value <> FValue then begin
FValue := Value;
DoChange;
end;
end;
{ TIpHtmlLength }
procedure TIpHtmlLength.DoChange;
begin
if assigned(FChange) then
FChange(Self);
end;
function TIpHtmlLength.GetLengthValue: Integer;
begin
if (LengthType = hlAbsolute) and ScaleBitmaps then
Result := round(FLengthValue * Aspect)
else
Result := FLengthValue;
end;
procedure TIpHtmlLength.SetLengthType(const Value: TIpHtmlLengthType);
begin
if Value <> FLengthType then begin
FLengthType := Value;
DoChange;
end;
end;
procedure TIpHtmlLength.SetLengthValue(const Value: Integer);
begin
if Value <> FLengthValue then begin
FLengthValue := Value;
DoChange;
end;
end;
{ TIpHtmlMultiLength }
function TIpHtmlMultiLength.GetLengthValue: Integer;
begin
if (LengthType = hmlAbsolute) and ScaleBitmaps then
Result := round(FLengthValue * Aspect)
else
Result := FLengthValue;
end;
{ TIpHtmlMultiLengthList }
procedure TIpHtmlMultiLengthList.AddEntry(Value: TIpHtmlMultiLength);
begin
List.Add(Value);
end;
procedure TIpHtmlMultiLengthList.Clear;
begin
while List.Count > 0 do begin
TIpHtmlMultiLength(List[0]).Free;
List.Delete(0);
end;
end;
constructor TIpHtmlMultiLengthList.Create;
begin
List := TList.Create;
end;
destructor TIpHtmlMultiLengthList.Destroy;
begin
inherited;
Clear;
List.Free;
end;
function TIpHtmlMultiLengthList.GetEntries: Integer;
begin
Result := List.Count;
end;
function TIpHtmlMultiLengthList.GetValues(
Index: Integer): TIpHtmlMultiLength;
begin
Result := TIpHtmlMultiLength(List[Index]);
end;
{ TIpHtmlNode }
function TIpHtmlNode.GetHint: string;
begin
Result := '';
end;
constructor TIpHtmlNode.Create(ParentNode : TIpHtmlNode);
begin
if assigned(ParentNode) then
if ParentNode is TIpHtmlNodeMulti then
TIpHtmlNodeMulti(ParentNode).FChildren.Add(Self)
else
raise EIpHtmlException.Create(SHtmlNotContainer); {!!.02}
FParentNode := ParentNode;
if ParentNode <> nil then
FOwner := ParentNode.Owner;
end;
destructor TIpHtmlNode.Destroy;
begin
if ((Owner = nil) or not Owner.Destroying)
and (FParentNode <> nil) then
TIpHtmlNodeMulti(FParentNode).FChildren.Remove(Self);
end;
function TIpHtmlNode.PageRectToScreen(const Rect: TRect;
var ScreenRect: TRect): Boolean;
{ -convert coordinates of rect passed in to screen coordinates and
return false if entire rect is clipped}
var
Tmp : TRect;
begin
if (Rect.Left = 0) and (Rect.Right = 0) and
(Rect.Top = 0) and (Rect.Bottom = 0) then begin
Result := False;
Exit;
end;
if not IntersectRect(Tmp, Rect, Owner.PageViewRect) then begin
Result := False;
Exit;
end;
ScreenRect := Rect;
with Owner.PageViewRect do
OffsetRect(ScreenRect, -Left, -Top);
with Owner.ClientRect do
OffsetRect(ScreenRect, Left, Top);
if not IntersectRect(Tmp, ScreenRect, Owner.ClientRect) then begin
Result := False;
Exit;
end;
Result := True;
end;
procedure TIpHtmlNode.ScreenLine(
StartPoint, EndPoint : TPoint;
const Width : Integer;
const Color : TColor);
var
SaveWidth : Integer;
begin
StartPoint := PagePtToScreen(StartPoint);
EndPoint := PagePtToScreen(EndPoint);
SaveWidth := Owner.Target.Pen.Width;
Owner.Target.Pen.Width := Width;
Owner.Target.Pen.Color := Color;
Owner.Target.MoveTo(StartPoint.x, StartPoint.y);
Owner.Target.LineTo(EndPoint.x, EndPoint.y);
Owner.Target.Pen.Width := SaveWidth;
end;
procedure TIpHtmlNode.ScreenRect(
R : TRect;
const Color : TColor);
begin
if PageRectToScreen(R, R) then begin
{$IFDEF IP_LAZARUS}
Owner.Target.Brush.Style := bsSolid;
{$ENDIF}
Owner.Target.Brush.Color := Color;
Owner.Target.FrameRect(R);
end;
end;
{$IFDEF IP_LAZARUS}
procedure TIpHtmlNode.ScreenFrame(
R : TRect;
Raised: boolean);
var
SaveWidth: Integer;
procedure DoLine(X1,Y1,X2,Y2: Integer; Clr: TColor);
begin
Owner.Target.Pen.Color := Clr;
Owner.Target.Line(X1,Y1,X2,Y2);
//Owner.Target.MoveTo(X1, Y1);
//Owner.Target.LineTo(X2, Y2);
end;
begin
if PageRectToScreen(R, R) then
with Owner.Target do begin
Brush.Style := bsSolid;
SaveWidth := Pen.Width;
Pen.Width := 1;
if Raised then begin
DoLine(R.Left, R.Top, R.Right-1, R.Top, RGB(220,220,220)); // above
DoLine(R.Right-1, R.Bottom-1, R.Left, R.Bottom-1, RGB(64,64,64)); // below
DoLine(R.Left, R.Top, r.Left, R.Bottom-1, RGB(192,192,192)); // Left
DoLine(R.Right-1, R.Bottom-1, R.Right-1, R.Top, RGB(128,128,128)); // Right
end else begin
DoLine(R.Left, R.Top, R.Right-1, R.Top, RGB(64,64,64)); // above
DoLine(R.Right-1, R.Bottom-1, R.Left, R.Bottom-1,RGB(220,220,220) ); // below
DoLine(R.Left, R.Top, r.Left, R.Bottom-1, RGB(128,128,128)); // Left
DoLine(R.Right-1, R.Bottom-1, R.Right-1, R.Top, RGB(192,192,192)); // Right
end;
Pen.Color := SaveWidth;
end;
end;
{$ENDIF}
procedure TIpHtmlNode.ScreenPolygon(
Points : array of TPoint;
const Color : TColor);
var
Pt : TPoint;
i : Integer;
SaveColor : TColor;
begin
for i := 0 to High(Points) do begin
Pt := PagePtToScreen(Points[i]);
Points[i] := Pt;
end;
Owner.Target.Pen.Color := Color;
SaveColor := Owner.Target.Brush.Color;
Owner.Target.Brush.Color := Color;
Owner.Target.Polygon(Points);
Owner.Target.Brush.Color := SaveColor;
end;
function TIpHtmlNode.PagePtToScreen(const Pt : TPoint): TPoint;
{-convert coordinates of point passed in to screen coordinates}
begin
Result := Pt;
with Owner.PageViewRect do begin
Dec(Result.x, Left);
Dec(Result.y, Top);
end;
with Owner.ClientRect do begin
Inc(Result.x, Left);
Inc(Result.y, Top);
end;
end;
procedure TIpHtmlNode.ReportDrawRects(M: TRectMethod);
begin
end;
procedure TIpHtmlNode.ReportMapRects(M: TRectMethod);
begin
end;
procedure TIpHtmlNode.InvalidateSize;
begin
if FParentNode = nil then
Owner.InvalidateSize
else
FParentNode.InvalidateSize;
end;
procedure TIpHtmlNode.EnumChildren(EnumProc: TIpHtmlNodeEnumProc;
UserData: Pointer);
begin
EnumProc(Self, UserData);
end;
procedure TIpHtmlNode.SubmitRequest;
begin
if FParentNode <> nil then
FParentNode.SubmitRequest;
end;
procedure TIpHtmlNode.ResetRequest;
begin
if FParentNode <> nil then
FParentNode.ResetRequest;
end;
procedure TIpHtmlNode.ReportCurDrawRects(Owner: TIpHtmlNode; M : TRectMethod);
begin
if FParentNode <> nil then
FParentNode.ReportCurDrawRects(Owner, M);
end;
procedure TIpHtmlNode.AppendSelection(var S: string);
begin
end;
procedure TIpHtmlNode.CreateControl(Parent: TWinControl);
begin
end;
procedure TIpHtmlNode.Enqueue;
begin
end;
procedure TIpHtmlNode.EnqueueElement(const Entry: PIpHtmlElement);
begin
end;
{!!.10 new}
function TIpHtmlNode.ElementQueueIsEmpty: Boolean;
begin
Result := True;
end;
procedure TIpHtmlNode.HideUnmarkedControl;
begin
end;
procedure TIpHtmlNode.ImageChange(NewPicture: TPicture);
begin
end;
procedure TIpHtmlNode.Invalidate;
begin
end;
procedure TIpHtmlNode.MakeVisible;
begin
end;
procedure TIpHtmlNode.SetProps(const RenderProps: TIpHtmlProps);
begin
end;
procedure TIpHtmlNode.UnmarkControl;
begin
end;
{!!.10 attribute support code - new}
function GetPropertyValue(PI: PPropInfo; const AObject: TObject): string;
function GetPropType : PTypeInfo;
begin
{$IFDEF VERSION3}
Result := PI.PropType^;
{$ELSE}
Result := PI.PropType;
{$ENDIF}
end;
function GetIntegerProperty : string;
begin
Result := IntToStr(GetOrdProp(AObject, PI));
end;
function GetCharProperty : string;
begin
Result := Char(GetOrdProp(AObject, PI));
end;
function GetEnumProperty : string;
begin
Result := GetEnumName(GetPropType, GetOrdProp(AObject, PI));
end;
function GetFloatProperty : string;
const
Precisions : array[TFloatType] of Integer = (7, 15, 18, 18, 19);
begin
Result := FloatToStrF(GetFloatProp(AObject, PI), ffGeneral,
Precisions[GetTypeData(GetPropType)^.FloatType], 0);
end;
function GetLStringProperty : string;
begin
Result := GetStrProp(AObject, PI);
end;
function GetWCharProperty : string;
begin
Result := Char(GetOrdProp(AObject, PI));
end;
function GetVariantProperty : string;
begin
{$IFDEF FPC}
Result := AnsiString(GetVariantProp(AObject, PI));
{$ELSE}
Result := GetVariantProp(AObject, PI);
{$ENDIF}
end;
function GetStringProperty : string;
begin
Result := GetStrProp(AObject, PI);
end;
type
TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
function GetSetProperty : string;
var
TypeInfo : PTypeInfo;
W : Cardinal;
I : Integer;
begin
Result := '[';
W := GetOrdProp(AObject, PI);
TypeInfo := GetTypeData(GetPropType)^.CompType{$IFNDEF IP_LAZARUS}^{$ENDIF};
for I := 0 to Pred(sizeof(Cardinal) * 8) do
if I in TCardinalSet(W) then begin
if Length(Result) <> 1 then
Result := Result + ',';
Result := Result + GetEnumName(TypeInfo, I);
end;
Result := Result + ']';
end;
begin
Result := '??';
case PI.PropType^.Kind of
tkInteger : Result := GetIntegerProperty;
tkChar : Result := GetCharProperty;
tkEnumeration : Result := GetEnumProperty;
tkFloat : Result := GetFloatProperty;
tkLString : Result := GetLStringProperty;
tkWChar : Result := GetWCharProperty;
tkVariant : Result := GetVariantProperty;
tkString : Result := GetStringProperty;
tkSet : Result := GetSetProperty;
else
Result := 'unsupported';
end;
end;
procedure SetPropertyValueLow(PI: PPropInfo;
const AObject: TObject; const NewValue: string);
function GetPropType : PTypeInfo;
begin
{$IFDEF VERSION3}
Result := PI.PropType^;
{$ELSE}
Result := PI.PropType;
{$ENDIF}
end;
procedure SetIntegerProperty;
begin
SetOrdProp(AObject, PI, StrToInt(NewValue));
end;
procedure SetCharProperty;
begin
SetOrdProp(AObject, PI, ord(NewValue[1]));
end;
procedure SetEnumProperty;
begin
{$IFDEF VERSION5}
SetEnumProp(AObject, PI, NewValue);
{$ENDIF}
end;
procedure SetFloatProperty;
begin
SetFloatProp(AObject, PI, StrToFloat(NewValue));
end;
procedure SetStringProperty;
begin
SetStrProp(AObject, PI, NewValue);
end;
type
TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
procedure SetSetProperty;
begin
{$IFDEF VERSION5}
SetSetProp(AObject, PI, NewValue);
{$ENDIF}
end;
begin
if not assigned(PI.SetProc) then
raise Exception.Create('Property is read-only');
case PI.PropType^.Kind of
tkInteger : SetIntegerProperty;
tkChar : SetCharProperty;
tkEnumeration : SetEnumProperty;
tkFloat : SetFloatProperty;
tkLString : SetStringProperty;
tkString : SetStringProperty;
tkSet : SetSetProperty;
else
raise Exception.Create('Unsupported attribute type');
end;
end;
function GetPropertyList(C: TObject; IncludeValues, IncludeBlanks: Boolean): TStringList;
var
LCount: Integer;
LSize: Integer;
PList : PPropList;
I, J: Integer;
S: string;
SubList: TStringList;
O: TObject;
begin
Result := TStringList.Create;
try
if C.ClassInfo <> nil then begin
LCount := GetPropList(C.ClassInfo, tkProperties, nil);
LSize := LCount * SizeOf(Pointer);
if LSize > 0 then begin
GetMem(PList, LSize);
try
GetPropList(C.ClassInfo, tkProperties, PList);
for I := 0 to LCount-1 do begin
if PList^[I].PropType^.Kind = tkClass then begin
{SubList := TStringList.Create;} {!!.12}
SubList := nil; {!!.12}
try
O := TObject(GetOrdProp(C, PList^[I]));
SubList := GetPropertyList(O, IncludeValues, IncludeBlanks);
for j := 0 to Pred(SubList.Count) do
Result.Add(PList^[I]^.Name + '.' + SubList[j]);
finally
SubList.Free;
end;
end else begin
if IncludeValues then begin
S := GetPropertyValue(PList^[I], C);
if IncludeBlanks or (S <> '') then
Result.Add(PList^[I]^.Name + '=' + S);
end else
Result.Add(PList^[I]^.Name);
end;
end;
finally
FreeMem(PList, LSize);
end;
end;
end;
except
Result.Free;
raise;
end;
end;
procedure SetPropertyValue(C: TObject; PropPath: string; const NewValue: string);
var
LCount: Integer;
LSize: Integer;
PList : PPropList;
I, J: Integer;
SubPropPath: string;
O: TObject;
begin
I := pos('=', PropPath);
if I <> 0 then
SetLength(PropPath, I - 1);
PropPath := trim(PropPath);
if PropPath = '' then
Exit;
PropPath := UpperCase(PropPath);
if C.ClassInfo <> nil then begin
LCount := GetPropList(C.ClassInfo, tkProperties, nil);
LSize := LCount * SizeOf(Pointer);
if LSize > 0 then begin
GetMem(PList, LSize);
try
GetPropList(C.ClassInfo, tkProperties, PList);
for I := 0 to LCount-1 do begin
if PList^[I].PropType^.Kind = tkClass then begin
J := pos('.', PropPath);
if J <> 0 then begin
SubPropPath := copy(PropPath, 1, J - 1);
if SubPropPath = UpperCase(PList^[I]^.Name) then begin
O := TObject(GetOrdProp(C, PList^[I]));
SetPropertyValue(O, copy(PropPath, J + 1, MAXINT), NewValue);
Exit;
end;
end;
end else begin
if PropPath = UpperCase(PList^[I]^.Name) then begin
SetPropertyValueLow(PList^[I], C, NewValue);
Exit;
end;
end;
end;
finally
FreeMem(PList, LSize);
end;
end;
end;
raise Exception.Create('Unknown property:' + PropPath);
end;
{!!.10 new}
procedure TIpHtmlNode.GetAttributes(Target: TStrings; IncludeValues, IncludeBlanks: Boolean);
var
List : TStringList;
begin
List := GetPropertyList(Self, IncludeValues, IncludeBlanks);
try
Target.Assign(List);
finally
List.Free;
end;
end;
procedure TIpHtmlNode.SetAttributeValue(const AttrName, NewValue: string);
begin
SetPropertyValue(Self, AttrName, NewValue);
end;
function TIpHtmlNode.ExpParentWidth: Integer;
begin
if assigned(FParentNode) then
Result := FParentNode.ExpParentWidth
else
Result := MAXINT;
end;
{ TIpHtmlNodeMulti }
constructor TIpHtmlNodeMulti.Create(ParentNode : TIpHtmlNode);
begin
inherited Create(ParentNode);
FChildren := TList.Create;
end;
destructor TIpHtmlNodeMulti.Destroy;
var
i : Integer;
begin
if Owner.Destroying then begin
for i := 0 to Pred(FChildren.Count) do
TIpHtmlNode(FChildren[I]).Free;
end else
while FChildren.Count > 0 do begin
TIpHtmlNode(FChildren[FChildren.Count - 1]).Free;
end;
FChildren.Free;
inherited Destroy;
end;
function TIpHtmlNodeMulti.GetChildNode(Index: Integer): TIpHtmlNode;
begin
Result := TIpHtmlNode(FChildren[Index]);
end;
function TIpHtmlNodeMulti.GetChildCount: Integer;
begin
Result := FChildren.Count;
end;
procedure TIpHtmlNodeMulti.Enqueue;
var
i : Integer;
begin
for i := 0 to Pred(FChildren.Count) do begin
TIpHtmlNode(FChildren[i]).Enqueue;
end;
end;
procedure TIpHtmlNodeMulti.SetProps(const RenderProps: TIpHtmlProps);
var
i : Integer;
{$IFDEF IP_LAZARUS}
Elem: TCSSProps = nil;
{$ENDIF}
begin
{$IFDEF IP_LAZARUS}
if Self.InheritsFrom(TIpHtmlNodeCore) then
TIpHtmlNodeCore(Self).LoadCSSProps(Owner, Elem, RenderProps);
{$ENDIF}
for i := 0 to Pred(FChildren.Count) do
TIpHtmlNode(FChildren[i]).SetProps(RenderProps);
end;
procedure TIpHtmlNodeMulti.ReportDrawRects(M: TRectMethod);
var
i : Integer;
begin
for i := 0 to Pred(FChildren.Count) do
TIpHtmlNode(FChildren[i]).ReportDrawRects(M);
end;
procedure TIpHtmlNodeMulti.ReportMapRects(M: TRectMethod);
var
i : Integer;
begin
for i := 0 to Pred(FChildren.Count) do
TIpHtmlNode(FChildren[i]).ReportMapRects(M);
end;
procedure TIpHtmlNodeMulti.EnumChildren(EnumProc: TIpHtmlNodeEnumProc;
UserData: Pointer);
var
i : Integer;
begin
inherited;
for i := 0 to Pred(FChildren.Count) do
TIpHtmlNode(FChildren[i]).EnumChildren(EnumProc, UserData);
end;
procedure TIpHtmlNodeMulti.AppendSelection(var S: string);
var
i : Integer;
begin
inherited;
for i := 0 to Pred(FChildren.Count) do
TIpHtmlNode(FChildren[i]).AppendSelection(S);
end;
{ TIpHtmlNodeBODY }
constructor TIpHtmlNodeBODY.Create(ParentNode : TIpHtmlNode);
begin
inherited Create(ParentNode);
{$IFDEF IP_LAZARUS}
FElementName := 'body';
{$ENDIF}
FBgColor := -1;
FText := -1;
FLink := -1;
FVLink := -1;
FALink := -1;
Owner.Body := Self;
end;
procedure TIpHtmlNodeBODY.Render(
const RenderProps: TIpHtmlProps);
var
MaxX, MaxY: Integer; {!!.02}
X, Y : Integer;
P : TPoint;
begin
if ScaleBitmaps then begin {!!.10}
Owner.Target.Brush.Color := clWhite;
Owner.Target.FillRect(Owner.ClientRect);
end else begin
{$IFDEF IP_LAZARUS}
if BackGround = '' then begin
if BGColor <> -1 then begin
Owner.Target.Brush.Color := BGColor;
Owner.Target.FillRect(Owner.ClientRect);
end else begin
Owner.Target.Brush.Color := clWhite;
Owner.Target.FillRect(Owner.ClientRect);
end;
end;
{$ELSE}
if BackGround = '' then begin
Owner.Target.Brush.Color := clWhite;
Owner.Target.FillRect(Owner.ClientRect);
end;
if BGColor <> -1 then begin
Owner.Target.Brush.Color := BGColor;
Owner.Target.FillRect(Owner.ClientRect);
end;
{$ENDIF}
if Background <> '' then begin
if BgPicture = nil then
Owner.DoGetImage(Self, Owner.BuildPath(Background), BgPicture);
if BgPicture <> nil then begin
MaxX := MaxI2(PageRect.Right, Owner.ClientRect.Right); {!!.02}
MaxY := MaxI2(PageRect.Bottom, Owner.ClientRect.Bottom); {!!.02}
Y := 0;
while (Y <= MaxY{PageRect.Bottom}) do begin {!!.02}
if (Y < Owner.PageViewRect.Top - BgPicture.Height)
or (Y > Owner.PageViewRect.Bottom) then
else begin
X := 0;
while (X <= MaxX{PageRect.Right}) do begin {!!.02}
P := PagePtToScreen(Point(X, Y));
Owner.Target.Draw(P.X, P.Y, BgPicture.Graphic);
Inc(X, BgPicture.Width);
end;
end;
Inc(Y, BgPicture.Height);
end;
end else begin {!!.12}
Owner.Target.Brush.Color := clWhite; {!!.12}
Owner.Target.FillRect(Owner.ClientRect); {!!.12}
end; {!!.12}
end;
end;
inherited Render(RenderProps);
{$IFDEF IP_LAZARUS}
// restore style
Owner.Target.Brush.Style:=bsSolid;
{$ENDIF}
end;
{$IFDEF IP_LAZARUS}
procedure TIpHtmlNodeBODY.LoadCSSProps(Owner: TIpHtml; var Element: TCSSProps; const Props: TIpHtmlProps);
var
LinkElement: TCSSProps;
begin
inherited LoadCSSProps(Owner, Element, Props);
LinkElement := Owner.CSS.GetElement('a:link', '');
if (LinkElement <> nil) and (LinkElement.Color <> -1) then
Link := LinkElement.Color;
LinkElement := Owner.CSS.GetElement('a:visited', '');
if (LinkElement <> nil) and (LinkElement.Color <> -1) then
VLink := LinkElement.Color;
LinkElement := Owner.CSS.GetElement('a:active', '');
if (LinkElement <> nil) and (LinkElement.Color <> -1) then
ALink := LinkElement.Color;
if Element = nil then
exit;
if Element.Color <> -1 then
Text := Element.Color;
end;
{$ENDIF}
destructor TIpHtmlNodeBODY.Destroy;
begin
inherited;
BgPicture.Free;
end;
procedure TIpHtmlNodeBODY.ImageChange(NewPicture: TPicture);
begin
{$IFOPT C+}
Owner.CheckImage(NewPicture);
{$ENDIF}
BgPicture.Free;
BgPicture := NewPicture;
Invalidate;
end;
procedure TIpHtmlNodeBODY.SetAlink(const Value: TColor);
begin
if Value <> FAlink then begin
Falink := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeBODY.SetBackground(const Value: string);
begin
if Value <> FBackground then begin
FBackground := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeBODY.SetBgColor(const Value: TColor);
begin
if Value <> FBgColor then begin
FBgColor := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeBODY.SetLink(const Value: TColor);
begin
if Value <> FLink then begin
FLink := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeBODY.SetText(const Value: TColor);
begin
if Value <> FText then begin
FText := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeBODY.SetVlink(const Value: TColor);
begin
if Value <> FVLink then begin
FVLink := Value;
InvalidateSize;
end;
end;
{ TIpHtml }
procedure TIpHtml.ClearCache;
var
i : Integer;
begin
for i := 0 to Pred(PropACache.Count) do begin
TIpHtmlPropA(PropACache[i]).Free;
end;
PropACache.Free;
for i := 0 to Pred(PropBCache.Count) do
TIpHtmlPropB(PropBCache[i]).Free;
PropBCache.Free;
end;
procedure TIpHtml.ResetCache;
var
i : Integer;
begin
for i := 0 to Pred(PropACache.Count) do begin
TIpHtmlPropA(PropACache[i]).FSizeOfSpaceKnown := False;
TIpHtmlPropA(PropACache[i]).tmHeight := 0;
end;
end;
procedure TIpHtml.AddWordEntry(const Value: string;
Props: TIpHtmlProps; Owner: TIpHtmlNode);
var
Entry : PIpHtmlElement;
L : Integer;
begin
Entry := NewElement(etWord, Owner);
Entry.Props := Props;
Entry.AnsiWord := Value;
Entry.IsBlank := 0;
L := length(Entry.AnsiWord);
while Entry.IsBlank < L do
if Entry.AnsiWord[Entry.IsBlank + 1] = ' ' then
Inc(Entry.IsBlank)
else
break;
if Entry.IsBlank < L then
Entry.IsBlank := 0;
Owner.EnqueueElement(Entry);
end;
procedure TIpHtml.AddWord(Value: string;
Props: TIpHtmlProps; Owner: TIpHtmlNode);
var
P : Integer;
begin
Value:= EscapeToAnsi(Value);
P := CharPos(ShyChar, Value);
if P = 0 then
AddWordEntry(Value, Props, Owner)
else begin
while Value <> '' do begin
AddWordEntry(copy(Value, 1, P - 1), Props, Owner);
Delete(Value, 1, P);
if Value <> '' then
Owner.EnqueueElement(SoftHyphen);
P := CharPos(ShyChar, Value);
if P = 0 then
P := length(Value) + 1;
end;
end;
end;
procedure TIpHtml.InvalidateRect(R: TRect);
begin
if Assigned(FOnInvalidateRect) then
FOnInvalidateRect(Self, R);
end;
procedure TIpHtml.Clear;
{- clear any contents}
var
i : Integer;
begin
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
for i := 0 to Pred(GifImages.Count) do
if TIpHtmlNodeIMG(GifImages[i]).FPicture <> nil then
TGifImage(TIpHtmlNodeIMG(GifImages[i]).FPicture.Graphic).PaintStop;
{$ELSE}
for i := 0 to Pred(AnimationFrames.Count) do
if TIpHtmlNodeIMG(AnimationFrames[i]).FPicture <> nil then
TIpAnimatedGraphic(TIpHtmlNodeIMG(AnimationFrames[i]).FPicture.Graphic).
AggressiveDrawing := False;
{$ENDIF}
{$ELSE}
for i := 0 to Pred(GifImages.Count) do
if TIpHtmlNodeIMG(GifImages[i]).FPicture <> nil then
TGifImage(TIpHtmlNodeIMG(GifImages[i]).FPicture.Graphic).PaintStop;
{$ENDIF}
ClearGifQueue;
FHotNode := nil;
FHtml.Free;
FHtml := TIpHtmlNodeHtml.Create(nil);
FHtml.FOwner := Self;
end;
function TIpHtml.NextChar : AnsiChar;
begin
{$IFDEF IP_LAZARUS}
Result:=#0;
{$ENDIF}
if CharStream.Read(Result, 1) = 0 then
Result := #0
else begin
Inc(GlobalPos);
if Result = #10 then begin
Inc(LineNumber);
LineOffset := 0;
end else
Inc(LineOffset);
{write(Result);}
end;
end;
procedure TIpHtml.ReportError(const ErrorMsg: string);
begin
raise Exception.CreateFmt(SHtmlLineError, [ErrorMsg, LineNumber, LineOffset]);
end;
procedure TIpHtml.ReportExpectedError(const ErrorMsg: string);
begin
ReportError(ErrorMsg + SHtmlExp);
end;
procedure TIpHtml.ReportExpectedToken(const Token: TIpHtmlToken);
begin
ReportExpectedError(IpHtmlTokens[Token]);
end;
procedure TIpHtml.ReportReferences(Node : TIpHtmlNode);
var
i : Integer;
S : string;
begin
if Node is TIpHtmlNodeA then
S := Trim(TIpHtmlNodeA(Node).HRef)
else
if Node is TIpHtmlNodeAREA then
S := Trim(TIpHtmlNodeAREA(Node).HRef);
if (S <> '') then
ReportReference(S);
if Node is TIpHtmlNodeMulti then
for i := 0 to Pred(TIpHtmlNodeMulti(Node).ChildCount) do
ReportReferences(TIpHtmlNodeMulti(Node).ChildNode[i]);
end;
procedure TIpHtml.LoadFromStream(S: TStream);
var
T : TIpHtmlToken;
begin
HtmlTokenList := nil;
DoneLoading := False;
try
HtmlTokenList := TStringList.Create;
for t := low(IpHtmlTokens) to high(IpHtmlTokens) do
HtmlTokenList.AddObject(IpHtmlTokens[T], TObject(Integer(T)));
HtmlTokenList.Sorted := True;
FHasFrames := False;
Clear;
CharStream := S;
GlobalPos := 0;
LineNumber := 1;
LineOffset := 0;
Parse;
ReportReferences(HtmlNode);
finally
HtmlTokenList.Free;
HtmlTokenList := nil;
DoneLoading := True;
FCanPaint := True;
end;
end;
{
procedure TIpHtml.ParseDocType;
begin
if CurToken = IpHtmlTagDOCTYPE then
NextToken;
end;
}
function TIpHtml.GetChar : AnsiChar;
var
Trimming, {!!.10}
Done: Boolean; {!!.10}
begin {!!.10}
Trimming := False; {!!.10}
repeat {!!.10}
Done := True;
if (CharSP > 0) then begin
Dec(CharSP);
Result := CharStack[CharSP];
end else begin
Result := NextChar;
{if FlagErrors then
write(Result);}
end;
{!!.10 thru end: new}
if (InPre = 0) and (CurToken <> IpHtmlTagPRE) then begin
if (Result <= ' ') and (Result > #0) then begin
if (Result < ' ') and LastWasClose then begin
Done := False;
Trimming := True;
end else
if Trimming then
Done := False
else
if LastWasSpace then
Done := False
else begin
Result := ' ';
LastWasSpace := True;
end;
end else
LastWasSpace := False;
end;
until Done;
LastWasClose := Result = '>';
end;
procedure TIpHtml.PutChar(Ch : AnsiChar);
begin
if (CharSP >= sizeof(CharStack)) then
raise EIpHtmlException.Create(SHtmlCharStackOverfl); {!!.02}
CharStack[CharSP] := Ch;
Inc(CharSP);
end;
function AnsiToEscape(const S: string): string;
{- returns the string with & escapes}
var
i : Integer;
begin
Result := S;
i := length(Result);
while i > 0 do begin
case Result[i] of
ShyChar :
begin
Result[i] := '&';
Insert('shy;', Result, i + 1);
end;
NbspChar :
begin
Result[i] := '&';
Insert('nbsp;', Result, i + 1);
end;
'"' :
begin
Result[i] := '&';
Insert('quot;', Result, i + 1);
end;
'&' :
begin
Insert('amp;', Result, i + 1);
end;
'<' :
begin
Result[i] := '&';
Insert('lt;', Result, i + 1);
end;
'>' :
begin
Result[i] := '&';
Insert('gt;', Result, i + 1);
end;
end;
Dec(i);
end;
end;
procedure TIpHtml.PutToken(Token : TIpHtmlToken);
begin
if HaveToken then
raise EIpHtmlException.Create(SHtmlTokenStackOverfl); {!!.02}
TokenBuffer := Token;
HaveToken := True;
end;
function TIpHtml.IsWhiteSpace: Boolean;
var
i : Integer;
begin
Result := False;
for i := 0 to TBW - 1 do
if TokenStringBuf[i] > ' ' then
Exit;
Result := True;
end;
procedure TrimFormattingPre(const S: string; Target: PAnsiChar);
var
R, W : Integer;
begin
r := 1;
w := 0;
while r <= length(S) do begin
case S[r] of
#13 :
begin
Target[w] := LF;
Inc(w);
end;
#10 :
if (w = 0) or (Target[w - 1] <> LF) then begin
Target[w] := LF;
Inc(w);
end;
#0..#8, #11..#12, #14..#31 :
;
#9, #32 :
begin
Target[w] := ' ';
Inc(w);
end;
else
begin
Target[w] := S[r];
Inc(w);
end;
end;
Inc(r);
end;
Target[w] := #0;
end;
procedure TrimFormattingNormal(const S: string; Target: PAnsiChar);
var
R, W : Integer;
begin
r := 1;
w := 0;
while r <= length(S) do begin
case S[r] of
#0..#9, #11..#13, #14..#31 :
;
#10 :
if w > 1 then begin
Target[w] := ' ';
Inc(w);
end;
#32 :
begin
Target[w] := ' ';
Inc(w);
end;
else
begin
Target[w] := S[r];
Inc(w);
end;
end;
Inc(r);
end;
Target[w] := #0;
r := 0;
w := 0;
while Target[r] <> #0 do begin
case Target[r] of
' ' :
if (w = 0) or (Target[w - 1] <> ' ') then begin
Target[w] := ' ';
Inc(w);
end;
else
if w <> r then
Target[w] := Target[r];
Inc(w);
end;
Inc(r);
end;
Target[w] := #0;
end;
function TIpHtml.GetTokenString: string;
begin
TokenStringBuf[TBW] := #0;
Result := StrPas(TokenStringBuf);
end;
procedure TIpHtml.NextToken;
var
ParmName : string;
{ParmBuf : array[0..4095] of AnsiChar;} {!!.12}
PBW : Integer;
i : Integer;
Ctl,
InValue, InQuote, InAttr, SeenEqual,
SeenQuotes, Done, EndFound : Boolean;
QuoteChar : AnsiChar;
Ch : AnsiChar;
procedure AddParmChar(const Ch: AnsiChar);
begin
{!!.12 begin}
if PBW >= ParmBufSize - 1 then begin
Inc(ParmBufSize, 4096);
ReallocMem(ParmBuf, ParmBufSize);
end;
{!!.12 end}
ParmBuf[PBW] := Ch;
Inc(PBW);
end;
function ParmString: string;
begin
if PBW = 0 then {!!.12}
Result := '' {!!.12}
else begin {!!.12}
ParmBuf[PBW] := #0;
Result := StrPas(ParmBuf);
PBW := 0;
end; {!!.12}
end;
procedure AddTokenChar(const Ch: AnsiChar);
begin
TokenStringBuf[TBW] := Ch;
Inc(TBW);
end;
begin
if HaveToken then begin
CurToken := TokenBuffer;
HaveToken := False;
Exit;
end;
QuoteChar := ' ';
repeat
TBW := 0;
PBW := 0;
ParmList.Clear;
ValueList.Clear;
Ch := GetChar;
if Ch = #0 then begin
CurToken := IpHtmlTagEof;
Exit;
end;
if Ch = '<' then begin
Ch := GetChar;
if Ch = '!' then begin
if GetChar = '-' then begin
if GetChar <> '-' then
if FlagErrors then
ReportError(SHtmlDashExp);
Ch := GetChar;
repeat
while Ch <> '-' do begin
if Ch = #0 then
break;
Ch := GetChar;
end;
if (Ch = #0) then
break
else begin
Ch := GetChar;
if Ch = #0 then
break;
if Ch = '-' then begin
Ch := GetChar;
while (Ch = '-') do {!!.12}
Ch := GetChar; {!!.12}
{if (Ch = #0) or (Ch = '>') then
break;} {!!.12}
while not (Ch in [#0,'>']) do {!!.12}
Ch := GetChar; {!!.12}
break; {!!.12}
end;
end;
until false;
CurToken := IpHtmlTagComment;
end else begin
Ch := GetChar;
while Ch <> '>' do
Ch := GetChar;
CurToken := IpHtmlTagComment;
end;
end else begin
while Ch <> '>' do begin
if Ch <= ' ' then begin
Ch := ' ';
break;
end;
if Ch in [#33..#255] then
AddTokenChar(UpCase(Ch));
Ch := GetChar;
end;
if Ch = ' ' then begin
Ch := GetChar;
{list :== [attr]* ">"}
{attr :== [" "]* attr-name [attr-value]}
{attr-value :== [" "]* "=" [" "]* value}
{value :== ['"']* string ['"']*}
InAttr := False;
InValue := False;
InQuote := False;
SeenEqual := False;
SeenQuotes := False;
ParmName := '';
PBW := 0;
while True do begin
case Ch of
#0 : break;
#1..#31 :
if InAttr then begin
InAttr := False;
ParmName := UpperCase(ParmString);
SeenEqual := False;
end else
if InValue then begin
if ParmName <> '' then begin
ParmList.Add(UpperCase(ParmName));
ValueList.Add(ParmString);
ParmName := '';
end;
InValue := False;
SeenEqual := False;
SeenQuotes := False;
end;
' ' :
if InQuote then
AddParmChar(' ')
else
if InAttr then begin
InAttr := False;
ParmName := UpperCase(ParmString);
SeenEqual := False;
end else
if InValue then begin
if ParmName <> '' then begin
ParmList.Add(UpperCase(ParmName));
ValueList.Add(ParmString);
ParmName := '';
end;
InValue := False;
SeenEqual := False;
SeenQuotes := False;
end;
'''' :
if InQuote then
if QuoteChar = '''' then
InQuote := False
else
AddParmChar('''')
else begin
InQuote := True;
SeenQuotes := True;
QuoteChar := '''';
end;
'"' :
if InQuote then
if QuoteChar = '"' then
InQuote := False
else
AddParmChar('"')
else begin
InQuote := True;
SeenQuotes := True;
QuoteChar := '"';
end;
'<', '>' :
begin
if InQuote then {!!.01}
AddParmChar(Ch) {!!.01}
else begin {!!.01}
if InValue then begin
if ParmName <> '' then begin
ParmList.Add(UpperCase(ParmName));
ValueList.Add(ParmString);
ParmName := '';
end;
end;
break;
end; {!!.01}
end;
'=' :
begin
SeenEqual := True;
if InAttr then begin
ParmName := ParmString;
InAttr := False;
end else
if InValue then
AddParmChar(Ch)
end;
else
if InAttr or InValue then
AddParmChar(Ch)
else
if SeenEqual and (InQuote or not SeenQuotes) then begin
InValue := True;
AddParmChar(Ch);
end else begin
if (ParmName <> '') and not SeenQuotes then begin
ParmList.Add(UpperCase(ParmName));
ValueList.Add(ParmName);
end;
ParmName := '';
AddParmChar(Ch);
SeenEqual := False;
SeenQuotes := False;
InValue := False;
InAttr := True;
end;
end;
Ch := GetChar;
end;
if InAttr then begin
ParmName := UpperCase(ParmString);
if (ParmName <> '') then begin
ParmList.Add(ParmName);
ValueList.Add(ParmName);
end;
end;
end;
{ Check if this is a token of the form <tok/> }
if (TBW > 0) and (TokenStringBuf[TBW - 1] = '/') then begin
{It is, set EndFound flag and convert to normal open token}
EndFound := True;
Dec(TBW);
end else
EndFound := False;
TokenStringBuf[TBW] := #0;
CurToken := IpHtmlTagUnknown;
i := HtmlTokenList.IndexOf(string(TokenStringBuf));
if i <> -1 then
{$IFDEF IP_LAZARUS}
CurToken := TIpHtmlToken(PtrInt(HtmlTokenList.Objects[i]));
{$ELSE}
CurToken := TIpHtmlToken(PtrInt(HtmlTokenList.Objects[i]));
{$ENDIF}
{If the token was a single terminated token ( <tok/>
as opposed to normal a <tok></tok> sequence), we fake
it by pushing a close token to match the open token
which was mangled above where EndFound was set.}
if (CurToken <> IpHtmlTagUnknown) and EndFound then
if succ(CurToken) in IpEndTokenSet then
PutToken(succ(CurToken));
(*
!!.10 logic moved inside GetChar
{clear white space after tag}
Ch := GetChar;
if (InPre = 0) and (CurToken <> IpHtmlTagPRE) then begin {!!.03}
if CurToken in IpEndTokenSet then begin
while (Ch > #0) and (Ch < #32) do
Ch := GetChar;
end else begin
while (Ch > #0) and (Ch < #32) do
Ch := GetChar;
end;
end; {!!.03}
PutChar(Ch);
*)
end;
end else begin
CurToken := IpHtmlTagText;
repeat
Done := True;
Ctl := False;
while Ch <> '<' do begin
case Ch of
#0 :
break;
#10,#13 :
begin
Ctl := True;
if InPre > 0 then {!!.10}
AddTokenChar(Ch);
end
else
AddTokenChar(Ch);
end;
Ch := GetChar;
end;
if Ch <> #0 then begin
Ch := GetChar;
while (Ch > #0) and (Ch < ' ') do {!!.10}
Ch := GetChar; {!!.10}
case Ch of
'/', '!', 'a'..'z','A'..'Z' :
begin
PutChar(Ch);
PutChar('<');
end
else
begin
AddTokenChar('<');
AddTokenChar(Ch);
Done := False;
Ch := GetChar;
end;
end;
end;
if (InPre = 0) and Ctl
and IsWhiteSpace then
CurToken := IpHtmlTagCOMMENT;
until Done;
end;
until
(CurToken <> IpHtmlTagCOMMENT)
and ((CurToken <> IpHtmlTagText) or (InBlock > 0) or (InPre > 0)
or not IsWhiteSpace);
end;
procedure TIpHtml.NextRealToken;
begin
repeat
NextToken;
until CurToken <> IpHtmlTagText;
end;
procedure TIpHtml.NextNonBlankToken;
begin
repeat
NextToken;
until (CurToken <> IpHtmlTagText)
or not IsWhiteSpace;
end;
procedure TIpHtml.SkipTextTokens;
begin
while CurToken = IpHtmlTagText do
NextToken;
end;
procedure TIpHtml.EnsureClosure(const EndToken : TIpHtmlToken;
const EndTokens : TIpHtmlTokenSet);
begin
if CurToken = EndToken then
NextToken
else
if CurToken in EndTokens then
else
if FlagErrors then
ReportExpectedToken(EndToken);
end;
procedure TIpHtml.ParseTitle(Parent: TIpHtmlNode);
var
B : PAnsiChar;
begin
FTitleNode := TIpHtmlNodeTITLE.Create(Parent);
NextToken;
if CurToken = IpHtmlTagText then begin
Getmem(B, length(GetTokenString) + 1);
try
TrimFormattingNormal(EscapeToAnsi(GetTokenString), B);
FTitleNode.Title := B;
finally
Freemem(B);
end;
NextToken;
end;
if CurToken = IpHtmlTagTITLEend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagTITLEend);
end;
procedure TIpHtml.ParseStyle(ParentNode : TIpHtmlNode);
var
CurStyle : TIpHtmlNodeSTYLE;
begin
CurStyle := TIpHtmlNodeSTYLE.Create(ParentNode);
with CurStyle do begin
Media := FindAttribute('MEDIA');
Title := FindAttribute('TITLE');
{$IFDEF IP_LAZARUS}
Type_ := FindAttribute('TYPE');
{$ENDIF}
end;
NextToken;
if CurToken <> IpHtmlTagSTYLEend then
ParseText([IpHtmlTagSTYLEend], CurStyle);
if CurToken = IpHtmlTagSTYLEend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagSTYLEend);
end;
procedure TIpHtml.ParseScript(Parent : TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
begin
TIpHtmlNodeSCRIPT.Create(Parent);
NextToken;
if CurToken <> IpHtmlTagScriptEnd then
repeat
NextToken;
until (CurToken = IpHtmlTagSCRIPTend)
or (CurToken in EndTokens); {!!.12}
EnsureClosure(IpHtmlTagSCRIPTend, EndTokens);
end;
procedure TIpHtml.ParseNoscript(Parent : TIpHtmlNode);
var
CurScript : TIpHtmlNodeNOSCRIPT;
begin
CurScript := TIpHtmlNodeNOSCRIPT.Create(Parent);
with CurScript do begin
ParseBaseProps(Self);
end;
NextToken;
ParseBodyText(CurScript, [IpHtmlTagNOSCRIPTend]);
if CurToken = IpHtmlTagNOSCRIPTend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagNOSCRIPTend);
end;
procedure TIpHtml.ParseIsIndex;
begin
IndexPhrase := FindAttribute('PROMPT');
{IsIndexPresent := IndexPhrase <> '';} {!!.12}
NextToken;
end;
procedure TIpHtml.ParseBase;
begin
{Base := FindAttribute('HREF');} {!!.12}
NextToken;
end;
procedure TIpHtml.ParseMeta;
begin
with TIpHtmlNodeMETA.Create(Parent) do begin
HttpEquiv := FindAttribute('HTTP-EQUIV');
Name := FindAttribute('NAME');
Content := FindAttribute('CONTENT');
Scheme := FindAttribute('SCHEME');
end;
NextToken;
end;
procedure TIpHtml.ParseLink(Parent : TIpHtmlNode);
begin
with TIpHtmlNodeLINK.Create(Parent) do begin
HRef := FindAttribute('HREF');
Rel := FindAttribute('REL');
Rev := FindAttribute('REV');
Title := FindAttribute('TITLE');
{$IFDEF IP_LAZARUS}
Type_ := LowerCase(FindAttribute('TYPE'));
if (LowerCase(Rel) = 'stylesheet') and (Type_ = 'text/css') then
ParseStyleSheet(Parent, Href);
{$ENDIF}
ParseBaseProps(Self);
end;
NextToken;
end;
procedure TIpHtml.ParseHeadItems(Parent : TIpHtmlNode);
begin
while not (CurToken in
[IpHtmlTagEOF, IpHtmlTagHEADend, IpHtmlTagFRAMESET, IpHtmlTagBODY]) do begin
case CurToken of
IpHtmlTagTITLE :
ParseTitle(Parent);
IpHtmlTagSTYLE :
ParseStyle(Parent);
IpHtmlTagSCRIPT :
ParseScript(Parent, [IpHtmlTagEOF]);
IpHtmlTagNOSCRIPT :
ParseNoscript(Parent);
IpHtmlTagISINDEX :
ParseIsIndex;
IpHtmlTagBASE :
ParseBase;
IpHtmlTagMETA :
ParseMeta(Parent);
IpHtmlTagLINK :
ParseLink(Parent);
else
{unknown}
NextToken;
end;
end;
end;
procedure TIpHtml.ParseHead(Parent : TIpHtmlNode);
begin
{lead token is optional}
if CurToken = IpHtmlTagHEAD then begin
NextToken;
ParseHeadItems(TIpHtmlNodeHEAD.Create(Parent));
if CurToken = IpHtmlTagHEADend then
NextToken;
end;
end;
procedure TIpHtml.ParseFont(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurFONT : TIpHtmlNodeFONT;
begin
CurFONT := TIpHtmlNodeFONT.Create(Parent);
with CurFONT do begin {!!.10}
Face := FindAttribute('FACE');
Size.Free; {!!.10}
Size := ParseRelSize{('+0')}; {!!.10}
Size.OnChange := SizeChanged; {!!.10}
Color := ColorFromString(FindAttribute('COLOR'));
ParseBaseProps(Self);
end;
NextToken;
ParseBodyText(CurFONT, EndTokens + [IpHtmlTagFONTend]);
EnsureClosure(IpHtmlTagFONTend, EndTokens);
end;
procedure TIpHtml.ParsePre(ParentNode : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurContainer : TIpHtmlNodePRE;
begin
CurContainer := TIpHtmlNodePRE.Create(ParentNode);
CurContainer.ParseBaseProps(Self);
Inc(InPre); {!!.10}
NextToken;
{Inc(InPre);} {!!.10}
ParseBodyText(CurContainer, EndTokens + [IpHtmlTagPREend]);
Dec(InPre);
EnsureClosure(IpHtmlTagPREend, EndTokens);
end;
procedure TIpHtml.ParseText(const EndTokens : TIpHtmlTokenSet;
Parent: TIpHtmlNode);
var
CurContainer : TIpHtmlNodeText;
begin
while not (CurToken in EndTokens) do begin
case CurToken of
IpHtmlTagEof :
Exit;
{IpHtmlTagFont :
begin
ParseFont(Parent, EndTokens);
end;}
IpHtmlTagText :
begin
CurContainer := TIpHtmlNodeText.Create(Parent);
if CurContainer=nil then ;
CurContainer.FEscapedText := GetTokenString;
NextToken;
end;
else
NextToken;
end;
end;
end;
procedure TIpHtml.ParseHeader(Parent : TIpHtmlNode; EndToken : TIpHtmlToken;
Size : Integer);
var
NewHeader : TIpHtmlNodeHeader;
begin
NewHeader := TIpHtmlNodeHeader.Create(Parent);
{$IFDEF IP_LAZARUS}
NewHeader.FElementName := 'h'+IntToStr(Size);
{$ENDIF}
NewHeader.ParseBaseProps(Self);
NewHeader.Size := Size;
NewHeader.Align := ParseAlignment;
NextToken;
ParseBodyText(NewHeader, [EndToken]);
if CurToken = EndToken then
NextToken
else
if FlagErrors then
ReportExpectedToken(EndToken);
end;
procedure TIpHtml.ParseParagraph(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
NewPara : TIpHtmlNodeP;
begin
NewPara := TIpHtmlNodeP.Create(Parent);
NewPara.ParseBaseProps(Self);
NewPara.Align := ParseAlignment;
NextToken;
ParseBodyText(NewPara, EndTokens + [IpHtmlTagPend, IpHtmlTagP, IpHtmltagTABLE]);
if CurToken = IpHtmlTagPend then
NextToken
else
if CurToken in (EndTokens + [IpHtmlTagP, IpHtmltagTABLE]) then
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagPend);
end;
procedure TIpHtml.ParseAddress(Parent : TIpHtmlNode);
var
NewPara : TIpHtmlNodeADDRESS;
begin
NewPara := TIpHtmlNodeADDRESS.Create(Parent);
NewPara.ParseBaseProps(Self);
NextToken;
ParseBodyText(NewPara, [IpHtmlTagADDRESSend]);
if CurToken = IpHtmlTagADDRESSend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagADDRESSend);
end;
procedure TIpHtml.ParseListItems(Parent : TIpHtmlNodeCore;
EndToken: TIpHtmlToken; const EndTokens : TIpHtmlTokenSet;
DefaultListStyle : TIpHtmlULType);
var
NewListItem : TIpHtmlNodeLI;
begin
while not (CurToken in EndTokens) do begin
case CurToken of
IpHtmlTagLI :
begin
NewListItem := TIpHtmlNodeLI.Create(Parent);
NewListItem.ParseBaseProps(Self);
{NewListItem.DefListType := DefaultListStyle;} {!!.12}
NewListItem.ListType := ParseULStyle(DefaultListStyle);
NewListItem.Value := ParseInteger('VALUE', -1);
NewListItem.Compact := ParseBoolean('COMPACT');
NextToken;
ParseBodyText(NewListItem,
EndTokens + [EndToken, IpHtmlTagLI, IpHtmlTagLIend] -
[IpHtmlTagP, IpHtmlTagPend]);
if CurToken = IpHtmlTagLIend then
NextToken;
SkipTextTokens; {!!.10}
end;
else
ParseBodyText(Parent, EndTokens + [EndToken, IpHtmlTagLI]);
end;
end;
end;
procedure TIpHtml.ParseUnorderedList(Parent: TIpHtmlNode;
EndToken : TIpHtmlToken; const EndTokens: TIpHtmlTokenSet);
var
NewList : TIpHtmlNodeList;
begin
case Pred(EndToken) of
IpHtmlTagDIR : NewList := TIpHtmlNodeDIR.Create(Parent);
IpHtmlTagMENU : NewList := TIpHtmlNodeMENU.Create(Parent);
else {IpHtmlTagUL : }NewList := TIpHtmlNodeUL.Create(Parent);
end;
NewList.ParseBaseProps(Self);
case ListLevel of
0 : NewList.ListType := ParseULStyle(ulDisc);
1 : NewList.ListType := ParseULStyle(ulCircle);
else
NewList.ListType := ParseULStyle(ulSquare);
end;
NewList.Compact := ParseBoolean('COMPACT');
NextToken;
Inc(ListLevel);
ParseListItems(NewList,
EndToken, EndTokens + [EndToken] - [IpHtmlTagP, IpHtmlTagLI],
NewList.ListType);
Dec(ListLevel);
EnsureClosure(EndToken, EndTokens);
end;
procedure TIpHtml.ParseOrderedList(Parent: TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
var
NewList : TIpHtmlNodeOL;
begin
NewList := TIpHtmlNodeOL.Create(Parent);
NewList.Style := ParseOLStyle(olArabic);
NewList.Start := ParseInteger('START', 1);
NewList.Compact := ParseBoolean('COMPACT');
NextToken;
ParseListItems(NewList, IpHtmlTagOLend, EndTokens + [IpHtmlTagOLend], ulDisc);
EnsureClosure(IpHtmlTagOLend, EndTokens);
end;
function TIpHtml.ParseInputType : TIpHtmlInputType;
var
S : string;
begin
Result := hitText;
S := UpperCase(FindAttribute('TYPE'));
if (S = '') or (S = 'TEXT') or (S = 'TEXTAREA') then
else
if S = 'PASSWORD' then
Result := hitPassword
else
if S = 'CHECKBOX' then
Result := hitCheckbox
else
if S = 'RADIO' then
Result := hitRadio
else
if S = 'SUBMIT' then
Result := hitSubmit
else
if S = 'RESET' then
Result := hitReset
else
if S = 'FILE' then
Result := hitFile
else
if S = 'HIDDEN' then
Result := hitHidden
else
if S = 'IMAGE' then
Result := hitImage
else
if S = 'BUTTON' then
Result := hitButton
else
if FlagErrors then
ReportError(SHtmlInvType);
end;
function TIpHtml.ParseButtonType : TIpHtmlButtonType;
var
S : string;
begin
Result := hbtSubmit;
S := UpperCase(FindAttribute('TYPE'));
if (S = '') or (S = 'SUBMIT') then
else
if S = 'RESET' then
Result := hbtReset
else
if S = 'BUTTON' then
Result := hbtButton
else
if FlagErrors then
ReportError(SHtmlInvType);
end;
procedure TIpHtml.ParseFormFields(Parent: TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
var
CurSelect : TIpHtmlNodeSELECT;
CurTextArea : TIpHtmlNodeTEXTAREA;
CurButton : TIpHtmlNodeBUTTON;
CurOptGroup : TIpHtmlNodeOPTGROUP;
CurLabel : TIpHtmlNodeLABEL;
CurFieldset : TIpHtmlNodeFIELDSET;
CurLegend : TIpHtmlNodeLEGEND;
CurOption : TIpHtmlNodeOPTION;
begin
while not (CurToken in EndTokens) do begin
case CurToken of
IpHtmlTagINPUT :
begin
with TIpHtmlNodeINPUT.Create(Parent) do begin
ParseBaseProps(Self);
InputType := ParseInputType;
Name := FindAttribute('NAME');
Value := FindAttribute('VALUE');
Checked := ParseBoolean('CHECKED');
Size := ParseInteger('SIZE', -1);
MaxLength := ParseInteger('MAXLENGTH', -1);
Src := FindAttribute('SRC');
Align := ParseImageAlignment('BOTTOM');
Disabled := ParseBoolean('DISABLED');
ReadOnly := ParseBoolean('READONLY');
Alt := FindAttribute('ALT');
TabIndex := ParseInteger('TABINDEX', -1);
end;
NextToken;
end;
IpHtmlTagBUTTON :
begin
CurButton := TIpHtmlNodeBUTTON.Create(Parent);
with CurButton do begin
ParseBaseProps(Self);
ButtonType := ParseButtonType;
Name := FindAttribute('NAME');
Value := FindAttribute('VALUE');
Disabled := ParseBoolean('DISABLED');
TabIndex := ParseInteger('TABINDEX', -1);
end;
NextToken;
ParseBodyText(CurButton, EndTokens + [IpHtmlTagBUTTONend]);
if CurToken = IpHtmlTagBUTTONend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagBUTTONend);
end;
IpHtmlTagSELECT :
begin
CurSelect := TIpHtmlNodeSELECT.Create(Parent);
with CurSelect do begin
Name := FindAttribute('NAME');
Size := ParseInteger('SIZE', -1);
ParseBaseProps(Self);
Multiple := ParseBoolean('MULTIPLE');
Disabled := ParseBoolean('DISABLED');
TabIndex := ParseInteger('TABINDEX', -1);
end;
NextNonBlankToken;
repeat
case CurToken of
IpHtmlTagOPTION :
begin
CurOption := TIpHtmlNodeOPTION.Create(CurSelect);
with CurOption do begin
ParseBaseProps(Self);
Selected := ParseBoolean('SELECTED');
Value := FindAttribute('VALUE');
Disabled := ParseBoolean('DISABLED');
OptionLabel := FindAttribute('LABEL');
end;
NextNonBlankToken;
ParseText(EndTokens +
[IpHtmlTagSelectEND, IpHtmlTagOption, IpHtmlTagOPTIONend],
CurOption);
if CurToken = IpHtmlTagOPTIONend then
NextNonBlankToken;
end;
IpHtmlTagOPTGROUP :
begin
CurOptGroup := TIpHtmlNodeOPTGROUP.Create(CurSelect);
with CurOptGroup do begin
ParseBaseProps(Self);
Disabled := ParseBoolean('DISABLED');
GroupLabel := FindAttribute('LABEL');
end;
NextNonBlankToken;
while CurToken = IpHtmlTagOPTION do begin
CurOption := TIpHtmlNodeOPTION.Create(CurOptGroup);
with CurOption do begin
ParseBaseProps(Self);
Selected := ParseBoolean('SELECTED');
Value := FindAttribute('VALUE');
Disabled := ParseBoolean('DISABLED');
OptionLabel := FindAttribute('LABEL');
end;
NextNonBlankToken;
ParseText(EndTokens +
[IpHtmlTagSelectEND, IpHtmlTagOption, IpHtmlTagOPTIONend],
CurOption);
if CurToken = IpHtmlTagOPTIONend then
NextNonBlankToken;
end;
if CurToken = IpHtmlTagOPTGROUPend then
NextNonBlankToken
else
if CurToken = IpHtmlTagOPTGROUP then
else
if CurToken = IpHtmlTagOPTION then
else
if CurToken = IpHtmlTagSELECTend then
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagOPTGROUPend);
end;
else
break;
end;
until False;
if CurToken = IpHtmlTagSELECTend then
NextNonBlankToken;
end;
IpHtmlTagTEXTAREA :
begin
CurTextArea := TIpHtmlNodeTEXTAREA.Create(Parent);
with CurTextArea do begin
Name := FindAttribute('NAME');
Rows := ParseInteger('ROWS', 20);
Cols := ParseInteger('COLS', 20);
ParseBaseProps(Self);
Disabled := ParseBoolean('DISABLED');
ReadOnly := ParseBoolean('READONLY');
TabIndex := ParseInteger('TABINDEX', -1);
end;
NextToken;
ParseText([IpHtmlTagTEXTAREAend], CurTextArea);
if CurToken = IpHtmlTagTEXTAREAend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagTEXTAREAend);
end;
IpHtmlTagLABEL :
begin
CurLabel := TIpHtmlNodeLABEL.Create(Parent);
with CurLabel do begin
ParseBaseProps(Self);
LabelFor := FindATTRIBUTE('LABEL');
end;
NextToken;
ParseBodyText(CurLabel, [IpHtmlTagLABELend]);
if CurToken = IpHtmlTagLABELend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagLABELend);
end;
IpHtmlTagFIELDSET :
begin
CurFieldset := TIpHtmlNodeFIELDSET.Create(Parent);
with CurFieldset do
ParseBaseProps(Self);
NextToken;
ParseFormFields(CurFieldSet, EndTokens + [IpHtmlTagFIELDSETend]);
if CurToken = IpHtmlTagFIELDSETend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagFIELDSETend);
end;
IpHtmlTagLEGEND :
begin
CurLegend := TIpHtmlNodeLEGEND.Create(Parent);
with CurLegend do begin
ParseBaseProps(Self);
end;
NextToken;
ParseBodyText(CurLegend, [IpHtmlTagLEGENDend]);
if CurToken = IpHtmlTagLEGENDend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagLEGENDend);
end;
else
Exit;
end;
end;
end;
procedure TIpHtml.ParseForm(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
NewForm : TIpHtmlNodeFORM;
begin
NewForm := TIpHtmlNodeFORM.Create(Parent);
with NewForm do begin
Action := FindAttribute('ACTION');
Method := ParseMethod;
Enctype := FindAttribute('ENCTYPE');
Name := FindAttribute('NAME');
AcceptCharset := FindAttribute('ACCEPT-CHARSET');
Accept := FindAttribute('ACCEPT');
if Enctype = '' then
Enctype := 'application/x-www-form-urlencoded';
if AcceptCharset = '' then
AcceptCharset := 'UNKNOWN';
ParseBaseProps(Self);
end;
NextToken;
ParseBodyText(NewForm, EndTokens + [IpHtmlTagFORMend]);
EnsureClosure(IpHtmlTagFORMend, EndTokens);
end;
procedure TIpHtml.ParseDefListItems(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurDT : TIpHtmlNodeDT;
CurDD : TIpHtmlNodeDD;
begin
while not (CurToken in EndTokens) do begin
case CurToken of
IpHtmlTagDT :
begin
CurDT := TIpHtmlNodeDT.Create(Parent);
CurDT.ParseBaseProps(Self);
NextToken;
ParseBodyText(CurDT, [IpHtmlTagDD, IpHtmlTagDTend] + EndTokens);
if CurToken = IpHtmlTagDTend then
NextToken;
end;
IpHtmlTagDD :
begin
CurDD := TIpHtmlNodeDD.Create(Parent);
CurDD.ParseBaseProps(Self);
NextToken;
ParseBodyText(CurDD, [IpHtmlTagDT, IpHtmlTagDDend] + EndTokens);
if CurToken = IpHtmlTagDDend then
NextToken;
end;
else
ParseBodyText(Parent, EndTokens + [IpHtmlTagDT, IpHtmlTagDD]);
end;
end;
end;
procedure TIpHtml.ParseDefinitionList(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
NewDL : TIpHtmlNodeDL;
begin
NewDL := TIpHtmlNodeDL.Create(Parent);
NewDL.ParseBaseProps(Self);
NewDL.Compact := ParseBoolean('COMPACT');
NextToken;
ParseDefListItems(NewDL, EndTokens + [IpHtmlTagDLend]);
EnsureClosure(IpHtmlTagDLend, EndTokens);
end;
procedure TIpHtml.ParseDIV(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurDIV : TIpHtmlNodeDIV;
begin
CurDIV := TIpHtmlNodeDIV.Create(Parent);
with CurDIV do begin
Align := ParseAlignment;
ParseBaseProps(Self);
end;
NextToken;
ParseBodyText(CurDIV, EndTokens + [IpHtmlTagDIVend]);
EnsureClosure(IpHtmlTagDIVend, EndTokens);
end;
procedure TIpHtml.ParseSPAN(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurSPAN : TIpHtmlNodeSPAN;
begin
CurSPAN := TIpHtmlNodeSPAN.Create(Parent);
with CurSPAN do begin
{$IFDEF IP_LAZARUS}
FElementName := 'span';
{$ENDIF}
Align := ParseAlignment;
ParseBaseProps(Self);
end;
NextToken;
ParseBodyText(CurSPAN, EndTokens + [IpHtmlTagSPANend]);
EnsureClosure(IpHtmlTagSPANend, EndTokens);
end;
procedure TIpHtml.ParseCENTER(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurContainer : TIpHtmlNodeDIV;
begin
CurContainer := TIpHtmlNodeDIV.Create(Parent);
with CurContainer do
Align := haCenter;
NextToken;
ParseBodyText(CurContainer, EndTokens + [IpHtmlTagCENTERend]);
EnsureClosure(IpHtmlTagCENTERend, EndTokens);
end;
procedure TIpHtml.ParseLEFT(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurContainer : TIpHtmlNodeDIV;
begin
CurContainer := TIpHtmlNodeDIV.Create(Parent);
with CurContainer do
Align := haLeft;
NextToken;
ParseBodyText(CurContainer, EndTokens + [IpHtmlTagLEFTend]);
EnsureClosure(IpHtmlTagLEFTend, EndTokens);
end;
procedure TIpHtml.ParseRIGHT(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurContainer : TIpHtmlNodeDIV;
begin
CurContainer := TIpHtmlNodeDIV.Create(Parent);
with CurContainer do
Align := haRight;
NextToken;
ParseBodyText(CurContainer, EndTokens + [IpHtmlTagRIGHTend]);
EnsureClosure(IpHtmlTagRIGHTend, EndTokens);
end;
procedure TIpHtml.ParseBLINK(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurBlink : TIpHtmlNodeBLINK;
begin
CurBlink := TIpHtmlNodeBLINK.Create(Parent);
NextToken;
ParseBodyText(CurBlink, EndTokens + [IpHtmlTagBLINKend]);
EnsureClosure(IpHtmlTagBLINKend, EndTokens);
end;
procedure TIpHtml.ParseBLOCKQUOTE(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
BQ : TIpHtmlNodeBLOCKQUOTE;
begin
BQ := TIpHtmlNodeBLOCKQUOTE.Create(Parent);
BQ.ParseBaseProps(Self);
NextToken;
ParseBodyText(BQ, EndTokens + [IpHtmlTagBLOCKQUOTEend]);
EnsureClosure(IpHtmlTagBLOCKQUOTEend, EndTokens);
end;
procedure TIpHtml.ParseQ(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
BQ : TIpHtmlNodeQ;
begin
BQ := TIpHtmlNodeQ.Create(Parent);
BQ.ParseBaseProps(Self);
NextToken;
ParseBodyText(BQ, EndTokens + [IpHtmlTagQend]);
EnsureClosure(IpHtmlTagQend, EndTokens);
end;
procedure TIpHtml.ParseINS(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
BQ : TIpHtmlNodeINS;
begin
BQ := TIpHtmlNodeINS.Create(Parent);
BQ.ParseBaseProps(Self);
BQ.Cite := FindAttribute('CITE');
BQ.Datetime := FindAttribute('DATETIME');
NextToken;
ParseBodyText(BQ, EndTokens + [IpHtmlTagINSend]);
EnsureClosure(IpHtmlTagINSend, EndTokens);
end;
procedure TIpHtml.ParseDEL(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
BQ : TIpHtmlNodeDEL;
begin
BQ := TIpHtmlNodeDEL.Create(Parent);
BQ.ParseBaseProps(Self);
BQ.Cite := FindAttribute('CITE');
BQ.Datetime := FindAttribute('DATETIME');
NextToken;
ParseBodyText(BQ, EndTokens + [IpHtmlTagDELend]);
EnsureClosure(IpHtmlTagDELend, EndTokens);
end;
procedure TIpHtml.ParseFontStyle(Parent : TIpHtmlNode;
StartToken : TIpHtmlToken; const EndTokens : TIpHtmlTokenSet);
var
CurStyle : TIpHtmlNodeFontStyle;
begin
CurStyle := TIpHtmlNodeFontStyle.Create(Parent);
case StartToken of
IpHtmlTagTT :
CurStyle.Style := hfsTT;
IpHtmlTagI :
CurStyle.Style := hfsI;
IpHtmlTagB :
CurStyle.Style := hfsB;
IpHtmlTagU :
CurStyle.Style := hfsU;
IpHtmlTagSTRIKE :
CurStyle.Style := hfsSTRIKE;
IpHtmlTagS :
CurStyle.Style := hfsS;
IpHtmlTagBIG :
CurStyle.Style := hfsBIG;
IpHtmlTagSMALL :
CurStyle.Style := hfsSMALL;
IpHtmlTagSUB :
CurStyle.Style := hfsSUB;
IpHtmlTagSUP :
CurStyle.Style := hfsSUP;
end;
CurStyle.ParseBaseProps(Self);
NextToken;
ParseBodyText(CurStyle, EndTokens);
EnsureClosure(succ(StartToken), EndTokens);
end;
procedure TIpHtml.ParseHR(Parent : TIpHtmlNode);
var
NewRule : TIpHtmlNodeHR;
begin
NewRule := TIpHtmlNodeHR.Create(Parent);
with NewRule do begin
Align := ParseImageAlignment('CENTER');
NoShade := ParseBoolean('NOSHADE');
Size := ParseHtmlInteger('SIZE', 1); {!!.10}
Size.OnChange := WidthChanged; {!!.10}
Width := ParseHyperLength('WIDTH', '100%');
Width.OnChange := WidthChanged; {!!.10}
Color := ColorFromString(FindAttribute('COLOR'));
ParseBaseProps(Self);
end;
NextToken;
end;
procedure TIpHtml.ParseBR(Parent : TIpHtmlNode);
var
BR : TIpHtmlNodeBR;
begin
BR := TIpHtmlNodeBR.Create(Parent);
BR.Clear := ParseBRClear;
BR.Id := FindAttribute('ID');
BR.ClassId :=FindAttribute('CLASS');
BR.Title :=FindAttribute('TITLE');
BR.Style :=FindAttribute('STYLE');
NextToken;
end;
procedure TIpHtml.ParseNOBR(Parent : TIpHtmlNode);
begin
NextToken;
ParseBodyText(TIpHtmlNodeNOBR.Create(Parent), [IpHtmlTagNOBRend]);
if CurToken = IpHtmlTagNOBRend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagNOBRend);
end;
procedure TIpHtml.ParsePhraseElement(Parent : TIpHtmlNode;
StartToken, EndToken : TIpHtmlToken; const EndTokens: TIpHtmlTokenSet);
var
CurPhrase : TIpHtmlNodePhrase;
begin
NextToken;
CurPhrase := TIpHtmlNodePhrase.Create(Parent);
case StartToken of
IpHtmlTagEM :
CurPhrase.Style := hpsEM;
IpHtmlTagSTRONG :
CurPhrase.Style := hpsSTRONG;
IpHtmlTagDFN :
CurPhrase.Style := hpsDFN;
IpHtmlTagCODE :
CurPhrase.Style := hpsCODE;
IpHtmlTagSAMP :
CurPhrase.Style := hpsSAMP;
IpHtmlTagKBD :
CurPhrase.Style := hpsKBD;
IpHtmlTagVAR :
CurPhrase.Style := hpsVAR;
IpHtmlTagCITE :
CurPhrase.Style := hpsCITE;
IpHtmlTagABBR :
CurPhrase.Style := hpsABBR;
IpHtmlTagACRONYM :
CurPhrase.Style := hpsACRONYM;
end;
CurPhrase.ParseBaseProps(Self);
ParseBodyText(CurPhrase, [EndToken] + EndTokens);
if CurToken = EndToken then
NextToken
else
if CurToken in EndTokens then
else
if FlagErrors then
ReportExpectedToken(EndToken);
end;
procedure TIpHtml.ParseAnchor(Parent : TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
var
CurAnchor : TIpHtmlNodeA;
begin
CurAnchor := TIpHtmlNodeA.Create(Parent);
with CurAnchor do begin
Name := FindAttribute('NAME');
HRef := FindAttribute('HREF');
Rel := FindAttribute('REL');
Rev := FindAttribute('REV');
Title := FindAttribute('TITLE');
ParseBaseProps(Self);
Shape := ParseShape;
TabIndex := ParseInteger('TABINDEX', -1);
Target := FindAttribute('TARGET');
end;
NextToken;
ParseBodyText(CurAnchor, EndTokens + [IpHtmlTagAend] - [IpHtmlTagA]);
if CurToken = IpHtmlTagAend then
NextToken
else
if CurToken = IpHtmlTagA then
else
if CurToken in EndTokens then
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagAend);
if (CurAnchor.ChildCount = 0)
and (CurAnchor.Name <> '') then
TIpHtmlNodeText.Create(CurAnchor).FEscapedText := '&xxxxxx;';
end;
procedure TIpHtml.ParseIMG(Parent : TIpHtmlNode);
var
CurIMG : TIpHtmlNodeIMG;
begin
CurIMG := TIpHtmlNodeIMG.Create(Parent);
with CurIMG do begin
Src := FindAttribute('SRC');
Alt := FindAttribute('ALT');
Align := ParseImageAlignment('BOTTOM');
Height := ParsePixels('HEIGHT', ''); {!!.10}
{ParseInteger('HEIGHT', -1);} {!!.10}
Height.OnChange := DimChanged; {!!.10}
Width := ParseHyperLength('WIDTH', ''); {!!.10}
Width.OnChange := DimChanged; {!!.10}
Border := ParseInteger('BORDER', 0);
HSpace := ParseInteger('HSPACE', 0);
VSpace := ParseInteger('VSPACE', 0);
UseMap := FindAttribute('USEMAP');
IsMap := ParseBoolean('ISMAP');
ParseBaseProps(Self);
LongDesc := FindAttribute('LONGDESC');
Name := FindAttribute('NAME');
end;
NextToken;
end;
procedure TIpHtml.ParseApplet(Parent: TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
var
CurApplet : TIpHtmlNodeAPPLET;
CurParam : TIpHtmlNodePARAM;
begin
CurApplet := TIpHtmlNodeAPPLET.Create(Parent);
with CurApplet do begin
Codebase := FindAttribute('CODEBASE');
Code := FindAttribute('CODE');
Alt := FindAttribute('ALT');
Name := FindAttribute('NAME');
Height := ParseInteger('HEIGHT', -1);
Width := ParseHyperLength('WIDTH', '');
Width.OnChange := WidthChanged; {!!.10}
Align := ParseImageAlignment('BOTTOM');
HSpace := ParseInteger('HSPACE', 1);
VSpace := ParseInteger('VSPACE', 1);
Archive := FindAttribute('ARCHIVE');
ObjectCode := FindAttribute('OBJECT');
Id := FindAttribute('ID');
ClassID := FindAttribute('CLASS');
Title := FindAttribute('TITLE');
Style := FindAttribute('STYLE');
end;
NextToken;
while not (CurToken in EndTokens + [IpHtmlTagAPPLETend]) do begin
case CurToken of
IpHtmlTagPARAM :
begin
CurParam := TIpHtmlNodePARAM.Create(CurApplet); {!!.12}
with CurParam do begin
{CurParam := TIpHtmlNodePARAM.Create(CurApplet);} {!!.12}
Name := FindAttribute('NAME');
Value := FindAttribute('VALUE');
Id := FindAttribute('ID');
ValueType := ParseObjectValueType;
end;
NextToken;
end;
else
ParseText([IpHtmlTagAPPLETend, IpHtmlTagPARAM], CurApplet);
end;
end;
EnsureClosure(IpHtmlTagAPPLETend, EndTokens);
end;
procedure TIpHtml.ParseOBJECT(Parent : TIpHtmlNode);
var
CurOBJECT : TIpHtmlNodeOBJECT;
CurParam : TIpHtmlNodePARAM;
begin
CurOBJECT := TIpHtmlNodeOBJECT.Create(Parent);
with CurOBJECT do begin
ClassID := FindAttribute('CLASSID');
Codebase := FindAttribute('CODEBASE');
Data := FindAttribute('DATA');
CodeType := FindAttribute('CODETYPE');
Archive := FindAttribute('ARCHIVE');
Standby := FindAttribute('STANDBY');
Align := ParseImageAlignment('BOTTOM');
Height := ParseInteger('HEIGHT', -1);
Width := ParseHyperLength('WIDTH', '');
Width.OnChange := WidthChanged; {!!.10}
Border := ParseInteger('BORDER', 0);
HSpace := ParseInteger('HSPACE', 1);
VSpace := ParseInteger('VSPACE', 1);
UseMap := FindAttribute('USEMAP');
Declare := ParseBoolean('DECLARE');
ParseBaseProps(Self);
Name := FindAttribute('NAME');
end;
NextToken;
while not (CurToken = IpHtmlTagOBJECTend) do begin
case CurToken of
IpHtmlTagPARAM :
begin
CurParam := TIpHtmlNodePARAM.Create(CurObject);
with CurParam do begin
Name := FindAttribute('NAME');
Value := FindAttribute('VALUE');
Id := FindAttribute('ID');
ValueType := ParseObjectValueType;
end;
NextToken;
end;
else
ParseText([IpHtmlTagOBJECTend, IpHtmlTagPARAM], CurObject);
end;
end;
if CurToken = IpHtmlTagOBJECTend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagOBJECTend);
end;
procedure TIpHtml.ParseTableRow(Parent: TIpHtmlNode;
const EndTokens : TIpHtmlTokenSet);
var
CurHeader : TIpHtmlNodeTH;
CurTableCell : TIpHtmlNodeTD;
begin
while not (CurToken in EndTokens) do begin
case CurToken of
IpHtmlTagTH :
begin
CurHeader := TIpHtmlNodeTH.Create(Parent);
with CurHeader do begin
Nowrap := ParseBoolean('NOWRAP');
Rowspan := ParseInteger('ROWSPAN', 1);
Colspan := ParseInteger('COLSPAN', 1);
ParseBaseProps(Self);
Align := ParseCellAlign(haCenter{haDefault});
VAlign := ParseVAlignment3;
Width := ParseHyperLength('WIDTH', '');
Width.OnChange := DimChanged; {!!.10}
Height := ParsePixels('HEIGHT', ''); {!!.10}
{ParseInteger('HEIGHT', -1);} {!!.10}
Height.OnChange := DimChanged;
BgColor := ColorFromString(FindAttribute('BGCOLOR'));
end;
NextToken;
ParseBodyText(CurHeader,
EndTokens + [IpHtmlTagTH, IpHtmlTagTHend, IpHtmlTagTD]);
if CurToken in [IpHtmlTagTHend, IpHtmlTagTDend] then
NextRealToken;
end;
IpHtmlTagTD :
begin
CurTableCell := TIpHtmlNodeTD.Create(Parent);
with CurTableCell do begin
{$IFDEF IP_LAZARUS}
FElementName := 'td';
{$ENDIF}
Nowrap := ParseBoolean('NOWRAP');
Rowspan := ParseInteger('ROWSPAN', 1);
Colspan := ParseInteger('COLSPAN', 1);
ParseBaseProps(Self);
Align := ParseCellAlign(haLeft{haDefault});
VAlign := ParseVAlignment3;
Width := ParseHyperLength('WIDTH', '');
Width.OnChange := DimChanged; {!!.10}
Height := ParsePixels('HEIGHT', ''); {!!.10}
{ParseInteger('HEIGHT', -1);} {!!.10}
Height.OnChange := DimChanged;
BgColor := ColorFromString(FindAttribute('BGCOLOR'));
end;
NextToken;
ParseBodyText(CurTableCell, EndTokens + [IpHtmlTagTD, IpHtmlTagTDend]);
if CurToken = IpHtmlTagTDend then
NextRealToken;
end;
else
NextToken;
end;
end;
end;
procedure TIpHtml.ParseTableRows(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
{!!.12 new}
procedure FixupPercentages(CurRow: TIpHtmlNodeTR);
var
i, Pt, P0: Integer;
begin
Pt := 0;
P0 := 0;
for i := 0 to CurRow.ChildCount - 1 do
if CurRow.ChildNode[i] is TIpHtmlNodeTableHeaderOrCell then
case TIpHtmlNodeTableHeaderOrCell(CurRow.ChildNode[i]).Width.LengthType of
hlUndefined :
Inc(P0);
hlPercent :
Inc(Pt, TIpHtmlNodeTableHeaderOrCell(CurRow.ChildNode[i]).Width.LengthValue);
end;
if (Pt > 0) and (Pt < 100) and (P0 > 0) then begin
Pt := (100 - Pt) div P0;
for i := 0 to CurRow.ChildCount - 1 do
if CurRow.ChildNode[i] is TIpHtmlNodeTableHeaderOrCell then
if TIpHtmlNodeTableHeaderOrCell(CurRow.ChildNode[i]).Width.LengthType = hlUndefined then begin
TIpHtmlNodeTableHeaderOrCell(CurRow.ChildNode[i]).Width.LengthType := hlPercent;
TIpHtmlNodeTableHeaderOrCell(CurRow.ChildNode[i]).Width.LengthValue := Pt;
end;
end;
end;
var
CurRow : TIpHtmlNodeTR;
begin
CurRow := nil; {!!.12}
while not (CurToken in EndTokens) do
case CurToken of
IpHtmlTagTR :
begin
if CurRow <> nil then {!!.12}
FixupPercentages(CurRow); {!!.12}
CurRow := TIpHtmlNodeTR.Create(Parent);
CurRow.ParseBaseProps(Self);
CurRow.Align := ParseAlignment;
CurRow.VAlign := ParseVAlignment;
NextRealToken;
ParseTableRow(CurRow,
EndTokens + [IpHtmlTagTRend, IpHtmlTagTR] -
[IpHtmlTagTH, IpHtmlTagTD]);
while CurToken = IpHtmlTagTRend do
NextToken;
end;
IpHtmlTagTH,
IpHtmlTagTD :
begin
if CurRow <> nil then {!!.12}
FixupPercentages(CurRow); {!!.12}
CurRow := TIpHtmlNodeTR.Create(Parent);
ParseTableRow(CurRow,
EndTokens + [IpHtmlTagTR] - [IpHtmlTagTH, IpHtmlTagTD]);
end;
else
NextToken;
end;
if CurRow <> nil then {!!.12}
FixupPercentages(CurRow); {!!.12}
end;
procedure TIpHtml.ParseTableBody(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurHead : TIpHtmlNodeTHEAD;
CurFoot : TIpHtmlNodeTFOOT;
CurBody : TIpHtmlNodeTBODY;
begin
if CurToken = IpHtmlTagTHEAD then begin
CurHead := TIpHtmlNodeTHEAD.Create(Parent);
CurHead.ParseBaseProps(Self);
CurHead.Align := ParseCellAlign(haLeft);
CurHead.VAlign := ParseVAlignment3;
NextToken;
ParseTableRows(CurHead,
EndTokens + [IpHtmlTagTFOOT, IpHtmlTagTBODY, IpHtmlTagTHEADend] -
[IpHtmlTagTR, IpHtmlTagTH, IpHtmlTagTD]);
if CurToken = IpHtmlTagTHEADend then
NextToken;
end;
if CurToken = IpHtmlTagTFOOT then begin
CurFoot := TIpHtmlNodeTFOOT.Create(Parent);
CurFoot.ParseBaseProps(Self);
CurFoot.Align := ParseCellAlign(haLeft);
CurFoot.VAlign := ParseVAlignment3;
NextToken;
ParseTableRows(CurFoot,
EndTokens + [IpHtmlTagTBODY, IpHtmlTagTFOOTend] -
[IpHtmlTagTR, IpHtmlTagTH, IpHtmlTagTD]);
if CurToken = IpHtmlTagTFOOTend then
NextToken;
end;
while not (CurToken in EndTokens) do begin
case CurToken of
IpHtmlTagTBODY :
begin
CurBody := TIpHtmlNodeTBODY.Create(Parent);
CurBody.ParseBaseProps(Self);
CurBody.Align := ParseCellAlign(haLeft);
CurBody.VAlign := ParseVAlignment3;
NextToken;
ParseTableRows(CurBody,
EndTokens + [IpHtmlTagTBODYend] -
[IpHtmlTagTR, IpHtmlTagTH, IpHtmlTagTD, IpHtmlTagTRend]);
if CurToken = IpHtmlTagTBODYend then
NextToken;
end;
IpHtmlTagTR :
begin
CurBody := TIpHtmlNodeTBODY.Create(Parent);
ParseTableRows(CurBody,
EndTokens - [IpHtmlTagTR, IpHtmlTagTH, IpHtmlTagTD]);
end;
else
Exit;
end;
end;
end;
procedure TIpHtml.ParseColGroup(Parent: TIpHtmlNode);
var
CurColGroup : TIpHtmlNodeCOLGROUP;
CurCol : TIpHtmlNodeCOL;
begin
while CurToken = IpHtmlTagCOLGROUP do begin
CurColGroup := TIpHtmlNodeCOLGROUP.Create(Parent);
with CurColGroup do begin
ParseBaseProps(Self);
Span := ParseInteger('SPAN', 1);
Width := ParseHyperMultiLength('WIDTH', '');
end;
NextToken;
SkipTextTokens; {!!.10}
while CurToken = IpHtmlTagCOL do begin
CurCol := TIpHtmlNodeCOL.Create(CurColGroup);
with CurCol do begin
ParseBaseProps(Self);
Span := ParseInteger('SPAN', 1);
Width := ParseHyperMultiLength('WIDTH', '');
end;
NextToken;
SkipTextTokens;
end;
if CurToken = IpHtmlTagCOLGROUPend then
NextToken;
end;
end;
procedure TIpHtml.ParseTABLE(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurTable : TIpHtmlNodeTABLE;
CurCaption : TIpHtmlNodeCAPTION;
begin
CurTable := TIpHtmlNodeTABLE.Create(Parent);
with CurTable do begin
Align := ParseImageAlignment('BOTTOM');
Width := ParseHyperLength('WIDTH', '');
Width.OnChange := WidthChanged; {!!.10}
Border := ParseInteger('BORDER', 0);
if Border = 0 then begin
Frame := hfVoid;
Rules := hrNone;
end else begin
Frame := hfBorder;
Rules := hrAll;
end;
CellSpacing := ParseInteger('CELLSPACING', 2);
CellPadding := ParseInteger('CELLPADDING', 2);
ParseBaseProps(Self);
Summary := FindAttribute('SUMMARY');
Frame := ParseFrameProp(Frame);
Rules := ParseRules(Rules);
BgColor := ColorFromString(FindAttribute('BGCOLOR'));
end;
repeat
NextToken;
until CurToken in
[IpHtmlTagCAPTION, IpHtmlTagCOLGROUP, IpHtmlTagTHEAD, IpHtmlTagTFOOT,
IpHtmlTagTBODY, IpHtmlTagTR, IpHtmlTagTABLEend, IpHtmlTagEOF];
if CurToken = IpHtmlTagCAPTION then begin
CurCaption := TIpHtmlNodeCAPTION.Create(CurTable);
CurCaption.Align := ParseVAlignment2;
CurCaption.ParseBaseProps(Self);
ParseBodyText(CurCaption,
[IpHtmlTagCAPTIONend, IpHtmlTagTABLEend, IpHtmlTagTBODY]);
if CurToken in EndTokens then
else
if CurToken = IpHtmlTagCAPTIONend then
NextToken
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagCAPTIONend)
else begin
while not (CurToken in EndTokens + [IpHtmlTagCAPTIONend]) do
NextToken;
if CurToken = IpHtmlTagCAPTIONend then
NextToken;
end;
end;
ParseColgroup(CurTable);
SkipTextTokens; {!!.10}
ParseTableBody(CurTable, EndTokens + [IpHtmlTagTABLEend]
- [IpHtmlTagTR, IpHtmlTagP, IpHtmlTagPend, IpHTMLTagCENTERend,
IpHtmlTagLEFTend, IpHtmlTagRIGHTend, IpHtmlTagBLINKend, IpHtmlTagBLOCKQUOTEend
]);
SkipTextTokens;
EnsureClosure(IpHtmlTagTABLEend, EndTokens);
end;
procedure TIpHtml.ParseMAP(Parent: TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var
CurMap : TIpHtmlNodeMAP;
begin
CurMap := TIpHtmlNodeMAP.Create(Parent);
CurMap.Name := FindAttribute('NAME');
CurMap.ParseBaseProps(Self);
NextToken;
while not (CurToken in EndTokens + [IpHtmlTagMAPend]) do begin
case CurToken of
IpHtmlTagAREA :
begin
with TIpHtmlNodeAREA.Create(CurMap) do begin
Shape := ParseShape;
Coords := FindAttribute('COORDS');
HRef := FindAttribute('HREF');
NoHRef := ParseBoolean('NOHREF');
Alt := FindAttribute('ALT');
TabIndex := ParseInteger('TABINDEX', -1);
Target := FindAttribute('TARGET');
ParseBaseProps(Self);
end;
NextToken;
end;
else
if FlagErrors then
ReportExpectedError('</MAP> or <AREA>')
else
NextToken;
end;
end;
EnsureClosure(IpHtmlTagMAPend, EndTokens);
end;
procedure TIpHtml.ParseBasefont(Parent : TIpHtmlNode);
var
CurBasefont : TIpHtmlNodeBASEFONT;
begin
CurBasefont := TIpHtmlNodeBASEFONT.Create(Parent);
if CurBasefont=nil then ;
CurBasefont.Size := ParseInteger('SIZE', 3);
NextToken;
end;
procedure TIpHtml.ParseInline(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
begin
case CurToken of
IpHtmlTagP : ParseParagraph(Parent, EndTokens); {moved from block} {!!.10}
IpHtmlTagFont : ParseFont(Parent, EndTokens);
IpHtmlTagDIV : ParseDiv(Parent, EndTokens);
IpHtmlTagSPAN : ParseSpan(Parent, EndTokens);
IpHtmlTagLEFT : ParseLeft(Parent, EndTokens);
IpHtmlTagCENTER : ParseCenter(Parent, EndTokens);
IpHtmlTagRIGHT : ParseRight(Parent, EndTokens);
IpHtmlTagBLINK : ParseBlink(Parent, EndTokens);
IpHtmlTagQ : ParseQ(Parent, EndTokens);
IpHtmlTagHR : ParseHR(Parent);
IpHtmlTagTT, IpHtmlTagI, IpHtmlTagB, IpHtmlTagU, IpHtmlTagSTRIKE, IpHtmlTagS,
IpHtmlTagBIG, IpHtmlTagSMALL, IpHtmlTagSUB, IpHtmlTagSUP :
ParseFontStyle(Parent, CurToken, EndTokens + [succ(CurToken)]);
IpHtmlTagEM, IpHtmlTagSTRONG, IpHtmlTagDFN, IpHtmlTagCODE,
IpHtmlTagSAMP, IpHtmlTagKBD, IpHtmlTagVAR, IpHtmlTagCITE,
IpHtmlTagABBR, IpHtmlTagACRONYM :
ParsePhraseElement(Parent, CurToken, succ(CurToken), EndTokens);
IpHtmlTagA : ParseAnchor(Parent, EndTokens);
IpHtmlTagBASEFONT : ParseBasefont(Parent);
IpHtmlTagBR : ParseBR(Parent);
IpHtmlTagNOBR : ParseNOBR(Parent);
IpHtmlTagMAP :
ParseMAP(Parent, EndTokens);
IpHtmlTagText :
begin
TIpHtmlNodeText.Create(Parent).FEscapedText := GetTokenString;
NextToken;
end;
IpHtmlTagINPUT,
IpHtmlTagSELECT,
IpHtmlTagButton,
IpHtmlTagTEXTAREA :
ParseFormFields(Parent, EndTokens);
IpHtmlTagINS :
ParseIns(Parent, EndTokens);
IpHtmlTagDEL :
ParseDel(Parent, EndTokens);
IpHtmlTagIFRAME :
ParseIFRAME(Parent);
IpHtmlTagSCRIPT :
ParseScript(Parent, EndTokens);
IpHtmlTagNOSCRIPT :
ParseNoscript(Parent);
IpHtmlTagSTYLE :
ParseStyle(Parent);
else
NextToken;
end;
end;
procedure TIpHtml.ParseBlock(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
begin
case CurToken of
IpHtmlTagH1 : ParseHeader(Parent, IpHtmlTagH1end, 1);
IpHtmlTagH2 : ParseHeader(Parent, IpHtmlTagH2end, 2);
IpHtmlTagH3 : ParseHeader(Parent, IpHtmlTagH3end, 3);
IpHtmlTagH4 : ParseHeader(Parent, IpHtmlTagH4end, 4);
IpHtmlTagH5 : ParseHeader(Parent, IpHtmlTagH5end, 5);
IpHtmlTagH6 : ParseHeader(Parent, IpHtmlTagH6end, 6);
{IpHtmlTagP : ParseParagraph(Parent, EndTokens);} {moved to inline} {!!.10}
IpHtmlTagDIR : ParseUnorderedList(Parent, IpHtmlTagDIRend, EndTokens);
IpHtmlTagMENU : ParseUnorderedList(Parent, IpHtmlTagMENUend, EndTokens);
IpHtmlTagUL : ParseUnorderedList(Parent, IpHtmlTagULen, EndTokens);
IpHtmlTagDL : ParseDefinitionList(Parent, EndTokens);
IpHtmlTagOL :
ParseOrderedList(Parent, EndTokens);
IpHtmlTagPRE : ParsePre(Parent, EndTokens);
IpHtmlTagBLOCKQUOTE : ParseBlockQuote(Parent, EndTokens);
IpHtmlTagFORM : ParseForm(Parent, EndTokens);
IpHtmlTagTABLE : ParseTable(Parent, EndTokens);
IpHtmlTagIMG : ParseIMG(Parent);
IpHtmlTagOBJECT : ParseObject(Parent);
IpHtmlTagAPPLET : ParseApplet(Parent, EndTokens);
IpHtmlTagADDRESS : ParseAddress(Parent);
IpHtmlTagEof : Exit;
IpHtmlTagFRAMESET :
ParseFrameSet(Parent, EndTokens + [IpHtmlTagFRAMESETend]);
IpHtmlTagUnknown :
if FlagErrors then
ReportError(SHtmlUnknownTok)
else
NextToken;
end;
end;
{$IFDEF IP_LAZARUS}
procedure TIpHtml.ParseStyleSheet(Parent: TIpHtmlNode; HRef: String);
var
StyleStream: TStream;
begin
if FDataProvider = nil then
begin
//DebugLn('No dataprovider!');
exit;
end;
if Parent is TIpHtmlNodeHEAD then
begin
Href := FDataProvider.BuildURL(CurURL, HRef);
StyleStream := FDataProvider.DoGetStream(HRef);
if StyleStream <> nil then
begin
with TCSSReader.Create(StyleStream, FCSS) do
begin
ParseCSS;
Free;
end;
StyleStream.Free;
end;
end;
end;
{$ENDIF}
procedure TIpHtml.ParseBodyText(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
begin
Inc(InBlock);
try
while not (CurToken in EndTokens) do begin
case CurToken of
IpHtmlTagH1,
IpHtmlTagH2,
IpHtmlTagH3,
IpHtmlTagH4,
IpHtmlTagH5,
IpHtmlTagH6,
{IpHtmlTagP,} {!!.10}
IpHtmlTagDIR,
IpHtmlTagMENU,
IpHtmlTagUL,
IpHtmlTagDL,
IpHtmlTagOL,
IpHtmlTagPRE,
IpHtmlTagBLOCKQUOTE,
IpHtmlTagFORM,
IpHtmlTagTABLE,
IpHtmlTagIMG,
IpHtmlTagOBJECT,
IpHtmlTagAPPLET,
IpHtmlTagADDRESS,
IpHtmlTagFRAMESET :
ParseBlock(Parent, EndTokens);
{Begin !!.12}
IpHtmlTagBODY :
begin
if Body = nil then begin
TIpHtmlNodeBODY.Create(Parent);
NextToken;
ParseBodyText(Body, EndTokens);
end
else
ParseInline(Parent, EndTokens);
end;
{End !!.12}
IpHtmlTagEof :
Exit;
else
ParseInline(Parent, EndTokens);
end;
end;
finally
Dec(InBlock);
end;
end;
function TIpHtml.FindAttribute(const AttrName : string) : string;
var
i : Integer;
begin
for i := 0 to Pred(ParmList.Count) do
if ParmList[i] = AttrName then begin
Result := ValueList[i];
Exit;
end;
Result := '';
end;
function TIpHtml.ParseInteger(const AttrName : string; Default : Integer) : Integer;
var
S : string;
Err : Integer;
begin
S := FindAttribute(AttrName);
if (S = '') then
Result := Default
else
if CompareText(S, AttrName) = 0 then
Result := 1
else begin
Val(S, Result, Err);
if Err <> 0 then begin
Result := Default;
if FlagErrors then
ReportError(SHtmlInvInt)
end;
end;
end;
{!!.10 new}
function TIpHtml.ParseHtmlInteger(const AttrName : string; Default : Integer) : TIpHtmlInteger;
var
S : string;
N, Err : Integer;
begin
S := FindAttribute(AttrName);
if (S = '') then
N := Default
else
if CompareText(S, AttrName) = 0 then
N := 1
else begin
Val(S, N, Err);
if Err <> 0 then begin
N := Default;
if FlagErrors then
ReportError(SHtmlInvInt)
end;
end;
Result := TIpHtmlInteger.Create(N);
end;
function TIpHtml.ParseRelSize{(const Default : string)} : TIpHtmlRelSize; {!!.10}
var
S : string;
Err : Integer;
begin
Result := TIpHtmlRelSize.Create; {!!.10}
Result.FSizeType := hrsUnspecified; {!!.10}
S := FindAttribute('SIZE');
if (S = '') then
Exit; {S := Default;} {!!.10}
Result.Value := 0;
if (length(S) > 1) and (S[1] = '+') then begin
Result.SizeType := hrsRelative;
Delete(S,1,1);
end else
if (length(S) > 1) and (S[1] = '-') then begin
Result.SizeType := hrsRelative;
end else
Result.SizeType := hrsAbsolute;
Val(S, Result.FValue, Err);
if Err <> 0 then
if FlagErrors then
ReportError(SHtmlInvInt);
end;
{!!.10 new}
function TIpHtml.ParsePixels(const AttrName: string;
const Default: string): TIpHtmlPixels;
var
S : string;
Err : Integer;
begin
Result := TIpHtmlPixels.Create;
S := FindAttribute(AttrName);
if (S = '') then
S := Default;
if S = '' then {!!.12}
Result.PixelsType := hpUndefined {!!.12}
else begin
Result.PixelsType := hpAbsolute; {!!.12}
val(S, Result.FValue, Err);
if (Err <> 0) or (Result.FValue < 0) then begin
if FlagErrors then
ReportError(SHtmlInvInt)
else
Result.FValue := 0;
end;
end;
end;
function TIpHtml.ParseHyperLength(const AttrName: string;
const Default: string): TIpHtmlLength;
var
S : string;
P, Err : Integer;
begin
Result := TIpHtmlLength.Create; {!!.10}
Result.LengthType := hlUndefined;
S := FindAttribute(AttrName);
if (S = '') then
S := Default;
if (S = '') then
Exit;
P := CharPos('%', S);
if P <> 0 then begin
Result.LengthType := hlPercent;
Delete(S, P, 1);
end else
Result.LengthType := hlAbsolute;
val(S, Result.FLengthValue, Err); {!!.10}
if (Err <> 0) or (Result.LengthValue < 0) then begin
if FlagErrors then
ReportError(SHtmlInvInt)
else
Result.LengthType := hlUndefined;
end else {!!.12}
if (Result.LengthType = hlPercent) {!!.12}
and (Result.LengthValue > 100) then {!!.12}
Result.LengthValue := 100; {!!.12}
end;
function TIpHtml.ParseHyperMultiLength(const AttrName: string;
const Default: string): TIpHtmlMultiLength;
var
S : string;
P, Err : Integer;
begin
Result := TIpHtmlMultiLength.Create;
Result.LengthType := hmlUndefined;
S := FindAttribute(AttrName);
if (S = '') then
S := Default;
if (S = '') then
Exit;
P := CharPos('%', S);
if P <> 0 then begin
Result.LengthType := hmlPercent;
Delete(S, P, 1);
end else begin
P := CharPos('*', S);
if P <> 0 then begin
Result.LengthType := hmlRelative;
Delete(S, P, 1);
end else
Result.LengthType := hmlAbsolute;
end;
val(S, Result.FLengthValue, Err);
if (Err <> 0) or (Result.FLengthValue < 0) then begin
if FlagErrors then
ReportError(SHtmlInvInt)
else
Result.LengthType := hmlUndefined;
end;
end;
function TIpHtml.ParseHyperMultiLengthList(const AttrName: string;
const Default: string): TIpHtmlMultiLengthList; {!!.10}
var
S, S2 : string;
B, E, P, Err : Integer;
NewEntry: TIpHtmlMultiLength;
begin
{List.Entries := 0;}
Result := TIpHtmlMultiLengthList.Create;
S := FindAttribute(AttrName);
if (S = '') then
S := Default;
if (S = '') then
Exit;
B := 1;
while B <= length(S) do begin
E := B;
repeat
Inc(E);
until (E > length(S)) or (S[E] = ',');
S2 := copy(S, B, E - B);
NewEntry := TIpHtmlMultiLength.Create; {!!.10}
{List.Values[List.Entries].LengthType := hmlUndefined;} {!!.10}
NewEntry.LengthType := hmlUndefined; {!!.10}
P := CharPos('%', S2);
if P <> 0 then begin
{List.Values[List.Entries].LengthType := hmlPercent;} {!!.10}
NewEntry.LengthType := hmlPercent; {!!.10}
Delete(S2, P, 1);
end else begin
P := CharPos('*', S2);
if P <> 0 then begin
{List.Values[List.Entries].LengthType := hmlRelative;} {!!.10}
NewEntry.LengthType := hmlRelative; {!!.10}
Delete(S2, P, 1);
end else
{List.Values[List.Entries].LengthType := hmlAbsolute;} {!!.10}
NewEntry.LengthType := hmlAbsolute; {!!.10}
end;
if S2 = '' then
{List.Values[List.Entries].LengthValue := 0} {!!.10}
NewEntry.LengthValue := 0 {!!.10}
else begin
{val(S2, List.Values[List.Entries].FLengthValue, Err);} {!!.10}
val(S2, NewEntry.FLengthValue, Err); {!!.10}
{if (Err <> 0) or (List.Values[List.Entries].LengthValue < 0) then begin}
if (Err <> 0) or (NewEntry.FLengthValue < 0) then begin {!!.10}
if FlagErrors then
ReportError(SHtmlInvInt)
else
{List.Values[List.Entries].LengthType := hmlUndefined;} {!!.10}
NewEntry.LengthType := hmlUndefined; {!!.10}
end;
end;
{Inc(List.Entries);} {!!.10}
Result.AddEntry(NewEntry);
B := E + 1;
end;
end;
function CalcMultiLength(const List: TIpHtmlMultiLengthList;
Avail: Integer; var Sections: Integer): TIntArr; {!!.10}
var
OrgAvail, i, S : Integer;
begin
Result := TIntArr.Create;
if List.Entries = 0 then begin
Sections := 1;
Result[0] := Avail;
Exit;
end;
OrgAvail := Avail;
Sections := List.Entries;
for i := 0 to Pred(List.Entries) do begin
if List.Values[i].LengthType = hmlAbsolute then begin
if Avail >= List.Values[i].LengthValue then begin
Result[i] := List.Values[i].LengthValue;
Dec(Avail, Result[i]);
end else begin
Result[i] := Avail;
Avail := 0;
end;
end else
Result[i] := 0;
end;
if Avail > 0 then begin
for i := 0 to Pred(List.Entries) do
if List.Values[i].LengthType = hmlPercent then
Result[i] := round(List.Values[i].LengthValue * Avail / 100);
for i := 0 to Pred(List.Entries) do
if List.Values[i].LengthType = hmlPercent then
Dec(Avail, Result[i]);
if Avail > 0 then begin
S := 0;
for i := 0 to Pred(List.Entries) do
if (List.Values[i].LengthType = hmlRelative) then
Inc(S, List.Values[i].LengthValue);
if S > 0 then
for i := 0 to Pred(List.Entries) do
if (List.Values[i].LengthType = hmlRelative) then begin
Result[i] := round(List.Values[i].LengthValue * Avail / S);
Dec(Avail, Result[i]);
end;
if Avail > 0 then
for i := 0 to Pred(List.Entries) do
if (List.Values[i].LengthType = hmlRelative)
and (List.Values[i].LengthValue = 0) then begin
Result[i] := Avail;
break;
end;
end;
end;
repeat
S := 0;
for i := 0 to Pred(List.Entries) do
Inc(S, Result[i]);
S := OrgAvail - S;
if S > 0 then
for i := 0 to Pred(List.Entries) do begin
{Inc(Result[i]);} {!!.10}
Result[i] := Result[i] + 1; {!!.10}
Dec(S);
if S = 0 then break;
end;
if S < 0 then
for i := 0 to Pred(List.Entries) do begin
{Dec(Result[i]);} {!!.10}
Result[i] := Result[i] - 1; {!!.10}
Inc(S);
if S = 0 then break;
end;
until S = 0;
end;
function TIpHtml.ParseBoolean(const AttrName : string) : Boolean;
var
i : Integer;
begin
for i := 0 to Pred(ParmList.Count) do
if ParmList[i] = AttrName then begin
Result := True;
Exit;
end;
Result := False;
end;
function TIpHtml.ParseOLStyle(Default : TIpHtmlOLStyle) : TIpHtmlOLStyle;
var
S : string;
begin
Result := Default;
S := FindAttribute('TYPE');
if (S = '') then
else
if (S = '1') then
Result := olArabic
else
if S = 'a' then
Result := olLowerAlpha
else
if S = 'A' then
Result := olUpperAlpha
else
if S = 'i' then
Result := olLowerRoman
else
if S = 'I' then
Result := olUpperRoman
else
if FlagErrors then
ReportError(SHtmlInvType);
end;
function TIpHtml.ParseULStyle(Default : TIpHtmlULType) : TIpHtmlULType;
var
S : string;
begin
Result := Default;
S := UpperCase(FindAttribute('TYPE'));
if (S = '') then
else
if (S = 'DISC') then
Result := ulDisc
else
if S = 'SQUARE' then
Result := ulSquare
else
if S = 'CIRCLE' then
Result := ulCircle
else
if FlagErrors then
ReportError(SHtmlInvType);
end;
function TIpHtml.ParseAlignment : TIpHtmlAlign;
var
S : string;
begin
Result := haLeft;
S := UpperCase(FindAttribute('ALIGN'));
if (S = '') then
Result := haDefault
else
if (S = 'LEFT') then
Result := haLeft
else
if (S = 'CENTER') or (S = 'MIDDLE') then
Result := haCenter
else
if S = 'RIGHT' then
Result := haRight
else
if S = 'JUSTIFY' then
Result := haJustify
else
if FlagErrors then
ReportError(SHtmlInvAlign);
end;
function TIpHtml.ParseVAlignment : TIpHtmlVAlign;
var
S : string;
begin
Result := hvaMiddle;
S := UpperCase(FindAttribute('VALIGN'));
if (S = '') or (S = 'MIDDLE') or (S = 'CENTER') then
else
if S = 'TOP' then
Result := hvaTop
else
if S = 'BOTTOM' then
Result := hvaBottom
else
if FlagErrors then
ReportError(SHtmlInvAlign);
end;
function TIpHtml.ParseVAlignment2: TIpHtmlVAlignment2;
var
S : string;
begin
Result := hva2Top;
S := UpperCase(FindAttribute('ALIGN'));
if (S = '') or (S = 'TOP') then
else
if S = 'BOTTOM' then
Result := hva2Bottom
else
if S = 'LEFT' then
Result := hva2Left
else
if S = 'RIGHT' then
Result := hva2Right
else
if FlagErrors then
ReportError(SHtmlInvAlign);
end;
function TIpHtml.ParseImageAlignment(const Default: string) : TIpHtmlImageAlign;
var
S : string;
begin
Result := hiaBottom;
S := UpperCase(FindAttribute('ALIGN'));
if S = '' then
S := Default;
if (S = 'BOTTOM') then
else
if S = 'TOP' then
Result := hiaTop
else
if (S = 'MIDDLE')
or (S = 'ABSCENTER') then
Result := hiaMiddle
else
if S = 'LEFT' then
Result := hiaLeft
else
if S = 'CENTER' then
Result := hiaCenter
else
if S = 'RIGHT' then
Result := hiaRight
else
if FlagErrors then
ReportError(SHtmlInvAlign);
end;
function TIpHtml.ParseObjectValueType: TIpHtmlObjectValueType;
var
S : string;
begin
Result := hovtData;
S := UpperCase(FindAttribute('VALUETYPE'));
if (S = '') or (S = 'DATA') then
else
if S = 'REF' then
Result := hovtRef
else
if S = 'OBJECT' then
Result := hovtObject
else
if FlagErrors then
ReportError(SHtmlInvValType);
end;
function TIpHtml.ParseShape : TIpHtmlMapShape;
var
S : string;
begin
Result := hmsDefault;
S := UpperCase(FindAttribute('SHAPE'));
if (S = '') or (S = 'DEFAULT') then
else
if (S = 'RECT') then
Result := hmsRect
else
if S = 'CIRCLE' then
Result := hmsCircle
else
if (S = 'POLY') or (S = 'POLYGON') then
Result := hmsPoly
else
if FlagErrors then
ReportError(SHtmlInvShape);
end;
function TIpHtml.ParseMethod : TIpHtmlFormMethod;
var
S : string;
begin
Result := hfmGet;
S := UpperCase(FindAttribute('METHOD'));
if (S = '') or (S = 'GET') then
else
if S = 'POST' then
Result := hfmPost
else
if FlagErrors then
ReportError(SHtmlInvMethod);
end;
function TIpHtml.ParseBRClear : TIpHtmlBreakClear;
var
S : string;
begin
Result := hbcNone;
S := UpperCase(FindAttribute('CLEAR'));
if (S = '') then
else
if (S = 'ALL') or (S = 'CLEAR') then
Result := hbcAll
else
if S = 'LEFT' then
Result := hbcLeft
else
if S = 'RIGHT' then
Result := hbcRight
else
if FlagErrors then
ReportError(SHtmlInvAlign);
end;
function TIpHtml.ParseDir : TIpHtmlDirection;
var
S : string;
begin
Result := hdLTR;
S := UpperCase(FindAttribute('DIR'));
if (S = '') or (S = 'LTR') then
else
if (S = 'RTL') then
Result := hdRTL
else
if FlagErrors then
ReportError(SHtmlInvDir);
end;
function TIpHtml.ColorFromString(S : string) : TColor;
var
R, G, B, Err : Integer;
begin
Result := -1;
if S = '' then
Exit;
S := UpperCase(S);
if S[1] = '#' then
if length(S) <> 7 then
if FlagErrors then
ReportError(SHtmlInvColor + S)
else
else begin
val('$'+Copy(S,2,2), R, Err);
if Err <> 0 then
R := 255;
val('$'+Copy(S,4,2), G, Err);
if Err <> 0 then
G := 255;
val('$'+Copy(S,6,2), B, Err);
if Err <> 0 then
B := 255;
Result := RGB(R, G, B);
end
else
if S = 'BLACK' then
Result := clBlack
else
if S = 'SILVER' then
Result := clSilver
else
if S = 'GRAY' then
Result := clGray
else
if S = 'WHITE' then
Result := clWhite
else
if S = 'MAROON' then
Result := clMaroon
else
if S = 'RED' then
Result := clRed
else
if S = 'PURPLE' then
Result := clPurple
else
if S = 'FUCHSIA' then
Result := clFuchsia
else
if S = 'GREEN' then
Result := clGreen
else
if S = 'LIME' then
Result := clLime
else
if S = 'OLIVE' then
Result := clOlive
else
if S = 'YELLOW' then
Result := clYellow
else
if S = 'NAVY' then
Result := clNavy
else
if S = 'BLUE' then
Result := clBlue
else
if S = 'TEAL' then
Result := clTeal
else
if S = 'AQUA' then
Result := clAqua
else
if length(S) = 6 then
try
val('$'+Copy(S,1,2), R, Err);
if Err <> 0 then
R := 255;
val('$'+Copy(S,3,2), G, Err);
if Err <> 0 then
G := 255;
val('$'+Copy(S,5,2), B, Err);
if Err <> 0 then
B := 255;
Result := RGB(R, G, B);
except
if FlagErrors then
ReportError(SHtmlInvColor + S)
else
Result := -1;
end;
end;
procedure TIpHtml.ParseFrame(Parent : TIpHtmlNode);
var
CurFrame : TIpHtmlNodeFRAME;
begin
CurFrame := TIpHtmlNodeFRAME.Create(Parent);
with CurFrame do begin
LongDesc := FindAttribute('LONGDESC');
Name := FindAttribute('NAME');
Src := FindAttribute('SRC');
FrameBorder := ParseInteger('BORDER', 1);
MarginWidth := ParseInteger('MARGINWIDTH', 1);
MarginHeight := ParseInteger('MARGINHEIGHT', 1);
NoResize := ParseBoolean('NORESIZE');
Scrolling := ParseFrameScrollingProp;
ParseBaseProps(Self);
end;
NextToken;
end;
procedure TIpHtml.ParseIFrame(Parent : TIpHtmlNode);
var
CurFrame : TIpHtmlNodeIFRAME;
begin
CurFrame := TIpHtmlNodeIFRAME.Create(Parent);
with CurFrame do begin
LongDesc := FindAttribute('LONGDESC');
Name := FindAttribute('NAME');
Src := FindAttribute('SRC');
FrameBorder := ParseInteger('BORDER', 1);
MarginWidth := ParseInteger('MARGINWIDTH', 1);
MarginHeight := ParseInteger('MARGINHEIGHT', 1);
Scrolling := ParseFrameScrollingProp;
Align := ParseAlignment;
Height := ParseHyperLength('HEIGHT', '');
Height.OnChange := WidthChanged; {!!.10}
Width := ParseHyperLength('WIDTH', '');
Width.OnChange := WidthChanged; {!!.10}
ParseBaseProps(Self);
end;
NextToken;
ParseBodyText(CurFrame, [IpHtmlTagIFRAMEend]);
if CurToken = IpHtmlTagIFRAMEend then
NextToken;
end;
procedure TIpHtml.ParseNOFRAMES(Parent : TIpHtmlNode);
var
CurNoFrames : TIpHtmlNodeNOFRAMES;
begin
CurNoFrames := TIpHtmlNodeNOFRAMES.Create(Parent);
NextToken;
ParseBodyText(CurNoFrames, [IpHtmlTagNOFRAMESend, IpHtmlTagFRAMESETend]);
if CurToken = IpHtmlTagNOFRAMESend then
NextToken;
end;
procedure TIpHtml.ParseFrameSet(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
begin
{$IFDEF IP_LAZARUS} //JMN
DebugLn('TIpHtml.ParseFrameSet A');
{$ENDIF}
FHasFrames := True;
while CurToken = IpHtmlTagFRAMESET do begin
CurFrameSet := TIpHtmlNodeFRAMESET.Create(Parent);
with CurFrameSet do begin
{ParseHyperMultiLengthList('ROWS', '100%', FRows);} {!!.10}
FRows := ParseHyperMultiLengthList('ROWS', '100%'); {!!.10}
{ParseHyperMultiLengthList('COLS', '100%', FCols);} {!!.10}
FCols := ParseHyperMultiLengthList('COLS', '100%'); {!!.10}
Id := FindAttribute('ID');
ClassId := FindAttribute('CLASS');
Title := FindAttribute('TITLE');
Style := FindAttribute('STYLE');
end;
NextToken;
if CurToken = IpHtmlTagFRAMESET then
ParseFrameSet(CurFrameSet, EndTokens + [IpHtmlTagFRAMESETend]);
while CurToken = IpHtmlTagFRAME do
ParseFrame(CurFrameSet);
if CurToken = IpHtmlTagNOFRAMES then
ParseNOFRAMES(CurFrameSet);
if CurToken = IpHtmlTagFRAMESETend then
NextToken;
end;
end;
procedure TIpHtml.ParseBody(Parent : TIpHtmlNode;
const EndTokens: TIpHtmlTokenSet);
var {!!.12}
i : Integer; {!!.12}
Node : TIpHtmlNode; {!!.12}
{$IFDEF IP_LAZARUS}
Element: TCSSProps = nil;
{$ENDIF}
begin
// while CurToken = IpHtmlTagText do {Deleted !!.12}
// NextToken; {Deleted !!.12}
if CurToken = IpHtmlTagFRAMESET then begin
ParseFrameSet(Parent, EndTokens);
Exit;
end;
{lead token is optional}
if CurToken = IpHtmlTagBODY then begin
TIpHtmlNodeBODY.Create(Parent);
with Body do begin
BgColor := ColorFromString(FindAttribute('BGCOLOR'));
Text := ColorFromString(FindAttribute('TEXT'));
Link := ColorFromString(FindAttribute('LINK'));
VLink := ColorFromString(FindAttribute('VLINK'));
ALink := ColorFromString(FindAttribute('ALINK'));
Background := FindAttribute('BACKGROUND');
ParseBaseProps(Self);
{$IFDEF IP_LAZARUS}
LoadCSSProps(Owner, Element, nil);
{$ENDIF}
end;
NextToken;
ParseBodyText(Body, EndTokens + [IpHtmlTagBODYend]);
EnsureClosure(IpHtmlTagBODYend, EndTokens);
end else begin
{Begin !!.12}
// Body := TIpHtmlNodeBODY.Create(Parent);
// ParseBodyText(Body, EndTokens + [IpHtmlTagBODYend]);
ParseBodyText(Parent, EndTokens + [IpHtmlTagBODYend]);
{ Does the HTML include a body node? }
if not TIpHtmlNodeHtml(Parent).HasBodyNode then
{ No. Create a body node under FHtml. }
with TIpHtmlNodeHtml(Parent) do begin
{$IFDEF IP_LAZARUS}
with
{$ENDIF}
TIpHtmlNodeBODY.Create(Parent){$IFDEF IP_LAZARUS} do LoadCSSProps(Owner, Element, nil){$ENDIF};
{ Make each of FHtml's current children the children of the
Body node. }
for i := Pred(ChildCount) downto 0 do
if ChildNode[i] <> Body then begin
Node := ChildNode[i];
FChildren.Remove(Node);
Node.FParentNode := Body;
Body.FChildren.Insert(0, Node);
end;
end; { with }
{End !!.12}
if CurToken = IpHtmlTagBODYend then
NextToken;
end;
end;
procedure TIpHtml.ParseHtml;
begin
{lead token is optional}
if CurToken = IpHtmlTagHtml then begin
HtmlNode.Version := FindAttribute('VERSION');
HtmlNode.Lang := FindAttribute('LANG');
HtmlNode.Dir := ParseDir;
NextToken;
ParseHead(HtmlNode); {may not be present}
ParseBody(HtmlNode, [IpHtmlTagHtmlend, IpHtmlTagEOF]); {may not be present}
if CurToken in [IpHtmlTagHtmlend, IpHtmlTagEOF] then
else
if FlagErrors then
ReportExpectedToken(IpHtmlTagHtmlend);
NextToken;
end else begin
ParseHead(HtmlNode); {may not be present}
ParseBody(HtmlNode, [IpHtmlTagEof]); {may not be present}
end;
end;
procedure TIpHtml.Parse;
begin
Getmem(TokenStringBuf, 65536); {!!.01}
try {!!.01}
CharSP := 0;
ListLevel := 0;
StartPos := CharStream.Position;
repeat
NextToken;
until CurToken in [IpHtmlTagHtml, IpHtmlTagFRAMESET, IpHtmlTagEOF];
if CurToken = IpHtmlTagEOF then begin
CharStream.Position := StartPos;
CharSP := 0;
ListLevel := 0;
repeat
NextToken;
until CurToken <> IpHtmlTagText;
end;
if CurToken = IpHtmlTagEOF then Exit;
//ParseDocType; {may not be present}
ParseHtml;
finally {!!.01}
FreeMem(TokenStringBuf); {!!.01}
TokenStringBuf := nil; {!!.01}
if ParmBuf <> nil then begin {!!.12}
FreeMem(ParmBuf); {!!.12}
ParmBuf := nil; {!!.12}
ParmBufSize := 0; {!!.12}
end; {!!.12}
end; {!!.01}
end;
constructor TIpHtml.Create;
var
TmpBitmap : TBitmap;
begin
inherited Create;
PropACache := TList.Create;
PropBCache := TList.Create;
DummyA := TIpHtmlPropA.Create;
DummyA.UseCount := 1;
DummyB := TIpHtmlPropB.Create(Self);
DummyB.UseCount := 1;
PropACache.Add(DummyA);
PropBCache.Add(DummyB);
ElementPool := TIpHtmlPoolManager.Create(sizeof(TIpHtmlElement), MaxElements);
SoftLF := BuildStandardEntry(etSoftLF);
HardLF := BuildStandardEntry(etHardLF);
HardLFClearLeft := BuildStandardEntry(etClearLeft);
HardLFClearRight := BuildStandardEntry(etClearRight);
HardLFClearBoth := BuildStandardEntry(etClearBoth);
LIndent := BuildStandardEntry(etIndent);
LOutdent := BuildStandardEntry(etOutdent);
SoftHyphen := BuildStandardEntry(etSoftHyphen);
DefaultProps := TIpHtmlProps.Create(Self);
FHtml := TIpHtmlNodeHtml.Create(nil);
FHtml.FOwner := Self;
ParmList := TStringList.Create;
ValueList := TStringList.Create;
AnchorList := TList.Create;
MapList := TList.Create;
AreaList := TList.Create;
MapImgList := TList.Create;
RectList := TList.Create;
ControlList := TList.Create;
LinkColor := clBlue;
VLinkColor := clPurple;
ALinkColor := clRed;
{$IFDEF IP_LAZARUS}
FCSS := TCSSGlobalProps.Create;
{$IFDEF UseGifImageUnit}
GifImages := TList.Create;
{$ELSE}
AnimationFrames := TList.Create;
{$ENDIF}
{$ELSE}
GifImages := TList.Create;
OtherImages := TList.Create; //JMN
{$ENDIF}
NameList := TStringList.Create;
DefaultImage := TPicture.Create;
TmpBitmap := TBitmap.Create;
try
{$IFNDEF IP_LAZARUS}
TmpBitmap.LoadFromResourceName (HInstance, 'DEFAULTIMAGE'); //JMN
(**
TmpBitmap.LoadFromResourceName(FindClassHInstance( {!!.06}
TIpHTMLCustomPanel), 'DEFAULTIMAGE');
**)
DefaultImage.Graphic := TmpBitmap;
{$ELSE}
if LazarusResources.Find('DEFAULTIMAGE')<>nil then begin
TmpBitmap.LoadFromLazarusResource('DEFAULTIMAGE');
DefaultImage.Graphic := TmpBitmap;
end;
{$ENDIF}
finally
TmpBitmap.Free;
end;
GifQueue := TList.Create;
FStartSel.x := -1;
FEndSel.x := -1;
//FixedTypeface := 'Courier New'; {!!.10} //JMN
end;
function TIpHtml.LinkVisited(const URL : string): Boolean;
begin
if (length(URL) > 0) and (URL[1] = '#') then
Result := True
else
Result := CheckKnownURL(URL);
end;
{$IFOPT C+}
procedure TIpHtml.CheckImage(Picture: TPicture);
begin
if Picture <> nil then begin
if not (Picture is TPicture) then
raise EIpHtmlException.Create(SHTMLInvPicture); {!!.02}
if Picture.Graphic = nil then
raise EIpHtmlException.Create(SHTMLNoGraphic); {!!.02}
if not (Picture.Graphic is TGraphic) then
raise EIpHtmlException.Create(SHTMLInvGraphic); {!!.02}
end;
end;
{$ENDIF}
procedure TIpHtml.DoGetImage(Sender: TIpHtmlNode; const URL: string;
var Picture: TPicture);
begin
if assigned(FOnGetImageX) then
OnGetImageX(Sender, URL, Picture)
else
raise EIpHtmlException.Create(SHTMLNoGetImage); {!!.02}
{$IFOPT C+}
CheckImage(Picture);
{$ENDIF}
end;
procedure TIpHtml.FinalizeRecs(P: Pointer);
begin
{$IFDEF IP_LAZARUS}
with PIpHtmlElement(P)^ do begin
//ElementType : TElementType;
AnsiWord:='';
//IsBlank : Integer;
//SizeProp: TIpHtmlPropA;
//Size: TSize;
//WordRect2 : TRect;
//Props : TIpHtmlProps;
//Owner : TIpHtmlNode;
end;
{$ELSE}
Finalize(PIpHtmlElement(P)^);
{$ENDIF}
end;
destructor TIpHtml.Destroy;
var
i : Integer;
begin
{$IFDEF IP_LAZARUS} //JMN
FCSS.Free;
{$IFDEF UseGifImageUnit}
for i := 0 to Pred(GifImages.Count) do
if TIpHtmlNodeIMG(GifImages[i]).FPicture <> nil then
TGifImage(TIpHtmlNodeIMG(GifImages[i]).FPicture.Graphic).PaintStop;
{$ELSE}
for i := 0 to Pred(AnimationFrames.Count) do
if TIpHtmlNodeIMG(AnimationFrames[i]).FPicture <> nil then
TIpAnimatedGraphic(TIpHtmlNodeIMG(AnimationFrames[i]).FPicture.Graphic).
AggressiveDrawing := False;
{$ENDIF}
{$ELSE}
for i := 0 to Pred(GifImages.Count) do
if TIpHtmlNodeIMG(GifImages[i]).FPicture <> nil then
TGifImage(TIpHtmlNodeIMG(GifImages[i]).FPicture.Graphic).PaintStop;
for i := 0 to Pred(OtherImages.Count) do //JMN
if TIpHtmlNodeIMG(OtherImages[i]).FPicture <> nil then
TIpHtmlNodeIMG(OtherImages[i]).FPicture.Graphic := nil;
{$ENDIF}
Destroying := True;
PaintBufferBitmap.Free;
ClearGifQueue;
Clear;
GifQueue.Free;
DefaultImage.Free;
NameList.Free;
ParmList.Free;
ValueList.Free;
FHtml.Free;
AnchorList.Free;
MapList.Free;
AreaList.Free;
ClearRectList;
RectList.Free;
MapImgList.Free;
ControlList.Free;
DefaultProps.Free;
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
GifImages.Free;
{$ELSE}
AnimationFrames.Free;
{$ENDIF}
{$ELSE}
GifImages.Free;
OtherImages.Free; //JMN
{$ENDIF}
ElementPool.EnumerateItems(FinalizeRecs);
ElementPool.Free;
ClearCache;
inherited;
end;
function TIpHtml.ParseFrameProp(Default : TIpHtmlFrameProp): TIpHtmlFrameProp;
var
S : string;
begin
Result := hfVoid;
S := UpperCase(FindAttribute('FRAME'));
if (S = '') then
Result := Default
else
if (S = 'VOID') then
else
if (S = 'ABOVE') then
Result := hfAbove
else
if S = 'BELOW' then
Result := hfBelow
else
if S = 'HSIDES' then
Result := hfHSides
else
if S = 'LHS' then
Result := hfLhs
else
if S = 'RHS' then
Result := hfRhs
else
if S = 'VSIDES' then
Result := hfvSides
else
if S = 'BOX' then
Result := hfBox
else
if S = 'BORDER' then
Result := hfBorder
else
if FlagErrors then
ReportError(SHtmlInvFrame);
end;
function TIpHtml.ParseRules(Default : TIpHtmlRules): TIpHtmlRules;
var
S : string;
begin
Result := hrNone;
S := UpperCase(FindAttribute('RULES'));
if (S = '') then
Result := Default
else
if (S = 'NONE') then
else
if (S = 'GROUPS') then
Result := hrGroups
else
if S = 'ROWS' then
Result := hrRows
else
if S = 'COLS' then
Result := hrCols
else
if S = 'ALL' then
Result := hrAll
else
if FlagErrors then
ReportError(SHtmlInvRule);
end;
function TIpHtml.ParseCellAlign(Default : TIpHtmlAlign): TIpHtmlAlign;
var
S : string;
begin
Result := haCenter;
S := UpperCase(FindAttribute('ALIGN'));
if (S = '') then
Result := Default
else
if (S = 'CENTER') or (S = 'MIDDLE') then
else
if (S = 'LEFT') then
Result := haLeft
else
if S = 'RIGHT' then
Result := haRight
else
if S = 'JUSTIFY' then
Result := haJustify
else
if S = 'CHAR' then
Result := haChar
else
if FlagErrors then
ReportError(SHtmlInvAlign);
end;
function TIpHtml.ParseFrameScrollingProp: TIpHtmlFrameScrolling;
var
S : string;
begin
Result := hfsAuto;
S := UpperCase(FindAttribute('SCROLLING'));
if (S = '') or (S = 'AUTO') then
else
if S = 'YES' then
Result := hfsYes
else
if S = 'NO' then
Result := hfsNo
else
if FlagErrors then
ReportError(SHtmlInvScroll);
end;
function TIpHtml.ParseVAlignment3: TIpHtmlVAlign3;
var
S : string;
begin
Result := hva3Middle;
S := UpperCase(FindAttribute('VALIGN'));
if (S = '') then
Result := hva3Default
else
if (S = 'MIDDLE') or (S = 'CENTER') then
else
if (S = 'TOP') then
Result := hva3Top
else
if S = 'BOTTOM' then
Result := hva3Bottom
else
if S = 'BASELINE' then
Result := hva3Baseline
else
if FlagErrors then
ReportError(SHtmlInvAlign);
end;
procedure TIpHtml.SetDefaultProps;
begin
if FDefaultTypeFace='' then begin
{$IFDEF MSWindows}
Defaultprops.FontName := 'Times New Roman';
{$ELSE}
Defaultprops.FontName := Graphics.DefFontData.Name
{$ENDIF}
end else
Defaultprops.FontName := FDefaultTypeface;
Defaultprops.FontSize := 12;
DefaultProps.BaseFontSize := 3;
Defaultprops.FontBaseline := 0;
DefaultProps.VAlignment := hva3Baseline;
Defaultprops.FontStyle := [];
Defaultprops.Alignment := haLeft;
DefaultProps.FontColor := TextColor;
DefaultProps.LinkColor := LinkColor;
DefaultProps.VLinkColor := VLinkColor;
DefaultProps.ALinkColor := ALinkColor;
DefaultProps.BgColor := BgColor; //JMN
DefaultProps.Preformatted := False;
DefaultProps.NoBreak := False;
if Body <> nil then begin
if Body.Text <> -1 then
DefaultProps.FontColor := Body.Text;
if Body.Link <> -1 then
DefaultProps.LinkColor := Body.Link;
if Body.VLink <> -1 then
DefaultProps.VLinkColor := Body.VLink;
if Body.ALink <> -1 then
DefaultProps.ALinkColor := Body.ALink;
if Body.BgColor <> -1 then
DefaultProps.BgColor := Body.BgColor;
end;
end;
function TIpHtml.PagePtToScreen(const Pt : TPoint): TPoint;
{-convert coordinates of point passed in to screen coordinates}
begin
Result := Pt;
with PageViewRect do begin
Dec(Result.x, Left);
Dec(Result.y, Top);
end;
with ClientRect do begin
Inc(Result.x, Left);
Inc(Result.y, Top);
end;
end;
function TIpHtml.PageRectToScreen(const Rect: TRect;
var ScreenRect: TRect): Boolean;
{-convert coordinates of rect passed in to screen coordinates and
return false if entire rect is clipped}
var
Tmp : TRect;
begin
if (Rect.Left = 0) and (Rect.Right = 0) and
(Rect.Top = 0) and (Rect.Bottom = 0) then begin
Result := False;
Exit;
end;
if not IntersectRect(Tmp, Rect, PageViewRect) then begin
Result := False;
Exit;
end;
ScreenRect := Rect;
with PageViewRect do
OffsetRect(ScreenRect, -Left, -Top);
with ClientRect do
OffsetRect(ScreenRect, Left, Top);
if not IntersectRect(Tmp, ScreenRect, ClientRect) then begin
Result := False;
Exit;
end;
Result := True;
end;
{$IFDEF IP_LAZARUS}
function TIpHtml.GetSelectionBlocks(out StartSelIndex,EndSelIndex: Integer): boolean;
var
R : TRect;
CurBlock: TIpHtmlNodeBlock;
begin
Result := false;
if not AllSelected
and ((FStartSel.x < 0) or (FEndSel.x < 0)) then Exit;
if not AllSelected then begin
CurBlock := nil;
// search blocks that intersect the selection
// 1.- find first block that intersect upleft point of sel. (start from 0)
StartSelIndex := 0;
while StartSelIndex < RectList.Count do begin
CurBlock := PIpHtmlRectListEntry(RectList[StartSelIndex]).Block;
{if AllSelected and (CurBlock <> nil) then
break;}
if PtInRect(CurBlock.PageRect, FStartSel) then begin
R := PIpHtmlRectListEntry(RectList[StartSelIndex]).Rect;
if R.Bottom = 0 then
else
if (R.Top > FStartSel.y) and (R.Bottom < FEndSel.y) then
// block within selection (vertically)
break
else
if PtInRect(R, FStartSel) or PtInRect(R, FEndSel) then
// selection start or ends in this block
break
else
if (R.Bottom < FStartSel.y) then
else
if (R.Top > FEndSel.Y) then
else
if (R.Left >= FStartSel.x) and (R.Right <= FEndSel.x) then
break;
end;
Inc(StartSelIndex);
end;
if StartSelIndex >= RectList.Count then Exit;
// 2.- find first block thta intersect downright point of sel. (start from count-1)
EndSelIndex := Pred(RectList.Count);
while EndSelIndex >= StartSelIndex do begin
if PIpHtmlRectListEntry(RectList[EndSelIndex]).Block = CurBlock then begin
{if AllSelected then
break;}
R := PIpHtmlRectListEntry(RectList[EndSelIndex]).Rect;
if R.Bottom = 0 then
else
if (R.Top > FStartSel.y) and (R.Bottom < FEndSel.y) then
break
else
if PtInRect(R, FStartSel) or PtInRect(R, FEndSel) then
break
else
if (R.Bottom < FStartSel.y) then
else
if (R.Top > FEndSel.Y) then
else
if (R.Left >= FStartSel.x) and (R.Right <= FEndSel.x) then
break;
end;
Dec(EndSelIndex);
end;
end else begin
StartSelIndex := 0;
EndSelIndex := RectList.Count - 1;
end;
Result := True;
end;
{$ENDIF}
procedure TIpHtml.PaintSelection;
var
StartSelIndex, EndSelIndex,
i : Integer;
R : TRect;
CurBlock: TIpHtmlNodeBlock;
begin
if not AllSelected
and ((FStartSel.x < 0) or (FEndSel.x < 0)) then Exit;
if not AllSelected then begin
CurBlock := nil;
StartSelIndex := 0;
while StartSelIndex < RectList.Count do begin
CurBlock := PIpHtmlRectListEntry(RectList[StartSelIndex]).Block;
{if AllSelected and (CurBlock <> nil) then
break;}
if PtInRect(CurBlock.PageRect, FStartSel) then begin
R := PIpHtmlRectListEntry(RectList[StartSelIndex]).Rect;
if R.Bottom = 0 then
else
if (R.Top > FStartSel.y) and (R.Bottom < FEndSel.y) then
break
else
if PtInRect(R, FStartSel) or PtInRect(R, FEndSel) then
break
else
if (R.Bottom < FStartSel.y) then
else
if (R.Top > FEndSel.Y) then
else
if (R.Left >= FStartSel.x) and (R.Right <= FEndSel.x) then
break;
end;
Inc(StartSelIndex);
end;
if StartSelIndex >= RectList.Count then Exit;
EndSelIndex := Pred(RectList.Count);
while EndSelIndex >= StartSelIndex do begin
if PIpHtmlRectListEntry(RectList[EndSelIndex]).Block = CurBlock then begin
{if AllSelected then
break;}
R := PIpHtmlRectListEntry(RectList[EndSelIndex]).Rect;
if R.Bottom = 0 then
else
if (R.Top > FStartSel.y) and (R.Bottom < FEndSel.y) then
break
else
if PtInRect(R, FStartSel) or PtInRect(R, FEndSel) then
break
else
if (R.Bottom < FStartSel.y) then
else
if (R.Top > FEndSel.Y) then
else
if (R.Left >= FStartSel.x) and (R.Right <= FEndSel.x) then
break;
end;
Dec(EndSelIndex);
end;
end else begin
StartSelIndex := 0;
EndSelIndex := RectList.Count - 1;
end;
for i := StartSelIndex to EndSelIndex do begin
R := PIpHtmlRectListEntry(RectList[i]).Rect;
if PageRectToScreen(R, R) then begin
{$IFDEF IP_LAZARUS}
DebugLn('TIpHtml.PaintSelection PatBlt not implemented');
{$ELSE}
PatBlt(PaintBuffer.Handle, R.Left, R.Top,
R.Right - R.Left, R.Bottom - R.Top, DSTINVERT);
{$ENDIF}
end;
end;
end;
procedure TIpHtml.RequestImageNodes(Node : TIpHtmlNode);
var
i : Integer;
begin
if Node is TIpHtmlNodeIMG then begin
if TIpHtmlNodeIMG(Node).FPicture = nil then
TIpHtmlNodeIMG(Node).LoadImage;
end;
if Node is TIpHtmlNodeMulti then
for i := 0 to Pred(TIpHtmlNodeMulti(Node).ChildCount) do begin
RequestImageNodes(TIpHtmlNodeMulti(Node).ChildNode[i]);
end;
end;
{$IFDEF IP_LAZARUS_DBG}
var
CCC: Integer;
procedure TIpHtml.DebugChild(Node: TIpHtmlNode; const UserData: Pointer);
var
i: Integer;
begin
if Node=UserData then
Write('Parent: ');
for i:=0 to CCC do Write(' ');
Write('Node: ', Node.ClassName);
if Node is TIpHtmlNodeText then
Write(' ', TIpHtmlNodeText(NodE).ANSIText);
WriteLn;
if Node=UserData then
Exit;
Inc(CCC);
Node.EnumChildren(DebugChild, Node);
Dec(CCC);
end;
procedure TIpHtml.DebugAll;
var
i: Integer;
item: PIpHtmlRectListEntry;
Node: TIpHtmlNode;
begin
CCC := 0;
Fhtml.EnumChildren(DebugChild, FHtml);
{
for i:=0 to RectList.Count-1 do begin
WriteLn('RectList[',i,']:');
Item := PIpHtmlRectListEntry(Rectlist[i]);
if Item<>nil then begin
WriteLn(' Node=', dbgs(Item.Node));
WriteLn(' Owner=', dbgs(Item.Node^.Owner));
WriteLn(' Text=', Item.Node^.AnsiWord);
Node := Item.Node^.Owner;
if Node<>nil then begin
WriteLn(' ClassName:', Node.ClassName);
if Node is TIpHtmlNodeText then
WriteLn(' Text=', TIpHtmlNodeText(Node).ANSIText);
end;
WriteLn(' Block=', dbgs(Item.Block));
WriteLn(' Rect=', dbgs(Item.Rect));
end;
end;
}
end;
{$ENDIF}
procedure TIpHtml.Render(TargetCanvas: TCanvas; TargetPageRect : TRect;
UsePaintBuffer: Boolean; const TopLeft: TPoint); {!!.10}
var
i : Integer;
begin
ClientRect.TopLeft := TopLeft; {Point(0, 0);} {!!.10}
ClientRect.Right := TargetPageRect.Right - TargetPageRect.Left;
ClientRect.Bottom := TargetPageRect.Bottom - TargetPageRect.Top;
if not DoneLoading then begin
TargetCanvas.FillRect(ClientRect);
Exit;
end;
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
for i := 0 to Pred(GifImages.Count) do
if TIpHtmlNodeIMG(GifImages[i]).FPicture <> nil then
with TGifImage(TIpHtmlNodeIMG(GifImages[i]).FPicture.Graphic) do
if Painters <> nil then
PaintStop;
{$ELSE}
for i := 0 to Pred(AnimationFrames.Count) do
if TIpHtmlNodeIMG(AnimationFrames[i]).FPicture <> nil then
with TIpAnimatedGraphic(TIpHtmlNodeIMG(AnimationFrames[i]).FPicture.Graphic) do
AggressiveDrawing := False;
{$ENDIF}
{$ELSE}
for i := 0 to Pred(GifImages.Count) do
if TIpHtmlNodeIMG(GifImages[i]).FPicture <> nil then
with TGifImage(TIpHtmlNodeIMG(GifImages[i]).FPicture.Graphic) do
if Painters <> nil then
PaintStop;
{$ENDIF}
for i := 0 to Pred(ControlList.Count) do
TIpHtmlNode(ControlList[i]).UnmarkControl;
SetDefaultProps;
PageViewRect := TargetPageRect;
if UsePaintBuffer then begin
if (PaintBuffer = nil)
or (PaintBufferBitmap.Width <> Clientrect.Right)
or (PaintBufferBitmap.Height <> ClientRect.Bottom) then begin
PaintBufferBitmap.Free;
PaintBufferBitmap := TBitmap.Create;
PaintBufferBitmap.Width := ClientRect.Right;
PaintBufferBitmap.Height := ClientRect.Bottom;
PaintBuffer := PaintBufferBitmap.Canvas;
end;
FTarget := PaintBuffer;
end else begin
PaintBuffer := TargetCanvas;
FTarget := TargetCanvas;
end;
ClearRectList;
if FHtml <> nil then
FHtml.Render(DefaultProps);
for i := 0 to Pred(ControlList.Count) do
TIpHtmlNode(ControlList[i]).HideUnmarkedControl;
{$IFNDEF IP_LAZARUS}
PaintSelection;
{$ENDIF}
if UsePaintBuffer then
TargetCanvas.CopyRect(ClientRect, PaintBuffer, ClientRect)
else
if PaintBufferBitmap <> nil then
PaintBuffer := PaintBufferBitmap.Canvas
else
PaintBuffer := nil;
StartGifPaint(TargetCanvas);
{Request all non-visible images}
RequestImageNodes(HtmlNode);
end;
procedure TIpHtml.ResetElementMetrics(P: Pointer);
begin
with PIpHtmlElement(P)^ do begin
Size.cx := 0;
Size.cy := 0;
WordRect2 := Rect(0, 0, 0, 0);
SizeProp := nil;
end;
end;
procedure TIpHtml.ResetWordLists;
begin
ElementPool.EnumerateItems(ResetElementMetrics);
end;
procedure TIpHtml.ResetBlocks(Node: TIpHtmlNode);
var
i : Integer;
begin
if Node = nil then Exit;
if Node is TIpHtmlNodeBlock then
with TIpHtmlNodeBlock(Node) do begin
InvalidateSize;
end
else
if Node is TIpHtmlNodeTable then
with TIpHtmlNodeTable(Node) do begin
FMin := -1;
FMax := -1;
end;
if Node is TIpHtmlNodeMulti then
for i := 0 to Pred(TIpHtmlNodeMulti(Node).ChildCount) do
ResetBlocks(TIpHtmlNodeMulti(Node).ChildNode[i]);
end;
{!!.02}
procedure TIpHtml.ResetImages(Node: TIpHtmlNode);
var
i : Integer;
begin
if Node = nil then Exit;
if Node is TIpHtmlNodeIMG then
with TIpHtmlNodeIMG(Node) do begin
{UnloadImage;} {!!.10}
InvalidateSize;
end
else
if Node is TIpHtmlNodeMulti then
for i := 0 to Pred(TIpHtmlNodeMulti(Node).ChildCount) do
ResetImages(TIpHtmlNodeMulti(Node).ChildNode[i]);
end;
procedure TIpHtml.ResetCanvasData;
begin
ResetCache;
ResetWordLists;
ResetBlocks(FHtml);
ResetImages(FHtml); {!!.02}
end;
function TIpHtml.GetPageRect(TargetCanvas: TCanvas; Width,
Height : Integer): TRect;
var
DefPageRect : TRect;
Min, Max, W, H : Integer;
begin
if not DoneLoading then begin
{$IFDEF IP_LAZARUS}
// always set Result
SetRectEmpty(Result);
{$ENDIF}
Exit;
end;
DoneLoading := False;
SetRectEmpty(FPageRect);
if FHtml <> nil then begin
if (TargetCanvas <> RenderCanvas)
or (PageHeight <> Height) then
ResetCanvasData;
PageHeight := Height;
SetDefaultProps;
{PanelWidth := Width;} {!!.12}
FTarget := TargetCanvas;
FHtml.CalcMinMaxWidth(DefaultProps, Min, Max);
W := MaxI2(Min + 2 * MarginWidth, Width);
H := FHtml.GetHeight(DefaultProps, W - 2 * MarginWidth) + 2 * MarginHeight;
DefPageRect := Rect(
MarginWidth,
MarginHeight,
W - MarginWidth,
H - MarginHeight);
ClearAreaLists;
ClearAreaList;
FHtml.Layout(DefaultProps, DefPageRect);
FPageRect := DefPageRect;
FPagerect.Bottom := FPageRect.Bottom + MarginHeight;
FPageRect.Right := FPageRect.Right + MarginWidth;
RenderCanvas := TargetCanvas;
end;
Result := FPageRect;
DoneLoading := True;
end;
procedure TIpHtml.InvalidateSize;
begin
if assigned(FOnInvalidateSize) then
FOnInvalidateSize(Self);
end;
procedure TIpHtml.ClearAreaList;
var
i : Integer;
begin
for i := 0 to Pred(AreaList.Count) do
TIpHtmlNodeArea(AreaList[i]).Reset;
AreaList.Clear;
end;
function RectFromString(const S: string): TRect;
var
i, j, x, err : Integer;
procedure Next;
begin
j := i;
while (j <= length(S)) and (S[j] <> ',') do
Inc(j);
val(copy(S, i, j - i), x, err);
end;
begin
SetRectEmpty(Result);
i := 1;
Next;
if err <> 0 then Exit;
Result.Left := x;
i := j + 1;
Next;
if err <> 0 then Exit;
Result.Top := x;
i := j + 1;
Next;
if err <> 0 then Exit;
Result.Right := x;
i := j + 1;
Next;
if err <> 0 then Exit;
Result.Bottom := x;
end;
function CircularRegion(const Coords: string; const Rect: TRect): HRgn;
var
i, j, err, cx, cy, R : Integer;
begin
Result := 0;
i := 1;
j := i;
while (j <= length(Coords)) and (Coords[j] <> ',') do
Inc(j);
val(copy(Coords, i, j - i), cx, err);
if err <> 0 then Exit;
i := j + 1;
j := i;
while (j <= length(Coords)) and (Coords[j] <> ',') do
Inc(j);
val(copy(Coords, i, j - i), cy, err);
if err <> 0 then Exit;
i := j + 1;
j := i;
while (j <= length(Coords)) and (Coords[j] <> ',') and (Coords[j] <> '%') do
Inc(j);
val(copy(Coords, i, j - i), R, err);
if err <> 0 then Exit;
if (j <= length(Coords)) and (Coords[j] = '%') then
R := round(R * MinI2(Rect.Right - Rect.Left, Rect.Bottom - Rect.Top) / 100);
if R < 1 then Exit;
Result := CreateEllipticRgn(
Rect.Left + cx - R,
Rect.Top + cy - R,
Rect.Left + cx + R,
Rect.Top + cy + R);
end;
function PolygonRegion(const Coords: string; const Rect: TRect): HRgn;
const
MAXPOINTS = 4096;
var
Points : array [0.. Pred(MAXPOINTS)] of TPoint;
Count, i, j, x, y, err : Integer;
begin
Result := 0;
Count := 0;
i := 1;
while i < length(Coords) do begin
j := i;
while (j <= length(Coords)) and (Coords[j] <> ',') do
Inc(j);
val(copy(Coords, i, j - i), x, err);
if err <> 0 then Exit;
i := j + 1;
j := i;
while (j <= length(Coords)) and (Coords[j] <> ',') do
Inc(j);
val(copy(Coords, i, j - i), y, err);
if err <> 0 then Exit;
Points[Count].x := x + Rect.Left;
Points[Count].y := y + Rect.Top;
Inc(Count);
i := j + 1;
end;
if Count < 3 then Exit;
if (Points[0].x <> Points[Count - 1].x)
or (Points[0].y <> Points[Count - 1].y) then begin
Points[Count] := Points[0];
Inc(Count);
end;
Result := CreatePolygonRgn(
{$IFDEF IP_LAZARUS}
PPoint(@Points[0]),
{$ELSE}
(@Points[0])^,
{$ENDIF}
Count,
ALTERNATE); {fill mode is irrelevant here}
end;
procedure TIpHtml.BuildAreaList;
var
i, j, k : Integer;
R, R2 : TRect;
begin
ClearAreaList;
for i := 0 to Pred(MapImgList.Count) do
with TIpHtmlNodeIMG(MapImgList[i]) do begin
R := GrossDrawRect;
for j := 0 to Pred(MapList.Count) do
with TIpHtmlNodeMap(MapList[j]) do begin
for k := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[k]) is TIpHtmlNodeArea then begin
with TIpHtmlNodeArea(FChildren[k]) do begin
if HRef <> '' then begin
case Shape of
hmsDefault :
FRect := R;
hmsRect :
begin
R2 := RectFromString(Coords);
OffsetRect(R2, R.Left, R.Top);
FRect := R2;
end;
hmsCircle :
FRgn := CircularRegion(Coords, R);
hmsPoly :
FRgn := PolygonRegion(Coords, R);
end;
end;
end;
AreaList.Add(TIpHtmlNodeArea(FChildren[k]));
end;
end;
end;
end;
procedure TIpHtml.MouseMove(Pt: TPoint);
var
i : Integer;
begin
FHotPoint := Point(-1, -1);
if (MapList.Count > 0) and (AreaList.Count = 0) then
BuildAreaList;
for i := 0 to Pred(AnchorList.Count) do
if TIpHtmlNodeA(AnchorList[i]).PtInRects(Pt) then begin
if FHotNode <> TIpHtmlNodeA(AnchorList[i]) then begin
if FHotNode <> nil then
if FHotNode is TIpHtmlNodeA then
TIpHtmlNodeA(FHotNode).Hot := False;
FHotNode := TIpHtmlNode(AnchorList[i]);
if FHotNode is TIpHtmlNodeA then
TIpHtmlNodeA(FHotNode).Hot := True;
end;
if (FHotNode <> nil) then
if FHotNode is TIpHtmlNodeA then
FHotPoint := TIpHtmlNodeA(FHotNode).RelMapPoint(Pt);
Exit;
end;
for i := 0 to Pred(AreaList.Count) do
if TIpHtmlNodeAREA(AreaList[i]).PtInRects(Pt) then begin
if FHotNode <> AreaList[i] then begin
if FHotNode <> nil then
if FHotNode is TIpHtmlNodeA then
TIpHtmlNodeA(FHotNode).Hot := False;
FHotNode := TIpHtmlNode(AreaList[i]);
end;
Exit;
end;
if FHotNode <> nil then
if FHotNode is TIpHtmlNodeA then
TIpHtmlNodeA(FHotNode).Hot := False;
FHotNode := nil;
FCurElement := nil;
for i := 0 to Pred(RectList.Count) do
if PtInRect(PIpHtmlRectListEntry(RectList[i]).Rect, Pt) then begin
FCurElement := PIpHtmlRectListEntry(RectList[i]).Node;
break;
end;
end;
function TIpHtml.BuildPath(const Ext: string): string;
begin
Result := BuildURL(CurURL, Ext);
end;
function TIpHtml.NewElement(EType : TElementType; Own: TIpHtmlNode) : PIpHtmlElement;
begin
Result := ElementPool.NewItm;
Result.ElementType := EType;
Result.Owner := Own;
{$IFDEF IP_LAZARUS}
Result.IsSelected := False;
{$ENDIF}
end;
function TIpHtml.BuildStandardEntry(EType: TElementType): PIpHtmlElement;
begin
Result := NewElement(EType, nil);
Result.Props := nil;
SetWordRect(Result, Rect(0, 0, 0, 0));
end;
procedure TIpHtml.MakeVisible(const R: TRect);
begin
if assigned(FOnScroll) then
FOnScroll(Self, R);
end;
function TIpHtml.FindElement(const Name: string): TIpHtmlNode;
var
i : Integer;
begin
NameList.Sorted := True;
i := NameList.IndexOf(Name);
if i <> -1 then
Result := TIpHtmlNode(NameList.Objects[i])
else
Result := nil;
end;
type
TIpHtmlGifQueueEntry = class
protected
FGraphic : TGraphic;
FR : TRect;
public
constructor Create(AGraphic: TGraphic; ARect: TRect);
property Graphic : TGraphic read FGraphic;
property R : TRect read FR;
end;
procedure TIpHtml.ClearAreaLists;
var
i : Integer;
begin
for i := 0 to Pred(AnchorList.Count) do
TIpHtmlNodeA(AnchorList[i]).ClearAreaList;
end;
procedure TIpHtml.Home;
begin
MakeVisible(Rect(0, 0, 1, 1));
end;
procedure TIpHtml.Get(const URL: string);
begin
if assigned(FOnGet) then
FOnGet(Self, URL);
end;
procedure TIpHtml.Post(const URL: string; FormData: TIpFormDataEntity); {!!.12}
begin
if assigned(FOnPost) then
FOnPost(Self, URL, FormData); {!!.12}
end;
procedure TIpHtml.AddRect(const R : TRect; Node : PIpHtmlElement;
Block: TIpHtmlNodeBlock);
var
NewEntry : PIpHtmlRectListEntry;
begin
New(NewEntry);
NewEntry.Rect := R;
NewEntry.Node := Node;
NewEntry.Block := Block;
RectList.Add(NewEntry);
end;
procedure TIpHtml.ClearRectList;
var
i : Integer;
p: PIpHtmlRectListEntry;
begin
for i := Pred(RectList.Count) downto 0 do begin
p:=PIpHtmlRectListEntry(RectList[i]);
Freemem(p);
end;
RectList.Clear;
end;
{$IFDEF IP_LAZARUS}
procedure TIpHtml.DeselectAllItems(Item: Pointer);
begin
PIpHtmlElement(item)^.IsSelected := False;
end;
{$ENDIF}
procedure TIpHtml.SetSelection(StartPoint, EndPoint: TPoint);
{$IFDEF IP_LAZARUS}
var
StartSelIndex,EndSelindex: Integer;
i: Integer;
r: TRect;
Selected: boolean;
DeselectAll: boolean;
item: PIpHtmlRectListEntry;
{$ENDIF}
begin
AllSelected := False;
if EndPoint.y > StartPoint.y then begin
FStartSel := StartPoint;
FEndSel := EndPoint;
end
else
if EndPoint.y = StartPoint.y then
if EndPoint.x > StartPoint.x then begin
FStartSel := StartPoint;
FEndSel := EndPoint;
end else begin
FStartSel := EndPoint;
FEndSel := StartPoint;
end
else begin
FStartSel := EndPoint;
FEndSel := StartPoint;
end;
{$IFDEF IP_LAZARUS}
if Body <> nil then begin
// Invalidate only those blocks that need it
DeselectAll := (EndPoint.x<0)and(EndPoint.y<0);
GetSelectionBlocks(StartSelIndex,EndSelIndex);
for i:= 0 to RectList.Count-1 do begin
item := PIpHtmlRectListEntry(RectList[i]);
// (de)select only text elements
if Item.Node.ElementType<>etWord then
Continue;
if DeselectAll then
Selected := false
else
Selected := (StartSelIndex<=i)and(i<=EndSelIndex);
// Invalidate only changed elements
if Item.Node.IsSelected<>Selected then begin
Item.Node.IsSelected := Selected;
if Body.PageRectToScreen(Item^.Rect, R) then
InvalidateRect(R);
end;
end;
// also deselect remaining elements
if DeselectAll then
ElementPool.EnumerateItems(DeselectAllItems);
end;
{$ELSE}
if Body <> nil then
InvalidateRect(Body.PageRect);
{$ENDIF}
end;
procedure TIpHtml.SelectAll;
begin
AllSelected := True;
end;
{!!.10 new}
procedure TIpHtml.DeselectAll;
begin
AllSelected := False;
FStartSel.x := -1;
FEndSel.x := -1;
end;
procedure TIpHtml.CopyToClipboard;
var
S : string;
begin
if HaveSelection then begin
S := '';
if FHtml <> nil then
FHtml.AppendSelection(S);
if S <> '' then begin
Clipboard.Open;
try
Clipboard.Clear;
Clipboard.AsText := S;
finally
Clipboard.Close;
end;
end;
end;
end;
function TIpHtml.HaveSelection: Boolean;
begin
Result := AllSelected or ((FEndSel.x > 0) or (FEndSel.y > 0));
end;
procedure TIpHtml.CreateIFrame(Parent: TWinControl;
Frame: TIpHtmlNodeIFRAME;
var Control: TWinControl);
begin
if assigned(FOnIFrameCreate) then
FOnIFrameCreate(Self, Parent, Frame, Control);
end;
function TIpHtml.CheckKnownURL(URL: string): boolean;
var
P : Integer;
begin
if assigned(FOnURLCheck) then begin
P := CharPos('#', URL);
if P <> 0 then
SetLength(URL, P - 1);
{$IFDEF IP_LAZARUS}
Result:=true;
{$ENDIF}
FOnURLCheck(Self, URL, Result);
end;
end;
procedure TIpHtml.ReportReference(URL: string);
var
P : Integer;
begin
if assigned(FOnReportURL) then begin
P := CharPos('#', URL);
if P <> 0 then
if P = 1 then
Exit
else
SetLength(URL, P - 1);
FOnReportURL(Self, URL);
end;
end;
procedure TIpHtml.ControlClick(Sender: TIpHtmlNodeControl);
begin
if assigned(FControlClick) then
FControlClick(Self, Sender);
end;
procedure TIpHtml.ControlCreate(Sender: TIpHtmlNodeControl);
begin
if assigned(FControlCreate) then
FControlCreate(Self, Sender);
end;
{ TIpHtmlGifQueueEntry }
constructor TIpHtmlGifQueueEntry.Create(AGraphic: TGraphic; ARect: TRect);
begin
{$IFDEF IP_LAZARUS}
DebugLn('TIpHtmlGifQueueEntry.Create ToDo NOT IMPLEMENTED YET');
{$ELSE}
FGraphic := AGraphic;
{$ENDIF}
FR := ARect;
end;
procedure TIpHtml.AddGifQueue(Graphic: TGraphic; const R: TRect);
begin
GifQueue.Add(TIpHtmlGifQueueEntry.Create(Graphic, R));
end;
procedure TIpHtml.StartGifPaint(Target: TCanvas);
var
i : Integer;
begin
for i := 0 to Pred(GifQueue.Count) do
with TIpHtmlGifQueueEntry(GifQueue[i]) do
Target.StretchDraw(R, Graphic);
ClearGifQueue;
end;
procedure TIpHtml.ClearGifQueue;
var
i : Integer;
begin
if Assigned(GifQueue) then {!!.12}
for i := Pred(GifQueue.Count) downto 0 do begin
TIpHtmlGifQueueEntry(GifQueue[i]).Free;
GifQueue.Delete(i);
end;
end;
{ TIpHtmlNodeText }
procedure TIpHtmlNodeText.SetProps(const RenderProps: TIpHtmlProps);
begin
PropsR := RenderProps;
end;
procedure TIpHtmlNodeText.Enqueue;
begin
BuildWordList;
end;
procedure TIpHtmlNodeText.BuildWordList;
var
NewEntry : PIpHtmlElement;
l : Integer;
B, N, N2 : PAnsiChar;
First : Boolean;
Ch : AnsiChar;
ImplicitLF: Boolean; {!!.10}
begin
First := True;
ImplicitLF := False; {!!.10}
if PropsR.Preformatted then begin
l := length(EscapedText);
if l > 0 then begin
Getmem(B, l + 1);
try
TrimFormattingPre(EscapedText, B);
N := B;
while N^ <> #0 do begin
case N^ of
CR : {!!.10}
ImplicitLF := True; {!!.10}
LF :
begin
EnqueueElement(Owner.HardLF);
Inc(N);
ImplicitLF := False; {!!.10}
end;
else
begin
if ImplicitLF then begin {!!.10}
EnqueueElement(Owner.HardLF); {!!.10}
Inc(N); {!!.10}
ImplicitLF := False; {!!.10}
end; {!!.10}
N2 := StrScan(N, CR); {!!.10}
if N2 <> nil then begin {!!.10}
N2^ := #0; {!!.10}
if First then {!!.10}
Owner.AddWord(N, PropsR, Self) {!!.10}
else {!!.10}
Owner.AddWord(N, nil, Self); {!!.10}
N2^ := CR; {!!.10}
First := False; {!!.10}
N := N2; {!!.10}
end else begin
N2 := StrScan(N, LF);
if N2 <> nil then begin
N2^ := #0;
if First then
Owner.AddWord(N, PropsR, Self)
else
Owner.AddWord(N, nil, Self);
N2^ := LF;
First := False;
N := N2;
end else begin
if First then
Owner.AddWord(N, PropsR, Self)
else
Owner.AddWord(N, nil, Self);
First := False;
N^ := #0;
end;
end;
end;
end;
end;
finally
FreeMem(B);
end;
end;
end else begin
l := length(EscapedText);
if l > 0 then begin
Getmem(B, l + 1);
try
TrimFormattingNormal(EscapedText, B);
N := B;
while N^ <> #0 do begin
case N^ of
LF :
begin
EnqueueElement(Owner.HardLF);
Inc(N);
end;
' ' :
begin
if not ElementQueueIsEmpty then begin {!!.10}
NewEntry := Owner.NewElement(etWord, Self);
NewEntry.AnsiWord := ' ';
NewEntry.IsBlank := 1;
if First then
NewEntry.Props := PropsR
else
NewEntry.Props := nil;
EnqueueElement(NewEntry);
First := False;
end; {!!.10}
Inc(N);
end;
else
begin
N2 := N;
while not (N2^ in [#0, ' ', LF]) do
Inc(N2);
if N2^ <> #0 then begin
Ch := N2^;
N2^ := #0;
if First then
Owner.AddWord(N, PropsR, Self)
else
Owner.AddWord(N, nil, Self);
N2^ := Ch;
First := False;
N := N2;
end else begin
if First then
Owner.AddWord(N, PropsR, Self)
else
Owner.AddWord(N, nil, Self);
First := False;
N^ := #0;
end;
end;
end;
end;
finally
FreeMem(B);
end;
end;
end;
end;
function TIpHtmlNodeText.GetAnsiText: string;
begin
Result := EscapeToAnsi(FEscapedText);
end;
procedure TIpHtmlNodeText.EnqueueElement(const Entry: PIpHtmlElement);
begin
FParentNode.EnqueueElement(Entry);
end;
function FindInnerBlock(Node : TIpHTMLNode): TIpHtmlNodeBlock;
begin
while not (Node is TIpHtmlNodeBlock) do
Node := Node.FParentNode;
Result := TIpHtmlNodeBlock(Node);
end;
procedure TIpHtmlNodeText.SetAnsiText(const Value: string);
begin
EscapedText := AnsiToEscape(Value);
end;
procedure TIpHtmlNodeText.SetEscapedText(const Value: string);
var
Block: TIpHtmlNodeBlock;
begin
FEscapedText := Value;
Block := FindInnerBlock(Self);
{we need to clear the queue so that it will be built again}
Block.ClearWordList;
{then, we need to Invalidate the block so that
the rendering logic recalculates everything}
Block.InvalidateSize;
end;
procedure TIpHtmlNodeText.ReportDrawRects(M: TRectMethod);
begin
ReportCurDrawRects(Self, M);
end;
{!!.10 new}
function TIpHtmlNodeText.ElementQueueIsEmpty: Boolean;
begin
Result := FParentNode.ElementQueueIsEmpty;
end;
{ TIpHtmlNodeFONT }
procedure TIpHtmlNodeFONT.ApplyProps(const RenderProps: TIpHtmlProps);
var
TmpSize : Integer;
begin
Props.Assign(RenderProps);
if Face <> '' then
Props.FontName := FirstString(Face);
case Size.SizeType of
hrsAbsolute :
case Size.Value of
1 : Props.FontSize := 8;
2 : Props.FontSize := 10;
3 : Props.FontSize := 12;
4 : Props.FontSize := 14;
5 : Props.FontSize := 18;
6 : Props.FontSize := 24;
7 : Props.FontSize := 36;
end;
hrsRelative :
begin
TmpSize := Props.BaseFontSize + Size.Value;
if TmpSize <= 1 then {!!.10}
Props.FontSize := 8 {!!.10}
else {!!.10}
case TmpSize of
{0,
1 : Props.FontSize := 8;} {!!.10}
2 : Props.FontSize := 10;
3 : Props.FontSize := 12;
4 : Props.FontSize := 14;
5 : Props.FontSize := 18;
6 : Props.FontSize := 24;
else
Props.FontSize := 36;
end;
end;
end;
if Color <> -1 then
Props.FontColor := Color;
end;
{!!.10 new}
constructor TIpHtmlNodeFONT.Create(ParentNode: TIpHtmlNode);
begin
inherited;
FSize := TIpHtmlRelSize.Create;
end;
destructor TIpHtmlNodeFONT.Destroy;
begin
inherited;
FSize.Free;
end;
procedure TIpHtmlNodeFONT.SetColor(const Value: TColor);
begin
if Value <> FColor then begin
FColor := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeFONT.SetFace(const Value: string);
begin
if Value <> FFace then begin
FFace := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeFONT.SizeChanged(Sender: TObject);
begin
InvalidateSize;
end;
{ TIpHtmlNodeFontStyle }
procedure TIpHtmlNodeFontStyle.ApplyProps(
const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
case Style of
hfsTT :
Props.FontName := Owner.FixedTypeface; {!!.10}
hfsI :
Props.FontStyle := Props.FontStyle + [fsItalic];
hfsB :
Props.FontStyle := Props.FontStyle + [fsBold];
hfsU :
Props.FontStyle := Props.FontStyle + [fsUnderline];
hfsSTRIKE,
hfsS :
Props.FontStyle := Props.FontStyle + [fsStrikeout];
hfsBIG :
Props.FontSize := Props.FontSize + 2;
hfsSMALL :
Props.FontSize := Props.FontSize - 2;
hfsSUB :
begin
Props.FontSize := Props.FontSize - 4;
Props.FontBaseline := Props.FontBaseline - 2;
end;
hfsSUP :
begin
Props.FontSize := Props.FontSize - 4;
Props.FontBaseline := Props.FontBaseline + 4;
end;
end;
{$IFDEF IP_LAZARUS}
case Style of
hfsTT : FElementName := 'tt';
hfsI : FElementName := 'i';
hfsB : FElementName := 'b';
hfsU : FElementName := 'u';
hfsSTRIKE: FElementName := 'strike';
hfsS : FElementName := 's';
hfsBIG : FElementName := 'big';
hfsSMALL : FElementName := 'small';
hfsSUB : FElementName := 'sub';
hfsSUP : FElementName := 'sup';
end;
{$ENDIF}
end;
{ TIpHtmlNodeBlock }
constructor TIpHtmlNodeBlock.Create(ParentNode : TIpHtmlNode);
begin
inherited Create(ParentNode);
ElementQueue := TList.Create;
FMin := -1;
FMax := -1;
Props := TIpHtmlProps.Create(Owner);
end;
destructor TIpHtmlNodeBlock.Destroy;
begin
ClearWordList;
ElementQueue.Free;
ElementQueue := nil;
Props.Free;
Props := nil;
inherited;
end;
procedure TIpHtmlNodeBlock.RenderQueue;
var
i : Integer;
CurWord : PIpHtmlElement;
LastProp : TIpHtmlProps;
R : TRect;
P : TPoint;
L0 : Boolean;
{$IFDEF IP_LAZARUS}
OldBrushcolor: TColor;
OldFontColor: TColor;
OldFontStyle: TFontStyles;
OldBrushStyle: TBrushStyle;
{$ENDIF}
begin
L0 := Level0;
LastProp := nil;
for i := 0 to Pred(ElementQueue.Count) do begin
CurWord := PIpHtmlElement(ElementQueue[i]);
if (CurWord.Props <> nil) and (CurWord.Props <> LastProp) then begin
{$IFDEF IP_LAZARUS}
Owner.Target.Font.BeginUpdate; // for speedup
{$ENDIF}
if (LastProp = nil) or not LastProp.AIsEqualTo(CurWord.Props) then
with CurWord.Props do begin
Owner.Target.Font.Name := FontName;
if ScaleFonts then {!!.10}
Owner.Target.Font.Size := round(FontSize * Aspect) {!!.10}
else {!!.10}
Owner.Target.Font.Size := FontSize;
Owner.Target.Font.Style := FontStyle;
end;
if ScaleBitmaps and BWPRinter then {!!.10}
Owner.Target.Font.Color := clBlack {!!.10}
else {!!.10}
if (LastProp = nil) or not LastProp.BIsEqualTo(CurWord.Props) then
Owner.Target.Font.Color := CurWord.Props.FontColor;
{$IFDEF IP_LAZARUS}
Owner.Target.Font.EndUpdate;
{$ENDIF}
LastProp := CurWord.Props;
end;
if IntersectRect(R, CurWord.WordRect2, Owner.PageViewRect) then
case CurWord.ElementType of
etWord :
begin
P := Owner.PagePtToScreen(CurWord.WordRect2.TopLeft);
{$IFDEF IP_LAZARUS}
OldBrushColor := Owner.Target.Brush.Color;
OldBrushStyle := Owner.Target.Brush.Style;
OldFontColor := Owner.Target.Font.Color;
OldFontStyle := Owner.Target.Font.Style;
if CurWord.IsSelected then begin
Owner.Target.Font.color := clHighlightText;
Owner.Target.brush.Style := bsSolid;
Owner.Target.brush.color := clHighLight;
Owner.PageRectToScreen(curWord.WordRect2, R);
Owner.Target.FillRect(R);
end else
{$ENDIF}
Owner.Target.Brush.Style := bsClear;
if CurWord.AnsiWord <> NAnchorChar //JMN
then Owner.Target.TextOut(P.x, P.y, NoBreakToSpace(CurWord.AnsiWord));
{$IFDEF IP_LAZARUS}
Owner.Target.Font.Color := OldFontColor;
Owner.Target.Brush.Color := OldBrushColor;
Owner.Target.Brush.Style := OldBrushStyle;
Owner.Target.Font.Style := OldFontStyle;
{$ENDIF}
Owner.AddRect(CurWord.WordRect2, CurWord, Self);
end;
etObject :
begin
TIpHtmlNodeAlignInline(CurWord.Owner).Draw(Self);
LastProp := nil;
end;
etSoftHyphen :
begin
P := Owner.PagePtToScreen(CurWord.WordRect2.TopLeft);
Owner.Target.Brush.Style := bsClear;
Owner.Target.TextOut(P.x, P.y, '-');
Owner.AddRect(CurWord.WordRect2, CurWord, Self);
end;
end
else
case CurWord.ElementType of
etWord,
etObject,
etSoftHyphen :
if (CurWord.WordRect2.Bottom <> 0)
and (CurWord.WordRect2.Top > Owner.PageViewRect.Bottom)
and L0 then
break;
end;
end;
end;
procedure TIpHtmlNodeBlock.Render(
const RenderProps: TIpHtmlProps);
begin
if not RenderProps.IsEqualTo(Props) then begin
SetProps(RenderProps);
Props.Assign(RenderProps);
end;
if ElementQueue.Count = 0 then
Enqueue;
RenderQueue;
end;
{!!.10 moved here from inside CalcMinMaxQueueWidth}
procedure TIpHtmlNodeBlock.UpdateCurrent(Start: Integer; CurProps : TIpHtmlProps);
{- update other words that use same properties as the
one at Start with their lengths. Cuts down on the number
of time the font properties need to be changed.}
var
i : Integer;
CurElement : PIpHtmlElement; {!!.10}
function GetExt(const S: string): TSize;
begin
Result := Owner.Target.TextExtent(
NoBreakToSpace(S));
end;
begin
for i := ElementQueue.Count - 1 downto Start + 1 do begin
CurElement := PIpHtmlElement(ElementQueue[i]);
{case CurElement.ElementType of
etWord :} {!!.10}
if CurElement.ElementType = etWord then
if CurElement.IsBlank = 0 then begin
if (CurElement.Props = nil)
or CurElement.Props.AIsEqualTo(CurProps) then begin
{if CurElement.IsBlank = 0 then begin}
if (CurElement.SizeProp <> CurProps.PropA) then begin
CurElement.Size :=
GetExt(CurElement.AnsiWord);
{Owner.Target.TextExtent(
NoBreakToSpace(CurElement.AnsiWord));}
if CurElement.AnsiWord = NAnchorChar
then CurElement.Size.cx := 1;// JMN
CurElement.SizeProp := CurProps.PropA;
end;
end;
end;
{end;}
end;
end;
procedure TIpHtmlNodeBlock.CalcMinMaxQueueWidth(
const RenderProps: TIpHtmlProps; var Min, Max: Integer);
var
i,
TextWidth : Integer;
MinW, MaxW : Integer;
CurElement : PIpHtmlElement;
CurObj : TIpHtmlNodeAlignInline;
LIndent, LIndentP : Integer;
LastW,
LastElement : Integer;
NoBr : Boolean;
IndentW : Integer;
CurProps : TIpHtmlProps;
CurFontName : string;
CurFontSize : Integer;
CurFontStyle : TFontStyles;
SizeOfSpace : TSize;
SizeOfHyphen : TSize;
procedure ApplyProps;
var
Changed : Boolean;
TextMetrics : TTextMetric;
begin
with CurElement.Props do begin
if (CurProps = nil) or not AIsEqualTo(CurProps) then begin
Changed := False;
if (CurProps = nil) or (CurFontName <> FontName) or (CurFontName = '') then begin
Owner.Target.Font.Name := FontName;
CurFontName := FontName;
Changed := True;
end;
if (CurProps = nil) or (CurFontSize <> FontSize) or (CurFontSize = 0) then begin
Owner.Target.Font.Size := FontSize;
CurFontSize := FontSize;
Changed := True;
end;
if (CurProps = nil) or (CurFontStyle <> FontStyle) then begin
Owner.Target.Font.Style := FontStyle;
CurFontStyle := FontStyle;
Changed := True;
end;
if PropA.SizeOfSpaceKnown then begin
SizeOfSpace := PropA.KnownSizeOfSpace;
SizeOfHyphen := PropA.KnownSizeOfHyphen;
end else begin
SizeOfSpace := Owner.Target.TextExtent(' ');
{$IFDEF IP_LAZARUS}
if SizeOfSpace.CX=0 then begin
DebugLn('TIpHtmlNodeBlock.CalcMinMaxQueueWidth Font not found "',Owner.Target.Font.Name,'" Size=',dbgs(Owner.Target.Font.Size));
end;
{$ENDIF}
SizeOfHyphen := Owner.Target.TextExtent('-');
PropA.SetKnownSizeOfSpace(SizeOfSpace);
PropA.KnownSizeOfHyphen := SizeOfHyphen;
end;
if Changed then begin
if PropA.tmHeight = 0 then begin
GetTextMetrics(Owner.Target.Handle, TextMetrics);
PropA.tmAscent := TextMetrics.tmAscent;
PropA.tmDescent := TextMetrics.tmDescent;
PropA.tmHeight := TextMetrics.tmHeight;
end;
end;
end;
end;
CurProps := CurElement.Props;
end;
(* !!.10 moved up as global method
procedure UpdateCurrent(Start: Integer);
{- update other words that use same properties as the
one at Start with their lengths. Cuts down on the number
of time the font properties need to be changed.}
var
i : Integer;
CurElement : PIpHtmlElement; {!!.10}
begin
for i := Start + 1 to LastElement do begin
CurElement := PIpHtmlElement(ElementQueue[i]);
{case CurElement.ElementType of
etWord :} {!!.10}
if CurElement.ElementType = etWord then
if CurElement.IsBlank = 0 then begin
if (CurElement.Props = nil)
or CurElement.Props.AIsEqualTo(CurProps) then begin
{if CurElement.IsBlank = 0 then begin}
if (CurElement.SizeProp <> CurProps.PropA) then begin
CurElement.Size :=
Owner.Target.TextExtent(
NoBreakToSpace(CurElement.AnsiWord));
CurElement.SizeProp := CurProps.PropA;
end;
end;
end;
{end;}
end;
end;
*)
begin
Min := 0;
Max := 0;
if ElementQueue.Count = 0 then Exit;
LIndent := 0;
LIndentP := 0;
{trim trailing blanks}
LastElement := ElementQueue.Count - 1;
repeat
if (LastElement >= 0) then begin
CurElement := PIpHtmlElement(ElementQueue[LastElement]);
case CurElement.ElementType of
etWord :
if CurElement.IsBlank <> 0 then
Dec(LastElement)
else
break
else
break;
end;
end else
break;
until false;
CurProps := nil;
CurFontName := '';
CurFontSize := 0;
CurFontStyle := [];
Owner.Target.Font.Style := CurFontStyle;
SizeOfSpace := Owner.Target.TextExtent(' ');
SizeOfHyphen := Owner.Target.TextExtent('-');
i := 0;
NoBr := False;
while i <= LastElement do begin
TextWidth := 0;
IndentW := 0;
LastW := 0;
while (i <= LastElement) do begin
MinW := 0;
CurElement := PIpHtmlElement(ElementQueue[i]);
if CurElement.Props <> nil then
ApplyProps;
case CurElement.ElementType of
etWord :
begin
{determine height and width of word}
if CurElement.IsBlank <> 0 then begin
if NoBr then begin
MaxW := SizeOfSpace.cx * CurElement.IsBlank;
MinW := MaxW + LastW;
end else begin
MinW := SizeOfSpace.cx * CurElement.IsBlank;
MaxW := MinW;
end;
end else begin
if (CurElement.SizeProp = CurProps.PropA) then
MaxW := CurElement.Size.cx
else begin
CurElement.Size :=
Owner.Target.TextExtent(
NoBreakToSpace(CurElement.AnsiWord));
if CurElement.AnsiWord = NAnchorChar
then CurElement.Size.cx := 1; //JMN
MaxW := CurElement.Size.cx;
CurElement.SizeProp := CurProps.PropA;
UpdateCurrent(i, CurProps);
end;
MinW := MaxW + LastW;
end;
LastW := MinW;
end;
etObject :
begin
CurObj := TIpHtmlNodeAlignInline(CurElement.Owner);
CurObj.CalcMinMaxWidth(MinW, MaxW);
LastW := 0;
CurProps := nil;
end;
etSoftLF..etClearBoth :
begin
if TextWidth + IndentW > Max then
Max := TextWidth + IndentW;
TextWidth := 0;
MinW := 0;
MaxW := 0;
Inc(i);
break;
end;
etIndent :
begin
Inc(LIndent);
LIndentP := LIndent * StdIndent;
if LIndentP > IndentW then
IndentW := LIndentP;
MinW := 0;
MaxW := 0;
end;
etOutdent :
begin
if LIndent > 0 then begin
Dec(LIndent);
LIndentP := LIndent * StdIndent;
end;
MinW := 0;
MaxW := 0;
end;
etSoftHyphen :
begin
MaxW := SizeOfHyphen.cx;
MinW := MaxW + LastW;
end;
end;
Inc(MinW, LIndentP);
if MinW > Min then
Min := MinW;
Inc(TextWidth, MaxW);
Inc(i);
end;
Max := MaxI2(Max, TextWidth + IndentW);
end;
end;
procedure TIpHtmlNodeBlock.CalcMinMaxWidth(const RenderProps: TIpHtmlProps;
var Min, Max: Integer);
begin
if RenderProps.IsEqualTo(Props) and (FMin <> -1) and (FMax <> -1) then begin
Min := FMin;
Max := FMax;
Exit;
end;
SetProps(RenderProps);
Props.Assign(RenderProps);
if ElementQueue.Count = 0 then
Enqueue;
CalcMinMaxQueueWidth(Props, Min, Max);
FMin := Min;
FMax := Max;
end;
procedure TIpHtmlNodeBlock.ClearWordList;
begin
if ElementQueue <> nil then
ElementQueue.Clear;
end;
procedure TIpHtmlNodeBlock.EnqueueElement(
const Entry: PIpHtmlElement);
begin
ElementQueue.Add(Entry);
end;
procedure TIpHtmlNodeBlock.Invalidate;
var
R : TRect;
begin
if PageRectToScreen(PageRect, R) then
Owner.InvalidateRect(R);
end;
function TIpHtmlNodeBlock.GetHeight(const RenderProps: TIpHtmlProps;
const Width: Integer): Integer;
begin
if LastW = Width then begin
Result := LastH;
Exit;
end;
Layout(RenderProps,
Rect(0, 0, Width, MaxInt));
Result := PageRect.Bottom;
LastH := Result;
LastW := Width;
end;
procedure TIpHtmlNodeBlock.Layout(const RenderProps: TIpHtmlProps;
const TargetRect: TRect);
begin
if EqualRect(TargetRect, PageRect) then Exit;
if not RenderProps.IsEqualTo(Props) then begin
SetProps(RenderProps);
Props.Assign(RenderProps);
end;
if ElementQueue.Count = 0 then
Enqueue;
if SameDimensions(TargetRect, PageRect) then
RelocateQueue(TargetRect.Left - PageRect.Left, TargetRect.Top - PageRect.Top)
else
LayoutQueue(Props, TargetRect);
end;
procedure TIpHtmlNodeBlock.RelocateQueue(const dx, dy: Integer);
var
i : Integer;
CurElement : PIpHtmlElement;
R : TRect;
begin
OffsetRect(FPageRect, dx, dy);
for i := 0 to Pred(ElementQueue.Count) do begin
CurElement := PIpHtmlElement(ElementQueue[i]);
R := CurElement.WordRect2;
if R.Bottom <> 0 then begin
OffsetRect(R, dx, dy);
SetWordRect(CurElement, R);
end;
end;
end;
procedure TIpHtmlNodeBlock.LayoutQueue(
const RenderProps: TIpHtmlProps; const TargetRect: TRect);
type
TWordInfo = record
BaseX : Integer;
BOff : Integer;
CurAsc : Integer;
Sz : TSize;
VA : TIpHtmlVAlign3;
Hs : Integer;
end;
PWordInfo = ^TWordInfo;
const
MAXWORDS = 65536;
type
TWordList = array[0..Pred(MAXWORDS)] of TWordInfo;
PWordList = ^TWordList;
var
Y,
i, MaxHeight, j,
MaxAscent, MaxDescent,
TextWidth, Width : Integer;
W : Integer;
Size : TSize;
MaxTextWidth : Integer;
CurElement : PIpHtmlElement;
Al, SaveAl : TIpHtmlAlign;
VAL : TIpHtmlVAlign3;
FirstWord, LastWord, {dx,} m, X0 : Integer;
CurHeight, CurAscent, CurDescent : Integer;
LineBreak : Boolean;
LeftQueue : TList;
RightQueue : TList;
tmAscent,
tmDescent,
tmHeight : Integer;
LIdent, RIdent : Integer;
VRemainL,
VRemainR : Integer;
Clear : (cNone, cLeft, cRight, cBoth);
BaseOffset : Integer;
ExpLIndent,
PendingIndent, PendingOutdent : Integer;
ExpBreak : Boolean;
LTrim : Boolean;
RectWidth : Integer;
FirstElement, LastElement : Integer;
SizeOfSpace : TSize;
SizeOfHyphen : TSize;
PendingLineBreak : Boolean;
Prefor : Boolean;
TempCenter : Boolean;
CurProps : TIpHtmlProps;
SoftBreak : Boolean;
IgnoreHardLF : Boolean;
CanBreak : Boolean;
LastBreakpoint : Integer;
WordInfo : PWordList;
{WordInfoCount : Integer;} {!!.12}
WordInfoSize : Integer;
CurObj : TIpHtmlNodeAlignInline;
HyphenSpace : Integer;
SoftLF : Boolean;
HyphensPresent : Boolean;
procedure QueueLeadingObjects;
var
CurObj : TIpHtmlNodeAlignInline;
begin
while FirstElement <= LastElement do begin
CurElement := PIpHtmlElement(ElementQueue[FirstElement]);
case CurElement.ElementType of
etObject :
begin
CurObj := TIpHtmlNodeAlignInline(CurElement.Owner);
case CurObj.Align of
hiaLeft :
begin
LeftQueue.Add(CurElement);
Inc(FirstElement);
end;
hiaRight :
begin
RightQueue.Add(CurElement);
Inc(FirstElement);
end;
else
break;
end;
end else
break;
end;
end;
end;
procedure DoLeftAligned;
var
CurObj : TIpHtmlNodeAlignInline;
begin
if (LeftQueue.Count > 0) and (VRemainL = 0) then begin
while LeftQueue.Count > 0 do begin
CurElement := LeftQueue[0];
CurObj := TIpHtmlNodeAlignInline(CurElement.Owner);
Size := CurObj.GetDim(RectWidth);
Width := (TargetRect.Right - TargetRect.Left)
- LIdent - RIdent - Size.cx - ExpLIndent;
if Width < 0 then
break;
SetWordRect(CurElement,
Rect(TargetRect.Left + LIdent,
Y,
TargetRect.Left + LIdent + Size.cx,
Y + Size.cy));
Inc(LIdent, Size.cx);
VRemainL := MaxI2(VRemainL, Size.cy);
LeftQueue.Delete(0);
end;
end;
end;
procedure DoRightAligned;
var
CurObj : TIpHtmlNodeAlignInline;
begin
if (RightQueue.Count > 0) and (VRemainR = 0) then begin
while RightQueue.Count > 0 do begin
CurElement := RightQueue[0];
CurObj := TIpHtmlNodeAlignInline(CurElement.Owner);
Size := CurObj.GetDim(RectWidth);
Width := (TargetRect.Right - TargetRect.Left)
- LIdent - RIdent - Size.cx - ExpLIndent;
if Width < 0 then
break;
SetWordRect(CurElement,
Rect(TargetRect.Right - RIdent - Size.cx,
Y,
TargetRect.Right - RIdent,
Y + Size.cy));
Inc(RIdent, Size.cx);
VRemainR := MaxI2(VRemainR, Size.cy);
RightQueue.Delete(0);
end;
end;
end;
procedure OutputLine;
var
WDelta, WMod, j : Integer;
R : TRect;
CurWordInfo : PWordInfo;
dx: Integer; {!!.12}
begin
WDelta := 0;
WMod := 0;
case Al of
haDefault,
haLeft :
dx := 0;
haCenter :
if Width >= TextWidth then
dx := (Width - TextWidth) div 2
else
dx := 0;
haRight :
if Width >= TextWidth then
dx := Width - TextWidth
else
dx := 0;
haChar :
if Width >= TextWidth then
dx := (Width - TextWidth) div 2
else
dx := 0;
else //haJustify :
if i >= ElementQueue.Count then
dx := 0
else begin
dx := 0;
m := i - FirstWord - 2;
if m > 0 then begin
WDelta := (Width - TextWidth) div m;
WMod := (Width - TextWidth) mod m;
end;
end;
end;
if Owner.PageHeight <> 0 then begin
{if we're printing, adjust line's vertical offset to not
straddle a page boundary}
j := Y mod Owner.PageHeight;
{only do this for 'small' objects, like text lines}
if (MaxAscent + MaxDescent < 200)
and (j + MaxAscent + MaxDescent > Owner.PageHeight) then
Inc(Y, ((j + MaxAscent + MaxDescent) - Owner.PageHeight));
end;
for j := FirstWord to LastWord do begin
CurElement := PIpHtmlElement(ElementQueue[j]);
CurWordInfo := @WordInfo[j - FirstWord];
if CurWordInfo.Sz.cx <> 0 then begin
R.Left := CurWordInfo.BaseX;
R.Right := R.Left + CurWordInfo.Sz.cx;
case CurWordInfo.VA of
hva3Top :
begin
R.Top := Y;
R.Bottom := Y + CurWordInfo.Sz.cy;
end;
hva3Middle :
begin
R.Top := Y + (MaxHeight - CurWordInfo.Sz.cy) div 2;
R.Bottom := R.Top + CurWordInfo.Sz.cy;
end;
hva3Bottom :
begin
R.Top := Y + MaxHeight - CurWordInfo.Sz.cy;
R.Bottom := R.Top + CurWordInfo.Sz.cy;
end;
hva3Default,
hva3Baseline :
begin
if CurWordInfo.CurAsc >= 0 then
R.Top := Y + MaxAscent - CurWordInfo.CurAsc
else
R.Top := Y;
R.Bottom := R.Top + CurWordInfo.Sz.cy;
end;
end;
if WMod <> 0 then begin
OffsetRect(R, dx + WDelta + 1, 0);
Dec(WMod);
end else
OffsetRect(R, dx + WDelta, 0);
SetWordRect(CurElement, R);
end else
SetWordRect(CurElement, NullRect);
end;
end;
procedure DoClear;
begin
case Clear of
cLeft :
if VRemainL > 0 then begin
Inc(Y, VRemainL);
VRemainL := 0;
LIdent := 0;
end;
cRight :
if VRemainR > 0 then begin
Inc(Y, VRemainR);
VRemainR := 0;
RIdent := 0;
end;
cBoth :
begin
Inc(Y,
MaxI2(VRemainL, VRemainR));
VRemainL := 0;
VRemainR := 0;
LIdent := 0;
RIdent := 0;
end;
end;
Clear := cNone;
end;
procedure ApplyProps;
var
TextMetrics : TTextMetric;
begin
with CurElement.Props do begin
if (CurProps = nil) or not AIsEqualTo(CurProps) then begin
if PropA.SizeOfSpaceKnown then begin
SizeOfSpace := PropA.KnownSizeOfSpace;
SizeOfHyphen := PropA.KnownSizeOfHyphen;
end else begin
Owner.Target.Font.Name := FontName;
Owner.Target.Font.Size := FontSize;
Owner.Target.Font.Style := FontStyle;
SizeOfSpace := Owner.Target.TextExtent(' ');
SizeOfHyphen := Owner.Target.TextExtent('-');
PropA.SetKnownSizeOfSpace(SizeOfSpace);
PropA.KnownSizeOfHyphen := SizeOfHyphen;
end;
if PropA.tmHeight = 0 then begin
Owner.Target.Font.Name := FontName;
Owner.Target.Font.Size := FontSize;
Owner.Target.Font.Style := FontStyle;
GetTextMetrics(Owner.Target.Handle, TextMetrics);
PropA.tmAscent := TextMetrics.tmAscent;
PropA.tmDescent := TextMetrics.tmDescent;
PropA.tmHeight := TextMetrics.tmHeight;
end;
tmHeight := PropA.tmHeight;
tmAscent := PropA.tmAscent;
tmDescent := PropA.tmDescent;
end;
if (CurProps = nil) or not BIsEqualTo(CurProps) then begin
Al := Alignment;
VAL := VAlignment;
BaseOffset := FontBaseline;
PreFor := Preformatted;
end;
end;
CurProps := CurElement.Props;
end;
procedure InitMetrics;
var
TextMetrics : TTextMetric;
begin
GetTextMetrics(Owner.Target.Handle, TextMetrics);
tmAscent := TextMetrics.tmAscent;
tmDescent := TextMetrics.tmDescent;
tmHeight := TextMetrics.tmHeight;
end;
{!!.10 rewritten
procedure SetWordInfoLength(NewLength : Integer);
begin
if (WordInfo = nil) or (NewLength > WordInfoSize) then begin
WordInfoSize := ((NewLength div 256) + 1) * 256;
ReAllocMem(WordInfo, WordInfoSize * sizeof(TWordInfo));
end;
end;
}
{!!.10 rewritten}
procedure SetWordInfoLength(NewLength : Integer);
var
NewWordInfoSize: Integer;
{$IFNDEF IP_LAZARUS}
NewWordInfo: PWordList;
{$ENDIF}
begin
if (WordInfo = nil) or (NewLength > WordInfoSize) then begin
NewWordInfoSize := ((NewLength div 256) + 1) * 256;
{$IFDEF IP_LAZARUS code below does not check if WordInfo<>nil}
ReallocMem(WordInfo,NewWordInfoSize * sizeof(TWordInfo));
{$ELSE}
NewWordInfo := AllocMem(NewWordInfoSize * sizeof(TWordInfo));
move(WordInfo^, NewWordInfo^, WordInfoSize);
Freemem(WordInfo);
WordInfo := NewWordInfo;
{$ENDIF}
WordInfoSize := NewWordInfoSize;
end;
end;
(*
procedure DumpQueue;
var
i: Integer;
CurElement : PIpHtmlElement;
begin
for i := 0 to ElementQueue.Count - 1 do begin
CurElement := PIpHtmlElement(ElementQueue[i]);
case CurElement.ElementType of
etWord :
write(' wrd:', CurElement.AnsiWord);
etObject :
write(' obj');
etSoftLF :
write(' softlf');
etHardLF :
write(' hardlf');
etClearLeft :
write(' clearleft');
etClearRight :
write(' clearright');
etClearBoth :
write(' clearboth');
etIndent :
write(' indent');
etOutdent :
write(' outdent');
etSoftHyphen :
write(' softhyphen');
end;
end;
writeln('/////////////////');
end;
*)
begin
if ElementQueue.Count = 0 then Exit;
{DumpQueue;} {debug}
LeftQueue := nil;
RightQueue := nil;
WordInfoSize := 0;
{WordInfoCount := 0;} {!!.12}
WordInfo := nil;
try
RectWidth := TargetRect.Right - TargetRect.Left;
Y := TargetRect.Top;
LeftQueue := TList.Create;
RightQueue := TList.Create;
SizeOfSpace := Owner.Target.TextExtent(' ');
SizeOfHyphen := Owner.Target.TextExtent('-');
InitMetrics;
CurProps := nil;
LIdent := 0;
RIdent := 0;
VRemainL := 0;
VRemainR := 0;
Clear := cNone;
ExpLIndent := 0;
PendingIndent := 0;
PendingOutdent := 0;
LastElement := ElementQueue.Count - 1;
FirstElement := 0;
QueueLeadingObjects;
Prefor := False;
ExpBreak := True;
TempCenter := False;
SaveAl := haLeft;
IgnoreHardLF := False;
LastBreakpoint := 0;
FPageRect := TargetRect;
i := 0;
MaxHeight := 0;
MaxAscent := 0;
MaxDescent := 0;
MaxTextWidth := 0;
LineBreak := False;
Al := haLeft;
VAL := hva3Top;
{trim trailing blanks}
LastElement := ElementQueue.Count - 1;
repeat
if (LastElement >= FirstElement) then begin
CurElement := PIpHtmlElement(ElementQueue[LastElement]);
if (CurElement.ElementType = etWord) then
if CurElement.IsBlank <> 0 then
Dec(LastElement)
else
break
else
break;
end else
break;
until false;
DoLeftAligned;
DoRightAligned;
i := FirstElement;
CurAscent := 0;
CurDescent := 0;
CurHeight := 0;
while i <= LastElement do begin
if PendingIndent > PendingOutDent then begin
if ExpLIndent < (TargetRect.Right - TargetRect.Left) - LIdent - RIdent then begin
Inc(ExpLIndent, (PendingIndent - PendingOutdent) * StdIndent);
end;
end else
if PendingOutdent > PendingIndent then begin
Dec(ExpLIndent, (PendingOutDent - PendingIndent) * StdIndent);
if ExpLIndent < 0 then
ExpLIndent := 0;
end;
PendingIndent := 0;
PendingOutdent := 0;
DoLeftAligned;
DoRightAligned;
Width := (TargetRect.Right - TargetRect.Left)
- LIdent - RIdent - ExpLIndent;
LTrim := LineBreak or (ExpBreak and not PreFor) or (ExpLIndent > 0);
W := Width; {total width we have}
TextWidth := 0;
FirstWord := i;
LastWord := i-1;
BaseOffset := 0;
X0 := TargetRect.Left + LIdent + ExpLIndent;
SoftBreak := False;
HyphenSpace := 0;
HyphensPresent := False;
while (i < ElementQueue.Count) do begin
CanBreak := False;
CurElement := PIpHtmlElement(ElementQueue[i]);
if CurElement.Props <> nil then
ApplyProps;
SoftLF := False;
case CurElement.ElementType of
etWord :
begin
IgnoreHardLF := False;
if LTrim and (CurElement.IsBlank <> 0) then
Size := SizeRec(0, 0)
else begin
if CurElement.IsBlank <> 0 then begin
Size.cx := SizeOfSpace.cx * CurElement.IsBlank;
Size.cy := SizeOfSpace.cy;
CanBreak := True;
end else begin
if (CurElement.SizeProp = CurProps.PropA) then
Size := CurElement.Size
else begin
Owner.Target.Font.Name := CurProps.FontName;
Owner.Target.Font.Size := CurProps.FontSize;
Owner.Target.Font.Style := CurProps.FontStyle;
CurElement.Size :=
Owner.Target.TextExtent(
NoBreakToSpace(CurElement.AnsiWord));
Size := CurElement.Size;
CurElement.SizeProp := CurProps.PropA;
end;
end;
LTrim := False;
LineBreak := False;
ExpBreak := False;
end;
CurAscent := tmAscent;
CurDescent := tmDescent;
CurHeight := tmHeight;
end;
etObject :
begin
IgnoreHardLF := False;
CurAscent := 0;
CurDescent := 0;
CanBreak := True;
LineBreak := False;
CurObj := TIpHtmlNodeAlignInline(CurElement.Owner);
Size := CurObj.GetDim(Width);
CurHeight := Size.cy;
case Curobj.Align of
hiaCenter :
begin
ExpBreak := False;
LTrim := False;
CurAscent := MaxAscent;
CurDescent := Size.cy - MaxAscent;
TempCenter := True;
SaveAl := Al;
Al := haCenter;
end;
hiaTop :
begin
ExpBreak := False;
LTrim := False;
CurAscent := -1;
CurDescent := Size.cy;
end;
hiaMiddle
:
begin
ExpBreak := False;
LTrim := False;
CurAscent := Size.cy div 2;
CurDescent := Size.cy div 2;
end;
hiaBottom :
begin
ExpBreak := False;
LTrim := False;
CurAscent := Size.cy;
CurDescent := 0;
end;
hiaLeft :
begin
LeftQueue.Add(CurElement);
CurElement := nil;
CurHeight := 0;
Size.cx := 0;
if LTrim then begin
Inc(i);
break;
end;
end;
hiaRight :
begin
RightQueue.Add(CurElement);
CurElement := nil;
CurHeight := 0;
Size.cx := 0;
if LTrim then begin
Inc(i);
break;
end;
end;
end;
end;
etSoftLF :
begin
PendingLineBreak := False;
if LineBreak or ExpBreak then begin
MaxAscent := 0;
MaxDescent := 0;
end else begin
if MaxAscent = 0 then begin
MaxAscent := MaxI2(MaxAscent, tmAscent);
MaxDescent := MaxI2(MaxDescent, tmDescent);
end;
PendingLineBreak := True;
end;
ExpBreak := True;
if LineBreak then
MaxDescent := 0;
Inc(i);
LastWord := i - 2;
if PendingLineBreak then
LineBreak := True;
if not IgnoreHardLF then
break;
Size.cx := w + 1;
SoftLF := True;
end;
etHardLF :
begin
ExpBreak := True;
if MaxAscent = 0 then begin
MaxAscent := MaxI2(MaxAscent, tmAscent);
MaxDescent := MaxI2(MaxDescent, tmDescent);
end;
if LineBreak then
MaxDescent := 0;
LastWord := i - 1;
if not IgnoreHardLF then begin
if LineBreak then begin
MaxAscent := Round (MaxAscent * FactBAParagG); //JMN
MaxDescent := Round (MaxDescent * FactBAParagG); //JMN
end;
Inc(i);
break;
end;
if LastWord < FirstWord then begin {!!.01}
LastWord := FirstWord; {!!.01}
CanBreak := True; {!!.01}
Inc(i); {!!.01}
end; {!!.01}
end;
etClearLeft, etClearRight, etClearBoth :
begin
ExpBreak := True;
case CurElement.ElementType of
etClearLeft : Clear := cLeft;
etClearRight : Clear := cRight;
etClearBoth : Clear := cBoth;
end;
if LineBreak then
MaxDescent := 0;
Inc(i);
LastWord := i - 2;
if not IgnoreHardLF then
break;
end;
etIndent :
begin
CurAscent := 1;
CurDescent := 0;
CurHeight := 1;
Size := SizeRec(0, 0);
Inc(PendingIndent);
LTrim := True;
IgnoreHardLF := True;
CanBreak := True;
end;
etOutdent :
begin
IgnoreHardLF := False;
CurAscent := 1;
CurDescent := 0;
CurHeight := 1;
Inc(PendingOutdent);
CanBreak := True;
Size := SizeRec(0, 0); {!!.10}
end;
etSoftHyphen :
begin
IgnoreHardLF := False;
Size := SizeOfHyphen;
Size.cy := SizeOfSpace.cy;
HyphenSpace := Size.cx;
HyphensPresent := HyphenSpace > 0;
CanBreak := True;
LTrim := False;
LineBreak := False;
ExpBreak := False;
CurAscent := tmAscent;
CurDescent := tmDescent;
CurHeight := tmHeight;
end;
end;
if (Size.cx <= W) then begin {!!.10}
if CanBreak then
LastBreakPoint := i;
MaxAscent := MaxI2(MaxAscent, CurAscent);
MaxDescent := MaxI2(MaxDescent, CurDescent);
MaxHeight := MaxI3(MaxHeight, CurHeight, MaxAscent + MaxDescent);
{if word fits on line}
{update width and height}
if (CurElement <> nil) and (CurElement.ElementType = etIndent) then
Size.cx := MinI2(W, StdIndent - ((X0 - TargetRect.Left) mod StdIndent));
Dec(W, Size.cx);
Inc(TextWidth, Size.cx);
if CurElement <> nil then begin
if HyphensPresent then
for j := 0 to i - FirstWord - 1 do begin
Assert(j < WordInfoSize);
with WordInfo[j] do
if Hs > 0 then begin
Inc(W, Hs);
Dec(TextWidth, Hs);
Dec(X0, Hs);
Hs := 0;
Sz.cx := 0;
end;
end;
SetWordInfoLength(i - FirstWord + 1);
with WordInfo[i - FirstWord] do begin
Sz := SizeRec(Size.cx, CurHeight);
BaseX := X0;
BOff := BaseOffset;
CurAsc := CurAscent + BaseOffset;
VA := VAL;
Hs := HyphenSpace;
HyphenSpace := 0;
end;
end;
Inc(X0, Size.cx);
LastWord := i;
Inc(i);
end else begin
if HyphensPresent then
if CurElement <> nil then begin
for j := 0 to i - FirstWord - 2 do
with WordInfo[j] do
if Hs > 0 then begin
Dec(TextWidth, Hs);
Hs := 0;
Sz.cx := 0;
end;
end;
if CanBreak then
LastBreakPoint := i - 1;
if (LastWord >= 0) and (LastWord < ElementQueue.Count) then begin
CurElement := PIpHtmlElement(ElementQueue[Lastword]);
if (CurElement.ElementType = etWord)
and (CurElement.IsBlank <> 0) then begin
WordInfo[LastWord - FirstWord].Sz.cx := 0;
LastWord := i - 2;
end;
end;
LineBreak := True;
SoftBreak := not SoftLF;
break;
end;
end;
if SoftBreak and (LastBreakPoint > 0) then
LastWord := LastBreakPoint;
OutputLine;
{if SoftBreak and (LastBreakPoint > 0) then} {!!}
{i := LastBreakPoint + 1;} {!!}
if TempCenter then begin
Al := SaveAl;
TempCenter := False;
end;
if (TextWidth = 0) then begin
if not ExpBreak and (VRemainL = 0) and (VRemainR = 0) then
break;
end;
if TextWidth > MaxTextWidth then
MaxTextWidth := TextWidth;
Inc(Y, MaxAscent + MaxDescent);
if VRemainL > 0 then begin
if SoftBreak and (TextWidth = 0) and (MaxAscent + MaxDescent = 0) then begin
Inc(Y, VRemainL);
VRemainL := 0;
LIdent := 0;
end else begin
Dec(VRemainL, MaxAscent + MaxDescent);
if VRemainL <= 0 then begin
VRemainL := 0;
LIdent := 0;
end;
end;
end;
if VRemainR > 0 then begin
if SoftBreak and (TextWidth = 0) and (MaxAscent + MaxDescent = 0) then begin
Inc(Y, VRemainR);
VRemainR := 0;
RIdent := 0;
end else begin
Dec(VRemainR, MaxAscent + MaxDescent);
if VRemainR <= 0 then begin
VRemainR := 0;
RIdent := 0;
end;
end;
end;
MaxHeight := 0;
MaxAscent := 0;
MaxDescent := 0;
{prepare for next line}
DoClear;
end;
Inc(Y,
MaxI3(MaxAscent div 2 + MaxDescent, VRemainL, VRemainR));
VRemainL := 0;
VRemainR := 0;
LIdent := 0;
RIdent := 0;
MaxDescent := 0;
DoLeftAligned;
DoRightAligned;
Inc(Y,
MaxI3(MaxAscent + MaxDescent, VRemainL, VRemainR));
FPageRect.Bottom := Y;
{clean up}
finally
LeftQueue.Free;
RightQueue.Free;
if WordInfo <> nil then
FreeMem(WordInfo);
end;
end;
procedure TIpHtmlNodeBlock.InvalidateSize;
begin
FMin := -1;
FMax := -1;
LastW := 0;
LastH := 0;
inherited;
end;
function TIpHtmlNodeBlock.Level0: Boolean;
var
P : TIpHtmlNode;
begin
Result := True;
P := FParentNode;
while P <> nil do begin
if P is TIpHtmlNodeBlock then begin
Result := False;
break;
end;
P := P.FParentNode;
end;
end;
procedure TIpHtmlNodeBlock.ReportCurDrawRects(Owner: TIpHtmlNode;
M : TRectMethod);
var
i : Integer;
CurElement : PIpHtmlElement;
begin
for i := 0 to Pred(ElementQueue.Count) do begin
CurElement := PIpHtmlElement(ElementQueue[i]);
if CurElement.Owner = Owner then
M(CurElement.WordRect2);
end;
end;
procedure TIpHtmlNodeBlock.AppendSelection(var S: string);
var
LastY, StartSelIndex, EndSelIndex, i : Integer;
CurElement : PIpHtmlElement;
R : TRect;
LFDone : Boolean;
begin
if not Owner.AllSelected then begin
StartSelIndex := 0;
while StartSelIndex < ElementQueue.Count do begin
CurElement := PIpHtmlElement(ElementQueue[StartSelIndex]);
R := CurElement.WordRect2;
if R.Bottom = 0 then
else
if (R.Top > Owner.FStartSel.y) and (R.Bottom < Owner.FEndSel.y) then
break
else
if PtInRect(R, Owner.FStartSel) or PtInRect(R, Owner.FEndSel) then
break
else
if (R.Bottom < Owner.FStartSel.y) then
else
if (R.Top > Owner.FEndSel.Y) then
else
if (R.Left >= Owner.FStartSel.x) and (R.Right <= Owner.FEndSel.x) then
break;
Inc(StartSelIndex);
end;
EndSelIndex := Pred(ElementQueue.Count);
while EndSelIndex >= 0 do begin
CurElement := PIpHtmlElement(ElementQueue[EndSelIndex]);
R := CurElement.WordRect2;
if R.Bottom = 0 then
else
if (R.Top > Owner.FStartSel.y) and (R.Bottom < Owner.FEndSel.y) then
break
else
if PtInRect(R, Owner.FStartSel) or PtInRect(R, Owner.FEndSel) then
break
else
if (R.Bottom < Owner.FStartSel.y) then
else
if (R.Top > Owner.FEndSel.Y) then
else
if (R.Left >= Owner.FStartSel.x) and (R.Right <= Owner.FEndSel.x) then
break;
Dec(EndSelIndex);
end;
end else begin
StartSelIndex := 0;
EndSelIndex := ElementQueue.Count - 1;
end;
LastY := -1;
LFDone := True;
for i := StartSelIndex to EndSelIndex do begin
CurElement := PIpHtmlElement(ElementQueue[i]);
R := CurElement.WordRect2;
if not LFDone and (R.Top <> LastY) then begin
S := S + #13#10;
LFDone := True;
end;
case CurElement.ElementType of
etWord :
begin
S := S + NoBreakToSpace(CurElement.AnsiWord);
LFDone := False;
end;
etObject :
begin
TIpHtmlNodeAlignInline(CurElement.Owner).AppendSelection(S);
LFDone := False;
end;
etSoftLF..etClearBoth :
if not LFDone then begin
S := S + #13#10;
LFDone := True;
end;
end;
LastY := R.Top;
end;
end;
{!!.10 new}
function TIpHtmlNodeBlock.ElementQueueIsEmpty: Boolean;
begin
Result := ElementQueue.Count = 0;
end;
{ TIpHtmlNodeP }
constructor TIpHtmlNodeP.Create(ParentNode: TIpHtmlNode);
begin
inherited;
{$IFDEF IP_LAZARUS}
FElementName := 'p';
{$ENDIF}
Props := TIpHtmlProps.Create(Owner);
end;
destructor TIpHtmlNodeP.Destroy;
begin
Props.Free;
inherited;
end;
procedure TIpHtmlNodeP.SetProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
Props.Alignment := Align;
inherited SetProps(Props);
end;
procedure TIpHtmlNodeP.Enqueue;
begin
if FChildren.Count > 0 then begin
if not (FParentNode is TIpHtmlNodeLI) then begin {!!.10}
EnqueueElement(Owner.SoftLF);
EnqueueElement(Owner.HardLF);
end;
end;
inherited Enqueue;
if FChildren.Count > 0 then begin
EnqueueElement(Owner.SoftLF);
EnqueueElement(Owner.HardLF);
end;
end;
procedure TIpHtmlNodeP.SetAlign(const Value: TIpHtmlAlign);
begin
if Value <> FAlign then begin
FAlign := Value;
InvalidateSize;
end;
end;
{ TIpHtmlNodeOBJECT }
{!!.10}
destructor TIpHtmlNodeOBJECT.Destroy;
begin
inherited;
FWidth.Free;
end;
procedure TIpHtmlNodeOBJECT.WidthChanged(Sender: TObject);
begin
InvalidateSize;
end;
{ TIpHtmlNodeOL }
procedure TIpHtmlNodeOL.Enqueue;
var
i : Integer;
begin
{render list}
if FChildren.Count > 0 then begin
EnqueueElement(Owner.SoftLF);
end;
FParentNode.EnqueueElement(Owner.LIndent);
for i := 0 to Pred(FChildren.Count) do
if TObject(FChildren[i]) is TIpHtmlNodeLI then begin
Counter := i + 1;
TIpHtmlNodeLI(FChildren[i]).Enqueue;
FParentNode.EnqueueElement(Owner.SoftLF);
end else
TIpHtmlNode(FChildren[i]).Enqueue;
FParentNode.EnqueueElement(Owner.LOutdent);
FParentNode.EnqueueElement(Owner.SoftLF);
end;
function TIpHtmlNodeOL.GetNumString: string;
function IntToRomanStr(i : Integer): string;
const
RC : array[0..6] of AnsiChar = ('M', 'D', 'C', 'L', 'X', 'V', 'I');
RV : array[0..6] of Integer = (1000, 500, 100, 50, 10, 5, 1);
var
n : Integer;
begin
Result := '';
n := 0;
repeat
while i >= RV[n] do begin
Result := Result + RC[n];
Dec(i, RV[n]);
end;
Inc(n);
until i = 0;
end;
begin
{$IFDEF IP_LAZARUS}
Result := ''; // stop warning
{$ENDIF}
case Style of
olArabic :
str(Counter, Result);
olLowerAlpha :
Result := chr(ord('a') + Counter - 1);
olUpperAlpha :
Result := chr(ord('A') + Counter - 1);
olLowerRoman :
Result := LowerCase(IntToRomanStr(Counter));
olUpperRoman :
Result := IntToRomanStr(Counter);
end;
end;
procedure TIpHtmlNodeOL.SetStart(const Value: Integer);
begin
if Value <> FStart then begin
FStart := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeOL.SetStyle(const Value: TIpHtmlOLStyle);
begin
if Value <> FStyle then begin
FStyle := Value;
InvalidateSize;
end;
end;
{ TIpHtmlNodeList }
procedure TIpHtmlNodeList.Enqueue;
var
i : Integer;
begin
if FChildren.Count > 0 then begin
EnqueueElement(Owner.SoftLF);
end;
{render list}
FParentNode.EnqueueElement(Owner.LIndent);
for i := 0 to Pred(FChildren.Count) do
if TObject(FChildren[i]) is TIpHtmlNodeLI then begin
TIpHtmlNodeLI(FChildren[i]).Enqueue;
FParentNode.EnqueueElement(Owner.SoftLF);
end else
TIpHtmlNode(FChildren[i]).Enqueue;
FParentNode.EnqueueElement(Owner.LOutdent);
EnqueueElement(Owner.SoftLF);
end;
procedure TIpHtmlNodeList.SetListType(const Value: TIpHtmlULType);
begin
if Value <> FListType then begin
FListType := Value;
InvalidateSize;
end;
end;
{ TIpHtmlNodeHeader }
constructor TIpHtmlNodeHeader.Create(ParentNode: TIpHtmlNode);
begin
inherited;
Props := TIpHtmlProps.Create(Owner);
end;
destructor TIpHtmlNodeHeader.Destroy;
begin
Props.Free;
inherited;
end;
procedure TIpHtmlNodeHeader.SetProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
case Size of
1 : Props.FontSize := 24;
2 : Props.FontSize := 18;
3 : Props.FontSize := 14;
4 : Props.FontSize := 12;
5 : Props.FontSize := 10;
6 : Props.FontSize := 8;
end;
Props.FontStyle := [fsBold];
Props.Alignment := Align;
inherited SetProps(Props);
end;
procedure TIpHtmlNodeHeader.Enqueue;
begin
if FChildren.Count > 0 then
EnqueueElement(Owner.HardLF);
inherited Enqueue;
if FChildren.Count > 0 then begin
EnqueueElement(Owner.SoftLF);
EnqueueElement(Owner.HardLF);
end;
end;
{ TIpHtmlNodeLI }
procedure TIpHtmlNodeLI.CalcMinMaxWidth(var Min, Max: Integer);
begin
if ScaleBitmaps then begin {!!.10}
Min := round(8 * Aspect); {!!.10}
Max := round(8 * Aspect); {!!.10}
end else begin {!!.10}
Min := 8;
Max := 8;
end;
end;
constructor TIpHtmlNodeLI.Create(ParentNode: TIpHtmlNode);
begin
inherited;
Align := hiaBottom;
WordEntry := Owner.NewElement(etWord, Self);
WordEntry.Props := Props;
end;
procedure TIpHtmlNodeLI.Draw;
var
R : TRect;
SaveColor : Tcolor;
begin
if PageRectToScreen(GrossDrawRect, R) then
case ListType of
ulDisc :
begin
SaveColor := Owner.Target.Brush.Color;
Owner.Target.Brush.Color := Props.FontColor;
if ScaleBitmaps then {!!.10}
Owner.Target.Ellipse(R.Left, R.Top, R.Left + round(7 * Aspect), R.Top + round(7 * Aspect))
else
Owner.Target.Ellipse(R.Left, R.Top, R.Left + 7, R.Top + 7);
Owner.Target.Brush.Color := SaveColor;
end;
ulSquare :
begin
if ScaleBitmaps then {!!.10}
Owner.Target.Rectangle(R.Left, R.Top, R.Left + round(7 * Aspect), R.Top + round(7 * Aspect))
else
Owner.Target.Rectangle(R.Left, R.Top, R.Left + 7, R.Top + 7);
end;
ulCircle :
begin
if ScaleBitmaps then {!!.10}
Owner.Target.Ellipse(R.Left, R.Top, R.Left + round(7 * Aspect), R.Top + round(7 * Aspect))
else
Owner.Target.Ellipse(R.Left, R.Top, R.Left + 7, R.Top + 7);
end;
end;
end;
procedure TIpHtmlNodeLI.SetProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
inherited SetProps(Props);
end;
procedure TIpHtmlNodeLI.Enqueue;
var
S : string;
i : Integer;
begin
if FParentNode is TIpHtmlNodeOL then begin
S := TIpHtmlNodeOL(FParentNode).GetNumString;
SetRawWordValue(WordEntry, S + '.');
EnqueueElement(WordEntry);
end else
EnqueueElement(Element);
EnqueueElement(Owner.LIndent);
for i := 0 to Pred(FChildren.Count) do
TIpHtmlNode(FChildren[i]).Enqueue;
EnqueueElement(Owner.LOutdent);
end;
function TIpHtmlNodeLI.GetDim(ParentWidth: Integer): TSize;
begin
if ScaleBitmaps then {!!.10}
Result := SizeRec(round(Aspect * 8), round(Aspect * 8)) {!!.10}
else {!!.10}
Result := SizeRec(8, 8);
end;
function TIpHtmlNodeLI.GrossDrawRect: TRect;
begin
Result := PIpHtmlElement(Element).WordRect2;
end;
procedure TIpHtmlNodeLI.SetListType(const Value: TIpHtmlULType);
begin
if Value <> FListType then begin
FListType := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeLI.SetValue(const Value: Integer);
begin
if Value <> FValue then begin
FValue := Value;
InvalidateSize;
end;
end;
{ TIpHtmlNodeBR }
procedure TIpHtmlNodeBR.Enqueue;
begin
case Clear of
hbcNone :
EnqueueElement(Owner.HardLF);
hbcLeft :
EnqueueElement(Owner.HardLFClearLeft);
hbcRight :
EnqueueElement(Owner.HardLFClearRight);
hbcAll :
EnqueueElement(Owner.HardLFClearBoth);
end;
end;
procedure TIpHtmlNodeBR.SetClear(const Value: TIpHtmlBreakClear);
begin
FClear := Value;
InvalidateSize;
end;
{ TIpHtmlNodeHR }
constructor TIpHtmlNodeHR.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
FColor := -1;
Align := hiaCenter;
SizeWidth := TIpHtmlPixels.Create;
end;
procedure TIpHtmlNodeHR.Draw;
var
R : TRect;
TopLeft : TPoint;
Dim : TSize;
SaveBrushColor,
SavePenColor : TColor;
begin
TopLeft := GrossDrawRect.TopLeft;
R.TopLeft := TopLeft;
Dim := GetDim(0);
R.Right := TopLeft.x + Dim.cx;
R.Bottom := TopLeft.y + Dim.cy;
if not PageRectToScreen(R, R) then
Exit;
if NoShade or (Color <> -1) then begin
SavePenColor := Owner.Target.Pen.Color;
SaveBrushColor := Owner.Target.Brush.Color;
if Color = -1 then begin
Owner.Target.Pen.Color := clBlack;
Owner.Target.Brush.Color := clBlack;
end else begin
Owner.Target.Pen.Color := Color;
Owner.Target.Brush.Color := Color;
end;
Owner.Target.FillRect(R);
Owner.Target.Pen.Color := SavePenColor;
Owner.Target.Brush.Color := SaveBrushColor;
end else begin
SavePenColor := Owner.Target.Pen.Color;
SaveBrushColor := Owner.Target.Brush.Color;
Owner.Target.Pen.Color := clGray;
Owner.Target.Brush.Color := clGray;
Owner.Target.FillRect(R);
Owner.Target.Pen.Color := clWhite;
Owner.Target.MoveTo(R.Left - 1, R.Bottom + 1);
Owner.Target.LineTo(R.Left - 1, R.Top - 1);
Owner.Target.LineTo(R.Right + 1, R.Top - 1);
Owner.Target.Pen.Color := clBlack;
Owner.Target.LineTo(R.Right + 1, R.Bottom + 1);
Owner.Target.LineTo(R.Left - 1, R.Bottom + 1);
Owner.Target.Pen.Color := SavePenColor;
Owner.Target.Brush.Color := SaveBrushColor;
end;
end;
function TIpHtmlNodeHR.GetDim(ParentWidth: Integer): TSize;
begin
if (SizeWidth.PixelsType <> hpAbsolute)
or ((ParentWidth <> 0) and (SizeWidth.Value <> ParentWidth)) then begin
case Width.LengthType of
hlUndefined :
FDim.cx := 0;
hlAbsolute :
FDim.cx := Width.LengthValue;
hlPercent :
FDim.cx := round(ParentWidth * Width.LengthValue / 100);
end;
FDim.cy := Size.Value;
SizeWidth.Value := ParentWidth;
SizeWidth.PixelsType := hpAbsolute;
end;
Result := FDim;
end;
function TIpHtmlNodeHR.GrossDrawRect: TRect;
begin
Result := PIpHtmlElement(Element).WordRect2;
end;
procedure TIpHtmlNodeHR.CalcMinMaxWidth(var Min, Max: Integer);
begin
Min := 0;
Max := 0;
case Width.LengthType of
hlAbsolute :
begin
Min := Width.LengthValue;
Max := Min;
end;
end;
end;
procedure TIpHtmlNodeHR.Enqueue;
begin
EnqueueElement(Owner.SoftLF);
inherited;
EnqueueElement(Owner.SoftLF);
end;
{!!.10 new}
destructor TIpHtmlNodeHR.Destroy;
begin
inherited;
FWidth.Free;
SizeWidth.Free;
FSize.Free; {!!.10}
end;
procedure TIpHtmlNodeHR.WidthChanged(Sender: TObject);
begin
InvalidateSize;
end;
{ TIpHtmlNodeA }
procedure TIpHtmlNodeA.AddArea(const R: TRect);
var
RCopy : PRect;
c : Integer;
begin
c := AreaList.Count;
if c > 0 then begin
RCopy := PRect(AreaList[c-1]);
if (R.Left = RCopy.Right)
and (R.Top = RCopy.Top)
and (R.Bottom = RCopy.Bottom) then begin
RCopy.Right := R.Right;
Exit;
end;
end;
New(RCopy);
RCopy^ := R;
AreaList.Add(RCopy);
end;
procedure TIpHtmlNodeA.AddMapArea(const R: TRect);
var
RCopy : PRect;
c : Integer;
begin
c := MapAreaList.Count;
if c > 0 then begin
RCopy := PRect(AreaList[c-1]);
if (R.Left = RCopy.Right)
and (R.Top = RCopy.Top)
and (R.Bottom = RCopy.Bottom) then begin
RCopy.Right := R.Right;
Exit;
end;
end;
New(RCopy);
RCopy^ := R;
MapAreaList.Add(RCopy);
end;
procedure TIpHtmlNodeA.ClearAreaList;
var
a: Pointer;
m: Pointer;
begin
while AreaList.Count > 0 do begin
a:=AreaList[0];
FreeMem(a);
AreaList.Delete(0);
end;
while MapAreaList.Count > 0 do begin
m:=MapAreaList[0];
FreeMem(m);
MapAreaList.Delete(0);
end;
end;
constructor TIpHtmlNodeA.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
{$IFDEF IP_LAZARUS}
FElementName := 'a';
{$ENDIF}
AreaList := TList.Create;
MapAreaList := TList.Create;
Props := TIpHtmlProps.Create(Owner);
end;
destructor TIpHtmlNodeA.Destroy;
begin
if HasRef then
Owner.AnchorList.Remove(Self);
Props.Free;
ClearAreaList;
AreaList.Free;
MapAreaList.Free;
inherited;
end;
procedure TIpHtmlNodeA.BuildAreaList;
var
i : Integer;
begin
for i := 0 to Pred(FChildren.Count) do begin
TIpHtmlNode(FChildren[i]).ReportDrawRects(AddArea);
TIpHtmlNode(FChildren[i]).ReportMapRects(AddMapArea);
end;
end;
function TIpHtmlNodeA.PtInRects(const P: TPoint): Boolean;
var
i : Integer;
begin
if AreaList.Count = 0 then
BuildAreaList;
for i := 0 to Pred(AreaList.Count) do begin
with PRect(AreaList[i])^ do
if PtInRect(PRect(AreaList[i])^,P) then begin
Result := True;
Exit;
end;
end;
Result := False;
end;
function TIpHtmlNodeA.RelMapPoint(const P: TPoint): TPoint;
var
i : Integer;
begin
if AreaList.Count = 0 then
BuildAreaList;
for i := 0 to Pred(MapAreaList.Count) do begin
with PRect(MapAreaList[i])^ do
if PtInRect(PRect(AreaList[i])^,P) then begin
Result := Point(
P.x - PRect(AreaList[i])^.Left,
P.y - PRect(AreaList[i])^.Top);
Exit;
end;
end;
Result := Point(-1, -1);
end;
procedure TIpHtmlNodeA.SetHot(const Value: Boolean);
var
i : Integer;
R : TRect;
begin
FHot := Value;
if AreaList.Count = 0 then
BuildAreaList;
SetProps(Props);
for i := 0 to Pred(AreaList.Count) do
if PageRectToScreen(PRect(AreaList[i])^, R) then
Owner.InvalidateRect(R);
end;
procedure TIpHtmlNodeA.SetHRef(const Value: string);
var
NewHasRef : Boolean;
begin
FHRef := Value;
NewHasRef := Value <> '';
if NewHasRef <> HasRef then begin
if HasRef then
Owner.AnchorList.Remove(Self)
else
Owner.AnchorList.Add(Self);
FHasRef := NewHasRef;
end;
end;
procedure TIpHtmlNodeA.DoOnBlur;
begin
{FHasFocus := False;} {!!.12}
Hot := False;
end;
procedure TIpHtmlNodeA.DoOnFocus;
begin
{FHasFocus := True;} {!!.12}
MakeVisible;
Hot := True;
end;
procedure TIpHtmlNodeA.SetName(const Value: string);
begin
if FName <> '' then
with Owner.NameList do
Delete(IndexOf(FName));
FName := Value;
if FName <> '' then
Owner.NameList.AddObject(FName, Self);
end;
procedure TIpHtmlNodeA.MakeVisible;
var
i : Integer;
R : TRect;
begin
if AreaList.Count = 0 then
BuildAreaList;
SetRectEmpty(R);
for i := 0 to Pred(AreaList.Count) do
UnionRect(R, R, PRect(AreaList[i])^);
Owner.MakeVisible(R);
end;
procedure TIpHtmlNodeA.SetProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
if FHot then begin
Props.FontColor := Props.ALinkColor;
Props.FontStyle := Props.FontStyle + [fsUnderline];
end else
if HasRef then begin
Props.FontStyle := Props.FontStyle + [fsUnderline];
if Owner.LinkVisited(HRef) then
Props.FontColor := Props.VLinkColor
else
Props.FontColor := Props.LinkColor;
end;
inherited SetProps(Props);
end;
function TIpHtmlNodeA.GetHint: string;
begin
Result := HRef;
end;
{ TIpHtmlNodeDIV }
constructor TIpHtmlNodeDIV.Create(ParentNode: TIpHtmlNode);
begin
inherited;
Props := TIpHtmlProps.Create(Owner);
end;
destructor TIpHtmlNodeDIV.Destroy;
begin
Props.Free;
inherited;
end;
procedure TIpHtmlNodeDIV.SetProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
Props.Alignment := Align;
inherited SetProps(Props);
end;
procedure TIpHtmlNodeDIV.Enqueue;
begin
if FChildren.Count > 0 then
EnqueueElement(Owner.HardLF);
inherited Enqueue;
if FChildren.Count > 0 then
EnqueueElement(Owner.HardLF);
end;
{ TIpHtmlNodeSPAN }
procedure TIpHtmlNodeSPAN.ApplyProps(const RenderProps: TIpHtmlProps);
{$IFDEF IP_LAZARUS}
var
Elem: TCSSProps = nil;
{$ENDIF}
begin
Props.Assign(RenderProps);
Props.Alignment := Align;
{$IFDEF IP_LAZARUS}
LoadCSSProps(Owner, Elem, Props);
{$ENDIF}
end;
{ TIpHtmlNodeTABLE }
procedure TIpHtmlNodeTABLE.CalcMinMaxColTableWidth(
const RenderProps: TIpHtmlProps;var Min, Max: Integer);
var
z, Min0, Max0: Integer;
i, j, CurCol, k : Integer;
TWMin, TWMax : Integer;
PendSpanWidthMin,
PendSpanWidthMax,
PendSpanStart,
PendSpanSpan : TIntArr;
PendCol : Integer;
procedure DistributeColSpace(ColSpan: Integer);
var
i, Rest, MinNow : Integer;
begin
if ColSpan > 1 then begin
PendSpanWidthMin[PendCol] := Min0;
PendSpanWidthMax[PendCol] := Max0;
PendSpanStart[PendCol] := CurCol;
PendSpanSpan[PendCol] := ColSpan;
Inc(PendCol);
Exit;
end;
MinNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(MinNow, ColTextWidthMin[i]);
if MinNow = 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do
ColTextWidthMin[i] := Min0 div ColSpan;
end else begin
Rest := Min0 - MinNow;
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do
{Inc(ColTextWidthMin[i],
round(Rest * ColTextWidthMin[i] / MinNow));} {!!.10}
ColTextWidthMin[i] := ColTextWidthMin[i] + {!!.10}
round(Rest * ColTextWidthMin[i] / MinNow); {!!.10}
MinNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(MinNow, ColTextWidthMin[i]);
Rest := Min0 - MinNow;
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do begin
{Inc(ColTextWidthMin[i]);} {!!.10}
ColTextWidthMin[i] := ColTextWidthMin[i] + 1; {!!.10}
Dec(Rest);
if rest = 0 then
break;
end;
end;
end;
end;
MinNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(MinNow, ColTextWidthMax[i]);
if MinNow = 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do
ColTextWidthMax[i] := Max0 div ColSpan;
end else begin
Rest := Max0 - MinNow;
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do
{Inc(ColTextWidthMax[i],
round(Rest * ColTextWidthMax[i] / MinNow))} {!!.10}
ColTextWidthMax[i] := ColTextWidthMax[i] + {!!.10}
round(Rest * ColTextWidthMax[i] / MinNow); {!!.10}
MinNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(MinNow, ColTextWidthMax[i]);
Rest := Max0 - MinNow;
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do begin
{Inc(ColTextWidthMax[i]);} {!!.10}
ColTextWidthMax[i] := ColTextWidthMax[i] + 1; {!!.10}
Dec(Rest);
if rest = 0 then
break;
end;
end;
end;
end;
for i := 0 to Pred(ColCount) do begin
ColTextWidthMin[i] := MinI2(ColTextWidthMin[i], ColTextWidthMax[i]);
ColTextWidthMax[i] := MaxI2(ColTextWidthMin[i], ColTextWidthMax[i]);
end;
end;
procedure DistributeSpannedColSpace;
var
z, i, Rest, MinNow, Min0, Max0, CurCol, ColSpan : Integer;
begin
for z := 0 to Pred(PendCol) do begin
Min0 := PendSpanWidthMin[z];
Max0 := PendSpanWidthMax[z];
CurCol := PendSpanStart[z];
ColSpan := PendSpanSpan[z];
MinNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(MinNow, ColTextWidthMin[i]);
if MinNow = 0 then begin
Rest := 0; {!!.10}
for i := CurCol to CurCol + ColSpan - 1 do begin {!!.10}
ColTextWidthMin[i] := Min0 div ColSpan;
Inc(Rest, ColTextWidthMin[i]); {!!.10}
end;
ColTextWidthMin[0] := ColTextWidthMin[0] + (Min0 - Rest); {!!.10}
end else begin
Rest := Min0 - MinNow;
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do
{Inc(ColTextWidthMin[i],
round(Rest * ColTextWidthMin[i] / MinNow));} {!!.10}
ColTextWidthMin[i] := ColTextWidthMin[i] + {!!.10}
round(Rest * ColTextWidthMin[i] / MinNow); {!!.10}
MinNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(MinNow, ColTextWidthMin[i]);
Rest := Min0 - MinNow;
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do begin
{Inc(ColTextWidthMin[i]);} {!!.10}
ColTextWidthMin[i] := ColTextWidthMin[i] + 1; {!!.10}
Dec(Rest);
if rest = 0 then
break;
end;
end;
end;
end;
MinNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(MinNow, ColTextWidthMax[i]);
if MinNow = 0 then begin
Rest := 0; {!!.10}
for i := CurCol to CurCol + ColSpan - 1 do begin
ColTextWidthMax[i] := Max0 div ColSpan;
Inc(Rest, ColTextWidthMax[i]); {!!.10}
end;
ColTextWidthMax[0] := ColTextWidthMax[0] + (Max0 - Rest); {!!.10}
end else begin
Rest := Max0 - MinNow;
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do
{Inc(ColTextWidthMax[i],
round(Rest * ColTextWidthMax[i] / MinNow));} {!!.10}
ColTextWidthMax[i] := ColTextWidthMax[i] + {!!.10}
round(Rest * ColTextWidthMax[i] / MinNow); {!!.10}
MinNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(MinNow, ColTextWidthMax[i]);
Rest := Max0 - MinNow;
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do begin
{Inc(ColTextWidthMax[i]);} {!!.10}
ColTextWidthMax[i] := ColTextWidthMax[i] + 1; {!!.10}
Dec(Rest);
if rest = 0 then
break;
end;
end;
end;
end;
for i := 0 to Pred(ColCount) do begin
{ColTextWidthMin[i] := MinI2(ColTextWidthMin[i], ColTextWidthMax[i]);} {!!.10}
ColTextWidthMax[i] := MaxI2(ColTextWidthMin[i], ColTextWidthMax[i]);
end;
end;
end;
(*
procedure BumpPercentages;
var
i, j, k, z : Integer;
MaxPercent, Pix : Integer;
begin
for i := 0 to Pred(ColCount) do
RowSp[i] := 0;
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is TIpHtmlNodeTHeadFootBody) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do begin
MaxPercent := 0;
CurCol := 0;
while RowSp[CurCol] <> 0 do begin
Dec(RowSp[CurCol]);
Inc(CurCol);
end;
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
case Width.LengthType of
hlPercent :
begin
Pix := 0;
for k := 0 to Pred(ColSpan) do
if RowSp[CurCol + k] = 0 then
Inc(Pix, ColTextWidthMin[CurCol + k]);
Pix := round(100 * Pix / Width.LengthValue);
if Pix > MaxPercent then
MaxPercent := Pix;
end;
end;
for k := 0 to Pred(ColSpan) do begin
while RowSp[CurCol] <> 0 do
Inc(CurCol);
Inc(CurCol);
end;
end;
CurCol := 0;
while RowSp[CurCol] <> 0 do begin
Dec(RowSp[CurCol]);
Inc(CurCol);
end;
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
case Width.LengthType of
hlPercent :
if MaxPercent > 0 then begin
Pix := 0;
for k := 0 to Pred(ColSpan) do
if RowSp[CurCol + k] = 0 then
Inc(Pix, ColTextWidthMin[CurCol + k]);
if Pix < round(Width.LengthValue * MaxPercent / 100) then begin
Pix := (round(MaxPercent * Width.LengthValue / 100) - Pix)
div ColSpan;
for k := 0 to Pred(ColSpan) do
if RowSp[CurCol + k] = 0 then
Inc(ColTextWidthMin[CurCol + k], Pix);
end;
end;
end;
for k := 0 to Pred(ColSpan) do begin
while RowSp[CurCol] <> 0 do begin
Dec(RowSp[CurCol]);
Inc(CurCol);
end;
RowSp[CurCol] := RowSpan - 1;
Inc(CurCol);
end;
end;
for j := CurCol to Pred(ColCount) do
if RowSp[j] > 0 then
Dec(RowSp[j]);
end;
end;
for i := 0 to Pred(ColCount) do
RowSp[i] := 0;
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is TIpHtmlNodeTHeadFootBody) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do begin
MaxPercent := 0;
CurCol := 0;
while RowSp[CurCol] <> 0 do begin
Dec(RowSp[CurCol]);
Inc(CurCol);
end;
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
case Width.LengthType of
hlPercent :
begin
Pix := 0;
for k := 0 to Pred(ColSpan) do
if RowSp[CurCol + k] = 0 then
Inc(Pix, ColTextWidthMax[CurCol + k]);
Pix := round(100 * Pix / Width.LengthValue);
if Pix > MaxPercent then
MaxPercent := Pix;
end;
end;
for k := 0 to Pred(ColSpan) do begin
while RowSp[CurCol] <> 0 do
Inc(CurCol);
Inc(CurCol);
end;
end;
CurCol := 0;
while RowSp[CurCol] <> 0 do begin
Dec(RowSp[CurCol]);
Inc(CurCol);
end;
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
case Width.LengthType of
hlPercent :
if MaxPercent > 0 then begin
Pix := 0;
for k := 0 to Pred(ColSpan) do
if RowSp[CurCol + k] = 0 then
Inc(Pix, ColTextWidthMax[CurCol + k]);
if Pix < round(Width.LengthValue * MaxPercent / 100) then begin
Pix := (round(MaxPercent * Width.LengthValue / 100) - Pix)
div ColSpan;
for k := 0 to Pred(ColSpan) do
if RowSp[CurCol + k] = 0 then
Inc(ColTextWidthMax[CurCol + k], Pix);
end;
end;
end;
for k := 0 to Pred(ColSpan) do begin
while RowSp[CurCol] <> 0 do begin
Dec(RowSp[CurCol]);
Inc(CurCol);
end;
RowSp[CurCol] := RowSpan - 1;
Inc(CurCol);
end;
end;
for j := CurCol to Pred(ColCount) do
if RowSp[j] > 0 then
Dec(RowSp[j]);
end;
end;
end;
*)
begin
if FMin <> -1 then begin
Min := FMin;
Max := FMax;
Exit;
end;
FMin := 0;
FMax := 0;
if ColCount = 0 then
Exit;
PendSpanWidthMin := nil; {!!.10}
PendSpanWidthMax := nil; {!!.10}
PendSpanStart := nil; {!!.10}
PendSpanSpan := nil; {!!.10}
try {!!.10}
PendSpanWidthMin := TIntArr.Create; {!!.10}
PendSpanWidthMax := TIntArr.Create; {!!.10}
PendSpanStart := TIntArr.Create; {!!.10}
PendSpanSpan := TIntArr.Create; {!!.10}
{calc col and table widths}
for i := 0 to Pred(ColCount) do begin
RowSp[i] := 0;
ColTextWidthMin[i] := 0;
ColTextWidthMax[i] := 0;
end;
PendCol := 0;
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is TIpHtmlNodeTHeadFootBody) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do begin
CurCol := 0;
while RowSp[CurCol] <> 0 do begin
{Dec(RowSp[CurCol]);} {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol);
end;
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
while RowSp[CurCol] <> 0 do begin {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol); {!!.10}
end; {!!.10}
CalcMinMaxWidth(RenderProps, Min0, Max0);
case Width.LengthType of
hlAbsolute :
begin
if Width.LengthValue <= ExpParentWidth then {!!.10}
Min0 := MaxI2(Min0, Width.LengthValue
{$IFDEF IP_LAZARUS}
- 2*CellPadding - CellSpacing - RUH); {!!.10}
{$ELSE}
- 2*CellPadding - 2*CS2 - RUH); {!!.10}
{$ENDIF}
Max0 := Min0;
end;
end;
FCalcWidthMin := Min0; {!!.10}
FCalcWidthMax := Max0; {!!.10}
DistributeColSpace(ColSpan);
for k := 0 to Pred(ColSpan) do begin
while RowSp[CurCol] <> 0 do begin
{Dec(RowSp[CurCol]);} {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol);
end;
RowSp[CurCol] := RowSpan - 1;
Inc(CurCol);
end;
end;
for j := CurCol to Pred(ColCount) do
if RowSp[j] > 0 then
{Dec(RowSp[j]);} {!!.10}
RowSp[j] := RowSp[j] - 1; {!!.10}
end;
end;
{BumpPercentages;} {!!.02}
DistributeSpannedColSpace;
finally
PendSpanWidthMin.Free;
PendSpanWidthMax.Free;
PendSpanStart.Free;
PendSpanSpan.Free;
end;
TWMin := 0;
TWMax := 0;
{$IFDEF IP_LAZARUS}
CellOverhead := BL + CellSpacing + BR;
{$ELSE}
CellOverhead := BL + 2*CS2 + RUH + BR;
{$ENDIF}
for i := 0 to Pred(ColCount) do begin
Inc(TWMin, ColTextWidthMin[i]);
Inc(TWMax, ColTextWidthMax[i]);
{$IFDEF IP_LAZARUS}
Inc(CellOverhead, RUH + 2*CellPadding + CellSpacing + RUH);
{$ELSE}
Inc(CellOverhead, 2*CellPadding + 2*CS2 + RUH);
{$ENDIF}
RowSp[i] := 0;
end;
FMin := MaxI2(FMin, TWMin + CellOverhead);
FMax := MaxI2(FMax, TWMax + CellOverhead);
Min := FMin;
Max := FMax;
end;
procedure TIpHtmlNodeTABLE.SetRect(TargetRect: TRect);
var
dx,dy : Integer;
z, i, j : Integer;
R : TRect;
begin
if ColCount = 0 then Exit;
dx := TargetRect.Left - BorderRect2.Left;
dy := TargetRect.Top - BorderRect2.Top;
OffsetRect(BorderRect, dx, dy);
OffsetRect(BorderRect2, dx, dy);
if FCaption <> nil then begin
with FCaption do begin
if not IsRectEmpty(PageRect) then begin
R := PageRect;
OffsetRect(R, dx, dy);
Layout(Props, R);
end;
end;
end;
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is TIpHtmlNodeTHeadFootBody) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do begin
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
if not IsRectEmpty(PadRect) then
OffsetRect(FPadRect, dx, dy);
if not IsRectEmpty(PageRect) then begin
R := PageRect;
OffsetRect(R, dx, dy);
Layout(Props, R);
end;
end;
end;
end;
end;
procedure TIpHtmlNodeTABLE.CalcSize(const ParentWidth: Integer;
const RenderProps: TIpHtmlProps);
{const}
{MAXCOLS = 16384; 4096;} {!!.01} {!!.10}
{MAXSPANROWS = 16384;} {4096;} {!!.01} {!!.10}
{type} {!!.10}
{TPRectArray = array[0..Pred(MAXCOLS)] of PRect;
PPRectArray = ^TPRectArray;} {!!.10}
(* !!.10
TColPArr = record
ColCount : Integer;
Rects : TRectArr; {PPRectArray;}
end;
TRowSArr = array[0..Pred(MaxSPANROWS)] of TColPArr;
PRowSArr = ^TRowSArr;
*)
var
z, GrossCellSpace, NetCellSpace, CellExtra,
NetCellSpaceExtraExtra,
{maxY, maxYY,} {moved into DoBlock} {!!.12}
RelCellExtra,
i, j, CurCol, k,
{HA, HB, Y0,} {moved into DoBlock} {!!.12}
CellSpace,
MinW, MaxW : Integer;
{CellRect1 : TRect;} {moved into DoBlock} {!!.12}
R : TRect;
TargetRect : TRect;
RowFixup : TRectRectArr; {PRowSArr;}
RowFixupCount : Integer;
{RowSp2 : TIntArr;}
{VA0, VA : TIpHtmlVAlign3;}{moved into DoBlock} {!!.12}
{AL0, AL : TIpHtmlAlign;} {moved into DoBlock} {!!.12}
(*
!!.10 no longer needed:
procedure AddSpanRow(Cols: Integer);
begin
ReAllocMem(RowFixup, (RowFixupCount + 1) * sizeof(TColPArr));
with RowFixup[RowFixupCount] do begin
ColCount := Cols;
Rects := AllocMem(Cols * sizeof(PRect));
end;
Inc(RowFixupCount);
end;
procedure SetSpanRows(Rows, Cols: Integer);
begin
while RowFixupCount < Rows do
AddSpanRow(Cols);
end;
*)
function GetSpanBottom(Row, Col: Integer): Integer;
var
R: PRect;
begin
R := RowFixup.Value[Row].Value[Col];
if R <> nil then
Result := R.Bottom
else
Result := 0;
(* !!.10 no longer needed:
if Row < RowFixupCount then
{if RowFixup[Row].Rects[Col] <> nil then}
Result := RowFixup[Row].Rects.Rect[Col].Bottom
{else
Result := 0}
else
Result := 0;
*)
end;
procedure SetSpanBottom(Row, Col, Value: Integer);
var
R: PRect;
begin
R := RowFixup.Value[Row].Value[Col];
if R <> nil then
R^.Bottom := Value;
(* !!.10 no longer needed:
if Row < RowFixupCount then
{if RowFixup[Row].Rects[Col] <> nil then}
RowFixup[Row].Rects.Rect[Col].Bottom := Value;
*)
end;
procedure SetSpanRect(Row,Col : Integer; const Rect: PRect);
begin
RowFixup[Row].Value[Col] := Rect; {!!.10}
{RowFixup[Row].Rects[Col] := Rect^;} {!!.10}
end;
procedure DeleteFirstSpanRow;
{var
i : Integer;}
begin
RowFixup.Delete(0);
(* !!.10 no longer needed:
if RowFixup <> nil then begin
Assert((RowFixupCount = 0) or not IsBadWritePtr(RowFixup[0].Rects, 4));
RowFixup[0].Rects.Free;
{if RowFixup[0].Rects <> nil then
{FreeMem(RowFixup[0].Rects);}
Dec(RowFixupCount);
for i := 0 to Pred(RowFixupCount) do
RowFixup[i] := RowFixup[i + 1];
ReAllocMem(RowFixup, RowFixupCount * sizeof(TColPArr));
{redundant:
if RowFixupCount = 0 then begin
FreeMem(RowFixup);
RowFixup := nil;
end;
}
Assert((RowFixupCount = 0) or not IsBadWritePtr(RowFixup[0].Rects, 4));
end;
*)
end;
(*
procedure DeleteSpanArray;
begin
while RowFixup <> nil do
DeleteFirstSpanRow;
end;
*)
procedure AdjustCol(ColSpan, DesiredWidth: Integer);
var
i, Rest, WNow, Avail : Integer;
begin
WNow := 0;
for i := CurCol to CurCol + ColSpan - 1 do
Inc(WNow, ColTextWidth[i]);
Avail := MinI2(DesiredWidth, CellSpace);
if WNow = 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do
ColTextWidth[i] := Avail div ColSpan;
end else begin
Rest := MinI2(CellSpace, DesiredWidth - WNow);
if Rest > 0 then begin
for i := CurCol to CurCol + ColSpan - 1 do
{Inc(ColTextWidth[i],
round(Rest * ColTextWidth[i] / WNow));} {!!.10}
ColTextWidth[i] := ColTextWidth[i] + {!!.10}
round(Rest * ColTextWidth[i] / WNow); {!!.10}
end;
end;
end;
procedure DoBlock(BlockType : TIpHtmlNodeTABLEHEADFOOTBODYClass);
var
z, i, j, k, zz : Integer;
RowSp2 : TIntArr;
AL0, AL : TIpHtmlAlign; {!!.12}
CellRect1 : TRect; {!!.12}
HA, HB, Y0: Integer; {!!.12}
maxY, maxYY: Integer; {!!.12}
VA0, VA : TIpHtmlVAlign3; {!!.12}
begin
RowSp2 := TIntArr.Create; {!!.10}
try
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is BlockType) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do begin
for j := 0 to Pred(ColCount) do
RowSp2[j] := RowSp[j];
CurCol := 0;
while RowSp[CurCol] <> 0 do begin
{Dec(RowSp[CurCol]);} {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol);
end;
VA0 := Props.VAlignment;
case VAlign of
hvaTop :
VA0 := hva3Top;
hvaMiddle :
VA0 := hva3Middle;
hvaBottom :
VA0 := hva3Bottom;
end;
case Align of
haDefault :
AL0 := haLeft;
else
AL0 := Align;
end;
{determine height of cells and lay out with top alignment}
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
while RowSp[CurCol] <> 0 do begin
{Dec(RowSp[CurCol]);} {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol);
end;
AL := AL0;
Props.Assign(Self.Props);
CellRect1 := TargetRect;
Inc(CellRect1.Left,
ColStart[CurCol]);
{$IFDEF IP_LAZARUS}
Inc(CellRect1.Top, CellSpacing + RUV);
{$ELSE}
Inc(CellRect1.Top, CS2 + RUV);
{$ENDIF}
CellRect1.Right :=
CellRect1.Left
+ 2*CellPadding
+ ColTextWidth[CurCol]
{$IFDEF IP_LAZARUS}
;
{$ELSE}
+ 2*CS2;
{$ENDIF}
for k := 1 to ColSpan - 1 do
Inc(CellRect1.Right,
ColTextWidth[CurCol + k] +
2*CellPadding +
{$IFDEF IP_LAZARUS}
2*RUH +
CellSpacing);
{$ELSE}
2*CS2 + RUH);
{$ENDIF}
{$IFDEF IP_LAZARUS}
// PadRect area of cell excluding rules
// CellRect area of text contained in cell
FPadRect := CellRect1;
Inc(CellRect1.Top, CellPadding);
inflateRect(CellRect1, -CellPadding, 0);
{$ELSE}
FPadRect := CellRect1;
InflateRect(FPadRect, -CS2, 0);
Inc(CellRect1.Top, CellPadding);
InflateRect(CellRect1, -(CellPadding + CS2), 0);
{$ENDIF}
VA := VAlign;
if VA = hva3Default then
VA := VA0;
case Align of
haDefault : ;
else
AL := Align;
end;
Props.VAlignment := VA;
Props.Alignment := AL;
Layout(Props, CellRect1);
{SetSpanRows(MaxI2(RowSpan, RowFixupCount + 1), ColCount);} {!!.10}
if (Height.PixelsType <> hpUndefined) {Height <> -1} then {!!.10}
if PageRect.Bottom - PageRect.Top < Height.Value then {!!.10}
FPageRect.Bottom := CellRect1.Top + Height.Value; {!!.10}
if (Height.PixelsType = hpUndefined) {Height = -1} {!!.10}
and IsRectEmpty(PageRect) then
FPadRect.Bottom := CellRect1.Top + CellPadding
else begin
FPadRect.Bottom := PageRect.Bottom + CellPadding;
end;
SetSpanRect(RowSpan - 1, CurCol, @PadRect);
for k := 0 to Pred(ColSpan) do begin
RowSp[CurCol] := RowSpan - 1;
Inc(CurCol);
end;
end;
{Adjust any trailing spanning columns}
for j := CurCol to Pred(ColCount) do
if RowSp[j] > 0 then
{Dec(RowSp[j]);} {!!.10}
RowSp[j] := RowSp[j] - 1; {!!.10}
maxYY := 0;
maxY := 0;
{if RowFixupCount > 0 then begin}
for zz := 0 to Pred(ColCount) do
maxY := MaxI2(GetSpanBottom(0, zz), maxY);
for zz := 0 to Pred(ColCount) do
SetSpanBottom(0, zz, maxY);
if maxY > maxYY then
maxYY := maxY;
{end;}
for j := 0 to Pred(ColCount) do
RowSp[j] := RowSp2[j];
CurCol := 0;
while RowSp[CurCol] <> 0 do begin
{Dec(RowSp[CurCol]);} {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol);
end;
{relocate cells which are not top aligned}
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
while RowSp[CurCol] <> 0 do begin
{Dec(RowSp[CurCol]);} {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol);
end;
AL := AL0;
{$IFDEF IP_LAZARUS}
HA := maxYY - (TargetRect.Top + CellSpacing + RUV);
{$ELSE}
HA := maxYY - TargetRect.Top;
{$ENDIF}
HB := PageRect.Bottom - PageRect.Top;
VA := VAlign;
if VA = hva3Default then
VA := VA0;
case VA of
hva3Middle :
Y0 := (HA - HB) div 2;
hva3Bottom :
Y0 := (HA - HB);
else
Y0 := 0;
end;
if Y0 > 0 then begin
CellRect1 := TargetRect;
Inc(CellRect1.Left,
ColStart[CurCol]);
{$IFDEF IP_LAZARUS}
Inc(CellRect1.Top, CellSpacing + RUV + Y0);
{$ELSE}
Inc(CellRect1.Top, CS2 + RUV + Y0);
{$ENDIF}
CellRect1.Right :=
CellRect1.Left
+ 2*CellPadding
+ ColTextWidth[CurCol]
{$IFDEF IP_LAZARUS}
;
{$ELSE}
+ 2*CS2;
{$ENDIF}
for k := 1 to ColSpan - 1 do
Inc(CellRect1.Right,
ColTextWidth[CurCol + k] +
2*CellPadding +
{$IFDEF IP_LAZARUS}
2*RUH + CellSpacing);
{$ELSE}
2*CS2 + RUH);
{$ENDIF}
Inc(CellRect1.Top, CellPadding);
{$IFDEF IP_LAZARUS}
inflateRect(CellRect1, -CellPadding, 0);
{$ELSE}
InflateRect(CellRect1, -(CellPadding + CS2), 0);
{$ENDIF}
case Align of
haDefault : ;
else
AL := Align;
end;
Props.VAlignment := VA;
Props.Alignment := AL;
Layout(Props, CellRect1);
{SetSpanRows(MaxI2(RowSpan, RowFixupCount + 1), ColCount);} {!!.10}
if Height.PixelsType <> hpUndefined {Height <> -1} then {!!.10}
if PageRect.Bottom - PageRect.Top < Height.Value then {!!.10}
FPageRect.Bottom := CellRect1.Top + Height.Value; {!!.10}
if (Height.PixelsType = hpUndefined) {(Height = -1)} {!!.10}
and IsRectEmpty(PageRect) then
FPadRect.Bottom := CellRect1.Top + CellPadding
else begin
FPadRect.Bottom := PageRect.Bottom + CellPadding;
end;
SetSpanRect(RowSpan - 1, CurCol, @PadRect);
end;
for k := 0 to Pred(ColSpan) do begin
RowSp[CurCol] := RowSpan - 1;
Inc(CurCol);
end;
end;
maxYY := 0;
maxY := 0;
{if RowFixupCount > 0 then begin}
for zz := 0 to Pred(ColCount) do
maxY := MaxI2(GetSpanBottom(0, zz), maxY);
for zz := 0 to Pred(ColCount) do
SetSpanBottom(0, zz, maxY);
if maxY > maxYY then
maxYY := maxY;
{end;}
{Adjust any trailing spanning columns}
for j := CurCol to Pred(ColCount) do
if RowSp[j] > 0 then
{Dec(RowSp[j]);} {!!.10}
RowSp[j] := RowSp[j] - 1; {!!.10}
{$IFDEF IP_LAZARUS}
TargetRect.Top := MaxI2(maxYY, TargetRect.Top) + RUV;
{$ELSE}
TargetRect.Top := MaxI2(maxYY, TargetRect.Top);
{$ENDIF}
DeleteFirstSpanRow;
end;
end;
while RowFixupCount > 0 do begin
maxYY := 0;
maxY := 0;
for zz := 0 to Pred(ColCount) do
maxY := MaxI2(GetSpanBottom(0, zz), maxY);
for zz := 0 to Pred(ColCount) do
SetSpanBottom(0, zz, maxY);
if maxY > maxYY then
maxYY := maxY;
TargetRect.Top := MaxI2(maxYY, TargetRect.Top);
DeleteFirstSpanRow;
end;
finally
RowSp2.Free;
end;
end;
var
P : Integer;
{Red : Double;}
begin
FTableWidth := 0;
if ColCount = 0 then
Exit;
Props.Assign(RenderProps);
CalcMinMaxColTableWidth(Props, MinW, MaxW);
case Width.LengthType of
hlUndefined :
begin
P := 0;
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is TIpHtmlNodeTHeadFootBody) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do begin
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
case Width.LengthType of
hlPercent :
Inc(P, Width.LengthValue);
end;
end;
end;
end;
if P <> 0 then
FTableWidth := MaxI2(MinW, round((P * ParentWidth) / 100)) {!!.10}
else
FTableWidth := MaxI2(MinW, MinI2(MaxW, ParentWidth));
end;
hlAbsolute :
FTableWidth :=
MaxI2(Width.LengthValue, MinW);
hlPercent :
FTableWidth := MaxI2(MinW, {!!.10}
round(
(Width.LengthValue * ParentWidth) / 100));
end;
(* !!.13
if FTableWidth >= MaxW then begin
for i := 0 to Pred(ColCount) do
ColTextWidth[i] := ColTextWidthMin[i];
end else begin
{if TableWidth < MinW then begin
Red := TableWidth / MinW;
for i := 0 to Pred(ColCount) do begin
ColTextWidthMin[i] := round(Red * ColTextWidthMin[i]);
ColTextWidth[i] := ColTextWidthMin[i];
end;
end else}
for i := 0 to Pred(ColCount) do
ColTextWidth[i] := ColTextWidthMin[i];
end;
*)
for i := 0 to Pred(ColCount) do {!!.13}
ColTextWidth[i] := ColTextWidthMin[i]; {!!.13}
for z := 0 to Pred(ColCount) do
RowSp[z] := 0;
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is TIpHtmlNodeTHeadFootBody) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do begin
CellSpace := FTableWidth - CellOverhead;
for j := 0 to Pred(ColCount) do
Dec(CellSpace, ColTextWidth[j]);
if CellSpace > 0 then begin
{distribute extra space}
CurCol := 0;
while RowSp[CurCol] <> 0 do begin
{Dec(RowSp[CurCol]);} {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol);
end;
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
case Width.LengthType of
hlAbsolute :
AdjustCol(ColSpan, Width.LengthValue -
{$IFDEF IP_LAZARUS}
2*CellPadding - CellSpacing - RUH);
{$ELSE}
2*CellPadding - 2*CS2 - RUH);
{$ENDIF}
hlPercent :
AdjustCol(Colspan,
round((FTableWidth - CellOverhead) *
Width.LengthValue / 100));
end;
CellSpace := FTableWidth - CellOverhead;
for k := 0 to Pred(ColCount) do
Dec(CellSpace, ColTextWidth[k]);
for k := 0 to Pred(ColSpan) do begin
while RowSp[CurCol] <> 0 do begin
{Dec(RowSp[CurCol]);} {!!.10}
RowSp[CurCol] := RowSp[CurCol] - 1; {!!.10}
Inc(CurCol);
end;
RowSp[CurCol] := RowSpan - 1;
Inc(CurCol);
end;
end;
for j := CurCol to Pred(ColCount) do
if RowSp[j] > 0 then
{Dec(RowSp[j]);} {!!.10}
RowSp[j] := RowSp[j] - 1; {!!.10}
end;
end;
end;
GrossCellSpace := MaxI2(FTableWidth - CellOverhead, 0);
NetCellSpace := 0;
for i := 0 to Pred(ColCount) do
Inc(NetCellSpace, ColTextWidth[i]);
if NetCellSpace > 0 then begin
CellExtra := GrossCellSpace - NetCellSpace;
if CellExtra > 0 then
for i := 0 to Pred(ColCount) do begin
RelCellExtra := round(CellExtra / NetCellSpace * ColTextWidth[i] );
if ColTextWidth[i] + RelCellExtra > ColTextWidthMax[i] then
ColTextWidth[i] := MaxI2(ColTextWidth[i], ColTextWidthMax[i])
else
ColTextWidth[i] := ColTextWidth[i] + RelCellExtra;
end;
end;
NetCellSpace := 0;
for i := 0 to Pred(ColCount) do
Inc(NetCellSpace, ColTextWidth[i]);
CellExtra := GrossCellSpace - NetCellSpace;
if CellExtra > 0 then begin
RelCellExtra := CellExtra div ColCount;
NetCellSpaceExtraExtra := CellExtra mod ColCount;
for i := 0 to Pred(ColCount) do begin
if (ColTextWidth[i] < ColTextWidthMax[i]) then begin
ColTextWidth[i] := ColTextWidth[i] + RelCellExtra;
if NetCellSpaceExtraExtra > 0 then begin
{Inc(ColTextWidth[i]);} {!!.10}
ColTextWidth[i] := ColTextWidth[i] + 1; {!!.10}
Dec(NetCellSpaceExtraExtra);
end;
end;
end;
end;
NetCellSpace := 0;
for i := 0 to Pred(ColCount) do
Inc(NetCellSpace, ColTextWidth[i]);
CellExtra := GrossCellSpace - NetCellSpace;
if CellExtra > 0 then begin
for i := 0 to Pred(ColCount) do begin
RelCellExtra := MinI2(ColTextWidthMax[i] - ColTextWidth[i], CellExtra);
if RelCellExtra > 0 then begin
{Inc(ColTextWidth[i], RelCellExtra);} {!!.10}
ColTextWidth[i] := ColTextWidth[i] + RelCellExtra; {!!.10}
Dec(CellExtra, RelCellExtra);
end;
end;
end;
NetCellSpace := 0;
for i := 0 to Pred(ColCount) do
Inc(NetCellSpace, ColTextWidth[i]);
CellExtra := GrossCellSpace - NetCellSpace;
if CellExtra > 0 then begin
RelCellExtra := CellExtra div ColCount;
NetCellSpaceExtraExtra := CellExtra mod ColCount;
for i := 0 to Pred(ColCount) do begin
ColTextWidth[i] := ColTextWidth[i] + RelCellExtra;
if NetCellSpaceExtraExtra > 0 then begin
{Inc(ColTextWidth[i]);} {!!.10}
ColTextWidth[i] := ColTextWidth[i] + 1; {!!.10}
Dec(NetCellSpaceExtraExtra);
end;
end;
end;
for i := 0 to Pred(ColCount) do
RowSp[i] := 0;
TargetRect := Rect(0, 0, ParentWidth, MaxInt);
BorderRect2 := TargetRect;
BorderRect := TargetRect;
for z := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[z]) is TIpHtmlNodeCAPTION then begin
FCaption := TIpHtmlNodeCAPTION(FChildren[z]);
if FCaption.Align <> hva2Bottom then begin
FCaption.Layout(Props, BorderRect2);
Inc(BorderRect.Top, FCaption.PageRect.Bottom - FCaption.PageRect.Top);
end;
end;
TargetRect := BorderRect;
R := BorderRect;
{$IFDEF IP_LAZARUS}
ColStart[0] := BL + CellSpacing + RUH;
{$ELSE}
ColStart[0] := BL + CS2 + RUH;
{$ENDIF}
RowSp[0] := 0;
for i := 1 to Pred(ColCount) do begin
ColStart[i] :=
ColStart[i-1]
+ 2*CellPadding
+ ColTextWidth[i-1]
{$IFDEF IP_LAZARUS}
+ CellSpacing
+ 2*RUH;
{$ELSE}
+ 2*CS2
+ RUH;
{$ENDIF}
RowSp[i] := 0;
end;
{calc size of table body}
Inc(TargetRect.Top, BT);
{calc rows}
RowFixup := TRectRectArr.Create;
try
RowFixupCount := 0;
DoBlock(TIpHtmlNodeTHEAD);
DoBlock(TIpHtmlNodeTBODY);
DoBlock(TIpHtmlNodeTFOOT);
{DeleteSpanArray;} {!!.10}
{if RowFixup <> nil then
FreeMem(RowFixup);} {!!.10}
finally
RowFixup.Free;
end;
{$IFDEF IP_LAZARUS}
Inc(TargetRect.Top, CellSpacing + RUV + BB);
{$ELSE}
Inc(TargetRect.Top, CS2 + RUV + BB);
{$ENDIF}
R.Right := R.Left + FTableWidth;
R.Bottom := TargetRect.Top;
if (R.Bottom > R.Top) and (R.Right = R.Left) then
R.Right := R.Left + 1;
BorderRect.BottomRight := R.BottomRight;
BorderRect2.BottomRight := R.BottomRight;
if assigned(FCaption) and (FCaption.Align = hva2Bottom) then begin
R.Top := BorderRect.Bottom;
R.Bottom := MaxInt;
FCaption.Layout(Props, R);
BorderRect2.Bottom := FCaption.PageRect.Bottom;
end;
end;
constructor TIpHtmlNodeTABLE.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
{$IFDEF IP_LAZARUS}
FElementName := 'table';
{$ENDIF}
BgColor := -1;
SizeWidth := TIpHtmlPixels.Create;
SizeWidth.PixelsType := hpUndefined;
FColCount := -1;
FMin := -1;
FMax := -1;
ColTextWidth := TIntArr.Create;
ColStart := TIntArr.Create;
ColTextWidthMin := TIntArr.Create;
ColTextWidthMax := TIntArr.Create;
RowSp := TIntArr.Create;
end;
procedure TIpHtmlNodeTABLE.Draw;
var
z, i, j : Integer;
R : TRect;
Al : TIpHtmlVAlign3;
begin
if (BGColor <> -1) and PageRectToScreen(BorderRect, R) then begin
Owner.Target.Brush.Color := BGColor;
Owner.Target.FillRect(R);
end;
Owner.Target.Pen.Color := clBlack;
Al := Props.VAlignment;
for z := 0 to Pred(ColCount) do
RowSp[z] := 0;
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is TIpHtmlNodeTHeadFootBody) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do begin
case VAlign of
hvaTop :
Al := hva3Top;
hvaMiddle :
Al := hva3Middle;
hvaBottom :
Al := hva3Bottom;
end;
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do begin
case VAlign of
hva3Default :
;
else
Al := VAlign;
end;
Props.VAlignment := Al;
Render(Props);
{paint left rule if selected}
case Rules of
hrNone,
hrGroups :;
hrRows :;
hrCols,
hrAll :
begin
if not IsRectEmpty(PadRect) then begin
R := PadRect;
Inflaterect(R, 1, 1);
{$IFDEF IP_LAZARUS}
ScreenFrame(R, False);
{$ELSE}
ScreenRect(R, RGB(192,192,192));
{$ENDIF}
end;
end;
end;
end;
end;
end;
{render frames}
if Frame in [hfAbove, hfHSides, hfBox, hfBorder] then
if Border = 1 then
ScreenLine(
BorderRect.TopLeft,
Point(BorderRect.Right-1, BorderRect.Top),
1,
RGB(220,220,220))
else
ScreenPolygon(
[BorderRect.TopLeft,
Point(BorderRect.Right, BorderRect.Top),
Point(BorderRect.Right - (Border - 1), BorderRect.Top + Border - 1),
Point(BorderRect.Left + Border - 1, BorderRect.Top + Border - 1)],
RGB(220,220,220));
if Frame in [hfBelow, hfHSides, hfBox, hfBorder] then
if Border = 1 then
ScreenLine(
Point(BorderRect.Right - 1, BorderRect.Bottom - 1),
Point(BorderRect.Left, BorderRect.Bottom - 1),
1,
RGB(64,64,64))
else
ScreenPolygon(
[
Point(BorderRect.Right - 1, BorderRect.Bottom - 1),
Point(BorderRect.Right - (Border - 1), BorderRect.Bottom - (Border - 1) - 1),
Point(BorderRect.Left + Border, BorderRect.Bottom - (Border - 1) - 1),
Point(BorderRect.Left, BorderRect.Bottom - 1)],
RGB(64,64,64));
if Frame in [hfLhs, hfvSides, hfBox, hfBorder] then
if Border = 1 then
ScreenLine(
BorderRect.TopLeft,
Point(BorderRect.Left, BorderRect.Bottom - 1),
1,
RGB(192,192,192))
else
ScreenPolygon(
[BorderRect.TopLeft,
Point(BorderRect.Left, BorderRect.Bottom - 1),
Point(BorderRect.Left + (Border - 1), BorderRect.Bottom - Border),
Point(BorderRect.Left + (Border - 1), BorderRect.Top + (Border - 1))],
RGB(192,192,192));
if Frame in [hfRhs, hfvSides, hfBox, hfBorder] then
if Border = 1 then
ScreenLine(
Point(BorderRect.Right - 1, BorderRect.Bottom - 1),
Point(BorderRect.Right - 1, BorderRect.Top),
1,
RGB(128,128,128))
else
ScreenPolygon(
[
Point(BorderRect.Right - 1, BorderRect.Bottom - 1),
Point(BorderRect.Right - 1, BorderRect.Top),
Point(BorderRect.Right - (Border - 1) - 1, BorderRect.Top + (Border - 1)),
Point(BorderRect.Right - (Border - 1) - 1, BorderRect.Bottom - Border)],
RGB(128,128,128));
{render caption}
//if assigned(FCaption) then
// FCaption.Render(Props);
end;
procedure TIpHtmlNodeTABLE.SetProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
Props.NoBreak := False;
inherited SetProps(RenderProps); {!!.10}
end;
function TIpHtmlNodeTABLE.GetDim(ParentWidth: Integer): TSize;
begin
if (SizeWidth.PixelsType <> hpAbsolute)
or (SizeWidth.Value <> ParentWidth) then begin
SizeWidth.PixelsType := hpUndefined;
CalcSize(ParentWidth, Props);
SizeWidth.Value := ParentWidth;
SizeWidth.PixelsType := hpAbsolute;
end;
Result :=
SizeRec(BorderRect2.Right - BorderRect2.Left,
BorderRect2.Bottom - BorderRect2.Top);
end;
procedure TIpHtmlNodeTABLE.CalcMinMaxWidth(var Min, Max: Integer);
begin
CalcMinMaxColTableWidth(Props, Min, Max);
case Width.LengthType of
hlAbsolute :
begin
Min := MaxI2(Min, Width.LengthValue);
Max := MaxI2(Max, Min);
end;
end;
end;
procedure TIpHtmlNodeTABLE.InvalidateSize;
begin
SizeWidth.PixelsType := hpUndefined;
FMin := -1;
FMax := -1;
inherited;
end;
function TIpHtmlNodeTABLE.GetColCount: Integer;
var
z, i, j, c : Integer;
begin
if FColCount = -1 then begin
FColCount := 0;
for z := 0 to Pred(FChildren.Count) do
if (TIpHtmlNode(FChildren[z]) is TIpHtmlNodeTHeadFootBody) then
with TIpHtmlNodeCore(FChildren[z]) do
for i := 0 to Pred(FChildren.Count) do begin
c := 0;
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeTR then
with TIpHtmlNodeTR(FChildren[i]) do
for j := 0 to Pred(FChildren.Count) do
if TIpHtmlNode(FChildren[j]) is TIpHtmlNodeTableHeaderOrCell then
with TIpHtmlNodeTableHeaderOrCell(FChildren[j]) do
Inc(c, Colspan);
if c > FColCount then
FColCount := c;
end;
{$IFNDEF IP_LAZARUS}
CS2 := CellSpacing div 2;
if (CellSpacing > 0) and (CS2 = 0) then
CS2 := 1;
{$ENDIF}
RUH := 0;
RUV := 0;
case Rules of
hrNone :;
hrGroups :
begin
RUH := 1;
RUV := 1;
end;
hrRows :
RUV := 1;
hrCols :
RUH := 1;
hrAll :
begin
RUH := 1;
RUV := 1;
end;
end;
BL := 0; BR := 0;
BT := 0; BB := 0;
case Frame of
hfVoid,
hfAbove :
BT := Border;
hfBelow :
BB := Border;
hfHSides :
begin
BT := Border;
BB := Border;
end;
hfLhs :
BL := Border;
hfRhs :
BR := Border;
hfvSides :
begin
BL := Border;
BR := Border;
end;
hfBox,
hfBorder :
begin
BT := Border;
BB := Border;
BL := Border;
BR := Border;
end;
end;
end;
Result := FColCount;
end;
procedure TIpHtmlNodeTABLE.Enqueue;
begin
case Align of
hiaTop,
hiaMiddle,
hiaBottom,
hiaCenter :
EnqueueElement(Owner.SoftLF);
end;
EnqueueElement(Element);
case Align of
hiaTop,
hiaMiddle,
hiaBottom,
hiaCenter :
EnqueueElement(Owner.SoftLF);
end;
end;
procedure TIpHtmlNodeTABLE.SetBorder(const Value: Integer);
begin
FBorder := Value;
if Border = 0 then begin
Frame := hfVoid;
Rules := hrNone;
end else begin
Frame := hfBorder;
Rules := hrAll;
end;
InvalidateSize;
end;
procedure TIpHtmlNodeTABLE.SetCellPadding(const Value: Integer);
begin
FCellPadding := Value;
InvalidateSize;
end;
procedure TIpHtmlNodeTABLE.SetCellSpacing(const Value: Integer);
begin
FCellSpacing := Value;
InvalidateSize;
end;
procedure TIpHtmlNodeTABLE.SetFrame(const Value: TIpHtmlFrameProp);
begin
FFrame := Value;
InvalidateSize;
end;
procedure TIpHtmlNodeTABLE.SetRules(const Value: TIpHtmlRules);
begin
FRules := Value;
InvalidateSize;
end;
destructor TIpHtmlNodeTABLE.Destroy;
begin
inherited;
FWidth.Free;
SizeWidth.Free;
ColTextWidth.Free;
ColStart.Free;
ColTextWidthMin.Free;
ColTextWidthMax.Free;
RowSp.Free;
end;
procedure TIpHtmlNodeTABLE.WidthChanged(Sender: TObject);
begin
InvalidateSize;
end;
function TIpHtmlNodeTABLE.ExpParentWidth: Integer;
begin
case Width.LengthType of
hlAbsolute :
Result := Width.LengthValue;
else
Result := inherited ExpParentWidth;
end;
end;
{$IFDEF IP_LAZARUS}
procedure TIpHtmlNodeTABLE.LoadCSSProps(Owner: TIpHtml; var Element: TCSSProps;
const Props: TIpHtmlProps);
begin
inherited LoadCSSProps(Owner, Element, Props);
if Element = nil then
exit;
if Element.BGColor <> -1 then
BgColor := Element.BGColor;
end;
{$ENDIF}
{ TIpHtmlNodeTR }
constructor TIpHtmlNodeTR.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
{$IFDEF IP_LAZARUS}
FElementName := 'tr';
{$ENDIF}
FAlign := haDefault;
FValign := hvaMiddle;
end;
{ TIpHtmlNodeMAP }
constructor TIpHtmlNodeMAP.Create(ParentNode: TIpHtmlNode);
begin
inherited;
Owner.MapList.Add(Self);
end;
destructor TIpHtmlNodeMAP.Destroy;
begin
Owner.MapList.Remove(Self);
inherited;
end;
{ TIpHtmlNodeAREA }
destructor TIpHtmlNodeAREA.Destroy;
var
I: Integer;
begin
I := Owner.AreaList.IndexOf(Self);
if I <> -1 then
Owner.AreaList.Delete(I);
inherited;
end;
function TIpHtmlNodeAREA.GetHint: string;
begin
if Alt <> '' then
Result := Alt
else
Result := HRef;
end;
function TIpHtmlNodeAREA.PtInRects(const P: TPoint): Boolean;
begin
if PtInRect(FRect, P) then
Result := True
else
if FRgn <> 0 then
Result := PtInRegion(FRgn, P.x, P.y)
else
Result := False;
end;
procedure TIpHtmlNodeAREA.Reset;
begin
if FRgn <> 0 then
DeleteObject(FRgn);
SetRectEmpty(FRect);
end;
{ TIpHtmlNodeIMG }
procedure TIpHtmlNodeIMG.LoadImage;
{var !!.10 no longer used
ScaledImage : TPicture;
ScaledBmp : TBitmap;}
begin
if Src <> '' then begin
if FPicture <> Owner.DefaultImage then begin {!!.10}
FPicture.Free; {!!.10}
FPicture := nil; {!!.10}
end; {!!.10}
Owner.DoGetImage(Self, Owner.BuildPath(Src), FPicture);
if FPicture = nil
then FPicture := Owner.DefaultImage;
(* !!.10 no longer used
if ScaleBitmaps then begin {!!.02}
ScaledImage := TPicture.Create; {!!.02}
ScaledBmp := TBitmap.Create; {!!.02}
ScaledBmp.Width := round(FPicture.Width * Aspect); {!!.02}
ScaledBmp.Height := round(FPicture.Height * Aspect); {!!.02}
ScaledImage.Graphic := ScaledBmp; {!!.02}
ScaledImage.Bitmap.Canvas.StretchDraw( {!!.02}
Rect(0, 0, ScaledBmp.Width - 1, ScaledBmp.Height - 1), {!!.02}
FPicture.Graphic); {!!.02}
ScaledBmp.Free; {!!.10}
FPicture.Free; {!!.02}
FPicture := ScaledImage; {!!.02}
end; {!!.02}
*)
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
if (FPicture <> nil)
and (FPicture.Graphic <> nil)
and (FPicture.Graphic is TGifImage)
then
Owner.GifImages.Add(Self);
{$ELSE}
if (FPicture <> nil)
and (FPicture.Graphic <> nil)
and (FPicture.Graphic is TIpAnimatedGraphic)
then
Owner.AnimationFrames.Add(Self);
{$ENDIF}
{$ELSE}
if (FPicture <> nil)
and (FPicture.Graphic <> nil) then begin
if FPicture.Graphic is TGifImage
then Owner.GifImages.Add(Self)
else Owner.OtherImages.Add(Self); //JMN
end;
{$ENDIF}
end;
end;
{!!.02 new - logic moved here from .Destroy}
procedure TIpHtmlNodeIMG.UnloadImage;
begin
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
if (FPicture <> nil)
and (FPicture.Graphic <> nil)
and (FPicture.Graphic is TGifImage)
then
Owner.GifImages.Remove(Self);
{$ELSE}
if (FPicture <> nil)
and (FPicture.Graphic <> nil)
and (FPicture.Graphic is TIpAnimatedGraphic)
then
Owner.AnimationFrames.Remove(Self);
{$ENDIF}
{$ELSE}
if (FPicture <> nil)
and (FPicture.Graphic <> nil) then begin
if FPicture.Graphic is TGifImage
then Owner.GifImages.Remove(Self)
else Owner.OtherImages.Remove(Self); //JMN
end;
{$ENDIF}
if FPicture <> Owner.DefaultImage then begin
FPicture.Free;
FPicture := nil;
end;
end;
destructor TIpHtmlNodeIMG.Destroy;
begin
UnloadImage; {!!.02}
UseMap := '';
inherited;
FWidth.Free; {!!.10}
SizeWidth.Free; {!!.10}
FHeight.Free; {!!.10}
end;
{$IFDEF IP_LAZARUS}
function TIpHtmlNodeIMG.GetBorder: Integer;
begin
if (FPicture<>nil)and(FPicture.Graphic=nil) then
Result := 1
else
Result := fBorder;
end;
{$ENDIF}
procedure TIpHtmlNodeIMG.Draw;
var
R : TRect;
TopLeft : TPoint;
Dim : TSize;
begin
if FPicture = nil then
LoadImage;
if (FPicture <> nil) and (FPicture.Graphic = nil) then {!!.15}
LoadImage;
Owner.AddRect(GrossDrawRect, Element, Block);
TopLeft := GrossDrawRect.TopLeft;
R.TopLeft := TopLeft;
Dim := GetDim(0);
R.Right := TopLeft.x + Dim.cx;
R.Bottom := TopLeft.y + Dim.cy;
if Border <> 0 then begin
if Border = 1 then begin
ScreenLine(
R.TopLeft,
Point(R.Right, R.Top),
1,
RGB(220,220,220));
ScreenLine(
R.BottomRight,
Point(R.Left, R.Bottom),
1,
RGB(64,64,64));
ScreenLine(
R.TopLeft,
Point(R.Left, R.Bottom),
1,
RGB(192,192,192));
ScreenLine(
R.BottomRight,
Point(R.Right, R.Top),
1,
RGB(128,128,128));
end else begin
ScreenPolygon(
[R.TopLeft,
Point(R.Right - 1, R.Top),
Point(R.Right - Border, R.Top + Border - 1),
Point(R.Left + Border - 1, R.Top + Border - 1)],
RGB(220,220,220));
ScreenPolygon(
[
Point(R.Right - 1, R.Bottom - 1),
Point(R.Right - Border, R.Bottom - Border),
Point(R.Left + (Border - 1), R.Bottom - Border),
Point(R.Left, R.Bottom - 1)],
RGB(64,64,64));
ScreenPolygon(
[R.TopLeft,
Point(R.Left, R.Bottom - 1),
Point(R.Left + (Border - 1), R.Bottom - Border),
Point(R.Left + (Border - 1), R.Top + (Border - 1))],
RGB(192,192,192));
ScreenPolygon(
[
Point(R.Right - 1, R.Bottom - 1),
Point(R.Right - 1, R.Top),
Point(R.Right - Border, R.Top + (Border - 1)),
Point(R.Right - Border, R.Bottom - Border)],
RGB(128,128,128));
end;
InflateRect(R, -Border, -Border);
end;
InflateRect(R, -HSpace, -VSpace);
if FPicture <> nil then begin
{$IFDEF IP_LAZARUS}
if FPicture.Graphic=nil then begin
if PageRectToScreen(R,R) then
Owner.Target.TextRect(R, R.Left, R.Top, GetHint);
Exit;
end;
{$ENDIF}
FPicture.Graphic.Transparent := True;
NetDrawRect := R;
if PageRectToScreen(R, R) then begin
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
if (FPicture.Graphic is TGifImage)
and (TGifImage(FPicture.Graphic).Images.Count > 1) then begin
TGifImage(FPicture.Graphic).DrawOptions :=
TGifImage(FPicture.Graphic).DrawOptions + [goDirectDraw];
Owner.AddGifQueue(FPicture.Graphic, R);
end else
{$ELSE}
if (FPicture.Graphic is TIpAnimatedGraphic)
and (TIpAnimatedGraphic(FPicture.Graphic).Images.Count > 1) then begin
TIpAnimatedGraphic(FPicture.Graphic).AggressiveDrawing := True;
Owner.AddGifQueue(FPicture.Graphic, R);
end else
begin
{$ENDIF}
{$ENDIF}
if FPicture = Owner.DefaultImage then begin
if ((NetDrawRect.Right - NetDrawRect.Left) > FPicture.Graphic.Width)
and ((NetDrawRect.Bottom - NetDrawRect.Top) > FPicture.Graphic.Height) then begin
Owner.Target.Brush.Color := Props.FontColor;
Owner.Target.FrameRect(R);
Owner.Target.Draw(R.Left + 1, R.Top + 1, FPicture.Graphic);
end else
Owner.Target.StretchDraw(R, FPicture.Graphic);
end else
Owner.Target.StretchDraw(R, FPicture.Graphic);
{$IFDEF IP_LAZARUS} //JMN
end;
{$ENDIF}
end;
end
end;
function TIpHtmlNodeIMG.GrossDrawRect : TRect;
begin
Result := PIpHtmlElement(Element).WordRect2;
end;
procedure TIpHtmlNodeIMG.ReportDrawRects(M: TRectMethod);
begin
M(GrossDrawRect);
end;
procedure TIpHtmlNodeIMG.ReportMapRects(M: TRectMethod);
begin
if IsMap then
M(GrossDrawRect);
end;
procedure TIpHtmlNodeIMG.ImageChange(NewPicture: TPicture);
var
OldDim,
Dim : TSize;
begin
{$IFOPT C+}
Owner.CheckImage(NewPicture);
{$ENDIF}
OldDim := GetDim(-1);
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
if (FPicture <> nil)
and (FPicture.Graphic <> nil)
and (FPicture.Graphic is TGifImage)
then
Owner.GifImages.Remove(Self);
{$ELSE}
if (FPicture <> nil)
and (FPicture.Graphic <> nil)
and (FPicture.Graphic is TIpAnimatedGraphic)
then
Owner.AnimationFrames.Remove(Self);
{$ENDIF}
{$ELSE}
if (FPicture <> nil)
and (FPicture.Graphic <> nil) then begin
if FPicture.Graphic is TGifImage
then Owner.GifImages.Remove(Self)
else Owner.OtherImages.Remove(Self); //JMN
end;
{$ENDIF}
if FPicture <> Owner.DefaultImage then
FPicture.Free;
FPicture := NewPicture;
{$IFDEF IP_LAZARUS} //JMN
{$IFDEF UseGifImageUnit}
if (FPicture <> nil)
and (FPicture.Graphic <> nil)
and (FPicture.Graphic is TGifImage)
then
Owner.GifImages.Add(Self);
{$ELSE}
if (FPicture <> nil)
and (FPicture.Graphic <> nil)
and (FPicture.Graphic is TIpAnimatedGraphic)
then
Owner.AnimationFrames.Add(Self);
{$ENDIF}
{$ELSE}
if (FPicture <> nil)
and (FPicture.Graphic <> nil) then begin
if FPicture.Graphic is TGifImage
then Owner.GifImages.Add(Self)
else Owner.OtherImages.Add(Self); //JMN
end;
{$ENDIF}
SizeWidth.PixelsType := hpUndefined;
Dim := GetDim(0);
if (Dim.cx <> OldDim.cx)
or (Dim.cy <> OldDim.cy) then
InvalidateSize
else
Invalidate;
end;
procedure TIpHtmlNodeIMG.SetProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
end;
function TIpHtmlNodeIMG.GetDim(ParentWidth: Integer): TSize;
var
DimKnown, NoLoad : Boolean;
begin
if ParentWidth < 0 then begin
NoLoad := True;
ParentWidth := 0;
end else
NoLoad := False;
if (SizeWidth.PixelsType <> hpAbsolute)
or ((ParentWidth <> 0) and (SizeWidth.Value <> ParentWidth)) then begin
DimKnown := True;
if (Height.PixelsType <> hpUndefined) {(Height > -1)} {!!.10}
and (Width.LengthType <> hlUndefined) then begin
case Width.LengthType of
hlUndefined :
DimKnown := False;
hlAbsolute :
begin
FSize := SizeRec(Width.LengthValue, Height.Value);
end;
hlPercent :
begin
FSize := SizeRec(
round(ParentWidth * Width.LengthValue / 100)
- 2*HSpace - 2*Border, {!!.10}
Height.Value); {!!.10}
end;
end;
end else
DimKnown := False;
if not DimKnown then begin
if (FPicture <> nil) then begin
{$IFDEF IP_LAZARUS}
if FPicture.Graphic=nil then
// todo: needs to return the "text size" of GetHint
FSize := SizeRec(100,20)
else
{$ENDIF}
if ScaleBitmaps then {!!.10}
FSize := SizeRec(round(FPicture.Width * Aspect), round(FPicture.Height * Aspect))
else
FSize := SizeRec(FPicture.Width, FPicture.Height)
end else begin
if NoLoad then
FSize := SizeRec(0, 0)
else begin
LoadImage;
if FPicture <> nil then begin
if ScaleBitmaps then {!!.10}
FSize := SizeRec(round(FPicture.Width * Aspect), round(FPicture.Height * Aspect))
else
{$IFDEF IP_LAZARUS}
if FPicture.Graphic=nil then
// todo: needs to return the "text size" of GetHint
FSize := SizeRec(100,20)
else
{$ENDIF}
FSize := SizeRec(FPicture.Width, FPicture.Height);
end else
FSize := SizeRec(0, 0);
end;
end;
if FPicture <> nil then begin
case Width.LengthType of
hlUndefined :;
hlAbsolute :
begin
FSize := SizeRec(Width.LengthValue, FSize.cy);
end;
hlPercent :
begin
FSize := SizeRec(
round(ParentWidth * Width.LengthValue / 100)
- 2*HSpace - 2*Border, {!!.10}
FSize.cy);
end;
end;
if Height.PixelsType <> hpUndefined {Height <> -1} then {!!.10}
FSize.cy := Height.Value; {!!.10}
end;
end;
FSize := SizeRec(FSize.cx + 2*HSpace + 2*Border, FSize.cy + 2*VSpace + 2*Border);
SizeWidth.Value := ParentWidth;
SizeWidth.PixelsType := hpAbsolute;
end;
Result := FSize;
end;
procedure TIpHtmlNodeIMG.CalcMinMaxWidth(var Min, Max: Integer);
var
Dim : TSize;
begin
Dim := GetDim(0);
Min := Dim.cx;
Max := Min;
end;
procedure TIpHtmlNodeIMG.SetUseMap(const Value: string);
begin
if FUseMap <> '' then begin
Owner.MapImgList.Remove(Self);
Owner.ClearAreaList;
end;
FUseMap := Value;
if FUseMap <> '' then begin
Owner.MapImgList.Add(Self);
Owner.ClearAreaList;
end;
end;
function TIpHtmlNodeIMG.GetHint: string;
begin
Result := Alt;
end;
procedure TIpHtmlNodeIMG.SetBorder(const Value: Integer);
begin
FBorder := Value;
InvalidateSize;
end;
procedure TIpHtmlNodeIMG.SetHSpace(const Value: Integer);
begin
FHSpace := Value;
InvalidateSize;
end;
procedure TIpHtmlNodeIMG.SetVSpace(const Value: Integer);
begin
FVSpace := Value;
InvalidateSize;
end;
{!!.10 new}
constructor TIpHtmlNodeIMG.Create;
begin
inherited;
SizeWidth := TIpHtmlPixels.Create;
end;
procedure TIpHtmlNodeIMG.DimChanged(Sender: TObject);
begin
InvalidateSize;
end;
procedure TIpHtmlNodeIMG.InvalidateSize;
begin
inherited;
SizeWidth.PixelsType := hpUndefined;
end;
{ TIpHtmlNodeFORM }
constructor TIpHtmlNodeFORM.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
Props := TIpHtmlProps.Create(Owner);
end;
destructor TIpHtmlNodeFORM.Destroy;
begin
Props.Free;
inherited;
end;
procedure TIpHtmlNodeFORM.AddChild(Node: TIpHtmlNode; const UserData: Pointer);
begin
if Node is TIpHtmlNodeControl then
if TIpHtmlNodeControl(Node).SuccessFul then
TList(UserData).Add(Node);
end;
{$IFNDEF HtmlWithoutHttp}
procedure TIpHtmlNodeFORM.SubmitForm;
var
CList : TList;
FList,
VList : TStringList;
URLData: string;
FormData: TIpFormDataEntity;
procedure IndentifySuccessfulControls;
begin
EnumChildren(AddChild, CList);
end;
procedure BuildDataset;
var
i : Integer;
begin
for i := 0 to Pred(CList.Count) do
with TIpHtmlNodeControl(CList[i]) do
AddValues(FList, VList);
end;
procedure URLEncodeDataset;
function Escape(const S: string): string;
var
i : Integer;
begin
Result := '';
for i := 1 to length(S) do
case S[i] of
#0..#31, '+', '&', '%', '=' :
Result := Result + '%'+IntToHex(ord(S[i]),2);
' ' :
Result := Result + '+';
else
Result := Result + S[i];
end;
end;
var
i : Integer;
begin
URLData := '';
for i := 0 to Pred(FList.Count) do begin
if URLData <> '' then
URLData := URLData + '&';
URLData := URLData +
Escape(FList[i]) +
'=' +
Escape(VList[i]);
end;
end;
procedure MimeEncodeDataset;
var
i : Integer;
begin
FormData := TIpFormDataEntity.Create(nil);
for i := 0 to Pred(FList.Count) do
if copy(VList[i], 1, 7) = 'file://' then
FormData.AddFile(copy(VList[i], 8, length(VList[i])),
Accept, 'plain', embinary)
else
FormData.AddFormData(FList[i], VList[i]);
end;
procedure SubmitDataset;
begin
case Method of
hfmGet :
Owner.Get(Action + '?' + URLData);
hfmPost :
begin
Owner.Post(Action, FormData); {!!.12}
{The Formdata object will be freed by the post logic,
which is called asynchroneously via PostMessage.
Clear the pointer to prevent our finalization
section from stepping on it prematurely.}
FormData := nil; {!!.12}
end;
end;
end;
begin
FormData := nil;
CList := nil;
FList := nil;
VList := nil;
try
CList := TList.Create;
FList := TStringList.Create;
VList := TStringList.Create;
IndentifySuccessfulControls;
BuildDataset;
case Method of {!!.12}
hfmGet : {!!.12}
{if (EncType = '') or
(CompareText(EncType, 'application/x-www-form-urlencoded') = 0) then} {!!.12}
URLEncodeDataset;
else //hfmPost : {!!.12}
{else
if CompareText(EncType, 'multipart/form-data') = 0 then} {!!.12}
MimeEncodeDataset;
end; {!!.12}
{else
raise EIpHtmlException.Create(EncType + SHtmlEncNotSupported);} {!!.02} {!!.12}
SubmitDataset;
finally
FormData.Free;
CList.Free;
FList.Free;
VList.Free;
end;
end;
procedure TIpHtmlNodeFORM.SubmitRequest;
begin
SubmitForm;
end;
{$ENDIF}
procedure TIpHtmlNodeFORM.ResetRequest;
begin
ResetForm;
end;
procedure TIpHtmlNodeFORM.ResetControl(Node: TIpHtmlNode; const UserData: Pointer);
begin
if Node is TIpHtmlNodeControl then
TIpHtmlNodeControl(Node).Reset;
end;
procedure TIpHtmlNodeFORM.ResetForm;
begin
EnumChildren(ResetControl, nil);
end;
{ TIpHtmlNodeDL }
{!!.16 new}
procedure TIpHtmlNodeDL.Enqueue;
begin
EnqueueElement(Owner.HardLF);
EnqueueElement(Owner.LIndent);
inherited;
EnqueueElement(Owner.LOutdent);
end;
{ TIpHtmlNodeDT }
procedure TIpHtmlNodeDT.Enqueue;
begin
inherited;
EnqueueElement(Owner.HardLF);
end;
{ TIpHtmlNodeDD }
procedure TIpHtmlNodeDD.Enqueue;
begin
EnqueueElement(Owner.HardLF); {!!.16}
EnqueueElement(Owner.LIndent);
inherited;
EnqueueElement(Owner.LOutdent);
EnqueueElement(Owner.HardLF);
end;
{ TIpHtmlNodePRE }
constructor TIpHtmlNodePRE.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
Props := TIpHtmlProps.Create(Owner);
end;
destructor TIpHtmlNodePRE.Destroy;
begin
Props.Free;
inherited;
end;
procedure TIpHtmlNodePRE.SetProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
Props.Preformatted := True;
Props.FontName := Owner.FixedTypeface;
Props.FontSize := Props.FontSize - 2;
inherited SetProps(Props);
end;
procedure TIpHtmlNodePRE.Enqueue;
begin
if FChildren.Count > 0 then
EnqueueElement(Owner.HardLF);
inherited Enqueue;
if FChildren.Count > 0 then
EnqueueElement(Owner.HardLF);
end;
{ TIpHtmlNodeBLOCKQUOTE }
procedure TIpHtmlNodeBLOCKQUOTE.Enqueue;
begin
EnqueueElement(Owner.LIndent);
inherited;
EnqueueElement(Owner.LOutdent);
end;
{ TIpHtmlNodePhrase }
procedure TIpHtmlNodePhrase.ApplyProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
case Style of
hpsEM :
Props.FontStyle := Props.FontStyle + [fsItalic];
hpsSTRONG :
Props.FontStyle := Props.FontStyle + [fsBold];
hpsCODE :
Props.FontName := Owner.FixedTypeface;
hpsKBD :
Props.FontName := Owner.FixedTypeface;
hpsVAR :
Props.FontStyle := Props.FontStyle + [fsItalic];
hpsCITE :
Props.FontStyle := Props.FontStyle + [fsItalic];
end;
end;
{ TIpHtmlNodeAPPLET }
{!!.10 new}
destructor TIpHtmlNodeAPPLET.Destroy;
begin
inherited;
FWidth.Free;
end;
function TIpHtmlNodeAPPLET.GetHint: string;
begin
Result := Alt;
end;
procedure TIpHtmlNodeAPPLET.WidthChanged(Sender: TObject);
begin
InvalidateSize;
end;
{ TIpHtmlNodeBASEFONT }
procedure TIpHtmlNodeBASEFONT.ApplyProps(
const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
case Size of
1 : Props.FontSize := 8;
2 : Props.FontSize := 10;
3 : Props.FontSize := 12;
4 : Props.FontSize := 14;
5 : Props.FontSize := 18;
6 : Props.FontSize := 24;
7 : Props.FontSize := 36;
end;
Props.BaseFontSize := Size;
end;
{ TIpHtmlNodeINPUT }
procedure TIpHtmlNodeINPUT.SetImageGlyph(Picture: TPicture);
var
FBitmap : TBitmap;
begin
with TBitbtn(FControl) do begin
FBitmap := TBitmap.Create;
try
FBitmap.Width := Picture.Width;
FBitmap.Height := Picture.Height;
Picture.Graphic.Transparent := False;
FBitmap.TransparentMode := tmFixed;
FBitmap.TransparentColor := RGB(254, 254, 254);
FBitmap.Canvas.Draw(0, 0, Picture.Graphic);
Glyph.Assign(FBitmap);
Width := FBitmap.Width + 4;
Height := FBitmap.Height + 4;
finally
FBitmap.Free;
end;
end;
end;
procedure TIpHtmlNodeINPUT.Reset;
begin
case InputType of
hitText :
begin
with TEdit(FControl) do
Text := Value;
end;
hitPassword :
begin
with TEdit(FControl) do
Text := Value;
end;
hitCheckbox :
begin
with TCheckBox(FControl) do
Checked := Self.Checked;
end;
hitRadio :
begin
{Begin !!.14}
{$IFDEF VERSION3ONLY}
with FControl do
{$ELSE}
with THtmlRadioButton(FControl) do
{$ENDIF}
{End !!.14}
Checked := Self.Checked;
end;
end;
end;
procedure TIpHtmlNodeINPUT.CreateControl(Parent: TWinControl);
function OwnerForm: TIpHtmlNode;
begin
Result := FParentNode;
while (Result <> nil) and not (Result is TIpHtmlNodeFORM) do
Result := Result.FParentNode;
end;
begin
Owner.ControlCreate(Self);
case InputType of
hitText :
begin
FControl := TEdit.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TEdit(FControl) do begin
Text := Value;
MaxLength := Self.MaxLength;
if Self.Size <> -1 then
Width := Self.Size * TFriendPanel(Parent).Canvas.TextWidth('0')
else
Width := 20 * TFriendPanel(Parent).Canvas.TextWidth('0');
Enabled := not Self.Disabled;
ReadOnly := Self.ReadOnly;
OnChange := ButtonClick; {!!.03}
end;
end;
hitPassword :
begin
FControl := TEdit.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TEdit(FControl) do begin
Text := Value;
MaxLength := Self.MaxLength;
Width := Self.Size * TFriendPanel(Parent).Canvas.TextWidth('0');
Enabled := not Self.Disabled;
ReadOnly := Self.ReadOnly;
PasswordChar := '*';
OnChange := ButtonClick; {!!.03}
end;
end;
hitCheckbox :
begin
FControl := TCheckBox.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TCheckBox(FControl) do begin
Width := 13;
Height := 13;
Checked := Self.Checked;
Enabled := not Self.Disabled and not Self.Readonly;
OnClick := ButtonClick;
end;
end;
hitRadio :
begin
{Begin !!.14}
{$IFDEF VERSION3ONLY}
FControl := TRadioButton.Create(Parent);
{$ELSE}
FControl := THtmlRadioButton.Create(Parent);
{$ENDIF}
FControl.Tag := PtrInt(OwnerForm);
FControl.Visible := False;
FControl.Parent := Parent;
{$IFDEF VERSION3ONLY}
with TRadioButton(FControl) do begin
{$ELSE}
with THtmlRadioButton(FControl) do begin
{$ENDIF}
{End !!.14}
Width := 13;
Height := 13;
Checked := Self.Checked;
Enabled := not Self.Disabled and not Self.Readonly;
OnClick := ButtonClick;
end;
end;
hitSubmit :
begin
FControl := TButton.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TButton(FControl) do begin
if Self.Value <> '' then
Caption := Self.Value
else
Caption := SHtmlDefSubmitCaption;
Width := TFriendPanel(Parent).Canvas.TextWidth(Caption) + 40;
Height := TFriendPanel(Parent).Canvas.TextHeight(Caption) + 10;
Enabled := not Self.Disabled and not Self.Readonly;
OnClick := SubmitClick;
end;
end;
hitReset :
begin
FControl := TButton.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TButton(FControl) do begin
if Self.Value <> '' then
Caption := Self.Value
else
Caption := SHtmlDefResetCaption;
Width := TFriendPanel(Parent).Canvas.TextWidth(Caption) + 40;
Height := TFriendPanel(Parent).Canvas.TextHeight(Caption) + 10;
Enabled := not Self.Disabled and not Self.Readonly;
OnClick := ResetClick;
end;
end;
hitFile :
begin
FControl := TPanel.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TPanel(FControl) do begin
Width := 200;
Height := TFriendPanel(Parent).Canvas.TextHeight('Wy') + 12;
Enabled := not Self.Disabled and not Self.Readonly;
BevelInner := bvNone;
BevelOuter := bvNone;
BorderStyle := bsNone;
end;
FFileSelect := TButton.Create(Parent);
with FFileSelect do begin
Parent := FControl;
Height := TFriendPanel(Parent).Canvas.TextHeight(SHtmlDefBrowseCaption) + 10;
Width := TFriendPanel(Parent).Canvas.TextWidth(SHtmlDefBrowseCaption) + 40;
Left := FControl.Left + FControl.Width - Width;
Top := 1;
Caption := SHtmlDefBrowseCaption;
OnClick := FileSelect;
end;
FFileEdit := TEdit.Create(Parent);
with FFileEdit do begin
Parent := FControl;
Left := 1;
Top := 1;
Width := FControl.Width - FFileSelect.Width;
Height := FControl.Height - 2;
end;
end;
hitHidden :
begin
end;
hitImage :
begin
FControl := TBitbtn.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
Owner.DoGetImage(Self, Owner.BuildPath(Src), FPicture);
if FPicture = nil
then FPicture := Owner.DefaultImage;
with TBitbtn(FControl) do begin
Caption := Self.Value;
Enabled := not Self.Disabled and not Self.Readonly;
SetImageGlyph(FPicture);
end;
end;
hitButton :
begin
FControl := TButton.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TButton(FControl) do begin
Caption := Self.Value;
Width := TFriendPanel(Parent).Canvas.TextWidth(Caption) + 40;
Height := TFriendPanel(Parent).Canvas.TextHeight(Caption) + 10;
Enabled := not Self.Disabled and not Self.Readonly;
OnClick := ButtonClick;
end;
end;
end;
if FControl <> nil then
FControl.Hint := Alt;
end;
procedure TIpHtmlNodeINPUT.Draw;
begin
inherited;
{Begin !!.14}
{$IFDEF VERSION3ONLY}
if FControl is TRadioButton then begin
{$ELSE}
if FControl is THtmlRadioButton then begin
{$ENDIF}
if Props.BgColor <> -1 then
{$IFDEF VERSION3ONLY}
TRadioButton(FControl).Color := Props.BgColor;
{$ELSE}
THtmlRadioButton(FControl).Color := Props.BgColor;
{$ENDIF}
{End !!.14}
end;
end;
procedure TIpHtmlNodeINPUT.ImageChange(NewPicture: TPicture);
begin
{$IFOPT C+}
Owner.CheckImage(NewPicture);
{$ENDIF}
if FPicture <> Owner.DefaultImage then
FPicture.Free;
FPicture := NewPicture;
SetImageGlyph(FPicture);
InvalidateSize;
end;
procedure TIpHtmlNodeINPUT.AddValues(NameList, ValueList : TStringList);
var
S : string;
begin
S := '';
case InputType of
hitText,
hitPassword :
S := TEdit(FControl).Text;
hitCheckbox :
S := Value;
hitRadio :
S := Value;
hitFile :
S := 'file://'+FFileEdit.Text;
hitHidden : {!!.15}
S := FValue; {!!.15}
end;
if S <> '' then begin
NameList.Add(Name);
ValueList.Add(S);
end;
end;
function TIpHtmlNodeINPUT.Successful: Boolean;
begin
{Begin !!.15}
Result :=
(Name <> '')and
( (InputType = hitHidden) or
( (not Disabled) and
(InputType in [hitText, hitPassword, hitCheckbox, hitRadio , hitFile])
)
);
{End !!.15}
if Result then begin
case InputType of
hitText,
hitPassword :
Result := TEdit(FControl).Text <> '';
hitCheckbox :
Result := TCheckBox(FControl).Checked;
hitRadio :
{$IFDEF VERSION3ONLY}
Result := TRadioButton(FControl).Checked;
{$ELSE}
Result := THtmlRadioButton(FControl).Checked;
{$ENDIF}
hitFile :
Result := FFileEdit.Text <> '';
hitHidden : {!!.15}
Result := FValue <> ''; {!!.15}
end;
end;
end;
procedure TIpHtmlNodeINPUT.SubmitClick(Sender: TObject);
begin
SubmitRequest;
end;
procedure TIpHtmlNodeINPUT.ResetClick(Sender: TObject);
begin
ResetRequest;
end;
procedure TIpHtmlNodeINPUT.ButtonClick(Sender: TObject);
begin
case InputType of
hitText, {!!.03}
hitPassword : {!!.03}
Value := TEdit(FControl).Text; {!!.03}
hitCheckbox :
Checked := TCheckBox(FControl).Checked;
hitRadio :
{$IFDEF VERSION3ONLY}
Checked := TRadioButton(FControl).Checked;
{$ELSE}
Checked := THtmlRadioButton(FControl).Checked;
{$ENDIF}
end;
Owner.ControlClick(Self);
end;
function TIpHtmlNodeINPUT.GetHint: string;
begin
Result := Alt;
end;
procedure TIpHtmlNodeINPUT.FileSelect(Sender: TObject);
begin
with TOpenDialog.Create(FControl) do
try
if Execute then
FFileEdit.Text := FileName;
finally
free;
end;
end;
destructor TIpHtmlNodeINPUT.Destroy;
begin
inherited;
FPicture.Free;
end;
{ TIpHtmlNodeSELECT }
procedure TIpHtmlNodeSELECT.AddValues(NameList, ValueList : TStringList);
var
i : Integer;
begin
if FControl is TListBox then
with TListBox(FControl) do begin
for i := 0 to Pred(Items.Count) do
if Selected[i] then begin
NameList.Add(Self.Name);
ValueList.Add(Items[i]);
end;
end
else with TComboBox(FControl) do begin
NameList.Add(Self.Name);
ValueList.Add(Items[ItemIndex]);
end;
end;
procedure TIpHtmlNodeSELECT.CreateControl(Parent: TWinControl);
var
i, j, k, MinW : Integer;
S, SelectedText : string;
B : PAnsiChar;
begin
Owner.ControlCreate(Self);
if Self.Multiple then begin
FControl := TListBox.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TListBox(FControl) do begin
IntegralHeight := True;
Height := (4 + ItemHeight) * Self.Size;
MultiSelect := True;
Enabled := not Self.Disabled;
OnClick := ButtonClick; {!!.01}
end;
end else begin
FControl := TComboBox.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TComboBox(FControl) do begin
Style := csDropDownList;
Height := (4 + ItemHeight) * Self.Size;
Enabled := not Self.Disabled;
OnClick := ButtonClick; {!!.01}
end;
end;
MinW := 50;
SelectedText := '';
for i := 0 to Pred(FChildren.Count) do
if TObject(FChildren[i]) is TIpHtmlNodeOPTION then
with TIpHtmlNodeOPTION(FChildren[i]) do begin
if (FChildren.Count > 0)
and (TObject(FChildren[0]) is TIpHtmlNodeText) then begin
S := TIpHtmlNodeText(FChildren[0]).EscapedText;
Getmem(B, length(S) + 1);
try
TrimFormattingNormal(S, B);
if Self.Multiple then begin
j := TListBox(FControl).Items.Add(Trim(B));
MinW := MaxI2(MinW, TFriendPanel(Parent).Canvas.TextWidth(Trim(B)));
TListBox(FControl).Selected[j] := Selected;
end else begin
TComboBox(FControl).Items.Add(Trim(B));
MinW := MaxI2(MinW, TFriendPanel(Parent).Canvas.TextWidth(Trim(B)));
if Selected then
SelectedText := Trim(B);
end;
finally
FreeMem(B);
end;
end;
end
else
if TObject(FChildren[i]) is TIpHtmlNodeOPTGROUP then
with TIpHtmlNodeOPTGROUP(FChildren[i]) do begin
for j := 0 to Pred(FChildren.Count) do
if TObject(FChildren[j]) is TIpHtmlNodeOPTION then
with TIpHtmlNodeOPTION(FChildren[j]) do begin
if (FChildren.Count > 0)
and (TObject(FChildren[0]) is TIpHtmlNodeText) then begin
S := TIpHtmlNodeText(FChildren[0]).EscapedText;
GetMem(B, length(S) + 1);
try
TrimFormattingNormal(S, B);
if Self.Multiple then begin
k := TListBox(FControl).Items.Add(Trim(B));
MinW := MaxI2(MinW, TFriendPanel(Parent).Canvas.TextWidth(Trim(B)));
TListBox(FControl).Selected[k] := Selected;
end else begin
TComboBox(FControl).Items.Add(Trim(B));
MinW := MaxI2(MinW, TFriendPanel(Parent).Canvas.TextWidth(Trim(B)));
if Selected then
SelectedText := Trim(B);
end;
finally
FreeMem(B);
end;
end;
end;
end;
if SelectedText <> '' then
with TComboBox(FControl) do
ItemIndex := Items.IndexOf(SelectedText);
FControl.Width := MinW + 40;
end;
procedure TIpHtmlNodeSELECT.Reset;
var
i, j, k : Integer;
S, SelectedText : string;
B : PAnsiChar;
begin
SelectedText := '';
if Self.Multiple then
TListBox(FControl).Clear
else
TComboBox(FControl).Clear;
for i := 0 to Pred(FChildren.Count) do
if TObject(FChildren[i]) is TIpHtmlNodeOPTION then
with TIpHtmlNodeOPTION(FChildren[i]) do begin
if (FChildren.Count > 0)
and (TObject(FChildren[0]) is TIpHtmlNodeText) then begin
S := TIpHtmlNodeText(FChildren[0]).EscapedText;
GetMem(B, length(S) + 1);
try
TrimFormattingNormal(S, B);
if Self.Multiple then begin
j := TListBox(FControl).Items.Add(Trim(B));
TListBox(FControl).Selected[j] := Selected;
end else begin
TComboBox(FControl).Items.Add(Trim(B));
if Selected then
SelectedText := Trim(B);
end;
finally
FreeMem(B);
end;
end;
end
else
if TObject(FChildren[i]) is TIpHtmlNodeOPTGROUP then
with TIpHtmlNodeOPTGROUP(FChildren[i]) do begin
for j := 0 to Pred(FChildren.Count) do
if TObject(FChildren[j]) is TIpHtmlNodeOPTION then
with TIpHtmlNodeOPTION(FChildren[j]) do begin
if (FChildren.Count > 0)
and (TObject(FChildren[0]) is TIpHtmlNodeText) then begin
S := TIpHtmlNodeText(FChildren[0]).EscapedText;
GetMem(B, length(S) + 1);
try
TrimFormattingNormal(S, B);
if Self.Multiple then begin
k := TListBox(FControl).Items.Add(Trim(B));
TListBox(FControl).Selected[k] := Selected;
end else begin
TComboBox(FControl).Items.Add(Trim(B));
if Selected then
SelectedText := Trim(B);
end;
finally
FreeMem(B);
end;
end;
end;
end;
if not Self.Multiple and (SelectedText <> '') then
with TComboBox(FControl) do
ItemIndex := Items.IndexOf(SelectedText);
end;
function TIpHtmlNodeSELECT.Successful: Boolean;
begin
Result :=
(Name <> '')
and not Disabled;
if Result then
if FControl is TListBox then begin
Result := TListBox(FControl).SelCount > 0;
end
else begin
Result := TComboBox(FControl).ItemIndex <> -1;
end;
end;
{!!.01 - added}
procedure TIpHtmlNodeSELECT.ButtonClick(Sender: TObject);
begin
Owner.ControlClick(Self);
end;
{ TIpHtmlNodeTEXTAREA }
procedure TIpHtmlNodeTEXTAREA.AddValues(NameList,
ValueList: TStringList);
begin
NameList.Add(Name);
ValueList.Add(TMemo(FControl).Text);
end;
procedure TIpHtmlNodeTEXTAREA.CreateControl(Parent: TWinControl);
var
i : Integer;
S : string;
B : PAnsiChar;
begin
Owner.ControlCreate(Self);
FControl := TMemo.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TMemo(FControl) do begin
Width := Cols * TFriendPanel(Parent).Canvas.TextWidth('0');
Height := Rows * TFriendPanel(Parent).Canvas.TextHeight('Wy');
Enabled := not Self.Disabled;
end;
for i := 0 to Pred(FChildren.Count) do
if TObject(FChildren[i]) is TIpHtmlNodeText then begin
S := TIpHtmlNodeText(FChildren[i]).EscapedText;
Getmem(B, length(S) + 1);
try
TrimFormattingNormal(S, B);
TMemo(FControl).Lines.Add(B);
finally
FreeMem(B);
end;
end;
end;
procedure TIpHtmlNodeTEXTAREA.Reset;
var
i : Integer;
S : string;
B : PAnsiChar;
begin
TMemo(FControl).Clear;
for i := 0 to Pred(FChildren.Count) do
if TObject(FChildren[i]) is TIpHtmlNodeText then begin
S := TIpHtmlNodeText(FChildren[i]).EscapedText;
GetMem(B, length(S) + 1);
try
TrimFormattingNormal(S, B);
TMemo(FControl).Lines.Add(B);
finally
Freemem(B);
end;
end;
end;
function TIpHtmlNodeTEXTAREA.Successful: Boolean;
begin
Result := trim(TMemo(FControl).Text) <> '';
end;
{ TIpHtmlNodeHtml }
procedure TIpHtmlNodeHtml.CalcMinMaxWidth(
const RenderProps: TIpHtmlProps; var Min,
Max: Integer);
var
i : Integer;
begin
for i := 0 to FChildren.Count - 1 do
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then begin
TIpHtmlNodeBody(FChildren[i]).CalcMinMaxWidth(RenderProps,
Min, Max);
end;
end;
function TIpHtmlNodeHtml.GetHeight(const RenderProps: TIpHtmlProps;
const Width: Integer): Integer;
var
i : Integer;
begin
Result := 0;
for i := 0 to FChildren.Count - 1 do
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then begin
Result := TIpHtmlNodeBody(FChildren[i]).
GetHeight(RenderProps, Width);
end;
end;
{Begin !!.12}
function TIpHtmlNodeHtml.HasBodyNode : Boolean;
var
i : Integer;
begin
Result := False;
for i := 0 to FChildren.Count - 1 do begin
Result := (TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody);
if Result then
Break;
end;
end;
{End !!.12}
procedure TIpHtmlNodeHtml.Layout(const RenderProps: TIpHtmlProps;
const TargetRect: TRect);
var
i : Integer;
begin
for i := 0 to FChildren.Count - 1 do
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then
TIpHtmlNodeBody(FChildren[i]).Layout(
RenderProps, TargetRect);
end;
procedure TIpHtmlNodeHtml.Render(const RenderProps: TIpHtmlProps);
var
i : Integer;
begin
for i := 0 to FChildren.Count - 1 do
if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then
TIpHtmlNodeBody(FChildren[i]).
Render(RenderProps);
end;
{ TIpHtmlNodeCore }
procedure TIpHtmlNodeCore.ParseBaseProps;
{$IFDEF IP_LAZARUS}
var
Commands: TStringList;
{$ENDIF}
begin
with Owner do begin
Id := FindAttribute('ID');
ClassId := FindAttribute('CLASS');
Title := FindAttribute('TITLE');
Style := FindAttribute('STYLE');
end;
{$IFDEF IP_LAZARUS}
if Style <> '' then
begin
if CSS = nil then
CSS := TCSSProps.Create;
Commands := SeperateCommands(Style);
CSS.ReadCommands(Commands);
Commands.Free;
end;
{$ENDIF}
end;
{$IFDEF IP_LAZARUS}
procedure TIpHtmlNodeCore.LoadCSSProps(Owner: TIpHtml; var Element: TCSSProps; const Props: TIpHtmlProps);
var
TmpElement: TCSSProps;
begin
if Owner.CSS = nil then
exit;
TmpElement := Element;
if Element = nil then
begin
// process first the Main element
Element := Owner.CSS.GetElement(ElementName, '');
if Element <> nil then
LoadCSSProps(Owner, Element, Props);
// load the .class if there is one
Element := Owner.CSS.GetElement('', ClassId);
if Element <> nil then
LoadCSSProps(Owner, Element, Props);
// then load the element + class if there is one
if (Element=nil)and(ClassID<>'') then
Element := Owner.CSS.GetElement(ElementName, ClassId);
end;
if (Element <> nil) and (Props <> nil) then
begin
{$WARNING Setting these font colors and name messes up the alignment for some reason}
if Element.Color <> -1 then
Props.FontColor := Element.Color;
if Element.BGColor <> -1 then
Props.BgColor := Element.Color;
if Element.Font.Name <> '' then
Props.FontName := FirstString(Element.Font.Name);
{$WARNING TODO Set Font size from CSS Value}
// see http://xhtml.com/en/css/reference/font-size/
if Element.Font.Size <> '' then
props.FontSize:=GetFontSizeFromCSS(Props.FontSize, Element.Font.Size);
if Element.Font.Style <> cfsNormal then
begin
case Element.Font.Style of
cfsItalic,cfsOblique: Props.FontStyle := Props.FontStyle + [fsItalic];
cfsInherit: ; // what to do?: search through parent nodes looking for a computed value
end;
end;
if Element.Font.Weight <> cfwNormal then
begin
case Element.Font.Weight of
cfwBold : Props.FontStyle := Props.FontStyle + [fsBold];
cfwBolder : Props.FontStyle := Props.FontStyle + [fsBold];
cfwLighter : Props.FontStyle := Props.FontStyle - [fsBold];
cfw100 : ;
cfw200 : ;
cfw300 : ;
cfw400 : ;
cfw500 : ;
cfw600 : ;
cfw700 : ;
cfw800 : ;
cfw900 : ;
end;
end;
end;
if TmpElement = nil then
begin
// lookup id elements
TmpElement := Owner.CSS.GetElement(Id);
if TmpElement <> nil then
LoadCSSProps(Owner, TmpElement, Props);
// lookup local elements for this tag, not from the stylesheet
TmpElement := CSS;
if TmpElement <> nil then
LoadCSSProps(Owner, TmpElement, Props);
end;
end;
function TIpHtmlNodeCore.ElementName: String;
begin
Result := FElementName;
end;
function TIpHtmlNodeCore.GetFontSizeFromCSS(CurrentFontSize:Integer;
aFontSize: string):Integer;
var
P: Integer;
begin
result := CurrentFontSize;
// check pt
P := Pos('pt',aFontSize);
if p>0 then
begin
p := StrToIntDef(copy(aFontSize,1,P-1), -1);
if P>0 then
begin
result := P;
exit;
end;
end;
end;
destructor TIpHtmlNodeCore.Destroy;
begin
if Assigned(FCSS) then
FCSS.Free;
inherited Destroy;
end;
{$ENDIF}
{ TIpHtmlNodeINS }
procedure TIpHtmlNodeINS.ApplyProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
Props.FontStyle := Props.FontStyle + [fsUnderline];
end;
{ TIpHtmlNodeDEL }
procedure TIpHtmlNodeDEL.ApplyProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
Props.FontStyle := Props.FontStyle + [fsStrikeOut];
end;
{ TIpHtmlNodeTHEAD }
constructor TIpHtmlNodeTHEAD.Create(ParentNode: TIpHtmlNode);
begin
inherited;
{$IFDEF IP_LAZARUS}
FElementName := 'thead';
{$ENDIF}
FVAlign := hva3Middle;
end;
{ TIpHtmlNodeTBODY }
constructor TIpHtmlNodeTBODY.Create(ParentNode: TIpHtmlNode);
begin
inherited;
{$IFDEF IP_LAZARUS}
FElementName := 'tbody';
{$ENDIF}
FVAlign := hva3Middle;
end;
{ TIpHtmlNodeSTYLE }
{!!.10 new}
function TIpHtmlNodeSTYLE.ElementQueueIsEmpty: Boolean;
begin
Result := True;
end;
procedure TIpHtmlNodeSTYLE.EnqueueElement(const Entry: PIpHtmlElement);
begin
end;
{ TIpHtmlNodeIFRAME }
procedure TIpHtmlNodeIFRAME.CreateControl(Parent: TWinControl);
begin
Owner.ControlCreate(Self);
Owner.CreateIFrame(Parent, Self, FControl);
end;
procedure TIpHtmlNodeIFRAME.AddValues(NameList, ValueList: TStringList);
begin
end;
procedure TIpHtmlNodeIFRAME.Reset;
begin
end;
function TIpHtmlNodeIFRAME.Successful: Boolean;
begin
Result := False;
end;
{!!.10 new}
destructor TIpHtmlNodeIFRAME.Destroy;
begin
inherited;
FHeight.Free;
FWidth.Free;
end;
procedure TIpHtmlNodeIFRAME.WidthChanged(Sender: TObject);
begin
InvalidateSize;
end;
procedure TIpHtmlNodeIFRAME.SetAlign(const Value: TIpHtmlAlign);
begin
if Value <> FAlign then begin
FAlign := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeIFRAME.SetFrameBorder(const Value: Integer);
begin
if Value <> FFrameBorder then begin
FFrameBorder := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeIFRAME.SetMarginHeight(const Value: Integer);
begin
if Value <> FMarginHeight then begin
FMarginHeight := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeIFRAME.SetMarginWidth(const Value: Integer);
begin
if Value <> FMarginWidth then begin
FMarginWidth := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeIFRAME.SetScrolling(
const Value: TIpHtmlFrameScrolling);
begin
if Value <> FScrolling then begin
FScrolling := Value;
InvalidateSize;
end;
end;
{ TIpHtmlNodeBUTTON }
procedure TIpHtmlNodeBUTTON.AddValues(NameList, ValueList : TStringList);
begin
end;
constructor TIpHtmlNodeBUTTON.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
Owner.ControlList.Add(Self);
end;
procedure TIpHtmlNodeBUTTON.CreateControl(Parent: TWinControl);
begin
Owner.ControlCreate(Self);
FControl := TButton.Create(Parent);
FControl.Visible := False;
FControl.Parent := Parent;
with TButton(FControl) do begin
Enabled := not Self.Disabled;
Caption := Value;
case ButtonType of
hbtSubmit :
begin
OnClick := SubmitClick;
if Caption = '' then
Caption := SHtmlDefSubmitCaption;
end;
hbtReset :
begin
OnClick := ResetClick;
if Caption = '' then
Caption := SHtmlDefResetCaption;
end;
hbtButton :
begin
OnClick := ButtonClick;
end;
end;
Width := TFriendPanel(Parent).Canvas.TextWidth(Caption) + 40;
Height := TFriendPanel(Parent).Canvas.TextHeight(Caption) + 10;
end;
end;
destructor TIpHtmlNodeBUTTON.Destroy;
begin
Owner.ControlList.Remove(Self);
inherited;
end;
procedure TIpHtmlNodeBUTTON.Reset;
begin
end;
procedure TIpHtmlNodeBUTTON.ResetClick(Sender: TObject);
begin
ResetRequest;
end;
procedure TIpHtmlNodeBUTTON.SubmitClick(Sender: TObject);
begin
SubmitRequest;
end;
procedure TIpHtmlNodeBUTTON.ButtonClick(Sender: TObject);
begin
Owner.ControlClick(Self);
end;
function TIpHtmlNodeBUTTON.Successful: Boolean;
begin
Result := False;
end;
{ TIpHtmlNodeCOL }
{!!.10 new}
destructor TIpHtmlNodeCOL.Destroy;
begin
inherited;
FWidth.Free;
end;
{ TIpHtmlNodeCOLGROUP }
{!!.10 new}
destructor TIpHtmlNodeCOLGROUP.Destroy;
begin
inherited;
FWidth.Free;
end;
{ TIpHtmlNodeLABEL }
constructor TIpHtmlNodeLABEL.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
Owner.ControlList.Add(Self);
end;
destructor TIpHtmlNodeLABEL.Destroy;
begin
Owner.ControlList.Remove(Self);
inherited;
end;
{ TIpHtmlNodeNOBR }
procedure TIpHtmlNodeNOBR.ApplyProps(const RenderProps: TIpHtmlProps);
begin
Props.Assign(RenderProps);
Props.NoBreak := True;
end;
{ TIpHtmlProps }
function TIpHtmlProps.AIsEqualTo(Compare: TIpHtmlProps): Boolean;
begin
Result :=
(PropA = Compare.PropA);
end;
procedure TIpHtmlProps.Assign(Source: TIpHtmlProps);
begin
if PropA <> Source.PropA then begin
PropA.DecUse;
PropA := Source.PropA;
PropA.IncUse;
end;
if PropB <> Source.PropB then begin
PropB.DecUse;
PropB := Source.PropB;
PropB.IncUse;
end;
end;
function TIpHtmlProps.BIsEqualTo(Compare: TIpHtmlProps): Boolean;
begin
Result :=
(PropB = Compare.PropB);
end;
constructor TIpHtmlProps.Create(Owner: TIpHtml);
begin
FOwner := Owner;
PropA := Owner.DummyA;
PropA.IncUse;
PropB := Owner.DummyB;
PropB.IncUse;
end;
destructor TIpHtmlProps.Destroy;
begin
PropA.DecUse;
PropB.DecUse;
inherited;
end;
function TIpHtmlProps.GetAlignment: TIpHtmlAlign;
begin
Result := PropB.Alignment;
end;
function TIpHtmlProps.GetALinkColor: TColor;
begin
Result := PropB.ALinkColor;
end;
function TIpHtmlProps.GetBaseFontSize: Integer;
begin
Result := PropA.BaseFontSize;
end;
function TIpHtmlProps.GetBgColor: TColor;
begin
Result := PropB.BgColor;
end;
function TIpHtmlProps.GetFontBaseline: Integer;
begin
Result := PropB.FontBaseline;
end;
function TIpHtmlProps.GetFontColor: TColor;
begin
Result := PropB.FontColor;
end;
function TIpHtmlProps.GetFontName: string;
begin
Result := PropA.FontName;
end;
function TIpHtmlProps.GetFontSize: Integer;
begin
Result := PropA.FontSize;
end;
function TIpHtmlProps.GetFontStyle: TFontStyles;
begin
Result := PropA.FontStyle;
end;
function TIpHtmlProps.GetLinkColor: TColor;
begin
Result := PropB.LinkColor;
end;
function TIpHtmlProps.GetNoBreak: Boolean;
begin
Result := PropB.NoBreak;
end;
function TIpHtmlProps.GetPreformatted: Boolean;
begin
Result := PropB.Preformatted;
end;
function TIpHtmlProps.GetVAlignment: TIpHtmlVAlign3;
begin
Result := PropB.VAlignment;
end;
function TIpHtmlProps.GetVLinkColor: TColor;
begin
Result := PropB.VLinkColor;
end;
function TIpHtmlProps.IsEqualTo(Compare: TIpHtmlProps): Boolean;
begin
Result :=
(PropA = Compare.PropA)
and (PropB = Compare.PropB);
end;
function TIpHtml.FindPropA(
const pFontName : string;
const pFontSize : Integer;
const pFontStyle : TFontStyles;
const pBaseFontSize : Integer): TIpHtmlPropA;
var
i: Integer;
begin
for i := 0 to Pred(PropACache.Count) do begin
Result := TIpHtmlPropA(PropACache[i]);
with Result do begin
if FontStyle <> pFontStyle then Continue;
if FontSize <> pFontSize then Continue;
if FontName <> pFontName then Continue;
if BaseFontSize <> pBaseFontSize then Continue;
Exit;
end;
end;
Result := nil;
end;
function TIpHtml.FindPropB(
const pFontBaseline : Integer;
const pFontColor : TColor;
const pAlignment : TIpHtmlAlign;
const pVAlignment : TIpHtmlVAlign3;
const pLinkColor : TColor;
const pVLinkColor : TColor;
const pALinkColor : TColor;
const pBgColor : TColor;
const pPreformatted : Boolean;
const pNoBreak : Boolean
): TIpHtmlPropB;
var
i: Integer;
begin
for i := 0 to Pred(PropBCache.Count) do begin
Result := TIpHtmlPropB(PropBCache[i]);
with Result do begin
if VAlignment <> pVAlignment then Continue;
if FontColor <> pFontColor then Continue;
if Alignment <> pAlignment then Continue;
if LinkColor <> pLinkColor then Continue;
if VLinkColor <> pVLinkColor then Continue;
if ALinkColor <> pALinkColor then Continue;
if BgColor <> pBgColor then Continue;
if Preformatted <> pPreformatted then Continue;
if NoBreak <> pNoBreak then Continue;
if FontBaseline <> pFontBaseline then Continue;
Exit;
end;
end;
Result := nil;
end;
procedure TIpHtmlProps.SetAlignment(const Value: TIpHtmlAlign);
var
NewPropB : TIpHtmlPropB;
begin
if (Value <> haDefault) and (Value <> Alignment) then begin
NewPropB := FOwner.FindPropB(FontBaseline, FontColor, Value,
VAlignment, LinkColor, VLinkColor, ALinkColor,
BgColor, Preformatted, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FAlignment := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetALinkColor(const Value: TColor);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> ALinkColor then begin
NewPropB := FOwner.FindPropB(FontBaseline, FontColor, Alignment,
VAlignment, LinkColor, VLinkColor, Value,
BgColor, Preformatted, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FALinkColor := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetBaseFontSize(const Value: Integer);
var
NewPropA : TIpHtmlPropA;
begin
if Value <> BaseFontSize then begin
NewPropA := FOwner.FindPropA(FontName, FontSize, FontStyle, Value);
if NewPropA = nil then begin
NewPropA := TIpHtmlPropA.CreateCopy(PropA);
NewPropA.FBaseFontSize := Value;
FOwner.PropACache.Add(NewPropA);
end;
NewPropA.IncUse;
PropA.DecUse;
PropA := NewPropA;
end;
end;
procedure TIpHtmlProps.SetBgColor(const Value: TColor);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> BgColor then begin
NewPropB := FOwner.FindPropB(FontBaseline, FontColor, Alignment,
VAlignment, LinkColor, VLinkColor, ALinkColor,
Value, Preformatted, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FBgColor := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetFontBaseline(const Value: Integer);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> FontBaseline then begin
NewPropB := FOwner.FindPropB(Value, FontColor, Alignment,
VAlignment, LinkColor, VLinkColor, ALinkColor,
bgColor, Preformatted, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FFontBaseline := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetFontColor(const Value: TColor);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> FontColor then begin
NewPropB := FOwner.FindPropB(FontBaseline, Value, Alignment,
VAlignment, LinkColor, VLinkColor, ALinkColor,
bgColor, Preformatted, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FFontColor := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetFontName(const Value: string);
var
NewPropA : TIpHtmlPropA;
begin
if Value <> FontName then begin
NewPropA := FOwner.FindPropA(Value, FontSize, FontStyle, BaseFontSize);
if NewPropA = nil then begin
NewPropA := TIpHtmlPropA.CreateCopy(PropA);
NewPropA.FFontName := Value;
FOwner.PropACache.Add(NewPropA);
end;
NewPropA.IncUse;
PropA.DecUse;
PropA := NewPropA;
end;
end;
procedure TIpHtmlProps.SetFontSize(const Value: Integer);
var
NewPropA : TIpHtmlPropA;
begin
if Value <> FontSize then begin
NewPropA := FOWner.FindPropA(FontName, Value, FontStyle, BaseFontSize);
if NewPropA = nil then begin
NewPropA := TIpHtmlPropA.CreateCopy(PropA);
NewPropA.FFontSize := Value;
FOwner.PropACache.Add(NewPropA);
end;
NewPropA.IncUse;
PropA.DecUse;
PropA := NewPropA;
end;
end;
procedure TIpHtmlProps.SetFontStyle(const Value: TFontStyles);
var
NewPropA : TIpHtmlPropA;
begin
if Value <> FontStyle then begin
NewPropA := FOwner.FindPropA(FontName, FontSize, Value, BaseFontSize);
if NewPropA = nil then begin
NewPropA := TIpHtmlPropA.CreateCopy(PropA);
NewPropA.FFontStyle := Value;
FOwner.PropACache.Add(NewPropA);
end;
NewPropA.IncUse;
PropA.DecUse;
PropA := NewPropA;
end;
end;
procedure TIpHtmlProps.SetLinkColor(const Value: TColor);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> LinkColor then begin
NewPropB := FOwner.FindPropB(FontBaseline, FontColor, Alignment,
VAlignment, Value, VLinkColor, ALinkColor,
bgColor, Preformatted, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FLinkColor := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetNoBreak(const Value: Boolean);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> NoBreak then begin
NewPropB := FOwner.FindPropB(FontBaseline, FontColor, Alignment,
VAlignment, LinkColor, VLinkColor, ALinkColor,
bgColor, Preformatted, Value);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FNoBreak := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetPreformatted(const Value: Boolean);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> Preformatted then begin
NewPropB := FOwner.FindPropB(FontBaseline, FontColor, Alignment,
VAlignment, LinkColor, VLinkColor, ALinkColor,
bgColor, Value, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FPreformatted := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetVAlignment(const Value: TIpHtmlVAlign3);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> VAlignment then begin
NewPropB := FOwner.FindPropB(FontBaseline, FontColor, Alignment,
Value, LinkColor, VLinkColor, ALinkColor,
bgColor, Preformatted, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FVAlignment := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
procedure TIpHtmlProps.SetVLinkColor(const Value: TColor);
var
NewPropB : TIpHtmlPropB;
begin
if Value <> VLinkColor then begin
NewPropB := FOwner.FindPropB(FontBaseline, FontColor, Alignment,
VAlignment, LinkColor, Value, ALinkColor,
bgColor, Preformatted, NoBreak);
if NewPropB = nil then begin
NewPropB := TIpHtmlPropB.CreateCopy(FOwner, PropB);
NewPropB.FVLinkColor := Value;
FOwner.PropBCache.Add(NewPropB);
end;
NewPropB.IncUse;
PropB.DecUse;
PropB := NewPropB;
end;
end;
{ TIpHtmlPropA }
procedure TIpHtmlPropA.Assign(const Source: TIpHtmlPropA);
begin
if Source <> nil then begin
FontName := Source.FontName;
FontSize := Source.FontSize;
FontStyle := Source.FontStyle;
BaseFontSize := Source.BaseFontSize;
end;
end;
constructor TIpHtmlPropA.CreateCopy(Source: TIpHtmlPropA);
begin
inherited Create;
Assign(Source);
end;
procedure TIpHtmlPropA.DecUse;
begin
Dec(FUseCount);
end;
procedure TIpHtmlPropA.IncUse;
begin
Inc(FUseCount);
end;
procedure TIpHtmlPropA.SetBaseFontSize(const Value: Integer);
begin
if Value <> FBaseFontSize then begin
FBaseFontSize := Value;
FSizeOfSpaceKnown := False;
end;
end;
procedure TIpHtmlPropA.SetFontName(const Value: string);
begin
if Value <> FFontName then begin
FFontName := Value;
FSizeOfSpaceKnown := False;
end;
end;
procedure TIpHtmlPropA.SetFontSize(const Value: Integer);
begin
if Value <> FFontSize then begin
FFontSize := Value;
FSizeOfSpaceKnown := False;
end;
end;
procedure TIpHtmlPropA.SetFontStyle(const Value: TFontStyles);
begin
if Value <> FFontStyle then begin
FFontStyle := Value;
FSizeOfSpaceKnown := False;
end;
end;
procedure TIpHtmlPropA.SetKnownSizeOfSpace(const Size: TSize);
begin
if Size.cx = 0 then
raise EIpHtmlException.Create(SHtmlInternal); {!!.02}
FKnownSizeOfSpace := Size;
FSizeOfSpaceKnown := True;
end;
{ TIpHtmlPropB }
procedure TIpHtmlPropB.Assign(const Source: TIpHtmlPropB);
begin
if Source <> nil then begin
FontBaseline := Source.Fontbaseline;
FontColor := Source.FontColor;
Alignment := Source.Alignment;
VAlignment := Source.VAlignment;
LinkColor := Source.LinkColor;
ALinkColor := Source.ALinkColor;
VLinkColor := Source.VLinkColor;
Preformatted := Source.Preformatted;
BgColor := Source.BgColor;
NoBreak := Source.NoBreak;
end;
end;
constructor TIpHtmlPropB.Create(Owner: TIpHtml);
begin
inherited Create;
FOwner := Owner;
end;
constructor TIpHtmlPropB.CreateCopy(Owner: TIpHtml; Source: TIpHtmlPropB);
begin
inherited Create;
FOwner := Owner;
Assign(Source);
end;
procedure TIpHtmlPropB.DecUse;
var
i, c: Integer;
begin
Dec(FUseCount);
if UseCount = 0 then begin
for i := Pred(FOwner.PropBCache.Count) downto 0 do
if FOwner.PropBCache[i] = Self then begin
c := FOwner.PropBCache.Count;
if (c > 1)
and (i < c - 1) then
FOwner.PropBCache[i] := FOwner.PropBCache[c - 1];
FOwner.PropBCache.Delete(c - 1);
Free;
Exit;
end;
raise EIpHtmlException.Create(SHtmlInternal); {!!.02}
end else
if UseCount < 0 then
raise EIpHtmlException.Create(SHtmlInternal); {!!.02}
end;
procedure TIpHtmlPropB.IncUse;
begin
Inc(FUseCount);
end;
{ TIpHtmlNodeTableHeaderOrCell }
procedure TIpHtmlNodeTableHeaderOrCell.CalcMinMaxWidth(
const RenderProps: TIpHtmlProps; var Min, Max: Integer);
begin
Props.Assign(RenderProps);
Props.Alignment := Align;
if Self is TIpHtmlNodeTH then
Props.FontStyle := Props.FontStyle + [fsBold];
Props.VAlignment := VAlign;
if BgColor <> -1 then
Props.BgColor := BgColor;
if NoWrap then
Props.NoBreak := True;
inherited CalcMinMaxWidth(Props, Min, Max);
if NoWrap then {!!.10}
Min := Max; {!!.10}
end;
procedure TIpHtmlNodeTableHeaderOrCell.Render(
const RenderProps: TIpHtmlProps);
var
R : TRect;
begin
Props.Assign(RenderProps);
if Align <> haDefault then
Props.Alignment := Align
else
if Self is TIpHtmlNodeTH then
Props.Alignment := haCenter
else
Props.Alignment := haLeft;
if Self is TIpHtmlNodeTH then
Props.FontStyle := Props.FontStyle + [fsBold];
Props.VAlignment := VAlign;
if NoWrap then
Props.NoBreak := True;
{$IFDEF IP_LAZARUS}
//DebugBox(Owner.Target, PadRect, clYellow, True);
{$ENDIF}
if PageRectToScreen(PadRect, R) then begin
if (BgColor <> -1) then begin
Props.BgColor := BgColor;
Owner.Target.Brush.Color := BGColor;
Owner.Target.FillRect(R);
end;
end;
inherited Render(Props);
end;
constructor TIpHtmlNodeTableHeaderOrCell.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
FRowSpan := 1;
FColSpan := 1;
FAlign := haDefault;
FVAlign := hva3Middle;
{FHeight := -1;} {!!.10}
BgColor := -1;
end;
procedure TIpHtmlNodeTableHeaderOrCell.Layout(
const RenderProps: TIpHtmlProps; const TargetRect: TRect);
begin
Props.Assign(RenderProps);
if Align <> haDefault then
Props.Alignment := Align
else
if Self is TIpHtmlNodeTH then
Props.Alignment := haCenter;
if Self is TIpHtmlNodeTH then
Props.FontStyle := Props.FontStyle + [fsBold];
if NoWrap then
Props.NoBreak := True;
case VAlign of
hva3Default :;
else
Props.VAlignment := VAlign;
end;
if BgColor <> -1 then
Props.BgColor := BgColor;
inherited Layout(Props, TargetRect);
end;
destructor TIpHtmlNodeTableHeaderOrCell.Destroy;
begin
inherited;
FWidth.Free; {!!.10}
FHeight.Free; {!!.10}
end;
{!!.10 new}
procedure TIpHtmlNodeTableHeaderOrCell.DimChanged(Sender: TObject);
begin
InvalidateSize;
end;
{ TIpHtmlNodeInline }
procedure TIpHtmlNodeInline.Invalidate;
begin
FParentNode.Invalidate;
end;
procedure TIpHtmlNodeInline.EnqueueElement(
const Entry: PIpHtmlElement);
begin
FParentNode.EnqueueElement(Entry);
end;
{!!.10 new}
function TIpHtmlNodeInline.ElementQueueIsEmpty: Boolean;
begin
Result := FParentNode.ElementQueueIsEmpty;
end;
{ TIpHtmlNodeAlignInline }
constructor TIpHtmlNodeAlignInline.Create(ParentNode: TIpHtmlNode);
begin
inherited;
Props := TIpHtmlProps.Create(FOwner);
Element := Owner.NewElement(etObject, Self);
Element.Props := Props;
end;
destructor TIpHtmlNodeAlignInline.Destroy;
begin
Props.Free;
inherited;
end;
procedure TIpHtmlNodeAlignInline.Enqueue;
begin
EnqueueElement(Element);
end;
procedure TIpHtmlNodeAlignInline.SetAlignment(
const Value: TIpHtmlImageAlign);
begin
FAlignment := Value;
Invalidate;
end;
procedure TIpHtmlNodeAlignInline.SetRect(TargetRect: TRect);
begin
end;
{ TIpHtmlNodeControl }
procedure TIpHtmlNodeControl.CalcMinMaxWidth(var Min, Max: Integer);
begin
if FControl <> nil then
Min := FControl.Width
else
Min := 0;
Max := Min;
end;
constructor TIpHtmlNodeControl.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
Owner.ControlList.Add(Self);
Align := hiaBottom;
end;
destructor TIpHtmlNodeControl.Destroy;
begin
Owner.ControlList.Remove(Self);
inherited;
end;
procedure TIpHtmlNodeControl.Draw;
var
R : TRect;
TopLeft : TPoint;
Dim : TSize;
begin
if FControl <> nil then begin
TopLeft := Element.WordRect2.TopLeft;
R.TopLeft := TopLeft;
Dim := GetDim(0);
R.Right := TopLeft.x + Dim.cx;
R.Bottom := TopLeft.y + Dim.cy;
if PageRectToScreen(R, R) then begin
FControl.Left := R.Left;
FCOntrol.Top := R.Top;
FControl.Visible := True;
Shown := not ScaleBitmaps{True}; {Keep controls hidden during printing} {!!.10}
end else
FControl.Visible := False;
end;
end;
procedure TIpHtmlNodeControl.SetProps(const RenderProps: TIpHtmlProps);
{$IFDEF IP_LAZARUS}
var
Elem: TCSSProps = nil;
{$ENDIF}
begin
Props.Assign(RenderProps);
{$IFDEF IP_LAZARUS}
LoadCSSProps(Owner, Elem, Props);
{$ENDIF}
end;
function TIpHtmlNodeControl.GetDim(ParentWidth: Integer): TSize;
begin
if FControl <> nil then
Result := SizeRec(FControl.Width, FControl.Height)
else
Result := SizeRec(0, 0);
end;
procedure TIpHtmlNodeControl.HideUnmarkedControl;
begin
if not Shown and (FControl <> nil) then
FControl.Visible := False;
end;
procedure TIpHtmlNodeControl.UnmarkControl;
begin
Shown := False;
end;
{ TIpHtmlNodeNv }
procedure TIpHtmlNodeNv.Invalidate;
begin
end;
procedure TIpHtmlNodeNv.InvalidateSize;
begin
end;
procedure TIpHtmlNodeNv.EnqueueElement(
const Entry: PIpHtmlElement);
begin
end;
procedure TIpHtmlNodeNv.ReportDrawRects(M: TRectMethod);
begin
end;
procedure TIpHtmlNodeNv.SetProps(const RenderProps: TIpHtmlProps);
begin
end;
procedure TIpHtmlNodeNv.Enqueue;
begin
end;
{!!.10 new}
function TIpHtmlNodeNv.ElementQueueIsEmpty: Boolean;
begin
Result := True;
end;
{ TIpHtmlNodeFRAME }
procedure TIpHtmlNodeFRAME.SetFrameBorder(const Value: Integer);
begin
if Value <> FFrameBorder then begin
FFrameBorder := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeFRAME.SetMarginHeight(const Value: Integer);
begin
if Value <> FMarginHeight then begin
FMarginHeight := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeFRAME.SetMarginWidth(const Value: Integer);
begin
if Value <> FMarginWidth then begin
FMarginWidth := Value;
InvalidateSize;
end;
end;
procedure TIpHtmlNodeFRAME.SetScrolling(
const Value: TIpHtmlFrameScrolling);
begin
if Value <> FScrolling then begin
FScrolling := Value;
InvalidateSize;
end;
end;
{ TIpHtmlNodeFRAMESET }
{!!.10 new}
destructor TIpHtmlNodeFRAMESET.Destroy;
begin
inherited;
FCols.Free;
FRows.Free;
end;
{ TIpHtmlNodeGenInline }
constructor TIpHtmlNodeGenInline.Create(ParentNode: TIpHtmlNode);
begin
inherited Create(ParentNode);
Props := TIpHtmlProps.Create(Owner);
end;
destructor TIpHtmlNodeGenInline.Destroy;
begin
Props.Free;
inherited;
end;
procedure TIpHtmlNodeGenInline.SetProps(const RenderProps: TIpHtmlProps);
begin
ApplyProps(RenderProps);
inherited SetProps(Props);
end;
{ TIpHtmlInternalPanel }
constructor TIpHtmlInternalPanel.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle + [csCaptureMouse];
DragMode := dmManual;
HScroll := TIpHtmlScrollBar.Create(Self, sbHorizontal);
HScroll.Tracking := True;
VScroll := TIpHtmlScrollBar.Create(Self, sbVertical);
VScroll.Tracking := True;
HintWindow := THintWindow.Create(Self);
HintWindow.Color := Application.HintColor;
end;
destructor TIpHtmlInternalPanel.Destroy;
begin
HScroll.Free;
VScroll.Free;
HintWindow.Free;
inherited;
end;
procedure TIpHtmlInternalPanel.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := Style or WS_HSCROLL or WS_VSCROLL;
end;
procedure TIpHtmlInternalPanel.DoHotChange;
begin
if assigned(FOnHotChange) then
FOnHotChange(Self);
end;
procedure TIpHtmlInternalPanel.DoCurElementChange;
begin
if assigned(FOnCurElementChange) then
FOnCurElementChange(Self);
end;
procedure TIpHtmlInternalPanel.DoHotInvoke;
begin
if assigned(FOnHotClick) then
FOnHotClick(Hyper);
end;
procedure TIpHtmlInternalPanel.DoClick;
begin
if assigned(FOnClick) then
FOnClick(Hyper);
end;
procedure TIpHtmlInternalPanel.ShowHintNow(const NewHint: string); {!!.12}
var
Tw,Th : Integer;
Sc : TPoint;
{$IFNDEF IP_LAZARUS}
IPHC: TIpHtmlCustomPanel; //JMN
{$ENDIF}
begin
{$IFDEF IP_LAZARUS}
if HtmlPanel.ShowHints and (NewHint <> CurHint) then begin
{$ELSE}
IPHC := HtmlPanel; //JMN
if Assigned (IPHC) and IPHC.ShowHints and (NewHint <> CurHint) then begin
{$ENDIF}
{$IFDEF IP_LAZARUS}
if (NewHint<>'') and not HintWindow.Visible then begin
Tw := HintWindow.Canvas.TextWidth(NewHint);
Th := HintWindow.Canvas.TextHeight(NewHint);
Sc := ClientToScreen(Point(HintX,HintY));
HintWindow.ActivateHint(Rect(Sc.X - Tw div 2 - 6,
Sc.Y + 16 - 6,
Sc.X + Tw div 2 + 6,
Sc.Y + Th + 16 + 6),
NewHint);
end;
{$ELSE}
if (NewHint <> '') and not IsWindowVisible(HintWindow.Handle) then begin
Tw := HintWindow.Canvas.TextWidth(NewHint);
Th := HintWindow.Canvas.TextHeight(NewHint);
Sc := ClientToScreen(Point(HintX,HintY));
HintWindow.ActivateHint(Rect(Sc.X - Tw div 2 - 4,
Sc.Y + 16,
Sc.X + Tw div 2 + 4,
Sc.Y + Th + 16),
NewHint);
end;
{$ENDIF}
CurHint := NewHint;
HintShownHere := True;
end;
end;
procedure TIpHtmlInternalPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
OldHot : TIpHtmlNode;
OldCurElement : PIpHtmlElement;
{$IFNDEF IP_LAZARUS}
IPHC: TIpHtmlCustomPanel; //JMN
{$ENDIF}
begin
if MouseIsDown and HaveSelection then begin
SelEnd := Point(X + ViewLeft, Y + ViewTop);
SetSelection;
ScrollPtInView(Point(X + ViewLeft, Y + ViewTop));
end;
if Hyper <> nil then begin
OldHot := Hyper.HotNode;
OldCurElement := Hyper.CurElement;
Hyper.MouseMove(Point(X + ViewLeft, Y + ViewTop));
if (Hyper.HotNode <> OldHot) or (Hyper.HotPoint.x >= 0) then
DoHotChange;
if Hyper.HotNode <> nil then begin
if Hyper.CurElement <> nil then begin
Hyper.CurElement := nil;
if OldCurElement <> Hyper.CurElement then
DoCurElementChange;
end;
end else begin
{$IFDEF IP_LAZARUS}
if HtmlPanel.AllowTextSelect then begin
{$ELSE}
IPHC := HtmlPanel; //JMN
if Assigned (IPHC) and IPHC.AllowTextSelect then begin
{$ENDIF}
if Hyper.CurElement <> nil then begin
if Hyper.CurElement.ElementType = etWord then
Cursor := crIBeam
else
Cursor := crDefault;
end else
Cursor := crDefault;
end;
if OldCurElement <> Hyper.CurElement then
DoCurElementChange;
end;
end;
if (Hyper <> nil) and (Hyper.HotNode <> nil) then
Hint := Hyper.HotNode.GetHint
else
if (Hyper <> nil) and (Hyper.CurElement <> nil)
and (Hyper.CurElement.ElementType = etObject)
and (Hyper.CurElement.Owner <> nil) then
Hint := Hyper.CurElement.Owner.GetHint
else
Hint := '';
{$IFNDEF IP_LAZARUS}
if NewSelection then begin
ClearSelection;
SelStart := Point(X + ViewLeft, Y + ViewTop);
NewSelection := False;
HaveSelection := True;
end;
{$ENDIF}
inherited;
if (Hint <> CurHint) and ((abs(HintX - X) > 4) or (abs(HintY - Y) > 4)) then begin
{$IFDEF IP_LAZARUS}
if HintWindow.Visible then
{$ELSE}
if IsWindowVisible(HintWindow.Handle) then
{$ENDIF}
HideHint;
HintShownHere := False;
end;
HintX := X;
HintY := Y;
if not HintShownHere then
ShowHintNow(Hint);
end;
procedure TIpHtmlInternalPanel.HideHint;
begin
{$IFDEF IP_LAZARUS}
HintWindow.Visible := False;
{$ELSE}
HintWindow.ReleaseHandle;
{$ENDIF}
end;
procedure TIpHtmlInternalPanel.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
{$IFNDEF IP_LAZARUS}
var
IPHC: TIpHtmlCustomPanel; //JMN
{$ENDIF}
begin
MouseDownX := X;
MouseDownY := Y;
MouseIsDown := True;
{$IFDEF IP_LAZARUS}
if (Button=mbLeft) and HtmlPanel.AllowTextSelect then begin
ClearSelection;
SelStart := Point(X + ViewLeft, Y + ViewTop);
NewSelection := False;
HaveSelection := True;
end;
{$ELSE}
IPHC := HtmlPanel; //JMN
if Assigned (IPHC)
then NewSelection := IPHC.AllowTextSelect and (Button = mbLeft);
{$ENDIF}
inherited;
end;
procedure TIpHtmlInternalPanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
MouseIsDown := False;
if (abs(MouseDownX - X) < 4)
and (abs(MouseDownY - Y) < 4) then
if (Button = mbLeft) and (Hyper.HotNode <> nil) then
{$IFDEF IP_LAZARUS}
// to avoid references to invalid objects do it asynchronously
Application.QueueAsyncCall(AsyncHotInvoke, 0)
{$ELSE}
DoHotInvoke
{$ENDIF}
else
DoClick;
end;
procedure TIpHtmlInternalPanel.Paint;
var
CR : TRect;
begin
CR := GetClientRect;
if not ScaleBitmaps {printing} {!!.10}
and (Hyper <> nil) then
Hyper.Render(Canvas,
Rect(
ViewLeft, ViewTop,
ViewLeft + (CR.Right - CR.Left),
ViewTop + (CR.Bottom - CR.Top)),
True,
Point(0, 0)) {!!.10}
else
Canvas.FillRect(CR);
{$IFDEF IP_LAZARUS}
//DebugBox(CR, clYellow);
//Debugbox(Canvas.ClipRect,clLime, true);
{$ENDIF}
end;
{!!.10 new}
procedure TIpHtmlInternalPanel.BeginPrint;
var
LogPixX, LMarginPix, RMarginPix,
LogPixY, TMarginPix, BMarginPix,
H: Integer;
begin
if InPrint = 0 then begin
SetRectEmpty(PrintPageRect);
if Hyper.TitleNode <> nil then
Printer.Title := Hyper.TitleNode.Title
else
Printer.Title := 'HTML Document';
Printer.BeginDoc;
Printed := False;
ScaleBitmaps := True;
GetRelativeAspect(Printer.Canvas.Handle);
BWPrinter := GetDeviceCaps(Printer.Canvas.Handle, PLANES) = 1;
LogPixX := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSX);
LMarginPix := round(HtmlPanel.PrintSettings.MarginLeft * LogPixX);
RMarginPix := round(HtmlPanel.PrintSettings.MarginRight * LogPixX);
PrintWidth := Printer.PageWidth - LMarginPix - RMarginPix;
LogPixY := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);
TMarginPix := round(HtmlPanel.PrintSettings.MarginTop * LogPixY);
BMarginPix := round(HtmlPanel.PrintSettings.MarginBottom * LogPixY);
PrintHeight := Printer.PageHeight - TMarginPix - BMarginPix;
PrintTopLeft := Point(LMarginPix, TMarginPix);
{PrintBottomRight := Point(
Printer.PageWidth - RMarginPix,
Printer.PageHeight - BMarginPix);} {!!.12}
PrintPageRect := Hyper.GetPageRect(Printer.Canvas,
PrintWidth, PrintHeight);
H := PrintPageRect.Bottom - PrintPageRect.Top;
PageCount := H div PrintHeight;
if H mod PrintHeight <> 0 then
Inc(PageCount);
end;
Inc(InPrint);
end;
{!!.10 new}
procedure TIpHtmlInternalPanel.EndPrint;
begin
Dec(InPrint);
if InPrint = 0 then begin
if Printed then
Printer.EndDoc
else
Printer.Abort;
ScaleBitmaps := False;
InvalidateSize;
end;
end;
procedure TIpHtmlInternalPanel.PrintPages(FromPage, ToPage: Integer);
var
CR : TRect;
var
i : Integer;
begin
{CR := Rect(0, 0, Printer.PageWidth, 0);}
if (Hyper <> nil) then begin
{Printer.BeginDoc;}
BeginPrint; {!!.10}
try
(*
ScaleBitmaps := True; {!!.02}
GetRelativeAspect(Printer.Canvas.Handle); {!!.02}
PrintPageRect := Hyper.GetPageRect(Printer.Canvas,
Printer.PageWidth, Printer.PageHeight);
*)
CR := Rect(0, 0, PrintWidth, 0); {!!.10}
for i := FromPage to ToPage do begin
CR.Top := (i - 1) * PrintHeight; {!!.10}
CR.Bottom := Cr.Top + PrintHeight; {!!.10}
Hyper.Render(Printer.Canvas, CR, False, PrintTopLeft); {!!.10}
if i < ToPage then
Printer.NewPage;
Printed := True; {!!.10}
end;
finally
{ScaleBitmaps := False;} {!!.10}
{Printer.EndDoc;} {!!.10}
{InvalidateSize;} {!!.10}
EndPrint; {!!.10}
end;
end;
end;
{!!.10 new}
procedure TIpHtmlInternalPanel.PrintPreview;
begin
if (Hyper <> nil) then begin
BeginPrint;
try
with TIpHTMLPreview.Create(Application) do
try
lblMaxPage.Caption := IntToStr(PageCount);
FCurPage := 1;
HTML := Hyper;
ScaleFonts := True;
try
OwnerPanel := Self;
ShowModal;
finally
ScaleFonts := False;
end;
finally
Free;
end;
finally
EndPrint;
end;
end;
end;
procedure TIpHtmlInternalPanel.EraseBackground(DC: HDC);
begin
//
end;
function TIpHtmlInternalPanel.GetPrintPageCount: Integer;
{var
H : Integer;} {!!.10}
begin
BeginPrint; {!!.10}
try {!!.10}
Result := PageCount; {!!.10}
finally {!!.10}
EndPrint; {!!.10}
end; {!!.10}
{!!.10
SetRectEmpty(PrintPageRect);
if Hyper <> nil then begin
PrintPageRect := Hyper.GetPageRect(Printer.Canvas,
Printer.PageWidth, Printer.PageHeight);
end;
H := PrintPageRect.Bottom - PrintPageRect.Top;
Result := H div Printer.PageHeight;
if H mod Printer.PageHeight <> 0 then
Inc(Result);
}
end;
procedure TIpHtmlInternalPanel.InvalidateSize;
begin
if Hyper <> nil then
PageRect := Hyper.GetPageRect(Canvas, ClientWidth, 0);
Invalidate;
end;
procedure TIpHtmlInternalPanel.Resize;
begin
inherited;
InvalidateSize;
end;
function TIpHtmlInternalPanel.PagePtToScreen(const Pt : TPoint): TPoint;
{-convert coordinates of point passed in to screen coordinates}
begin
Result := Pt;
Dec(Result.x, ViewLeft);
Dec(Result.y, ViewTop);
end;
procedure TIpHtmlInternalPanel.ScrollInViewRaw(R : TRect);
begin
R.TopLeft := PagePtToScreen(R.TopLeft);
R.BottomRight := PagePtToScreen(R.BottomRight);
if R.Left < 0 then
with HScroll do
Position := Position + R.Left
else if R.Right > ClientWidth then begin
if R.Right - R.Left > ClientWidth then
R.Right := R.Left + ClientWidth;
with HScroll do
Position := Position + R.Right - ClientWidth;
end;
if R.Top < 0 then
with VScroll do
Position := Position + R.Top
else if R.Bottom > ClientHeight then begin
if R.Bottom - R.Top > ClientHeight then
R.Bottom := R.Top + ClientHeight;
with VScroll do
Position := Position + R.Bottom - ClientHeight;
end;
end;
procedure TIpHtmlInternalPanel.ScrollInView(R : TRect);
begin
R.Bottom := R.Top + (ClientHeight - (R.Bottom - R.Top) - 10);
R.Right := R.Left + (ClientWidth - (R.Right - R.Left) - 10);
ScrollInViewRaw(R);
end;
procedure TIpHtmlInternalPanel.ScrollPtInView(P : TPoint);
begin
P := PagePtToScreen(P);
if P.x < 0 then
with HScroll do
Position := Position + P.x
else if P.x > ClientWidth then begin
with HScroll do
Position := Position + P.x - ClientWidth;
end;
if P.y < 0 then
with VScroll do
Position := Position + P.y
else if P.y > ClientHeight then begin
with VScroll do
Position := Position + P.y - ClientHeight;
end;
end;
procedure TIpHtmlInternalPanel.ScrollRequest(Sender: TIpHtml; const R: TRect);
begin
ScrollInView(R);
end;
procedure TIpHtmlInternalPanel.SetHtml(const Value: TIpHtml);
begin
FHyper := Value;
InvalidateSize;
end;
procedure TIpHtmlInternalPanel.SetPageRect(const Value: TRect);
begin
if not SettingPageRect then begin
SettingPageRect := True;
FPageRect := Value;
HScroll.CalcAutoRange;
VScroll.CalcAutoRange;
SettingPageRect := False;
end;
end;
procedure TIpHtmlInternalPanel.UpdateScrollBars;
begin
if not FUpdatingScrollBars and HandleAllocated then
try
FUpdatingScrollBars := True;
if VScroll.NeedsScrollBarVisible then
begin
HScroll.Update(False, True);
VScroll.Update(True, False);
end
else if HScroll.NeedsScrollBarVisible then
begin
VScroll.Update(False, True);
HScroll.Update(True, False);
end
else
begin
VScroll.Update(False, False);
HScroll.Update(True, False);
end;
finally
FUpdatingScrollBars := False;
end;
end;
procedure TIpHtmlInternalPanel.WMHScroll(var Message: TWMHScroll);
begin
{$IFDEF IP_LAZARUS}
if HScroll.Visible then
HScroll.ScrollMessage(Message);
{$ELSE}
if (Message.ScrollBar = 0) and HScroll.Visible then
HScroll.ScrollMessage(Message) else
inherited;
{$ENDIF}
end;
procedure TIpHtmlInternalPanel.WMVScroll(var Message: TWMVScroll);
begin
{$IFDEF IP_LAZARUS}
if VScroll.Visible then
VScroll.ScrollMessage(Message);
{$ELSE}
if (Message.ScrollBar = 0) and VScroll.Visible then
VScroll.ScrollMessage(Message) else
inherited;
{$ENDIF}
end;
{$IFDEF IP_LAZARUS}
procedure TIpHtmlInternalPanel.AsyncHotInvoke(data: ptrint);
begin
DoHotInvoke;
end;
{$ENDIF}
procedure TIpHtmlInternalPanel.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TIpHtmlInternalPanel.DoOnMouseWheel(Shift: TShiftState; Delta, XPos,
YPos: SmallInt);
var
I : Integer;
begin
if Delta < 0 then begin
for I := 1 to WheelDelta do
Perform(WM_VSCROLL, MAKELONG(SB_LINEDOWN, 0), 0);
end else if Delta > 0 then begin
for I := 1 to WheelDelta do
Perform(WM_VSCROLL, MAKELONG(SB_LINEUP, 0), 0);
end;
end;
{$IFDEF Version4}
procedure TIpHtmlInternalPanel.MouseWheelHandler(var Message: TMessage);
begin
inherited;
with Message do
DoOnMouseWheel(KeysToShiftState(LOWORD(wParam)),
HIWORD(wParam),
LOWORD(lParam), HIWORD(lParam));
end;
{$ENDIF}
procedure TIpHtmlInternalPanel.ClearSelection;
begin
Hyper.SetSelection(Point(-1, -1), Point(-1, -1));
HaveSelection := False;
end;
procedure TIpHtmlInternalPanel.SetSelection;
begin
if Hyper <> nil then
Hyper.SetSelection(SelStart, SelEnd);
end;
function TIpHtmlInternalPanel.HtmlPanel: TIpHtmlCustomPanel;
begin
Result := TIpHtmlPanel(Parent);
{$IFDEF IP_LAZARUS}
while not (Result is TIpHtmlPanel) do
{$ELSE}
while Assigned(Result) and (Result.ClassType <> TIpHtmlPanel) do //JMN
{$ENDIF}
Result := TIpHtmlPanel(Result.Parent);
end;
{ TIpHtmlScrollBar }
constructor TIpHtmlScrollBar.Create(AControl: TIpHtmlInternalPanel;
AKind: TScrollBarKind);
begin
inherited Create;
FControl := AControl;
FKind := AKind;
FPageIncrement := 80;
FIncrement := FPageIncrement div 10;
FVisible := True;
{FDelay := 10;} {!!.12}
{FLineDiv := 4;} {!!.12}
{FPageDiv := 12;} {!!.12}
{FColor := clBtnHighlight;} {!!.12}
{FParentColor := True;} {!!.12}
FUpdateNeeded := True;
end;
procedure TIpHtmlScrollBar.CalcAutoRange;
begin
if Kind = sbHorizontal then
DoSetRange(FControl.PageRect.Right)
else
DoSetRange(FControl.PageRect.Bottom);
end;
function TIpHtmlScrollBar.ControlSize(ControlSB, AssumeSB: Boolean): Integer;
var
BorderAdjust: Integer;
function ScrollBarVisible(Code: Word): Boolean;
var
Style: Longint;
begin
Style := WS_HSCROLL;
if Code = SB_VERT then Style := WS_VSCROLL;
Result := GetWindowLong(FControl.Handle, GWL_STYLE) and Style <> 0;
end;
function Adjustment(Code, Metric: Word): Integer;
begin
Result := 0;
if not ControlSB then
if AssumeSB and not ScrollBarVisible(Code) then
Result := -(GetSystemMetrics(Metric) - BorderAdjust)
else if not AssumeSB and ScrollBarVisible(Code) then
Result := GetSystemMetrics(Metric) - BorderAdjust;
end;
begin
BorderAdjust := Integer(GetWindowLong(FControl.Handle, GWL_STYLE) and
(WS_BORDER or WS_THICKFRAME) <> 0);
if Kind = sbVertical then
Result := FControl.ClientHeight + Adjustment(SB_HORZ, SM_CXHSCROLL) else
Result := FControl.ClientWidth + Adjustment(SB_VERT, SM_CYVSCROLL);
end;
function TIpHtmlScrollBar.NeedsScrollBarVisible: Boolean;
begin
Result := FRange > ControlSize(False, False);
end;
procedure TIpHtmlScrollBar.ScrollMessage(var Msg: TWMScroll);
function GetRealScrollPosition: Integer;
var
SI: TScrollInfo;
Code: Integer;
begin
SI.cbSize := SizeOf(TScrollInfo);
SI.fMask := SIF_TRACKPOS;
Code := SB_HORZ;
if FKind = sbVertical then
Code := SB_VERT;
Result := Msg.Pos;
if FlatSB_GetScrollInfo(FControl.Handle, Code, SI) then
Result := SI.nTrackPos;
end;
begin
with Msg do
case ScrollCode of
SB_LINEUP:
SetPosition(FPosition - FIncrement);
SB_LINEDOWN:
SetPosition(FPosition + FIncrement);
SB_PAGEUP:
SetPosition(FPosition - ControlSize(True, False));
SB_PAGEDOWN:
SetPosition(FPosition + ControlSize(True, False));
SB_THUMBPOSITION:
if FCalcRange > 32767 then
SetPosition(GetRealScrollPosition)
else
SetPosition(Pos);
SB_THUMBTRACK:
if Tracking then
if FCalcRange > 32767 then
SetPosition(GetRealScrollPosition)
else
SetPosition(Pos);
SB_TOP:
SetPosition(0);
SB_BOTTOM:
SetPosition(FCalcRange);
SB_ENDSCROLL:
;
end;
end;
procedure TIpHtmlScrollBar.SetPosition(Value: Integer);
var
Code: Word;
begin
if csReading in FControl.ComponentState then
FPosition := Value
else begin
if Value > FCalcRange then Value := FCalcRange
else if Value < 0 then Value := 0;
if Kind = sbHorizontal then
Code := SB_HORZ else
Code := SB_VERT;
if Value <> FPosition then
begin
FPosition := Value;
if Kind = sbHorizontal then
FControl.ViewLeft := Value
else
FControl.ViewTop := Value;
FControl.Invalidate;
end;
if FlatSB_GetScrollPos(FControl.Handle, Code) <> FPosition then
FlatSB_SetScrollPos(FControl.Handle, Code, FPosition, True);
end;
end;
procedure TIpHtmlScrollBar.DoSetRange(Value: Integer);
begin
FRange := Value;
if FRange < 0 then FRange := 0;
FControl.UpdateScrollBars;
end;
procedure TIpHtmlScrollBar.SetVisible(Value: Boolean);
begin
FVisible := Value;
FControl.UpdateScrollBars;
end;
procedure TIpHtmlScrollBar.Update(ControlSB, AssumeSB: Boolean);
type
TPropKind = (pkStyle, pkButtonSize, pkThumbSize, pkSize, pkBkColor);
const
Props: array[TScrollBarKind, TPropKind] of Integer = (
(WSB_PROP_HSTYLE, WSB_PROP_CXHSCROLL, WSB_PROP_CXHTHUMB, WSB_PROP_CYHSCROLL,
WSB_PROP_HBKGCOLOR),
(WSB_PROP_VSTYLE, WSB_PROP_CYVSCROLL, WSB_PROP_CYVTHUMB, WSB_PROP_CXVSCROLL,
WSB_PROP_VBKGCOLOR));
var
Code: Word;
ScrollInfo: TScrollInfo;
procedure UpdateScrollProperties(Redraw: Boolean);
begin
FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkStyle], FSB_REGULAR_MODE, Redraw);
FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkBkColor],
ColorToRGB(clBtnHighlight), False);
end;
begin
FCalcRange := 0;
Code := SB_HORZ;
if Kind = sbVertical then
Code := SB_VERT;
if Visible then begin
FCalcRange := Range - ControlSize(ControlSB, AssumeSB);
if FCalcRange < 0 then
FCalcRange := 0;
end;
ScrollInfo.cbSize := SizeOf(ScrollInfo);
ScrollInfo.fMask := SIF_ALL;
ScrollInfo.nMin := 0;
if FCalcRange > 0 then
ScrollInfo.nMax := Range
else
ScrollInfo.nMax := 0;
ScrollInfo.nPage := ControlSize(ControlSB, AssumeSB) + 1;
ScrollInfo.nPos := FPosition;
ScrollInfo.nTrackPos := FPosition;
UpdateScrollProperties(FUpdateNeeded);
FUpdateNeeded := False;
FlatSB_SetScrollInfo(FControl.Handle, Code, ScrollInfo, True);
SetPosition(FPosition);
FPageIncrement := (ControlSize(True, False) * 9) div 10;
end;
{ TIpHtmlFocusRect }
constructor TIpHtmlFocusRect.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csCaptureMouse, csClickEvents, csSetCaption,
csOpaque, csReplicatable, csDoubleClicks];
Width := 65;
Height := 17;
end;
procedure TIpHtmlFocusRect.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
CreateSubClass(Params, 'STATIC');
with Params do begin
{$IFNDEF IP_LAZARUS}
Style := Style or SS_NOTIFY;
{$ENDIF}
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
{$IFDEF IP_LAZARUS}
procedure TIpHtmlFocusRect.WMSetFocus(var Message: TLMSetFocus);
begin
inherited WMSetFocus(Message);
Anchor.DoOnFocus;
end;
procedure TIpHtmlFocusRect.WMKillFocus(var Message: TLMKillFocus);
begin
inherited WMKillFocus(Message);
Anchor.DoOnBlur;
{HaveFocus := False;} {!!.12}
end;
{$ELSE}
procedure TIpHtmlFocusRect.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
Anchor.DoOnFocus;
end;
procedure TIpHtmlFocusRect.WMKillFocus(var Message: TWMKillFocus);
begin
inherited;
Anchor.DoOnBlur;
{HaveFocus := False;} {!!.12}
end;
{$ENDIF}
{ TIpHtmlFrame }
procedure TIpHtmlFrame.InitHtml;
begin
Html.TextColor := FViewer.TextColor;
Html.LinkColor := FViewer.LinkColor;
Html.ALinkColor := FViewer.ALinkColor;
Html.VLinkColor := FViewer.VLinkColor;
if FViewer.DataProvider <> nil then
Html.OnGetImageX := FViewer.DataProvider.DoGetImage;
Html.OnInvalidateRect := InvalidateRect;
Html.OnInvalidateSize := InvalidateSize;
Html.OnGet := Get;
Html.OnPost := Post;
Html.OnIFrameCreate := IFrameCreate;
Html.OnURLCheck := FViewer.URLCheck;
Html.OnReportURL := FViewer.ReportURL;
Html.FlagErrors := FFlagErrors;
Html.MarginWidth := FMarginWidth;
Html.MarginHeight := FMarginHeight;
{$IFDEF IP_LAZARUS}
if FDataProvider <> nil then
Html.FDataProvider := FDataProvider;
{$ENDIF}
end;
constructor TIpHtmlFrame.Create(Viewer: TIpHtmlCustomPanel; Parent: TCustomPanel;
DataProvider : TIpAbstractHtmlDataProvider; FlagErrors, NoScroll: Boolean;
MarginWidth, MarginHeight: Integer);
begin
FNoScroll := NoScroll;
FParent := Parent;
FViewer := Viewer;
FDataProvider := DataProvider;
Html := TIpHtml.Create;
Html.FixedTypeface := Viewer.FixedTypeface; {!!.10}
Html.DefaultTypeFace := Viewer.DefaultTypeFace;
FFlagErrors := FlagErrors;
FMarginWidth := MarginWidth;
FMarginheight := MarginHeight;
InitHtml;
end;
destructor TIpHtmlFrame.Destroy;
var
i : Integer;
begin
if FramePanel <> nil then {!!.12}
FramePanel.OnResize := nil; {!!.12}
for i := 0 to Pred(FrameCount) do
Frames[i].Free;
if HyperPanel <> nil then begin
HyperPanel.Hyper := nil;
HyperPanel.Free;
HyperPanel := nil;
end;
if (FDataProvider <> nil) and (not (csDestroying in FDataProvider.ComponentState)) then
FDataProvider.DoLeave(Html);
Html.Free;
inherited;
end;
procedure TIpHtmlFrame.InvalidateRect(Sender: TIpHtml; const R: TRect);
begin
if HyperPanel <> nil then
{$IFDEF IP_LAZARUS}
LCLIntf.InvalidateRect(HyperPanel.Handle, @R, False);
{$ELSE}
Windows.InvalidateRect(HyperPanel.Handle, @R, False);
{$ENDIF}
end;
procedure TIpHtmlFrame.InvalidateSize(Sender: TObject);
begin
if HyperPanel <> nil then
if not InOpen then {!!.10}
HyperPanel.InvalidateSize;
end;
procedure TIpHtmlFrame.OpenURL(const URL: string; Delayed: Boolean);
begin
if Delayed then begin
FViewer.GetURL := URL;
FViewer.PostURL := '';
FViewer.PostData := nil;
PostMessage(FViewer.Handle, CM_IpHttpGetRequest, 0, PtrInt(Self));
end else
OpenRelativeURL(URL);
end;
procedure TIpHtmlFrame.AlignPanels;
var
ColW : TIntArr;
RowH : TIntArr;
ColWCount, RowHCount : Integer;
N, i, R, C, L, T : Integer;
begin
if (Html = nil) or (Html.FrameSet = nil) then Exit;
if FramePanel = nil then Exit;
ColW := CalcMultiLength(Html.FrameSet.Cols, FramePanel.ClientWidth,
ColWCount);{!!.10}
try
RowH := CalcMultiLength(Html.FrameSet.Rows, FramePanel.ClientHeight,
RowHCount); {!!.10}
try
R := 0;
C := 0;
L := 0;
T := 0;
N := 0;
for i := 0 to Pred(Html.FrameSet.ChildCount) do begin
if Html.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin
if Pnl[N] <> nil then {!!.03}
Pnl[N].SetBounds(L, T, ColW[C], RowH[R]);
Inc(L, ColW[C]);
if C < ColWCount - 1 then
Inc(C)
else begin
C := 0;
L := 0;
Inc(T, RowH[R]);
Inc(R);
end;
Inc(N);
end;
end;
finally
RowH.Free;
end;
finally
ColW.Free;
end;
end;
function TIpHtmlFrame.IsExternal(const URL: string): Boolean;
var
St, ResourceType : string;
begin
if Assigned(FDataProvider) then
St := FDataProvider.BuildURL(CurURL, URL)
else
St := IpUtils.BuildURL(CurURL, URL);
if FDataProvider = nil then
raise EIpHtmlException.Create(SHtmlNoDataProvider); {!!.02}
if not FDataProvider.DoCheckURL(St, ResourceType) then
raise EIpHtmlException.Create(SHtmlResUnavail + St); {!!.02}
St := LowerCase(ResourceType);
if ( Pos('text/', St) = 0) and (pos('image/', St) = 0) then begin
FViewer.FHotURL := St;
FViewer.DoHotClick;
Result := True;
end else
Result := False;
end;
function BuildImagePage(const URL: string): TMemoryStream;
var
S : string;
begin
Result := TMemoryStream.Create;
S := '<Html><BODY><IMG src=';
Result.Write(S[1], length(S));
Result.Write(URL[1], length(URL));
S := '></BODY></Html>';
Result.Write(S[1], length(S));
Result.Seek(0, 0);
end;
procedure TIpHtmlFrame.OpenRelativeURL(const URL: string);
var
S : TStream;
MW, MH,
i, R, C, L, T : Integer;
ColW : TIntArr;
RowH : TIntArr;
ColWCount, RowHCount : Integer;
Scroll : Boolean;
St, ResourceType : string;
CurFrameDef : TIpHtmlNodeFrame;
IsImage : Boolean;
begin
InOpen := True; {!!.10}
try {!!.10}
if Assigned(FDataProvider) then
St := FDataProvider.BuildURL(CurURL, URL)
else
St := IpUtils.BuildURL(CurURL, URL);
if FDataProvider = nil then
raise EIpHtmlException.Create(SHtmlNoDataProvider); {!!.02}
if not FDataProvider.DoCheckURL(St, ResourceType) then
raise EIpHtmlException.Create(SHtmlResUnavail + St); {!!.02}
{if CompareText(St, CurURL) = 0 then Exit;} {!!.12}
IsImage := False;
S := nil;
if pos('image/', LowerCase(ResourceType)) <> 0 then begin
IsImage := True;
S := BuildImagePage(St);
end else
if Pos('text/', LowerCase(ResourceType)) = 0 then begin
FViewer.FHotURL := St;
FViewer.DoHotClick;
Exit;
end;
CurURL := St;
CurAnchor := '';
for i := 0 to Pred(FrameCount) do
Frames[i].Free;
FramePanel.Free;
FramePanel := nil;
FrameCount := 0;
if HyperPanel <> nil then begin
Html.OnScroll := nil;
HyperPanel.Hyper := nil;
HyperPanel.Free;
HyperPanel := nil;
end;
if FDataProvider <> nil then
FDataProvider.DoLeave(Html);
Html.Clear;
ColWCount := 0;
RowHCount := 0;
if FDataProvider <> nil then begin
if not IsImage then
S := FDataProvider.DoGetHtmlStream(CurURL, PostData);
if S <> nil then
try
Html.CurURL := CurURL;
Html.LoadFromStream(S);
if Html.HasFrames then begin
FramePanel := TPanel.Create(FParent);
FramePanel.BevelOuter := bvNone;
FramePanel.Align := alClient;
FramePanel.Parent := FParent;
FramePanel.OnResize := FramePanelResize;
FramePanel.FullRepaint := False;
ColW := CalcMultiLength(Html.FrameSet.Cols, FramePanel.ClientWidth,
ColWCount); {!!.10}
try
RowH := CalcMultiLength(Html.FrameSet.Rows, FramePanel.ClientHeight,
RowHCount); {!!.10}
try
R := 0;
C := 0;
L := 0;
T := 0;
FrameCount := 0;
for i := 0 to Pred(Html.FrameSet.ChildCount) do begin
if Html.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin
CurFrameDef := TIpHtmlNodeFrame(Html.FrameSet.ChildNode[i]);
Pnl[FrameCount] := TPanel.Create(FramePanel);
Pnl[FrameCount].BevelOuter := bvNone;
Pnl[FrameCount].SetBounds(L, T, ColW[C], RowH[R]);
Pnl[FrameCount].Parent := FramePanel;
Pnl[FrameCount].FullRepaint := False;
if CurFrameDef.FrameBorder <> 0 then begin {!!.02}
Pnl[FrameCount].BorderStyle := bsSingle; {!!.02}
Pnl[FrameCount].BorderWidth := CurFrameDef.FrameBorder; {!!.02}
end; {!!.02}
Inc(L, ColW[C]);
case CurFrameDef.Scrolling of
hfsAuto, hfsYes :
Scroll := True;
else //hfsNo :
Scroll := False;
end;
if CurFrameDef.MarginWidth <> -1 then
MW := CurFrameDef.MarginWidth
else
MW := FViewer.MarginWidth;
if CurFrameDef.MarginHeight <> -1 then
MH:= CurFramedef.MarginHeight
else
MH := FViewer.MarginHeight;
Frames[FrameCount] :=
TIpHtmlFrame.Create(FViewer, Pnl[FrameCount], FDataProvider,
FViewer.FlagErrors, not Scroll, MW, MH);
Frames[FrameCount].Name := CurFrameDef.Name;
if C < ColWCount - 1 then
Inc(C)
else begin
C := 0;
L := 0;
Inc(T, RowH[R]);
Inc(R);
end;
Inc(FrameCount);
end;
end;
finally
RowH.Free;
end;
finally
ColW.Free;
end;
Application.ProcessMessages;
FrameCount := 0;
for i := 0 to Pred(Html.FrameSet.ChildCount) do begin
if Html.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin
Frames[FrameCount].CurURL := CurURL;
Frames[FrameCount].OpenRelativeURL({Base,}
TIpHtmlNodeFrame(Html.FrameSet.ChildNode[i]).Src);
Inc(FrameCount);
end;
end;
end else begin
HyperPanel := TIpHtmlInternalPanel.Create(FParent);
if FNoScroll then begin
HyperPanel.HScroll.Visible := False;
HyperPanel.VScroll.Visible := False;
end;
HyperPanel.Parent := FParent;
HyperPanel.Align := alClient;
HyperPanel.OnHotChange := FViewer.HotChange;
HyperPanel.OnCurElementChange := FViewer.CurElementChange;
HyperPanel.OnHotClick := FViewer.HotClick;
HyperPanel.OnClick := FViewer.ClientClick;
HyperPanel.TabStop := True;
Html.OnScroll := HyperPanel.ScrollRequest;
Html.OnControlClick := ControlClick;
Html.OnControlCreate := ControlCreate;
for i := 0 to Pred(Html.AnchorList.Count) do
with TIpHtmlFocusRect.Create(HyperPanel) do begin
SetBounds(-100, -100, 10, 10);
TabStop := True;
Parent := HyperPanel;
Anchor := Html.AnchorList[i];
end;
for i := 0 to Pred(Html.ControlList.Count) do
TIpHtmlNode(Html.ControlList[i]).CreateControl(HyperPanel);
HyperPanel.Hyper := Html;
end;
finally
S.Free;
end;
end;
finally {!!.10}
InOpen := False; {!!.10}
if HyperPanel <> nil then
HyperPanel.InvalidateSize; {!!.10}
end; {!!.10}
end;
procedure TIpHtmlFrame.FramePanelResize(Sender: TObject);
begin
AlignPanels;
end;
procedure TIpHtmlFrame.MakeAnchorVisible(const URL: string);
var
E : TIpHtmlNode;
i : Integer;
begin
E := Html.FindElement(URL);
CurAnchor := '';
if E <> nil then begin
E.MakeVisible;
CurAnchor := '#'+URL;
end else
for i := 0 to Pred(FrameCount) do
Frames[i].MakeAnchorVisible(URL);
end;
procedure TIpHtmlFrame.Home;
begin
if Html <> nil then
Html.Home;
end;
function TIpHtmlFrame.FindFrame(const FrameName: string): TIpHtmlFrame;
var
i : Integer;
begin
if AnsiCompareText(FrameName, Name) = 0 then
Result := Self
else begin
Result := nil;
for i := 0 to Pred(FrameCount) do begin
Result := Frames[i].FindFrame(FrameName);
if Result <> nil then
Exit;
end;
end;
end;
procedure TIpHtmlFrame.Get(Sender: TIpHtml; const URL: string);
begin
FViewer.GetURL := URL;
FViewer.PostURL := '';
FViewer.PostData := nil;
PostMessage(FViewer.Handle, CM_IpHttpGetRequest, 0, PtrInt(Self));
end;
procedure TIpHtmlFrame.Post(Sender: TIpHtml; const URL: string;
FormData: TIpFormDataEntity); {!!.12}
begin
FViewer.GetURL := '';
FViewer.PostURL := URL;
FViewer.PostData := FormData; {!!.12}
PostMessage(FViewer.Handle, CM_IpHttpGetRequest, 0, PtrInt(Self));
end;
function TIpHtmlFrame.HaveSelection: Boolean;
var
i : Integer;
begin
if Html = nil then
Result := False
else
if Html.HaveSelection then
Result := True
else begin
Result := False;
for i := 0 to Pred(FrameCount) do
if Frames[i].HaveSelection then begin
Result := True;
break;
end;
end;
end;
procedure TIpHtmlFrame.CopyToClipboard;
var
i : Integer;
begin
if Html <> nil then
if Html.HaveSelection then
Html.CopyToClipboard
else begin
for i := 0 to Pred(FrameCount) do
if Frames[i].HaveSelection then begin
Frames[i].CopyToClipboard;
Exit;
end;
end;
end;
procedure TIpHtmlFrame.SelectAll;
var
i : Integer;
begin
if Html <> nil then begin
Html.SelectAll;
for i := 0 to Pred(FrameCount) do
Frames[i].SelectAll;
end;
end;
{!!.10 new}
procedure TIpHtmlFrame.DeselectAll;
var
i : Integer;
begin
if Html <> nil then begin
Html.DeselectAll;
for i := 0 to Pred(FrameCount) do
Frames[i].DeselectAll;
end;
end;
procedure TIpHtmlFrame.IFrameCreate(Sender: TIpHtml; Parent: TWinControl;
Frame: TIpHtmlNodeIFRAME; var Control: TWinControl);
var
MW, MH, W, H : Integer;
Scroll : Boolean;
NewFrame : TIpHtmlFrame;
begin
Control := TPanel.Create(Parent);
Pnl[FrameCount] := TPanel(Control);
TPanel(Control).BevelOuter := bvNone;
case Frame.Width.LengthType of
hlAbsolute :
W := Frame.Width.LengthValue;
else
{hlUndefined,
hlPercent :}
begin
if Frame.Width.LengthType = hlUndefined then
W := Parent.ClientWidth
else
W := round(Frame.Width.LengthValue * Parent.ClientWidth / 100);
end;
end;
case Frame.Height.LengthType of
hlAbsolute :
H := Frame.Height.LengthValue;
else
{hlUndefined,
hlPercent :}
begin
if Frame.Height.LengthType = hlUndefined then
H := Parent.ClientHeight
else
H := round(Frame.Height.LengthValue * Parent.ClientHeight / 100);
end;
end;
TPanel(Control).SetBounds(0, 0, W, H);
TPanel(Control).Parent := Parent;
TPanel(Control).FullRepaint := False;
case Frame.Scrolling of
hfsAuto, hfsYes :
Scroll := True;
else //hfsNo :
Scroll := False;
end;
if Frame.FrameBorder <> 0 then begin
TPanel(Control).BorderStyle := bsSingle;
TPanel(Control).BorderWidth := Frame.FrameBorder;
end;
if Frame.MarginWidth <> -1 then
MW := Frame.MarginWidth
else
MW := FViewer.MarginWidth;
if Frame.MarginHeight <> -1 then
MH:= Frame.MarginHeight
else
MH := FViewer.MarginHeight;
NewFrame :=
TIpHtmlFrame.Create(FViewer, TCustomPanel(Control), FDataProvider,
FViewer.FlagErrors, not Scroll, MW, MH);
Frames[FrameCount] := NewFrame;
NewFrame.Name := Frame.Name;
Application.ProcessMessages;
NewFrame.CurURL := CurURL;
NewFrame.OpenRelativeURL(Frame.Src);
Inc(FrameCount);
Frame.FFrame := NewFrame;
end;
procedure TIpHtmlFrame.SetHtml(NewHtml: TIpHtml);
var
MW, MH,
ColWCount, RowHCount,
i, R, C, L, T : Integer;
ColW : TIntArr;
RowH : TIntArr;
Scroll : Boolean;
CurFrameDef : TIpHtmlNodeFrame;
begin
for i := 0 to Pred(FrameCount) do
Frames[i].Free;
FramePanel.Free;
FramePanel := nil;
FrameCount := 0;
if HyperPanel <> nil then begin
Html.OnScroll := nil;
HyperPanel.Hyper := nil;
HyperPanel.Free;
HyperPanel := nil;
end;
if FDataProvider <> nil then
FDataProvider.DoLeave(Html);
Html.Clear;
ColWCount := 0;
RowHCount := 0;
Html.Free;
Html := NewHtml;
InitHtml;
Html.DoneLoading := True;
if Html.HasFrames then begin
FramePanel := TPanel.Create(FParent);
FramePanel.BevelOuter := bvNone;
FramePanel.Align := alClient;
FramePanel.Parent := FParent;
FramePanel.OnResize := FramePanelResize;
FramePanel.FullRepaint := False;
ColW := CalcMultiLength(Html.FrameSet.Cols, FramePanel.ClientWidth,
ColWCount); {!!.10}
try
RowH := CalcMultiLength(Html.FrameSet.Rows, FramePanel.ClientHeight,
RowHCount); {!!.10}
try
R := 0;
C := 0;
L := 0;
T := 0;
FrameCount := 0;
for i := 0 to Pred(Html.FrameSet.ChildCount) do begin
if Html.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin
CurFrameDef := TIpHtmlNodeFrame(Html.FrameSet.ChildNode[i]);
Pnl[FrameCount] := TPanel.Create(FramePanel);
Pnl[FrameCount].BevelOuter := bvNone;
Pnl[FrameCount].SetBounds(L, T, ColW[C], RowH[R]);
Pnl[FrameCount].Parent := FramePanel;
Pnl[FrameCount].FullRepaint := False;
if CurFrameDef.FrameBorder <> 0 then begin {!!.02}
Pnl[FrameCount].BorderStyle := bsSingle; {!!.02}
Pnl[FrameCount].BorderWidth := CurFrameDef.FrameBorder; {!!.02}
end; {!!.02}
Inc(L, ColW[C]);
case CurFrameDef.Scrolling of
hfsAuto, hfsYes :
Scroll := True;
else //hfsNo :
Scroll := False;
end;
if CurFrameDef.MarginWidth <> -1 then
MW := CurFrameDef.MarginWidth
else
MW := FViewer.MarginWidth;
if CurFrameDef.MarginHeight <> -1 then
MH:= CurFramedef.MarginHeight
else
MH := FViewer.MarginHeight;
Frames[FrameCount] :=
TIpHtmlFrame.Create(FViewer, Pnl[FrameCount], FDataProvider,
FViewer.FlagErrors, not Scroll, MW, MH);
Frames[FrameCount].Name := CurFrameDef.Name;
if C < ColWCount - 1 then
Inc(C)
else begin
C := 0;
L := 0;
Inc(T, RowH[R]);
Inc(R);
end;
Inc(FrameCount);
end;
end;
finally
RowH.Free;
end;
finally
ColW.Free;
end;
Application.ProcessMessages;
FrameCount := 0;
for i := 0 to Pred(Html.FrameSet.ChildCount) do begin
if Html.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin
Frames[FrameCount].CurURL := CurURL;
Frames[FrameCount].OpenRelativeURL(
TIpHtmlNodeFrame(Html.FrameSet.ChildNode[i]).Src);
Inc(FrameCount);
end;
end;
end else begin
HyperPanel := TIpHtmlInternalPanel.Create(FParent);
if FNoScroll then begin
HyperPanel.HScroll.Visible := False;
HyperPanel.VScroll.Visible := False;
end;
HyperPanel.Parent := FParent;
HyperPanel.Align := alClient;
HyperPanel.OnHotChange := FViewer.HotChange;
HyperPanel.OnCurElementChange := FViewer.CurElementChange;
HyperPanel.OnHotClick := FViewer.HotClick;
HyperPanel.OnClick := FViewer.ClientClick;
HyperPanel.TabStop := True;
Html.OnScroll := HyperPanel.ScrollRequest;
for i := 0 to Pred(Html.AnchorList.Count) do
with TIpHtmlFocusRect.Create(HyperPanel) do begin
SetBounds(-100, -100, 10, 10);
TabStop := True;
Parent := HyperPanel;
Anchor := Html.AnchorList[i];
end;
for i := 0 to Pred(Html.ControlList.Count) do begin
TIpHtmlNode(Html.ControlList[i]).CreateControl(HyperPanel);
end;
HyperPanel.Hyper := Html;
end;
end;
procedure TIpHtmlFrame.EnumDocuments(Enumerator: TIpHtmlEnumerator);
var
i : Integer;
begin
if Html <> nil then
Enumerator(Html);
for i := 0 to Pred(FrameCount) do
Frames[i].EnumDocuments(Enumerator);
end;
procedure TIpHtmlFrame.ControlClick(Sender: TIpHtml;
Node: TIpHtmlNodeControl);
begin
FViewer.ControlClick(Self, Sender, Node);
end;
procedure TIpHtmlFrame.ControlCreate(Sender: TIpHtml;
Node: TIpHtmlNodeControl);
begin
FViewer.ControlCreate(Self, Sender, Node);
end;
procedure TIpHtmlFrame.Scroll(Action: TIpScrollAction);
var
R : TRect;
H, W : Integer;
begin
if Html = nil then Exit;
if HyperPanel = nil then Exit;
R := Html.PageViewRect;
H := R.Bottom - R.Top;
W := R.Right - R.Left;
case Action of
hsaHome :
begin
R.Top := 0;
R.Bottom := R.Top + H;
end;
hsaEnd :
begin
R.Bottom := Html.FPageRect.Bottom;
R.Top := R.Bottom - H;
end;
hsaPgUp :
begin
OffsetRect(R, 0, -H);
if R.Top < 0 then begin
R.Top := 0;
R.Bottom := R.Top + H;
end;
end;
hsaPgDn :
begin
OffsetRect(R, 0, H);
if R.Bottom > Html.FPageRect.Bottom then begin
R.Bottom := Html.FPageRect.Bottom;
R.Top := R.Bottom - H;
end;
end;
hsaLeft :
begin
OffsetRect(R, -100, 0);
if R.Left < 0 then begin
R.Left := 0;
R.Right := R.Left + W;
end;
end;
hsaRight :
begin
OffsetRect(R, 100, 0);
if R.Right > Html.FPageRect.Right then begin
R.Bottom := Html.FPageRect.Right;
R.Left := R.Right - W;
end;
end;
hsaUp :
begin
OffsetRect(R, 0, -100);
if R.Top < 0 then begin
R.Top := 0;
R.Bottom := R.Top + H;
end;
end;
hsaDown :
begin
OffsetRect(R, 0, 100);
if R.Bottom > Html.FPageRect.Bottom then begin
R.Bottom := Html.FPageRect.Bottom;
R.Top := R.Bottom - H;
end;
end;
end;
HyperPanel.ScrollInViewRaw(R);
end;
procedure TIpHtmlFrame.Stop;
begin
if FDataProvider <> nil then
FDataProvider.DoLeave(Html);
end;
{ TIpHtmlNvFrame }
procedure TIpHtmlNvFrame.InitHtml;
begin
if FScanner.DataProvider <> nil then
Html.OnGetImageX := FScanner.DataProvider.DoGetImage;
Html.FlagErrors := FFlagErrors;
end;
constructor TIpHtmlNvFrame.Create(Scanner: TIpHtmlCustomScanner;
DataProvider : TIpAbstractHtmlDataProvider; FlagErrors: Boolean);
begin
FScanner := Scanner;
FDataProvider := DataProvider;
Html := TIpHtml.Create;
FFlagErrors := FlagErrors;
InitHtml;
end;
destructor TIpHtmlNvFrame.Destroy;
var
i : Integer;
begin
for i := 0 to Pred(FrameCount) do
Frames[i].Free;
Html.Free;
inherited;
end;
procedure TIpHtmlNvFrame.OpenURL(const URL: string);
begin
OpenRelativeURL(URL);
end;
procedure TIpHtmlNvFrame.OpenRelativeURL(const {Base, }URL: string);
var
S : TStream;
i, C : Integer;
ColWCount : Integer;
St, ResourceType : string;
CurFrameDef : TIpHtmlNodeFrame;
begin
if Assigned(FDataProvider) then
St := FDataProvider.BuildURL(CurURL, URL)
else
St := IpUtils.BuildURL(CurURL, URL);
if FDataProvider = nil then
raise EIpHtmlException.Create(SHtmlNoDataProvider); {!!.02}
if not FDataProvider.DoCheckURL(St, ResourceType) then
raise EIpHtmlException.Create(SHtmlResUnavail + St); {!!.02}
if CompareText(ResourceType, 'text/html') <> 0 then
Exit;
if CompareText(St, CurURL) = 0 then Exit;
CurURL := St;
CurAnchor := '';
for i := 0 to Pred(FrameCount) do
Frames[i].Free;
FrameCount := 0;
FDataProvider.DoLeave(Html);
Html.Clear;
ColWCount := 0;
if FDataProvider <> nil then begin
S := FDataProvider.DoGetHtmlStream(CurURL, PostData);
if S <> nil then
try
Html.CurURL := CurURL;
Html.LoadFromStream(S);
if Html.HasFrames then begin
C := 0;
FrameCount := 0;
for i := 0 to Pred(Html.FrameSet.ChildCount) do begin
if Html.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin
CurFrameDef := TIpHtmlNodeFrame(Html.FrameSet.ChildNode[i]);
Frames[FrameCount] :=
TIpHtmlNvFrame.Create(FScanner, FDataProvider,
FScanner.FlagErrors);
Frames[FrameCount].Name := CurFrameDef.Name;
if C < ColWCount - 1 then
Inc(C)
else begin
C := 0;
end;
Inc(FrameCount);
end;
end;
Application.ProcessMessages;
FrameCount := 0;
for i := 0 to Pred(Html.FrameSet.ChildCount) do begin
if Html.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin
Frames[FrameCount].CurURL := CurURL;
Frames[FrameCount].OpenRelativeURL({Base,}
TIpHtmlNodeFrame(Html.FrameSet.ChildNode[i]).Src);
Inc(FrameCount);
end;
end;
end;
finally
S.Free;
end;
end;
end;
procedure TIpHtmlNvFrame.MakeAnchorVisible(const URL: string);
var
E : TIpHtmlNode;
i : Integer;
begin
E := Html.FindElement(URL);
CurAnchor := '';
if E <> nil then begin
E.MakeVisible;
CurAnchor := '#'+URL;
end else
for i := 0 to Pred(FrameCount) do
Frames[i].MakeAnchorVisible(URL);
end;
procedure TIpHtmlNvFrame.Home;
begin
if Html <> nil then
Html.Home;
end;
function TIpHtmlNvFrame.FindFrame(const FrameName: string): TIpHtmlNvFrame;
var
i : Integer;
begin
if AnsiCompareText(FrameName, Name) = 0 then
Result := Self
else begin
Result := nil;
for i := 0 to Pred(FrameCount) do begin
Result := Frames[i].FindFrame(FrameName);
if Result <> nil then
Exit;
end;
end;
end;
function TIpHtmlNvFrame.HaveSelection: Boolean;
var
i : Integer;
begin
if Html = nil then
Result := False
else
if Html.HaveSelection then
Result := True
else begin
Result := False;
for i := 0 to Pred(FrameCount) do
if Frames[i].HaveSelection then begin
Result := True;
break;
end;
end;
end;
procedure TIpHtmlNvFrame.CopyToClipboard;
var
i : Integer;
begin
if Html <> nil then
if Html.HaveSelection then
Html.CopyToClipboard
else begin
for i := 0 to Pred(FrameCount) do
if Frames[i].HaveSelection then begin
Frames[i].CopyToClipboard;
Exit;
end;
end;
end;
procedure TIpHtmlNvFrame.SelectAll;
var
i : Integer;
begin
if Html <> nil then begin
Html.SelectAll;
for i := 0 to Pred(FrameCount) do
Frames[i].SelectAll;
end;
end;
procedure TIpHtmlNvFrame.EnumDocuments(Enumerator: TIpHtmlEnumerator);
var
i : Integer;
begin
if Html <> nil then
Enumerator(Html);
for i := 0 to Pred(FrameCount) do
Frames[i].EnumDocuments(Enumerator);
end;
procedure TIpHtmlNVFrame.Stop;
begin
if FDataProvider <> nil then
FDataProvider.DoLeave(Html);
end;
{ TIpHtmlCustomPanel }
procedure TIpHtmlCustomPanel.DoHotChange;
begin
if Assigned(FHotChange) then
FHotChange(Self);
end;
procedure TIpHtmlCustomPanel.DoHotClick;
begin
if Assigned(FHotClick) then
FHotClick(Self);
end;
{New in !!.16}
procedure TIpHtmlCustomPanel.DoOnMouseWheel(Shift: TShiftState; Delta, XPos, YPos: SmallInt);
var
I: Integer;
begin
if Delta < 0 then
begin
for I := 1 to WheelDelta do
Scroll(hsaDown);
end else
if Delta > 0 then
begin
for I := 1 To WheelDelta do
Scroll(hsaUp);
end;
end;
{!!.16}
procedure TIpHtmlCustomPanel.HotChange(Sender: TObject);
var
P : TIpHtmlInternalPanel;
Html : TIpHtml;
begin
P := TIpHtmlInternalPanel(Sender);
Html := P.Hyper;
if Html.HotNode <> nil then begin
if Html.HotPoint.x >= 0 then
FHotURL := TIpHtmlNodeA(Html.HotNode).HRef+
'?'+IntToStr(Html.HotPoint.x)+','+IntToStr(Html.HotPoint.y)
else
if Html.HotNode is TIpHtmlNodeA then
FHotURL := TIpHtmlNodeA(Html.HotNode).HRef
else
FHotURL := TIpHtmlNodeAREA(Html.HotNode).HRef;
FHotNode := Html.HotNode;
P.Cursor := crHandPoint;
end else begin
FHotNode := nil;
FHotURL := '';
P.Cursor := crDefault;
end;
DoHotChange;
end;
procedure TIpHtmlCustomPanel.CurElementChange(Sender: TObject);
var
P : TIpHtmlInternalPanel;
Html : TIpHtml;
begin
P := TIpHtmlInternalPanel(Sender);
Html := P.Hyper;
FCurElement := Html.CurElement;
if assigned(FCurElementChange) then {!!.10}
FCurElementChange(Self); {!!.10}
end;
function TIpHtmlCustomPanel.GetTitle: string;
begin
if (MasterFrame <> nil)
and (MasterFrame.Html <> nil)
and (MasterFrame.Html.TitleNode <> nil) then
Result := MasterFrame.Html.TitleNode.Title
else
Result := '';
end;
constructor TIpHtmlCustomPanel.Create(AOwner: TComponent);
begin
inherited;
BevelOuter := bvNone;
Caption := '';
ControlStyle := [csCaptureMouse, csClickEvents,
csSetCaption, csOpaque, csDoubleClicks, csReplicatable];
TargetStack := TStringList.Create;
URLStack := TStringList.Create;
VisitedList := TStringList.Create;
VisitedList.Sorted := True;
FTextColor := clBlack;
FLinkColor := clBlue;
FVLinkColor := clMaroon;
FALinkColor := clRed;
FBgColor := clWhite; //JMN
FShowHints := True;
FMarginWidth := 10;
FMarginHeight := 10;
FAllowTextSelect := True;
FixedTypeface := 'Courier New'; {!!.10}
DefaultTypeFace := Graphics.DefFontData.Name;
FPrintSettings := TIpHtmlPrintSettings.Create; {!!.10}
FFactBAParag := 1;
end;
destructor TIpHtmlCustomPanel.Destroy;
begin
FPrintSettings.Free; {!!.10}
TargetStack.Free;
URLStack.Free;
MasterFrame.Free;
MasterFrame := nil;
VisitedList.Free;
inherited;
end;
procedure TIpHtmlCustomPanel.EraseBackground(DC: HDC);
begin
//
end;
procedure TIpHtmlCustomPanel.OpenURL(const URL: string);
begin
InternalOpenURL('', URL);
end;
procedure TIpHtmlCustomPanel.MakeAnchorVisible(const Name: string);
begin
if MasterFrame <> nil then
MasterFrame.MakeAnchorVisible(Name)
end;
procedure TIpHtmlCustomPanel.InternalOpenURL(const Target, HRef : string);
var
URL, BaseURL, RelURL : string;
P : Integer;
TargetFrame : TIpHtmlFrame;
begin
if HRef = '' then {!!.12}
Exit; {!!.12}
if HRef[1] = '#' then begin
RelURL := copy(HRef, 2, length(HRef) - 1);
BaseURL := '';
end
else begin
if MasterFrame <> nil then begin
if Assigned(FDataProvider) then
URL := FDataProvider.BuildURL(MasterFrame.Html.CURURL, HRef)
else
URL := IpUtils.BuildURL(MasterFrame.Html.CURURL, HRef);
end
else
URL := HRef;
P := CharPos('#', URL);
if P = 0 then begin
RelURL := '';
BaseURL := URL;
end else begin
BaseURL := copy(URL, 1, P - 1);
RelURL := copy(URL, P + 1, length(URL));
end;
end;
if BaseURL = '' then begin //JMN
if MasterFrame <> nil then
Push('', RelURL);
end
else begin
if VisitedList.IndexOf(BaseURL) = -1 then
VisitedList.Add(BaseURL);
if (Target <> '') and (MasterFrame <> nil) then
TargetFrame := MasterFrame.FindFrame(Target)
else
TargetFrame := nil;
if TargetFrame = nil then begin
if MasterFrame <> nil then
Push('', MasterFrame.CURURL + MasterFrame.CurAnchor);
if DataProvider = nil then
raise EIpHtmlException.Create(SHtmlNoDataProvider); {!!.02}
if (MasterFrame = nil)
or ((MasterFrame <> nil) and (not MasterFrame.IsExternal(URL))) then begin //JMN
if (MasterFrame <> nil)
and (MasterFrame.Html <> nil) then
FDataProvider.DoLeave(MasterFrame.Html);
MasterFrame.Free;
MasterFrame := nil;
Application.ProcessMessages;
MasterFrame := TIpHtmlFrame.Create(Self, Self, DataProvider, FlagErrors, False,
MarginWidth, MarginHeight);
// LazDebug try
MasterFrame.OpenURL(URL, False);
{ LazDebug except
MasterFrame.Free;
MasterFrame := nil;
raise;
end;}
{CurURL := URL;} {!!.12}
end;
end else begin
Push(Target, TargetFrame.CURURL + TargetFrame.CurAnchor);
TargetFrame.OpenURL(BaseURL, False);
end;
end;
if RelURL <> '' then
MasterFrame.MakeAnchorVisible(RelURL)
else
if MasterFrame <> nil then {!!.02}
MasterFrame.Home;
if assigned(FDocumentOpen) then {!!.10}
FDocumentOpen(Self); {!!.10}
end;
procedure TIpHtmlCustomPanel.HotClick(Sender: TObject);
var
HRef : string;
Target : string;
begin
if TIpHtml(Sender).HotNode is TIpHtmlNodeA then begin
HRef := TIpHtmlNodeA(TIpHtml(Sender).HotNode).HRef;
Target := TIpHtmlNodeA(TIpHtml(Sender).HotNode).Target;
end else begin
HRef := TIpHtmlNodeAREA(TIpHtml(Sender).HotNode).HRef;
Target := TIpHtmlNodeAREA(TIpHtml(Sender).HotNode).Target;
end;
if (FDataProvider <> nil)
and FDataProvider.CanHandle(HRef) then
InternalOpenURL(Target, HRef)
else
DoHotClick;
end;
procedure TIpHtmlCustomPanel.GoBack;
begin
if (URLStack.Count > 0) then begin
{$IFDEF IP_LAZARUS}
if URLStack.Count >= URLStack.count then Stp := URLStack.Count - 1;
if URLStack.Count > 0 then begin
InternalOpenURL(TargetStack[Stp], URLStack[Stp]);
Dec(Stp);
end;
{$ELSE}
InternalOpenURL(TargetStack[Stp], URLStack[Stp]);
Dec(Stp);
{$ENDIF}
end;
end;
function TIpHtmlCustomPanel.canGoBack : boolean;
begin
Result := (URLStack.Count > 0);
end;
procedure TIpHtmlCustomPanel.GoForward;
begin
if Stp < URLStack.Count - 1 then begin
InternalOpenURL(TargetStack[Stp + 1], URLStack[Stp + 1]);
Inc(Stp);
end;
end;
function TIpHtmlCustomPanel.canGoForward : boolean;
begin
Result := (Stp < URLStack.Count - 1);
end;
procedure TIpHtmlCustomPanel.Push(const Target, URL: string);
begin
if (Stp > 0)
and (TargetStack[Stp] = Target)
and (URLStack[Stp] = URL) then Exit;
while STP < URLStack.Count - 1 do begin
URLStack.Delete(Stp);
TargetStack.Delete(Stp);
end;
URLStack.Add(URL);
TargetStack.Add(Target);
Stp := URLStack.Count - 1;
end;
procedure TIpHtmlCustomPanel.Notification(AComponent: TComponent; Operation: TOperation);
begin
if (Operation = opRemove) then
if (AComponent = DataProvider) then begin
DataProvider := nil;
end;
inherited Notification(AComponent, Operation);
end;
procedure TIpHtmlCustomPanel.Paint;
var
Sz: TSize;
begin
if csDesigning in ComponentState then begin
Canvas.Brush.Color := clBtnFace; {!!.10}
Canvas.FillRect(Canvas.ClipRect); {!!.10}
Canvas.Pen.Color := clWhite;
Sz := Canvas.TextExtent('Html');
Canvas.Polygon([
Point(0,4),
Point(0, Height - 5),
Point(Width div 2 - Sz.cx div 2, Height div 2)]);
Canvas.Polygon([
Point(Width - 1,4),
Point(Width - 1, Height - 5),
Point(Width div 2 + Sz.cx div 2, Height div 2)]);
Canvas.Polygon([
Point(2, 4),
Point(Width - 3, 4),
Point(Width div 2, Height div 2 - Sz.cy div 2)]);
Canvas.Polygon([
Point(2, Height - 4),
Point(Width - 3, Height - 4),
Point(Width div 2, Height div 2 + Sz.cy div 2)]);
Canvas.Brush.Color := clRed;
Canvas.Pen.Color := clBlack;
Canvas.Ellipse(
Width div 2 - Sz.cx, Height div 2 - Sz.cy,
Width div 2 + Sz.cx, Height div 2 + Sz.cy);
Canvas.TextOut(Width div 2 - Sz.cx div 2, Height div 2 - Sz.cy div 2,
'Html');
Canvas.Brush.Color := clWhite;
Canvas.Pen.Color := clBlack;
end;
end;
procedure TIpHtmlCustomPanel.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
if (MasterFrame = nil)
or (MasterFrame.Html = nil)
or (not MasterFrame.Html.CanPaint) then
if not (csDesigning in ComponentState) then
FillRect(Message.DC, ClientRect, Brush.Handle);
Message.Result := 1;
end;
procedure TIpHtmlCustomPanel.CMIpHttpGetRequest(var Message: TMessage);
var
FB : TIpHtmlFrame;
begin
FB := TIpHtmlFrame(Message.lParam);
if PostData <> nil then begin {!!.12}
FB.PostData := PostData;
FB.OpenRelativeURL(PostURL); {!!.12}
{$IFNDEF HtmlWithoutHttp}
PostData.Free; {!!.12}
PostData := nil; {!!.12}
{$ENDIF}
end else {!!.12}
FB.OpenRelativeURL(GetURL);
end;
procedure TIpHtmlCustomPanel.ClientClick(Sender: TObject);
begin
Click;
end;
function TIpHtmlCustomPanel.HaveSelection: Boolean;
begin
Result :=
(MasterFrame <> nil)
and (MasterFrame.HaveSelection);
end;
procedure TIpHtmlCustomPanel.SelectAll;
begin
if MasterFrame <> nil then begin
MasterFrame.SelectAll;
Invalidate;
end;
end;
procedure TIpHtmlCustomPanel.DeselectAll;
begin
if MasterFrame <> nil then begin
MasterFrame.DeselectAll;
Invalidate;
end;
end;
procedure TIpHtmlCustomPanel.CopyToClipboard;
begin
if MasterFrame <> nil then
MasterFrame.CopyToClipboard;
end;
procedure TIpHtmlCustomPanel.SetHtml(NewHtml: TIpHtml);
begin
if (MasterFrame <> nil)
and (MasterFrame.Html <> nil)
and (FDataProvider <> nil) then
FDataProvider.DoLeave(MasterFrame.Html);
MasterFrame.Free;
MasterFrame := nil;
MasterFrame := TIpHtmlFrame.Create(Self, Self, DataProvider, FlagErrors, False,
MarginWidth, MarginHeight);
// LazDebug try
if NewHtml <> nil then begin //JMN
FactBAParagG := FactBAParag;
NewHtml.BgColor := BgColor; //JMN
NewHtml.FixedTypeface := FixedTypeface; {!!.10}
NewHtml.DefaultTypeFace := DefaultTypeFace;
MasterFrame.SetHtml(NewHtml);
end;
{ LazDebug
except
MasterFrame.Free;
MasterFrame := nil;
raise;
end;}
end;
procedure TIpHtmlCustomPanel.URLCheck(Sender: TIpHtml; const URL: string;
var Visited: Boolean);
begin
Visited := VisitedList.IndexOf(URL) <> -1;
end;
procedure TIpHtmlCustomPanel.ReportURL(Sender: TIpHtml; const URL: string);
begin
if (FDataProvider <> nil) then
FDataProvider.DoReference(URL);
end;
procedure TIpHtmlCustomPanel.EnumDocuments(Enumerator: TIpHtmlEnumerator);
begin
if MasterFrame <> nil then
MasterFrame.EnumDocuments(Enumerator);
end;
procedure TIpHtmlCustomPanel.ControlClick(Frame: TIpHtmlFrame; Html: TIpHtml;
Node: TIpHtmlNodeControl);
begin
if assigned(FControlClick) then
FControlClick(Self, Frame, Html, Node);
end;
procedure TIpHtmlCustomPanel.ControlCreate(Frame: TIpHtmlFrame; Html: TIpHtml;
Node: TIpHtmlNodeControl);
begin
if assigned(FControlCreate) then
FControlCreate(Self, Frame, Html, Node);
end;
function TIpHtmlCustomPanel.IsURLHtml(const URL: string): Boolean;
var
ResourceType: string;
begin
Result := (FDataProvider <> nil)
and FDataProvider.DoCheckURL(URL, ResourceType)
and (CompareText(ResourceType, 'text/html') = 0);
end;
procedure TIpHtmlCustomPanel.Stop;
begin
if assigned(MasterFrame) then
MasterFrame.Stop;
end;
{New in !!.16}
{$IFDEF VERSION4}
procedure TIpHtmlCustomPanel.MouseWheelHandler(var Message: TMessage);
begin
inherited MouseWheelHandler(Message);
with Message do
DoOnMouseWheel(KeysToShiftState(LOWORD(wParam)), HIWORD(wParam), LOWORD(lParam), HIWORD(lParam));
end;
{$ENDIF}
function TIpHtmlCustomPanel.GetPrintPageCount: Integer;
begin
if Assigned(MasterFrame)
and Assigned(MasterFrame.HyperPanel) then begin
{ !!.10 logic moved to InternalPanel
Printer.BeginDoc;
try
ScaleBitmaps := True;
GetRelativeAspect(Printer.Canvas.Handle);
}
Result := MasterFrame.HyperPanel.GetPrintPageCount;
{
!!.10 logic moved to InternalPanel
finally
ScaleBitmaps := False;
Printer.Abort;
MasterFrame.HyperPanel.InvalidateSize;
end;
}
end else
Result := 0;
end;
procedure TIpHtmlCustomPanel.Print(FromPg, ToPg: LongInt);
begin
if Assigned(MasterFrame) then
MasterFrame.HyperPanel.PrintPages(FromPg, ToPg);
end;
procedure TIpHtmlCustomPanel.PrintPreview;
begin
{$IFDEF IP_LAZARUS}
if not assigned(printer) then begin
raise exception.create(
'Printer has not been assigned, checkout that package'#13+
'Printer4lazarus.lpk has been installed and OSPrinters'#13+
'or PrintDialog is in uses clause of main unit');
end;
{$ENDIF}
if Assigned(MasterFrame) then
MasterFrame.HyperPanel.PrintPreview;
end;
procedure TIpHtmlCustomPanel.Scroll(Action: TIpScrollAction);
begin
if MasterFrame <> nil then
MasterFrame.Scroll(Action);
end;
procedure TIpHtmlCustomPanel.WMGetDlgCode(var Msg: TMessage);
begin
{ we want 'em all! For Lazarus: Then use OnKeyDown! }
Msg.Result := DLGC_WANTALLKEYS +
DLGC_WANTARROWS +
DLGC_WANTCHARS +
{$IFNDEF IP_LAZARUS}
DLGC_WANTMESSAGE +
{$ENDIF}
DLGC_WANTTAB
end;
function TIpHtmlCustomPanel.GetVersion : string;
begin
Result := IpShortVersion;
end;
procedure TIpHtmlCustomPanel.SetVersion(const Value : string);
begin
{ Intentionally empty }
end;
procedure TIpHtmlCustomPanel.SetDefaultTypeFace(const Value: string);
begin
if FDefaultTypeFace<>Value then begin
FDefaultTypeFace := Value;
if (MasterFrame<>nil)and(MasterFrame.Html<>nil) then begin
MasterFrame.Html.DefaultTypeFace := FDefaultTypeFace;
Invalidate;
end;
end;
end;
procedure TIpHtmlCustomPanel.SetFactBAParag(const Value: Real); //JMN
var
V: Real;
begin
V := Value;
if V > 2
then V := 2
else if V < 0
then V := 0;
FFactBAParag := V;
end;
function TIpHtmlCustomPanel.FactBAParagNotIs1: Boolean; //JMN
begin
Result := FactBAParag <> 1;
end;
function TIpHtmlCustomPanel.GetVScrollPos: Integer; //JMN
begin
if MasterFrame <> nil
then Result := MasterFrame.HyperPanel.VScroll.Position
else Result := -1;
end;
procedure TIpHtmlCustomPanel.SetVScrollPos(const Value: Integer); //JMN
begin
if (MasterFrame <> nil) and (Value >= 0)
then MasterFrame.HyperPanel.VScroll.Position := Value;
end;
{ TIpHtmlCustomScanner }
function TIpHtmlCustomScanner.GetTitle: string;
begin
if (MasterFrame <> nil)
and (MasterFrame.Html <> nil)
and (MasterFrame.Html.TitleNode <> nil) then
Result := MasterFrame.Html.TitleNode.Title
else
Result := '';
end;
constructor TIpHtmlCustomScanner.Create(AOwner: TComponent);
begin
inherited;
TargetStack := TStringList.Create;
URLStack := TStringList.Create;
end;
destructor TIpHtmlCustomScanner.Destroy;
begin
TargetStack.Free;
URLStack.Free;
MasterFrame.Free;
MasterFrame := nil;
inherited;
end;
procedure TIpHtmlCustomScanner.OpenURL(const URL: string);
begin
InternalOpenURL('', URL);
end;
procedure TIpHtmlCustomScanner.InternalOpenURL(const Target, HRef : string);
var
URL, BaseURL, RelURL : string;
P : Integer;
TargetFrame : TIpHtmlNvFrame;
begin
if HRef = '' then {!!.12}
Exit; {!!.12}
if HRef[1] = '#' then begin
RelURL := copy(HRef, 2, length(HRef) - 1);
BaseURL := '';
end else begin
if MasterFrame <> nil then begin
if Assigned(FDataProvider) then
URL := FDataProvider.BuildURL(MasterFrame.Html.CURURL, HRef)
else
URL := IpUtils.BuildURL(MasterFrame.Html.CURURL, HRef);
end
else
URL := HRef;
P := CharPos('#', URL);
if P = 0 then begin
RelURL := '';
BaseURL := URL;
end else begin
BaseURL := copy(URL, 1, P - 1);
RelURL := copy(URL, P + 1, length(URL));
end;
end;
if BaseURL <> '' then begin
if (Target <> '') and (MasterFrame <> nil) then
TargetFrame := MasterFrame.FindFrame(Target)
else
TargetFrame := nil;
if TargetFrame = nil then begin
if MasterFrame <> nil then
Push('', MasterFrame.CURURL + MasterFrame.CurAnchor);
if DataProvider = nil then
raise EIpHtmlException.Create(SHtmlNoDataProvider); {!!.02}
if (MasterFrame <> nil)
and (MasterFrame.Html <> nil) then
FDataProvider.DoLeave(MasterFrame.Html);
MasterFrame.Free;
MasterFrame := nil;
Application.ProcessMessages;
MasterFrame := TIpHtmlNVFrame.Create(Self, DataProvider, FlagErrors);
// LazDebug try
MasterFrame.OpenURL(URL);
{ LazDebug except
MasterFrame.Free;
MasterFrame := nil;
raise;
end;}
CurURL := URL;
end else begin
Push(Target, TargetFrame.CURURL + TargetFrame.CurAnchor);
TargetFrame.OpenURL(BaseURL);
end;
end;
if RelURL <> '' then
MasterFrame.MakeAnchorVisible(RelURL)
else
MasterFrame.Home;
end;
procedure TIpHtmlCustomScanner.Push(const Target, URL: string);
begin
if (Stp > 0)
and (TargetStack[Stp] = Target)
and (URLStack[Stp] = URL) then Exit;
while STP < URLStack.Count - 1 do begin
URLStack.Delete(Stp);
TargetStack.Delete(Stp);
end;
URLStack.Add(URL);
TargetStack.Add(Target);
Stp := URLStack.Count - 1;
end;
procedure TIpHtmlCustomScanner.EnumDocuments(Enumerator: TIpHtmlEnumerator);
begin
if MasterFrame <> nil then
MasterFrame.EnumDocuments(Enumerator);
end;
function TIpHtmlCustomScanner.IsURLHtml(const URL: string): Boolean;
var
ResourceType: string;
begin
Result := (FDataProvider <> nil)
and FDataProvider.DoCheckURL(URL, ResourceType)
and (CompareText(ResourceType, 'text/html') = 0);
end;
procedure TIpHtmlCustomScanner.Stop;
begin
if assigned(MasterFrame) then
MasterFrame.Stop;
end;
{Begin !!.14}
function TIpHtmlCustomScanner.GetVersion : string;
begin
Result := IpShortVersion;
end;
procedure TIpHtmlCustomScanner.SetVersion(const Value : string);
begin
{ Intentionally empty }
end;
{End !!.14}
{$IFDEF IP_LAZARUS}
function LazFlatSB_GetScrollInfo(hWnd: HWND; BarFlag: Integer;
var ScrollInfo: TScrollInfo): BOOL; stdcall;
begin
Result:=LCLIntf.GetScrollInfo(HWnd,BarFlag,ScrollInfo);
end;
function LazFlatSB_GetScrollPos(hWnd: HWND; nBar: Integer): Integer; stdcall;
begin
Result:=LCLIntf.GetScrollPos(HWnd,nBar);
end;
function LazFlatSB_SetScrollPos(hWnd: HWND; nBar, nPos: Integer;
bRedraw: BOOL): Integer; stdcall;
begin
Result:=LCLIntf.SetScrollPos(HWnd,nBar,nPos,bRedraw);
end;
function LazFlatSB_SetScrollProp(p1: HWND; index: Integer; newValue: Integer;
p4: Bool): Bool; stdcall;
begin
// ToDo
Result:=true;
end;
function LazFlatSB_SetScrollInfo(hWnd: HWND; BarFlag: Integer;
const ScrollInfo: TScrollInfo; Redraw: BOOL): Integer; stdcall;
begin
Result:=LCLIntf.SetScrollInfo(HWnd,BarFlag,ScrollInfo,Redraw);
end;
{$ENDIF}
procedure InitScrollProcs;
{$IFNDEF IP_LAZARUS}
var
ComCtl32: THandle;
{$ENDIF}
begin
{$IFDEF IP_LAZARUS}
@FlatSB_GetScrollInfo := @LazFlatSB_GetScrollInfo;
@FlatSB_GetScrollPos := @LazFlatSB_GetScrollPos;
@FlatSB_SetScrollPos := @LazFlatSB_SetScrollPos;
@FlatSB_SetScrollProp := @LazFlatSB_SetScrollProp;
@FlatSB_SetScrollInfo := @LazFlatSB_SetScrollInfo;
{$ELSE}
ComCtl32 := GetModuleHandle('comctl32.dll');
@FlatSB_GetScrollInfo := GetProcAddress(ComCtl32, 'FlatSB_GetScrollInfo');
@FlatSB_GetScrollPos := GetProcAddress(ComCtl32, 'FlatSB_GetScrollPos');
@FlatSB_SetScrollPos := GetProcAddress(ComCtl32, 'FlatSB_SetScrollPos');
@FlatSB_SetScrollProp := GetProcAddress(ComCtl32, 'FlatSB_SetScrollProp');
@FlatSB_SetScrollInfo := GetProcAddress(ComCtl32, 'FlatSB_SetScrollInfo');
{$ENDIF}
end;
{ TIntArr }
destructor TIntArr.Destroy;
begin
inherited;
Freemem(InternalIntArr);
end;
function TIntArr.GetValue(Index: Integer): Integer;
begin
if (Index < 0) or (Index >= IntArrSize) then
Result := 0
else
Result := InternalIntArr^[Index];
end;
procedure TIntArr.SetValue(Index, Value: Integer);
var
{$IFDEF IP_LAZARUS}
p: ^Integer;
{$ELSE}
Tmp: PInternalIntArr;
{$ENDIF}
NewSize: Integer;
begin
if Index >= 0 then begin
if Index >= IntArrSize then begin
NewSize := IntArrSize;
repeat
Inc(NewSize, TINTARRGROWFACTOR);
until Index < NewSize;
{$IFDEF IP_LAZARUS code below does not check if InternalIntArr<>nil}
ReallocMem(InternalIntArr,NewSize * sizeof(PtrInt));
p := pointer(InternalIntArr);
Inc(p, IntArrSize);
fillchar(p^, (NewSize - IntArrSize)*sizeOf(PtrInt), 0);
IntArrSize := NewSize;
{$ELSE}
Tmp := AllocMem(NewSize * sizeof(Integer));
move(InternalIntArr^, Tmp^, IntArrSize * sizeof(Integer));
IntArrSize := NewSize; {!!.12}
{Inc(IntArrSize, NewSize);} {Deleted !!.12}
Freemem(InternalIntArr);
InternalIntArr := Tmp;
{$ENDIF}
end;
InternalIntArr^[Index] := Value;
end;
end;
{ TRectArr }
destructor TRectArr.Destroy;
begin
inherited;
Freemem(InternalRectArr);
end;
{
function TRectArr.GetRect(Index: Integer): PRect;
begin
Assert(Self <> nil);
if (Index < 0) then begin
Result := nil;
Exit;
end;
if (Index >= IntArrSize) then
SetValue(Index, NullRect);
Result := @InternalRectArr^[Index];
end;
}
function TRectArr.GetValue(Index: Integer): PRect;
begin
Assert(Self <> nil);
if (Index < 0) or (Index >= IntArrSize) then
Result := nil
else
Result := InternalRectArr^[Index];
end;
procedure TRectArr.SetValue(Index: Integer; Value: PRect);
var
{$IFNDEF IP_LAZARUS}
Tmp: PInternalRectArr;
{$ELSE}
P: Pointer;
{$ENDIF}
NewSize: Integer;
begin
Assert(Self <> nil);
if Index >= 0 then begin
if Index >= IntArrSize then begin
NewSize := IntArrSize;
repeat
Inc(NewSize, TINTARRGROWFACTOR);
until Index < NewSize;
{$IFDEF IP_LAZARUS code below does not check if InternalIntArr<>nil and set buggy IntArrSize}
ReallocMem(InternalRectArr,NewSize * sizeof(PtrInt));
P := pointer(InternalRectArr);
Inc(P, IntArrSize);
fillchar(p^, (NewSize - IntArrSize)*sizeOf(PtrInt), 0);
IntArrSize:=NewSize;
{$ELSE}
Tmp := AllocMem(NewSize * sizeof(Integer));
move(InternalRectArr^, Tmp^, IntArrSize * sizeof(Integer));
Inc(IntArrSize, NewSize);
Freemem(InternalRectArr);
InternalRectArr := Tmp;
{$ENDIF}
end;
InternalRectArr^[Index] := Value;
end;
end;
{ TRectRectArr }
procedure TRectRectArr.Delete(Index: Integer);
var
i: Integer;
begin
if (Index >= 0) and (Index < IntArrSize) then begin
Value[Index].Free;
for i := 1 to IntArrSize - 1 do
InternalRectRectArr[i-1] := InternalRectRectArr[i];
InternalRectRectArr[IntArrSize - 1] := nil;
end;
end;
destructor TRectRectArr.Destroy;
var
i: Integer;
begin
inherited;
for i := 0 to IntArrSize - 1 do
Delete(i);
if InternalRectRectArr <> nil then
Freemem(InternalRectRectArr);
end;
function TRectRectArr.GetValue(Index: Integer): TRectArr;
var
{$IFNDEF IP_LAZARUS}
Tmp: PInternalRectRectArr;
{$ELSE}
P: ^Pointer;
{$ENDIF}
NewSize: Integer;
begin
if Index >= 0 then begin
if Index >= IntArrSize then begin
NewSize := IntArrSize;
repeat
Inc(NewSize, TINTARRGROWFACTOR);
until Index < NewSize;
{$IFDEF IP_LAZARUS code below does not check if InternalIntArr<>nil and set buggy IntArrSize}
ReallocMem(InternalRectRectArr,NewSize * sizeof(PtrInt));
p := pointer(InternalRectRectArr);
Inc(p, IntArrSize);
fillchar(p^, (NewSize - IntArrSize)*sizeOf(PtrInt), 0);
IntArrSize:=NewSize;
{$ELSE}
Tmp := AllocMem(NewSize * sizeof(Integer));
move(InternalRectRectArr^, Tmp^, IntArrSize * sizeof(Integer));
Inc(IntArrSize, NewSize);
Freemem(InternalRectRectArr);
InternalRectRectArr := Tmp;
{$ENDIF}
end;
Result := InternalRectRectArr^[Index];
if Result = nil then begin
Result := TRectArr.Create;
InternalRectRectArr^[Index] := Result;
end;
end else
Result := nil;
end;
{ TIpHtmlPrintSettings }
constructor TIpHtmlPrintSettings.Create;
begin
inherited;
FMarginLeft := DEFAULT_PRINTMARGIN;
FMarginTop := DEFAULT_PRINTMARGIN;
FMarginRight := DEFAULT_PRINTMARGIN;
FMarginBottom := DEFAULT_PRINTMARGIN;
end;
destructor TIpHtmlPrintSettings.Destroy;
begin
inherited;
end;
initialization
{$IFDEF IP_LAZARUS}
{$I iphtml.lrs}
{$ENDIF}
InitScrollProcs;
end.