451 lines
15 KiB
ObjectPascal
451 lines
15 KiB
ObjectPascal
|
{*******************************************************************}
|
||
|
|
{ }
|
||
|
|
{ ExpressWeb Framework by Developer Express }
|
||
|
|
{ HTML rendering Modules }
|
||
|
|
{ }
|
||
|
|
{ Copyright (c) 2000-2009 Developer Express Inc. }
|
||
|
|
{ ALL RIGHTS RESERVED }
|
||
|
|
{ }
|
||
|
|
{ The entire contents of this file is protected by U.S. and }
|
||
|
|
{ International Copyright Laws. Unauthorized reproduction, }
|
||
|
|
{ reverse-engineering, and distribution of all or any portion of }
|
||
|
|
{ the code contained in this file is strictly prohibited and may }
|
||
|
|
{ result in severe civil and criminal penalties and will be }
|
||
|
|
{ prosecuted to the maximum extent possible under the law. }
|
||
|
|
{ }
|
||
|
|
{ RESTRICTIONS }
|
||
|
|
{ }
|
||
|
|
{ THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES }
|
||
|
|
{ (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE }
|
||
|
|
{ SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS }
|
||
|
|
{ LICENSED TO DISTRIBUTE THE EXPRESSWEB FRAMEWORK AND ALL }
|
||
|
|
{ ACCOMPANYING VCL CLASSES AS PART OF AN EXECUTABLE WEB }
|
||
|
|
{ APPLICATION ONLY. }
|
||
|
|
{ }
|
||
|
|
{ THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED }
|
||
|
|
{ FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE }
|
||
|
|
{ COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE }
|
||
|
|
{ AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT }
|
||
|
|
{ AND PERMISSION FROM DEVELOPER EXPRESS INC. }
|
||
|
|
{ }
|
||
|
|
{ CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON }
|
||
|
|
{ ADDITIONAL RESTRICTIONS. }
|
||
|
|
{ }
|
||
|
|
{*******************************************************************}
|
||
|
|
unit cxWebCompProd;
|
||
|
|
|
||
|
|
interface
|
||
|
|
|
||
|
|
{$I cxVer.inc}
|
||
|
|
|
||
|
|
uses
|
||
|
|
Classes, SysUtils,
|
||
|
|
cxWebIntf;
|
||
|
|
|
||
|
|
const
|
||
|
|
scxStyle = 'style'; // Do not localize
|
||
|
|
|
||
|
|
type
|
||
|
|
PcxWebHTMLComponent = ^TcxWebHTMLComponent;
|
||
|
|
TcxWebHTMLComponent = record
|
||
|
|
ClassName: String;
|
||
|
|
Name: String;
|
||
|
|
ParentName: String;
|
||
|
|
Values: TStrings;
|
||
|
|
end;
|
||
|
|
|
||
|
|
EcxComponentProducerException = class(Exception);
|
||
|
|
|
||
|
|
TcxWebComponentProducer = class
|
||
|
|
private
|
||
|
|
FNewComponents: TList;
|
||
|
|
FOwner: TComponent;
|
||
|
|
protected
|
||
|
|
procedure Add(AComponent: TComponent);
|
||
|
|
procedure Clear;
|
||
|
|
|
||
|
|
function SetAttributes(AComponent: TComponent; AName, AValue: String): Boolean;
|
||
|
|
procedure SetComponentProperty(AComponent: TComponent; AName, AValue: String;
|
||
|
|
ASetComponentProperties: Boolean);
|
||
|
|
procedure SetComponentProperties(AComponent: TComponent; AValues: TStrings;
|
||
|
|
ASetComponentProperties: Boolean);
|
||
|
|
function CreateComponent(AComponentClass: TComponentClass;
|
||
|
|
AItem: TcxWebHTMLComponent): TComponent;
|
||
|
|
|
||
|
|
property Owner: TComponent read FOwner;
|
||
|
|
public
|
||
|
|
constructor Create(AOwner: TComponent);
|
||
|
|
destructor Destroy; override;
|
||
|
|
|
||
|
|
function ProduceWebComponent(AItem: TcxWebHTMLComponent;
|
||
|
|
AIsFirstRequest, ASetComponentProperties, ACanAssignCustomAttrs: Boolean;
|
||
|
|
var AComponentClass: TComponentClass): TComponent;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function cxWebGetClass(ARoot: TComponent; AClassName: String): TComponentClass;
|
||
|
|
|
||
|
|
implementation
|
||
|
|
|
||
|
|
uses StrUtils, TypInfo,
|
||
|
|
cxWebColors, cxWebStrs, cxWebGraphics;
|
||
|
|
|
||
|
|
function cxWebGetClass(ARoot: TComponent; AClassName: String): TComponentClass;
|
||
|
|
|
||
|
|
function GetComponentClass(AClassName: string): TClass;
|
||
|
|
var
|
||
|
|
I: Integer;
|
||
|
|
begin
|
||
|
|
Result := nil;
|
||
|
|
for I := 0 to ARoot.ComponentCount - 1 do
|
||
|
|
if CompareText(AClassName, ARoot.Components[I].ClassName) = 0 then
|
||
|
|
begin
|
||
|
|
Result := ARoot.Components[I].ClassType;
|
||
|
|
break;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
const
|
||
|
|
ClassAddonString: Array[0..3] of String = ('TcxWeb', 'Tcx', 'T', '');
|
||
|
|
var
|
||
|
|
APersistentClass: TClass;
|
||
|
|
I: Integer;
|
||
|
|
ASt: string;
|
||
|
|
begin
|
||
|
|
Result := nil;
|
||
|
|
for I := Low(ClassAddonString) to High(ClassAddonString) do
|
||
|
|
begin
|
||
|
|
ASt := ClassAddonString[I] + AClassName;
|
||
|
|
APersistentClass := Classes.GetClass(ASt);
|
||
|
|
if APersistentClass = nil then
|
||
|
|
APersistentClass := GetComponentClass(ASt);
|
||
|
|
if (APersistentClass <> nil) and (APersistentClass.InheritsFrom(TComponent)) then
|
||
|
|
begin
|
||
|
|
Result := TComponentClass(APersistentClass);
|
||
|
|
break;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
type
|
||
|
|
TSetComponentPropertyFunc = procedure (AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: string);
|
||
|
|
|
||
|
|
procedure SetComponentIntegerProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
var
|
||
|
|
Value: Integer;
|
||
|
|
begin
|
||
|
|
if (APPropInfo^.PropType <> nil) and (APPropInfo^.PropType^.Name = 'TcxWebColor') then
|
||
|
|
Value := cxStringToWebColor(AValue)
|
||
|
|
else Value := StrToInt(AValue);
|
||
|
|
SetOrdProp(AInstance, APPropInfo.Name, Value);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentCharProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
var
|
||
|
|
Value: Integer;
|
||
|
|
begin
|
||
|
|
if (Length(AValue) > 0) then
|
||
|
|
Value := Integer(AValue[1])
|
||
|
|
else Value := 0;
|
||
|
|
SetOrdProp(AInstance, APPropInfo.Name, Value);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentEnumerationProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
begin
|
||
|
|
SetEnumProp(AInstance, APPropInfo.Name, AValue);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentFloatProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
var
|
||
|
|
Value: Extended;
|
||
|
|
begin
|
||
|
|
Value := StrToFloat(AValue);
|
||
|
|
SetFloatProp(AInstance, APPropInfo.Name, Value);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentStringProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
begin
|
||
|
|
SetStrProp(AInstance, APPropInfo.Name, AValue);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentSetProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
begin
|
||
|
|
SetSetProp(AInstance, APPropInfo.Name, AValue);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentObjectProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
var
|
||
|
|
Value: TObject;
|
||
|
|
begin
|
||
|
|
if (AValue = '') or (UpperCase(AValue) = 'NIL') or (UpperCase(AValue) = 'NULL') then
|
||
|
|
SetObjectProp(AInstance, APPropInfo.Name, nil)
|
||
|
|
else
|
||
|
|
begin
|
||
|
|
Value := AOwner.FindComponent(AValue);
|
||
|
|
if Value <> nil then
|
||
|
|
SetObjectProp(AInstance, APPropInfo.Name, Value)
|
||
|
|
else
|
||
|
|
raise EcxComponentProducerException.CreateFmt(scxInvalidPropertyValue, [AValue, APPropInfo.Name]);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentMethodProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
var
|
||
|
|
Value: TMethod;
|
||
|
|
begin
|
||
|
|
if csDesigning in AOwner.ComponentState then Exit;
|
||
|
|
|
||
|
|
if (AValue = '') or (UpperCase(AValue) = 'NIL') or (UpperCase(AValue) = 'NULL') then
|
||
|
|
SetObjectProp(AInstance, APPropInfo.Name, nil)
|
||
|
|
else
|
||
|
|
begin
|
||
|
|
Value.Code := AOwner.MethodAddress(AValue);
|
||
|
|
Value.Data := AOwner;
|
||
|
|
if Value.Code <> nil then
|
||
|
|
SetMethodProp(AInstance, APPropInfo.Name, Value)
|
||
|
|
else
|
||
|
|
raise EcxComponentProducerException.CreateFmt(scxInvalidPropertyValue, [AValue, APPropInfo.Name]);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentWideStringProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
begin
|
||
|
|
SetWideStrProp(AInstance, APPropInfo.Name, WideString(AValue));
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentVariantProperty(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
begin
|
||
|
|
SetVariantProp(AInstance, APPropInfo.Name, AValue);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure SetComponentInt64Property(AOwner: TComponent; AInstance: TObject;
|
||
|
|
APPropInfo: PPropInfo; AValue: String);
|
||
|
|
var
|
||
|
|
Value: Int64;
|
||
|
|
begin
|
||
|
|
Value := StrToInt64(AValue);
|
||
|
|
SetInt64Prop(AInstance, APPropInfo.Name, Value);
|
||
|
|
end;
|
||
|
|
|
||
|
|
function GetSetComponentPropertyFunc(ATypeKind: TTypeKind): TSetComponentPropertyFunc;
|
||
|
|
const
|
||
|
|
AFunc: Array[TTypeKind] of TSetComponentPropertyFunc =
|
||
|
|
(nil, // tkUnknown
|
||
|
|
SetComponentIntegerProperty, // tkInteger
|
||
|
|
SetComponentCharProperty, // tkChar
|
||
|
|
SetComponentEnumerationProperty, // tkEnumeration
|
||
|
|
SetComponentFloatProperty, // tkFloat
|
||
|
|
SetComponentStringProperty, // tkString
|
||
|
|
SetComponentSetProperty, // tkSet
|
||
|
|
SetComponentObjectProperty, // tkClass
|
||
|
|
SetComponentMethodProperty, // tkMethod
|
||
|
|
nil, // tkWChar
|
||
|
|
SetComponentStringProperty, // tkLString
|
||
|
|
SetComponentWideStringProperty, // tkWString
|
||
|
|
SetComponentVariantProperty, // tkVariant
|
||
|
|
nil, // tkArray
|
||
|
|
nil, // tkRecord
|
||
|
|
nil, // tkInterface
|
||
|
|
SetComponentInt64Property, // tkInt64
|
||
|
|
nil);// tkDynArray
|
||
|
|
begin
|
||
|
|
Result := AFunc[ATypeKind];
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
procedure GetPropertyInfo(AComponent: TComponent; APropertyName: String;
|
||
|
|
out AInstance: TObject; out APPropInfo: PPropInfo);
|
||
|
|
var
|
||
|
|
ASt: String;
|
||
|
|
begin
|
||
|
|
AInstance := AComponent;
|
||
|
|
APPropInfo := nil;
|
||
|
|
while Pos('.', APropertyName) > 0 do
|
||
|
|
begin
|
||
|
|
ASt := Copy(APropertyName, 1, Pos('.', APropertyName) - 1);
|
||
|
|
APropertyName := Copy(APropertyName, Pos('.', APropertyName) + 1, Length(APropertyName));
|
||
|
|
APPropInfo := GetPropInfo(AInstance, ASt);
|
||
|
|
if (APPropInfo <> nil) then
|
||
|
|
AInstance := GetObjectProp(AInstance, APPropInfo)
|
||
|
|
else AInstance := nil;
|
||
|
|
if AInstance = nil then break;
|
||
|
|
end;
|
||
|
|
if AInstance <> nil then
|
||
|
|
APPropInfo := GetPropInfo(AInstance, APropertyName);
|
||
|
|
end;
|
||
|
|
|
||
|
|
constructor TcxWebComponentProducer.Create(AOwner: TComponent);
|
||
|
|
begin
|
||
|
|
FNewComponents := TList.Create;
|
||
|
|
FOwner := AOwner;
|
||
|
|
end;
|
||
|
|
|
||
|
|
destructor TcxWebComponentProducer.Destroy;
|
||
|
|
begin
|
||
|
|
Clear;
|
||
|
|
FNewComponents.Free;
|
||
|
|
inherited;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TcxWebComponentProducer.ProduceWebComponent(AItem: TcxWebHTMLComponent;
|
||
|
|
AIsFirstRequest, ASetComponentProperties, ACanAssignCustomAttrs: Boolean;
|
||
|
|
var AComponentClass: TComponentClass): TComponent;
|
||
|
|
begin
|
||
|
|
if CompareText(Owner.Name, AItem.Name) = 0 then
|
||
|
|
begin
|
||
|
|
Result := Owner;
|
||
|
|
AComponentClass := TComponentClass(Owner.ClassType);
|
||
|
|
end else
|
||
|
|
begin
|
||
|
|
if CompareText(AItem.ClassName, 'form') = 0 then
|
||
|
|
AComponentClass := TComponentClass(Owner.ClassType)
|
||
|
|
else AComponentClass := cxWebGetClass(Owner, AItem.ClassName);
|
||
|
|
if AComponentClass = nil then
|
||
|
|
raise EcxComponentProducerException.CreateFmt(scxInvalidComponentClassName, [AItem.ClassName]);
|
||
|
|
Result := Owner.FindComponent(AItem.Name);
|
||
|
|
if (Result = nil) and Supports(AComponentClass, IcxWebPage) then
|
||
|
|
Result := Owner;
|
||
|
|
if AIsFirstRequest then
|
||
|
|
begin
|
||
|
|
if Result = nil then
|
||
|
|
Result := CreateComponent(AComponentClass, AItem)
|
||
|
|
else
|
||
|
|
if (Result.ClassType <> TClass(AComponentClass)) then
|
||
|
|
raise EcxComponentProducerException.CreateFmt(scxIncorrectComponentClassName, [AItem.Name, AItem.ClassName]);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
if (Result <> nil) and AIsFirstRequest and ASetComponentProperties then
|
||
|
|
SetComponentProperties(Result, AItem.Values, ASetComponentProperties);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TcxWebComponentProducer.Add(AComponent: TComponent);
|
||
|
|
begin
|
||
|
|
if csDesigning in Owner.ComponentState then
|
||
|
|
FNewComponents.Add(AComponent);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TcxWebComponentProducer.Clear;
|
||
|
|
begin
|
||
|
|
if csDesigning in Owner.ComponentState then
|
||
|
|
while FNewComponents.Count > 0 do
|
||
|
|
begin
|
||
|
|
TComponent(FNewComponents.Items[0]).Free;
|
||
|
|
FNewComponents.Delete(0);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TcxWebComponentProducer.SetAttributes(AComponent: TComponent; AName, AValue: String): Boolean;
|
||
|
|
var
|
||
|
|
AttrIntf: IcxWebControlAttributes;
|
||
|
|
|
||
|
|
procedure GetStyleAttributes(StyleString: string);
|
||
|
|
var
|
||
|
|
S, Name, Value: string;
|
||
|
|
APos: Integer;
|
||
|
|
begin
|
||
|
|
S := StyleString;
|
||
|
|
while true do
|
||
|
|
begin
|
||
|
|
APos := Pos(':', S);
|
||
|
|
if APos = 0 then break;
|
||
|
|
Name := LeftStr(S, APos - 1);
|
||
|
|
S := RightStr(S, Length(S) - APos);
|
||
|
|
APos := Pos(';', S);
|
||
|
|
if APos = 0 then
|
||
|
|
begin
|
||
|
|
AttrIntf.SetStyleAttribute(Name, S);
|
||
|
|
break;
|
||
|
|
end;
|
||
|
|
Value := LeftStr(S, APos - 1);
|
||
|
|
S := RightStr(S, Length(S) - APos);
|
||
|
|
AttrIntf.SetStyleAttribute(Name, Value);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
begin
|
||
|
|
if Supports(AComponent, IcxWebControlAttributes, AttrIntf) then
|
||
|
|
begin
|
||
|
|
if SameText(AName, scxStyle) then
|
||
|
|
GetStyleAttributes(AValue)
|
||
|
|
else AttrIntf.SetAttribute(AName, AValue);
|
||
|
|
Result := True;
|
||
|
|
end
|
||
|
|
else Result := False;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TcxWebComponentProducer.SetComponentProperty(AComponent: TComponent; AName, AValue: String;
|
||
|
|
ASetComponentProperties: Boolean);
|
||
|
|
var
|
||
|
|
APPropInfo: PPropInfo;
|
||
|
|
AFunc: TSetComponentPropertyFunc;
|
||
|
|
AInstance: TObject;
|
||
|
|
begin
|
||
|
|
GetPropertyInfo(AComponent, AName, AInstance, APPropInfo);
|
||
|
|
if APPropInfo <> nil then
|
||
|
|
begin
|
||
|
|
AFunc := GetSetComponentPropertyFunc(APPropInfo.PropType^.Kind);
|
||
|
|
if Assigned(AFunc) then
|
||
|
|
begin
|
||
|
|
if (APPropInfo.PropType^.Kind <> tkMethod) or
|
||
|
|
(Owner.MethodAddress(AValue) <> nil) then
|
||
|
|
begin
|
||
|
|
try
|
||
|
|
AFunc(AComponent.Owner, AInstance, APPropInfo, AValue);
|
||
|
|
except
|
||
|
|
if ASetComponentProperties and not SetAttributes(AComponent, AName, AValue) then
|
||
|
|
raise EcxComponentProducerException.CreateFmt(scxCannotAssignProperty, [AName, AComponent.Name]);
|
||
|
|
end;
|
||
|
|
end else
|
||
|
|
begin
|
||
|
|
if ASetComponentProperties and not SetAttributes(AComponent, AName, AValue) then
|
||
|
|
raise EcxComponentProducerException.CreateFmt(scxCannotAssignProperty, [AName, AComponent.Name]);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end
|
||
|
|
else
|
||
|
|
begin
|
||
|
|
if ASetComponentProperties and not SetAttributes(AComponent, AName, AValue) then
|
||
|
|
raise EcxComponentProducerException.CreateFmt(scxCannotAssignProperty, [AName, AComponent.Name]);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TcxWebComponentProducer.SetComponentProperties(AComponent: TComponent; AValues: TStrings;
|
||
|
|
ASetComponentProperties: Boolean);
|
||
|
|
var
|
||
|
|
I: Integer;
|
||
|
|
begin
|
||
|
|
for I := 0 to AValues.Count - 1 do
|
||
|
|
SetComponentProperty(AComponent, AValues.Names[I], AValues.Values[AValues.Names[I]], ASetComponentProperties);
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TcxWebComponentProducer.CreateComponent(AComponentClass: TComponentClass;
|
||
|
|
AItem: TcxWebHTMLComponent): TComponent;
|
||
|
|
var
|
||
|
|
AParent: TComponent;
|
||
|
|
AWebContainerControl: IcxWebContainerControl;
|
||
|
|
AWebControl: IcxWebControl;
|
||
|
|
begin
|
||
|
|
Result := AComponentClass.Create(Owner);
|
||
|
|
Add(Result);
|
||
|
|
Result.Name := AItem.Name;
|
||
|
|
if SameText(Owner.Name, AItem.ParentName) then
|
||
|
|
AParent := Owner
|
||
|
|
else AParent := Owner.FindComponent(AItem.ParentName);
|
||
|
|
if (AParent <> nil) and
|
||
|
|
Supports(AParent, IcxWebContainerControl, AWebContainerControl) and
|
||
|
|
Supports(Result, IcxWebControl, AWebControl) then
|
||
|
|
AWebControl.Parent := AWebContainerControl;
|
||
|
|
end;
|
||
|
|
|
||
|
|
end.
|