| 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
| ///////////////////////////////////////////////////////////////////////////
// //
// Copyright (c) 2015 by Charta Software B.V. //
// All rights reserved //
// //
// Version: 1.7.0.83525 //
// Web site: https://pascal.chartasoftware.com/ //
// //
// This code and information are provided "as is" without warranty of //
// any kind. Dissemination of this information or reproduction of //
// this material is strictly forbidden unless prior written permission //
// is obtained from Charta Software B.V.. //
// //
///////////////////////////////////////////////////////////////////////////
unit Visitor;
{
TVisitor is a base class for classes implementing the Visitor pattern.
It works by dynamically dispatching visit function calls at runtime
to correctly named published visit functions: VisitX(). X is the class
name of the visited object.
}
interface
uses
Boolean,
Exception,
Memory.Pointer,
Text;
type
{$IF Defined(FPC)}{$M+}{$ENDIF}
TVisitor = class(TObject)
protected
function GetMethodName(Value: TObject): TText; virtual;
function GetMethodAddress(Prefix: TText; Value: TObject; Suffix: TText): TPointer; virtual;
procedure PrepareMethod(var Method: TMethod; Prefix: TText; Value: TObject; Suffix: TText; RaiseException: TBoolean = True);
procedure Visit(Prefix: TText; Value: TObject; Suffix: TText);
function VisitWithResult(Prefix: TText; Value: TObject; Suffix: TText): TObject;
published
// When deriving from TVisitor make all necessary visit method published
// in order to let the TVisitor find the methods.
end;
{$IF Defined(FPC)}{$M-}{$ENDIF}
EVisitorFunctionNotFound = class(EException);
TVisitFunction = function (Value: TObject): TObject of object;
TVisitProcedure = procedure (Value: TObject) of object;
implementation
{ TVisitor }
function TVisitor.GetMethodAddress(Prefix: TText; Value: TObject; Suffix: TText): TPointer;
var
MethodName: TText;
begin
MethodName := Prefix + GetMethodName(Value) + Suffix;
Result := MethodAddress(MethodName);
end;
function TVisitor.GetMethodName(Value: TObject): TText;
begin
Result := Value.ClassName;
Result := Result.SubTextFrom(1);
end;
procedure TVisitor.PrepareMethod(var Method: TMethod; Prefix: TText; Value: TObject; Suffix: TText; RaiseException: TBoolean);
begin
Method.Code := GetMethodAddress(Prefix, Value, Suffix);
Method.Data := Self;
if (Method.Code = nil) and RaiseException then
raise EVisitorFunctionNotFound.Create(
'Cannot visit an object of class "' + Value.ClassName + '", because method "' +
Self.ClassName + '.' + Prefix + GetMethodName(Value) + Suffix + '" cannot be found in published section'
);
end;
procedure TVisitor.Visit(Prefix: TText; Value: TObject; Suffix: TText);
var
VisitProcedure: TVisitProcedure;
begin
PrepareMethod(TMethod(VisitProcedure), Prefix, Value, Suffix);
try
VisitProcedure(Value);
except
on EAbstractMethodCalled do
raise EException.Create(
'Cannot visit an object of class "' + Value.ClassName + '", because method "' +
Self.ClassName + '.' + Prefix + GetMethodName(Value) + Suffix + '" is abstract'
);
end;
end;
function TVisitor.VisitWithResult(Prefix: TText; Value: TObject; Suffix: TText): TObject;
var
VisitFunction: TVisitFunction;
begin
PrepareMethod(TMethod(VisitFunction), Prefix, Value, Suffix);
try
Result := VisitFunction(Value);
except
on EAbstractMethodCalled do
raise EException.Create(
'Cannot visit an object of class "' + Value.ClassName + '", because method "' +
Self.ClassName + '.' + Prefix + GetMethodName(Value) + Suffix + '" is abstract'
);
end;
end;
end.
|