· 4 years ago · May 13, 2021, 01:38 PM
1{***************************************************************************}
2{ }
3{ Spring Framework for Delphi }
4{ }
5{ Copyright (c) 2009-2018 Spring4D Team }
6{ }
7{ http://www.spring4d.org }
8{ }
9{***************************************************************************}
10{ }
11{ Licensed under the Apache License, Version 2.0 (the "License"); }
12{ you may not use this file except in compliance with the License. }
13{ You may obtain a copy of the License at }
14{ }
15{ http://www.apache.org/licenses/LICENSE-2.0 }
16{ }
17{ Unless required by applicable law or agreed to in writing, software }
18{ distributed under the License is distributed on an "AS IS" BASIS, }
19{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. }
20{ See the License for the specific language governing permissions and }
21{ limitations under the License. }
22{ }
23{***************************************************************************}
24
25{$I Spring.inc}
26
27/// <summary>
28/// Declares the fundamental types for the <see href="http://www.spring4d.org">
29/// Spring4D</see> Framework.
30/// </summary>
31unit Spring;
32
33{$IFDEF DELPHIXE4_UP}
34 {$ZEROBASEDSTRINGS OFF}
35{$ENDIF}
36
37interface
38
39uses
40 Classes,
41 Diagnostics,
42 Generics.Collections,
43 Generics.Defaults,
44 Rtti,
45 SyncObjs,
46 SysUtils,
47 TimeSpan,
48 Types,
49 TypInfo,
50 Variants;
51
52type
53
54 {$REGION 'Type redefinitions'}
55
56 TBytes = SysUtils.TBytes;
57 TByteSet = set of Byte;
58
59 TStringDynArray = Types.TStringDynArray;
60
61 TTimeSpan = TimeSpan.TTimeSpan;
62
63 TStopwatch = Diagnostics.TStopwatch;
64
65 PTypeInfo = TypInfo.PTypeInfo;
66 PPPTypeInfo = ^PPTypeInfo;
67
68 PInterface = ^IInterface;
69
70 TValue = Rtti.TValue;
71 PValue = ^TValue;
72
73 TAttributeClass = class of TCustomAttribute;
74
75{$IFDEF DELPHI2010}
76 TThreadID = LongWord;
77
78 PNativeInt = ^NativeInt;
79 PNativeUInt = ^NativeUInt;
80{$ENDIF}
81
82{$IFNDEF DELPHIXE2_UP}
83 IntPtr = NativeInt;
84 UIntPtr = NativeUInt;
85{$ENDIF}
86
87 PObject = ^TObject;
88
89 {$ENDREGION}
90
91
92 {$REGION 'TGuidHelper'}
93
94{$IFDEF DELPHI2010}
95 TGuidHelper = record helper for TGUID
96 public
97 class function Create(const B: TBytes): TGUID; overload; static;
98 class function Create(const S: string): TGUID; overload; static;
99 class function Create(A: Integer; B: SmallInt; C: SmallInt; const D: TBytes): TGUID; overload; static;
100
101 class function &&op_Equality(const left, right: TGUID): Boolean; static;
102 class function &&op_Inequality(const left, right: TGUID): Boolean; static; inline;
103 class function Empty: TGuid; static;
104 class function NewGuid: TGuid; static;
105
106 function ToByteArray: TBytes;
107 function ToString: string;
108 end;
109{$ENDIF}
110
111 {$ENDREGION}
112
113
114 {$REGION 'TMethodHelper'}
115
116{$IFNDEF DELPHIXE3_UP}
117 TMethodHelper = record helper for TMethod
118 public
119 class function &&op_Equality(const left, right: TMethod): Boolean; static; inline;
120 class function &&op_Inequality(const left, right: TMethod): Boolean; static; inline;
121 class function &&op_GreaterThan(const left, right: TMethod): Boolean; static; inline;
122 class function &&op_LessThan(const left, right: TMethod): Boolean; static; inline;
123 end;
124{$ENDIF}
125
126 {$ENDREGION}
127
128
129 {$REGION 'TType'}
130
131 TType = class
132 private
133 class var fContext: TRttiContext;
134 public
135 class constructor Create;
136 class destructor Destroy;
137
138 class function HasWeakRef<T>: Boolean; inline; static;
139 class function IsManaged<T>: Boolean; inline; static;
140 class function Kind<T>: TTypeKind; inline; static;
141
142 class function GetType<T>: TRttiType; overload; static; inline;
143 class function GetType(typeInfo: PTypeInfo): TRttiType; overload; static;
144 class function GetType(classType: TClass): TRttiInstanceType; overload; static;
145
146 class property Context: TRttiContext read fContext;
147 end;
148
149 {$ENDREGION}
150
151
152 {$REGION 'TEnum'}
153
154 /// <summary>
155 /// Provides static methods to manipulate an enumeration type.
156 /// </summary>
157 /// <remarks>
158 /// This does only work for enum types that have type info. Discontiguous
159 /// enumerations and enumerations which don't start at zero have no type
160 /// info. See: <see href="http://stackoverflow.com/questions/1420562/why-do-i-get-type-has-no-typeinfo-error-with-an-enum-type" />
161 /// </remarks>
162 TEnum = class
163 public
164 class function ToInteger<T>(const value: T): Integer; static; inline;
165 class function IsValid<T>(const value: Integer): Boolean; overload; static;
166 class function IsValid<T>(const value: T): Boolean; overload; static;
167 class function GetName<T>(const value: Integer): string; overload; static;
168 class function GetName<T>(const value: T): string; overload; static;
169 class function GetNames<T>: TStringDynArray; static;
170 class function GetValue<T>(const value: string): Integer; overload; static;
171 class function GetValue<T>(const value: T): Integer; overload; static;
172 class function GetValues<T>: TIntegerDynArray; static;
173 class function TryParse<T>(const value: Integer; out enum: T): Boolean; overload; static;
174 class function TryParse<T>(const value: string; out enum: T): Boolean; overload; static;
175 class function Parse<T>(const value: Integer): T; overload; static;
176 class function Parse<T>(const value: string): T; overload; static;
177 end;
178
179 {$ENDREGION}
180
181
182 {$REGION 'TActivator'}
183
184 IObjectActivator = interface
185 ['{CE05FB89-3467-449E-81EA-A5AEECAB7BB8}']
186 function CreateInstance: TValue;
187 end;
188
189 TConstructor = function(InstanceOrVMT: Pointer; Alloc: ShortInt = 1): Pointer;
190
191 TActivator = record
192 private
193 class var ConstructorCache: TDictionary<PTypeInfo,TConstructor>;
194 class function FindConstructor(const classType: TRttiInstanceType;
195 const arguments: array of TValue): TRttiMethod; overload; static;
196 class procedure RaiseNoConstructorFound(classType: TClass); static;
197 public
198 class constructor Create;
199 class destructor Destroy;
200
201 class procedure ClearCache; static;
202
203 class function CreateInstance(const classType: TRttiInstanceType): TValue; overload; static;
204 class function CreateInstance(const classType: TRttiInstanceType;
205 const arguments: array of TValue): TValue; overload; static;
206 class function CreateInstance(const classType: TRttiInstanceType;
207 const constructorMethod: TRttiMethod; const arguments: array of TValue): TValue; overload; static;
208
209 class function CreateInstance(typeInfo: PTypeInfo): TObject; overload; static; inline;
210 class function CreateInstance(const typeName: string): TObject; overload; static; inline;
211 class function CreateInstance(const typeName: string;
212 const arguments: array of TValue): TObject; overload; static;
213
214 class function CreateInstance(classType: TClass): TObject; overload; static;
215 class function CreateInstance(classType: TClass;
216 const arguments: array of TValue): TObject; overload; static;
217
218 class function CreateInstance<T: class>: T; overload; static; inline;
219 class function CreateInstance<T: class>(
220 const arguments: array of TValue): T; overload; static;
221
222 class function FindConstructor(classType: TClass): TConstructor; overload; static;
223 end;
224
225 {$ENDREGION}
226
227
228 {$REGION 'Attributes'}
229
230 TBaseAttribute = class(TCustomAttribute)
231 strict protected
232 constructor Create;
233 end;
234
235{$IFDEF DELPHIXE3_UP}
236 DefaultAttribute = Classes.DefaultAttribute;
237{$ELSE}
238 DefaultAttribute = class(TBaseAttribute)
239 strict protected
240 fValue: Variant;
241 public
242 constructor Create(const defaultValue: Boolean); overload;
243 constructor Create(const defaultValue: Integer); overload;
244 constructor Create(const defaultValue: Cardinal); overload;
245 constructor Create(const defaultValue: Int64); overload;
246 constructor Create(const defaultValue: UInt64); overload;
247 constructor Create(const defaultValue: string); overload;
248 constructor Create(const defaultValue: Extended); overload;
249 property Value: Variant read fValue;
250 end;
251{$ENDIF}
252
253 /// <summary>
254 /// This attribute marks automatically initialized interface or object
255 /// fields inside of classes that inherit from TManagedObject or are using
256 /// the mechanism provided by TInitTable.
257 /// </summary>
258 /// <remarks>
259 /// Because of limited RTTI in Delphi 2010 interface fields are only
260 /// supported when the interface type has a GUID.
261 /// </remarks>
262 ManagedAttribute = class(TBaseAttribute)
263 strict private
264 fCreateInstance: Boolean;
265 fInstanceClass: TClass;
266 fFactory: TFunc<PTypeInfo,Pointer>;
267 strict protected
268 constructor Create(const factory: TFunc<PTypeInfo,Pointer>); overload;
269 public
270 constructor Create(createInstance: Boolean = True); overload;
271 constructor Create(instanceClass: TClass) overload;
272
273 property CreateInstance: Boolean read fCreateInstance;
274 property InstanceClass: TClass read fInstanceClass;
275 property Factory: TFunc<PTypeInfo,Pointer> read fFactory;
276 end;
277
278 {$ENDREGION}
279
280
281 {$REGION 'TInitTable'}
282
283 TInitTable = class
284 strict private type
285 TInitializableField = class abstract
286 public
287 procedure InitializeValue(instance: Pointer); virtual; abstract;
288 end;
289
290 TDefaultField<T> = class(TInitializableField)
291 strict private type
292 PT = ^T;
293 private
294 fOffset: Integer;
295 fValue: T;
296 public
297 constructor Create(offset: Integer; const value: Variant);
298 procedure InitializeValue(instance: Pointer); override; final;
299 end;
300
301 TDefaultProperty<T> = class(TInitializableField)
302 strict private type
303 TGetter = function: T of object;
304 TIndexedGetter = function(index: Integer): T of object;
305 TSetter = procedure(const value: T) of object;
306 TIndexedSetter = procedure(index: Integer; const value: T) of object;
307 var
308 fPropInfo: PPropInfo;
309 fValue: T;
310 public
311 constructor Create(propInfo: PPropInfo; const value: Variant);
312 procedure InitializeValue(instance: Pointer); override; final;
313 end;
314
315 TFinalizableField = class abstract(TInitializableField)
316 public
317 procedure FinalizeValue(instance: Pointer); virtual; abstract;
318 end;
319
320 TManagedObjectField = class(TFinalizableField)
321 private
322 fOffset: Integer;
323 fFieldType: PTypeInfo;
324 fCls: TClass;
325 fCtor: TConstructor;
326 fFactory: TFunc<PTypeInfo,Pointer>;
327 public
328 constructor Create(offset: Integer; fieldType: PTypeInfo; cls: TClass;
329 const factory: TFunc<PTypeInfo,Pointer>);
330 procedure InitializeValue(instance: Pointer); override;
331 procedure FinalizeValue(instance: Pointer); override;
332 end;
333
334 TManagedInterfaceField = class(TManagedObjectField)
335 private
336 fEntry: PInterfaceEntry;
337 function CreateInstance: Pointer;
338 public
339 constructor Create(offset: Integer; fieldType: PTypeInfo; cls: TClass;
340 const factory: TFunc<PTypeInfo,Pointer>; entry: PInterfaceEntry);
341 procedure InitializeValue(instance: Pointer); override;
342 procedure FinalizeValue(instance: Pointer); override;
343 end;
344
345 const
346 {$IF SizeOf(Pointer) = 4}
347 PROPSLOT_MASK = $FF000000;
348 PROPSLOT_FIELD = $FF000000;
349 PROPSLOT_VIRTUAL = $FE000000;
350 {$ELSEIF SizeOf(Pointer) = 8}
351 PROPSLOT_MASK = $FF00000000000000;
352 PROPSLOT_FIELD = $FF00000000000000;
353 PROPSLOT_VIRTUAL = $FE00000000000000;
354 {$ELSE OTHER_PTR_SIZE}
355 {$MESSAGE Fatal 'Unrecognized pointer size'}
356 {$IFEND OTHER_PTR_SIZE}
357 strict private
358 DefaultFields: TArray<TInitializableField>;
359 ManagedFields: TArray<TFinalizableField>;
360 DefaultFieldCount: Integer;
361 ManagedFieldCount: Integer;
362 private class var
363{$IFDEF USE_VMTAUTOTABLE}
364 InitTables: TObjectList<TInitTable>;
365{$ELSE}
366 InitTables: TDictionary<TClass,TInitTable>;
367{$ENDIF}
368 FormatSettings: TFormatSettings;
369 procedure AddDefaultField(fieldType: PTypeInfo; const value: Variant;
370 offset: Integer);
371 procedure AddDefaultProperty(fieldType: PTypeInfo; const value: Variant;
372 propInfo: PPropInfo);
373 procedure AddManagedField(const field: TRttiField; const attribute: ManagedAttribute);
374 class function GetCodePointer(instance: TObject; p: Pointer): Pointer; static; inline;
375 public
376 class constructor Create;
377 class destructor Destroy;
378
379 constructor Create(classType: TClass);
380 destructor Destroy; override;
381
382 procedure InitInstance(instance: Pointer);
383 {$IFNDEF AUTOREFCOUNT}
384 procedure CleanupInstance(instance: Pointer);
385 {$ENDIF}
386 end;
387
388 {$ENDREGION}
389
390
391 {$REGION 'TManagedObject'}
392
393 TManagedObject = class(TObject)
394 public
395 class function NewInstance: TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; override;
396 {$IFNDEF AUTOREFCOUNT}
397 procedure FreeInstance; override;
398 {$ENDIF}
399 end;
400
401 TManagedInterfacedObject = class(TInterfacedObject)
402 public
403 class function NewInstance: TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; override;
404 {$IFNDEF AUTOREFCOUNT}
405 procedure FreeInstance; override;
406 {$ENDIF}
407 end;
408
409 {$ENDREGION}
410
411
412 {$REGION 'TCollectionChangedAction'}
413
414 /// <summary>
415 /// Describes the action that caused a CollectionChanged event.
416 /// </summary>
417 TCollectionChangedAction = (
418 /// <summary>
419 /// An item was added to the collection.
420 /// </summary>
421 caAdded,
422
423 /// <summary>
424 /// An item was removed from the collection.
425 /// </summary>
426 caRemoved,
427
428 /// <summary>
429 /// An item was removed from the collection without considering
430 /// ownership.
431 /// </summary>
432 caExtracted,
433
434 /// <summary>
435 /// An item was replaced in the collection.
436 /// </summary>
437 caReplaced,
438
439 /// <summary>
440 /// An item was moved within the collection.
441 /// </summary>
442 caMoved,
443
444 /// <summary>
445 /// The content of the collection changed dramatically.
446 /// </summary>
447 caReseted,
448
449 /// <summary>
450 /// An item in the collection was changed.
451 /// </summary>
452 caChanged
453 );
454
455 {$ENDREGION}
456
457
458 {$REGION 'TValueHelper'}
459
460 TValueHelper = record helper for TValue
461 private
462 procedure Init(typeInfo: Pointer);
463{$IFNDEF DELPHIXE8_UP}
464 function GetTypeKind: TTypeKind; inline;
465{$ENDIF}
466 function GetValueType: TRttiType;
467 function TryAsInterface(typeInfo: PTypeInfo; out Intf): Boolean;
468 class procedure RaiseConversionError(source, target: PTypeInfo); static;
469 public
470 class function &&op_Equality(const left, right: TValue): Boolean; static; inline;
471 class function &&op_Inequality(const left, right: TValue): Boolean; static; inline;
472
473{$IFNDEF DELPHIXE4_UP}
474 class function &&op_Implicit(value: Single): TValue; overload; static; inline;
475 class function &&op_Implicit(value: Double): TValue; overload; static; inline;
476 class function &&op_Implicit(value: Currency): TValue; overload; static; inline;
477 class function &&op_Implicit(value: UInt64): TValue; overload; static; inline;
478{$ENDIF}
479
480{$IFNDEF DELPHIXE8_UP}
481 class function &&op_Implicit(const value: TVarRec): TValue; overload; static; inline;
482{$ENDIF}
483
484 class function &&op_Implicit(value: TDateTime): TValue; overload; static; inline;
485 class function &&op_Implicit(value: TDate): TValue; overload; static; inline;
486 class function &&op_Implicit(value: TTime): TValue; overload; static; inline;
487
488 class function From(buffer: Pointer; typeInfo: PTypeInfo): TValue; overload; static;
489 class function From(instance: TObject; classType: TClass): TValue; overload; static;
490 class function FromFloat(typeInfo: PTypeInfo; value: Extended): TValue; overload; static;
491 class function FromVariant(const value: Variant): TValue; static;
492
493 /// <summary>
494 /// Returns a TValue that holds the value that was passed in a TVarRec.
495 /// The TypeInfo of the returned TValue depends on the VType of the
496 /// passed TVarRec.
497 /// </summary>
498 class function FromVarRec(const value: TVarRec): TValue; static;
499
500 function AsPointer: Pointer;
501
502{$IFDEF DELPHI2010}
503 function AsString: string;
504{$ENDIF}
505
506 /// <summary>
507 /// Casts the currently stored value to another type.
508 /// </summary>
509 /// <remarks>
510 /// This method fixes the missing interface cast support of
511 /// TValue.AsType<T>.
512 /// </remarks>
513 function AsType<T>: T;
514
515 /// <summary>
516 /// Casts the currently stored value to another type.
517 /// </summary>
518 /// <remarks>
519 /// This method fixes the missing interface cast support of TValue.Cast.
520 /// </remarks>
521 function Cast(typeInfo: PTypeInfo): TValue;
522
523 /// <summary>
524 /// Compares to another TValue.
525 /// </summary>
526 function CompareTo(const value: TValue): Integer;
527
528 /// <summary>
529 /// Converts the stored value to another type.
530 /// </summary>
531 function Convert<T>: TValue; overload;
532
533 /// <summary>
534 /// Converts the stored value to another type using the specified format
535 /// settings.
536 /// </summary>
537 function Convert<T>(const formatSettings: TFormatSettings): TValue; overload;
538
539 /// <summary>
540 /// Converts the stored value to another type.
541 /// </summary>
542 function Convert(targetType: PTypeInfo): TValue; overload;
543
544 /// <summary>
545 /// Converts the stored value to another type using the specified format
546 /// settings.
547 /// </summary>
548 function Convert(targetType: PTypeInfo; const formatSettings: TFormatSettings): TValue; overload;
549
550 /// <summary>
551 /// Checks for equality with another TValue.
552 /// </summary>
553 function Equals(const value: TValue): Boolean;
554
555 /// <summary>
556 /// Returns the array content.
557 /// </summary>
558 function GetArray: TArray<TValue>;
559
560 /// <summary>
561 /// Returns the stored nullable value or <c>TValue.Empty</c> when it is
562 /// null.
563 /// </summary>
564 /// <exception cref="EInvalidOperationException">
565 /// When the stored value is not a nullable value.
566 /// </exception>
567 function GetNullableValue: TValue;
568
569 /// <summary>
570 /// Checks whether the stored value is an object or interface reference.
571 /// </summary>
572 function IsInstance: Boolean;
573
574 /// <summary>
575 /// Checks whether the stored value is an interface reference.
576 /// </summary>
577 function IsInterface: Boolean;
578
579 /// <summary>
580 /// Checks whether the stored value is a float type.
581 /// </summary>
582 function IsFloat: Boolean;
583
584 /// <summary>
585 /// Checks whether the stored value is a numeric type.
586 /// </summary>
587 function IsNumeric: Boolean;
588
589 /// <summary>
590 /// Checks whether the stored value is a <c>string</c>.
591 /// </summary>
592 function IsString: Boolean;
593
594 /// <summary>
595 /// Checks whether the stored value is a <c>Variant</c>.
596 /// </summary>
597 function IsVariant: Boolean;
598
599{$IFDEF DELPHI2010}
600 function IsType<T>: Boolean; overload;
601 function IsType(ATypeInfo: PTypeInfo): Boolean; overload;
602{$ENDIF}
603
604 /// <summary>
605 /// Sets the stored value of a nullable.
606 /// </summary>
607 procedure SetNullableValue(const value: TValue);
608
609 /// <summary>
610 /// Tries to convert the stored value. Returns false when the conversion
611 /// is not possible.
612 /// </summary>
613 function TryConvert(targetType: PTypeInfo; out targetValue: TValue): Boolean; overload;
614
615 /// <summary>
616 /// Tries to convert the stored value using the specified format
617 /// settings. Returns false when the conversion is not possible.
618 /// </summary>
619 function TryConvert(targetType: PTypeInfo; out targetValue: TValue;
620 const formatSettings: TFormatSettings): Boolean; overload;
621
622 /// <summary>
623 /// Tries to get the stored value of a nullable. Returns false when the
624 /// nullable is null.
625 /// </summary>
626 function TryGetNullableValue(out value: TValue): Boolean;
627
628 /// <summary>
629 /// Tries to get the stored value of a lazy. Returns false when the lazy
630 /// was not assigned.
631 /// </summary>
632 function TryGetLazyValue(out value: TValue): Boolean;
633
634 /// <summary>
635 /// Tries to convert the stored value. Returns false when the conversion
636 /// is not possible.
637 /// </summary>
638 function TryToType<T>(out targetValue: T): Boolean; overload;
639
640 /// <summary>
641 /// Tries to convert the stored value using the specified format
642 /// settings. Returns false when the conversion is not possible.
643 /// </summary>
644 function TryToType<T>(out targetValue: T;
645 const formatSettings: TFormatSettings): Boolean; overload;
646
647 /// <summary>
648 /// Returns the stored value as TObject.
649 /// </summary>
650 function ToObject: TObject;
651
652 /// <summary>
653 /// Returns the string representation of the stored value.
654 /// </summary>
655 function ToString: string;
656
657 /// <summary>
658 /// Converts stored value to the specified type.
659 /// </summary>
660 function ToType<T>: T; overload;
661
662 /// <summary>
663 /// Converts stored value to the specified type using the specified
664 /// format settings.
665 /// </summary>
666 function ToType<T>(const formatSettings: TFormatSettings): T; overload;
667
668 /// <summary>
669 /// Returns the stored value as Variant.
670 /// </summary>
671 function ToVariant: Variant;
672
673 /// <summary>
674 /// If the stored value is an object it will get destroyed/disposed.
675 /// </summary>
676 procedure Free;
677
678 /// <summary>
679 /// Specifies the type kind of the stored value.
680 /// </summary>
681 /// <remarks>
682 /// This fixes the issue with returning <c>tkUnknown</c> when the stored
683 /// value is an empty reference type (RSP-10071).
684 /// </remarks>
685{$IFNDEF DELPHIXE8_UP}
686 property Kind: TTypeKind read GetTypeKind;
687{$ENDIF}
688
689 /// <summary>
690 /// Returns the TRttiType of the stored value.
691 /// </summary>
692 property ValueType: TRttiType read GetValueType;
693 end;
694
695 {$ENDREGION}
696
697
698 {$REGION 'TRttiMethodHelper'}
699
700{$IF CompilerVersion < 31}
701 {$HINTS OFF}
702 TRttiMethodHack = class(TRttiMethod)
703 private
704 function GetParameters: TArray<TRttiParameter>; override;
705 end;
706 {$HINTS ON}
707{$IFEND}
708
709 TRttiMethodHelper = class helper for TRttiMethod
710 private
711 function GetIsAbstract: Boolean;
712 function GetReturnTypeHandle: PTypeInfo;
713{$IF CompilerVersion < 31}
714 procedure DispatchValue(const value: TValue; typeInfo: PTypeInfo);
715 procedure FixParameters(const parameters: TArray<TRttiParameter>);
716 public
717 /// <summary>
718 /// Returns the parameters of the method
719 /// </summary>
720 /// <remarks>
721 /// This fixes the incorrect Parent property of TRttiParameter (RSP-9824).
722 /// </remarks>
723 function GetParameters: TArray<TRttiParameter>; inline;
724
725 /// <summary>
726 /// Invokes the method.
727 /// </summary>
728 /// <remarks>
729 /// This fixes the missing interface cast support in TValue (QC#123729).
730 /// </remarks>
731 function Invoke(Instance: TObject; const Args: array of TValue): TValue; overload;
732
733 /// <summary>
734 /// Invokes the method.
735 /// </summary>
736 /// <remarks>
737 /// This fixes the missing interface cast support in TValue (QC#123729).
738 /// </remarks>
739 function Invoke(Instance: TClass; const Args: array of TValue): TValue; overload;
740
741 /// <summary>
742 /// Invokes the method.
743 /// </summary>
744 /// <remarks>
745 /// This fixes the missing interface cast support in TValue (QC#123729).
746 /// </remarks>
747 function Invoke(Instance: TValue; const Args: array of TValue): TValue; overload;
748{$IFEND}
749 public
750
751 /// <summary>
752 /// Returns if the method is dynamic or virtual abstract.
753 /// </summary>
754 property IsAbstract: Boolean read GetIsAbstract;
755
756 /// <summary>
757 /// Returns the PTypeInfo of the ReturnType if assigned; otherwise
758 /// returns nil.
759 /// </summary>
760 property ReturnTypeHandle: PTypeInfo read GetReturnTypeHandle;
761 end;
762
763 {$ENDREGION}
764
765
766 {$REGION 'TRttiInvokableTypeHelper'}
767
768 {$IFDEF DELPHIXE2_UP}
769 TRttiInvokableTypeHelper = class helper for TRttiInvokableType
770 public
771 function CreateImplementation(AUserData: Pointer;
772 const ACallback: TMethodImplementationCallback): TMethodImplementation;
773 end;
774 {$ENDIF}
775
776 {$ENDREGION}
777
778
779 {$REGION 'TMethodImplementationHelper'}
780
781 {$IFNDEF DELPHI2010}
782 TMethodImplementationHelper = class helper for TMethodImplementation
783 public
784 function AsMethod: TMethod;
785 end;
786 {$ENDIF}
787
788 {$ENDREGION}
789
790
791 {$REGION 'Procedure types'}
792
793 /// <summary>
794 /// Represents a logical predicate.
795 /// </summary>
796 /// <param name="arg">
797 /// the value needs to be determined.
798 /// </param>
799 /// <returns>
800 /// Returns <c>True</c> if the value was accepted, otherwise, returns <c>
801 /// False</c>.
802 /// </returns>
803 /// <remarks>
804 /// <note type="tip">
805 /// This type redefined the <see cref="SysUtils|TPredicate`1">
806 /// SysUtils.TPredicate<T></see> type with a const parameter.
807 /// </note>
808 /// </remarks>
809 /// <seealso cref="Spring.DesignPatterns|ISpecification<T>" />
810 {$M+}
811 TPredicate<T> = reference to function(const arg: T): Boolean;
812 {$M-}
813
814 /// <summary>
815 /// Represents an anonymous method that has a single parameter and does not
816 /// return a value.
817 /// </summary>
818 /// <seealso cref="TActionProc<T>" />
819 /// <seealso cref="TActionMethod<T>" />
820 {$M+}
821 TAction<T> = reference to procedure(const arg: T);
822
823 TAction<T1, T2> = reference to procedure(const arg1: T1; const arg2: T2);
824
825 TAction<T1, T2, T3> = reference to procedure(const arg1: T1; const arg2: T2; const arg3: T3);
826
827 TAction<T1, T2, T3, T4> = reference to procedure(const arg1: T1; const arg2: T2; const arg3: T3; const arg4: T4);
828 {$M-}
829
830 /// <summary>
831 /// Represents a procedure that has a single parameter and does not return
832 /// a value.
833 /// </summary>
834 /// <seealso cref="TAction<T>" />
835 /// <seealso cref="TActionMethod<T>" />
836 TActionProc<T> = procedure(const arg: T);
837
838 /// <summary>
839 /// Represents a instance method that has a single parameter and does not
840 /// return a value.
841 /// </summary>
842 /// <seealso cref="TAction<T>" />
843 /// <seealso cref="TActionProc<T>" />
844 TActionMethod<T> = procedure(const arg: T) of object;
845
846 /// <summary>
847 /// Represents a anonymous method that has the same signature as
848 /// TNotifyEvent.
849 /// </summary>
850 {$M+}
851 TNotifyProc = reference to procedure(Sender: TObject);
852 {$M-}
853
854 /// <summary>
855 /// An event type like TNotifyEvent that also has a generic item parameter.
856 /// </summary>
857 TNotifyEvent<T> = procedure(Sender: TObject; const item: T) of object;
858
859 {$ENDREGION}
860
861
862 {$REGION 'Multicast Event'}
863
864 TMethodPointer = procedure of object;
865
866 IEvent = interface
867 ['{CFC14C4D-F559-4A46-A5B1-3145E9B182D8}']
868 {$REGION 'Property Accessors'}
869 function GetCanInvoke: Boolean;
870 function GetInvoke: TMethodPointer;
871 function GetEnabled: Boolean;
872 function GetOnChanged: TNotifyEvent;
873 function GetUseFreeNotification: Boolean;
874 procedure SetEnabled(const value: Boolean);
875 procedure SetOnChanged(const value: TNotifyEvent);
876 procedure SetUseFreeNotification(const value: Boolean);
877 {$ENDREGION}
878
879 procedure Add(const handler: TMethodPointer);
880 procedure Remove(const handler: TMethodPointer);
881
882 /// <summary>
883 /// Removes all event handlers which were registered by an instance.
884 /// </summary>
885 procedure RemoveAll(instance: Pointer);
886
887 /// <summary>
888 /// Clears all event handlers.
889 /// </summary>
890 procedure Clear;
891
892 /// <summary>
893 /// Returns <b>True</b> when the event will do anything because it is <see cref="Spring|IEvent.Enabled">
894 /// Enabled</see> and contains any event handler. Otherwise returns <b>
895 /// False</b>.
896 /// </summary>
897 property CanInvoke: Boolean read GetCanInvoke;
898
899 /// <summary>
900 /// Gets the value indicates whether the multicast event is enabled, or
901 /// sets the value to enable or disable the event.
902 /// </summary>
903 property Enabled: Boolean read GetEnabled write SetEnabled;
904
905 property Invoke: TMethodPointer read GetInvoke;
906 property OnChanged: TNotifyEvent read GetOnChanged write SetOnChanged;
907
908 /// <summary>
909 /// Specifies if the event internally tracks if the event handlers are
910 /// implemented by a TComponent descendant and automatically unsubscribes
911 /// those when the implementing component is being destroyed.
912 /// </summary>
913 property UseFreeNotification: Boolean read GetUseFreeNotification write SetUseFreeNotification;
914 end;
915
916 /// <summary>
917 /// Represents a multicast event.
918 /// </summary>
919 /// <typeparam name="T">
920 /// The event handler type must be an instance procedural type such as
921 /// TNotifyEvent.
922 /// </typeparam>
923 IEvent<T> = interface(IEvent)
924 {$REGION 'Property Accessors'}
925 function GetInvoke: T;
926 {$ENDREGION}
927
928 /// <summary>
929 /// Adds an event handler to the list.
930 /// </summary>
931 procedure Add(handler: T);
932
933 /// <summary>
934 /// Removes an event handler if it was added to the event.
935 /// </summary>
936 procedure Remove(handler: T);
937
938 /// <summary>
939 /// Invokes all event handlers.
940 /// </summary>
941 property Invoke: T read GetInvoke;
942 end;
943
944 Event<T> = record
945 private
946 fInstance: IEvent<T>;
947 function GetCanInvoke: Boolean;
948 function GetEnabled: Boolean;
949 function GetInvoke: T;
950 function GetOnChanged: TNotifyEvent;
951 function GetUseFreeNotification: Boolean;
952 procedure SetEnabled(const value: Boolean);
953 procedure SetOnChanged(value: TNotifyEvent);
954 procedure SetUseFreeNotification(const value: Boolean);
955 procedure EnsureInitialized;
956 public
957 procedure Add(const handler: T);
958 procedure Remove(const handler: T);
959 procedure RemoveAll(instance: Pointer);
960 procedure Clear;
961
962 property CanInvoke: Boolean read GetCanInvoke;
963 property Enabled: Boolean read GetEnabled write SetEnabled;
964 property Invoke: T read GetInvoke;
965 property OnChanged: TNotifyEvent read GetOnChanged write SetOnChanged;
966
967 /// <summary>
968 /// Specifies if the event internally tracks if the event handlers are
969 /// implemented by a TComponent descendant and automatically unsubscribes
970 /// those when the implementing component is being destroyed.
971 /// </summary>
972 property UseFreeNotification: Boolean read GetUseFreeNotification write SetUseFreeNotification;
973
974 class operator Implicit(const value: IEvent<T>): Event<T>;
975 class operator Implicit(var value: Event<T>): IEvent<T>;
976 class operator Implicit(var value: Event<T>): T;
977 end;
978
979 INotifyEvent = IEvent<TNotifyEvent>;
980
981 INotifyEvent<T> = interface(IEvent<TNotifyEvent<T>>)
982 end;
983
984 {$ENDREGION}
985
986
987 {$REGION 'Interfaces'}
988
989 /// <summary>
990 /// Supports cloning, which creates a new instance of a class with the same
991 /// value as an existing instance.
992 /// </summary>
993 IClonable = interface(IInvokable)
994 ['{B6BC3795-624B-434F-BB19-6E8F55149D0A}']
995
996 /// <summary>
997 /// Creates a new object that is a copy of the current instance.
998 /// </summary>
999 /// <returns>
1000 /// A new object that is a copy of this instance.
1001 /// </returns>
1002 function Clone: TObject;
1003 end;
1004
1005 /// <summary>
1006 /// Defines a generalized type-specific comparison method that a class
1007 /// implements to order or sort its instances.
1008 /// </summary>
1009 IComparable = interface(IInvokable)
1010 ['{7F0E25C8-50D7-4CF0-AB74-1913EBD3EE42}']
1011
1012 /// <summary>
1013 /// Compares the current instance with another object of the same type
1014 /// and returns an integer that indicates whether the current instance
1015 /// precedes, follows, or occurs in the same position in the sort order
1016 /// as the other object.
1017 /// </summary>
1018 /// <param name="obj">
1019 /// An object to compare with this instance.
1020 /// </param>
1021 /// <returns>
1022 /// <para>
1023 /// A value that indicates the relative order of the objects being
1024 /// compared. The return value has these meanings:
1025 /// </para>
1026 /// <list type="table">
1027 /// <listheader>
1028 /// <term>Value</term>
1029 /// <description>Meaning</description>
1030 /// </listheader>
1031 /// <item>
1032 /// <term>Less than zero</term>
1033 /// <description>This instance precedes <i>obj</i> in the sort
1034 /// order.</description>
1035 /// </item>
1036 /// <item>
1037 /// <term>Zero</term>
1038 /// <description>This instance occurs in the same position in
1039 /// the sort order as <i>obj</i>.</description>
1040 /// </item>
1041 /// <item>
1042 /// <term>Greater than zero</term>
1043 /// <description>This instance follows <i>obj</i> in the sort
1044 /// order.</description>
1045 /// </item>
1046 /// </list>
1047 /// </returns>
1048 /// <exception cref="Spring|EArgumentException">
1049 /// <i>obj</i> is not the same type as this instance.
1050 /// </exception>
1051 function CompareTo(const obj: TObject): Integer;
1052 end;
1053
1054 /// <summary>
1055 /// Base interface for anything that has a countable quantity.
1056 /// </summary>
1057 ICountable = interface(IInvokable)
1058 ['{CA225A9C-B6FD-4D6E-B3BD-22119CCE6C87}']
1059 {$REGION 'Property Accessors'}
1060 function GetCount: Integer;
1061 function GetIsEmpty: Boolean;
1062 {$ENDREGION}
1063
1064 /// <summary>
1065 /// Returns the number of elements in a countable.
1066 /// </summary>
1067 property Count: Integer read GetCount;
1068
1069 /// <summary>
1070 /// Determines whether a countable contains no elements.
1071 /// </summary>
1072 property IsEmpty: Boolean read GetIsEmpty;
1073 end;
1074
1075 {$ENDREGION}
1076
1077
1078 {$REGION 'TNamedValue'}
1079
1080 /// <summary>
1081 /// A record type that stores a TValue and a name.
1082 /// </summary>
1083 TNamedValue = record
1084 private
1085 fValue: TValue;
1086 fName: string;
1087 public
1088 constructor Create(const value: TValue; const name: string);
1089 class function From<T>(const value: T; const name: string): TNamedValue; overload; static;
1090
1091 class operator Implicit(const value: TNamedValue): TValue;
1092 class operator Implicit(const value: TValue): TNamedValue;
1093
1094 property Name: string read fName;
1095 property Value: TValue read fValue;
1096 end;
1097
1098 {$ENDREGION}
1099
1100
1101 {$REGION 'TTypedValue'}
1102
1103 /// <summary>
1104 /// A record type that stores a TValue and a typeinfo.
1105 /// </summary>
1106 TTypedValue = record
1107 private
1108 fValue: TValue;
1109 fTypeInfo: PTypeInfo;
1110 public
1111 constructor Create(const value: TValue; const typeInfo: PTypeInfo);
1112 class function From<T>(const value: T): TTypedValue; overload; static;
1113 class function From<T>(const value: T; const typeInfo: PTypeInfo): TTypedValue; overload; static;
1114
1115 class operator Implicit(const value: TTypedValue): TValue;
1116 class operator Implicit(const value: TValue): TTypedValue;
1117
1118 property TypeInfo: PTypeInfo read fTypeInfo;
1119 property Value: TValue read fValue;
1120 end;
1121
1122 {$ENDREGION}
1123
1124
1125 {$REGION 'TInterfaceBase'}
1126
1127 /// <summary>
1128 /// Provides a non-reference-counted <see cref="System|IInterface" />
1129 /// implementation.
1130 /// </summary>
1131 TInterfaceBase = class abstract(TObject, IInterface)
1132 protected
1133 function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
1134 function _AddRef: Integer; stdcall;
1135 function _Release: Integer; stdcall;
1136 end;
1137
1138 {$ENDREGION}
1139
1140
1141 {$REGION 'TInterfacedObjectEx'}
1142
1143 /// <summary>
1144 /// Provides an improved implementation for TInterfacedObject that was
1145 /// introduced in Delphi XE7 for earlier versions. It makes sure that
1146 /// reference counting during destruction does not call the destructor
1147 /// recursively by using the highest bit in the FRefCount field to mark the
1148 /// instance as currently being destroyed.
1149 /// </summary>
1150 {$IF not defined(DELPHIXE7_UP) and not defined(AUTOREFCOUNT)}
1151 TInterfacedObjectEx = class(TInterfacedObject)
1152 private
1153 const objDestroyingFlag = Integer($80000000);
1154 function GetRefCount: Integer; inline;
1155 public
1156 procedure BeforeDestruction; override;
1157 property RefCount: Integer read GetRefCount;
1158 end;
1159 {$ELSE}
1160 TInterfacedObjectEx = TInterfacedObject;
1161 {$IFEND}
1162
1163 {$ENDREGION}
1164
1165
1166 {$REGION 'Guard'}
1167
1168 /// <summary>
1169 /// Provides static methods to check arguments and raise argument
1170 /// exceptions.
1171 /// </summary>
1172 /// <remarks>
1173 /// It's recommended that all arguments of public types and members should
1174 /// be checked.
1175 /// </remarks>
1176 Guard = record
1177 private
1178 class procedure RaiseArgumentException(typeKind: TTypeKind; const argumentName: string); overload; static;
1179 class procedure RaiseNullableHasNoValue; static;
1180 class procedure RaiseNoDelegateAssigned; static;
1181 class procedure RaiseInvalidTypeCast(sourceType, targetType: PTypeInfo); static;
1182 public
1183 class procedure CheckTrue(condition: Boolean; const msg: string = ''); static; inline;
1184 class procedure CheckFalse(condition: Boolean; const msg: string = ''); static; inline;
1185
1186 class procedure CheckInheritsFrom(const obj: TObject; parentClass: TClass; const argumentName: string); overload; static; inline;
1187 class procedure CheckInheritsFrom(cls, parentClass: TClass; const argumentName: string); overload; static; inline;
1188
1189 class procedure CheckNotNull(const argumentValue: TObject; const argumentName: string); overload; static; inline;
1190 class procedure CheckNotNull(argumentValue: Pointer; const argumentName: string); overload; static; inline;
1191 class procedure CheckNotNull(const argumentValue: IInterface; const argumentName: string); overload; static; inline;
1192 class procedure CheckNotNull(condition: Boolean; const parameterName: string); overload; static; inline;
1193 class procedure CheckNotNull<T>(const argumentValue: T; const argumentName: string); overload; static; inline;
1194
1195 class procedure CheckEnum<T{:enum}>(const argumentValue: T; const argumentName: string); overload; static; inline;
1196 class procedure CheckEnum<T{:enum}>(argumentValue: Integer; const argumentName: string); overload; static; inline;
1197
1198 class procedure CheckSet<T{:set}>(const argumentValue: T; const argumentName: string); overload; static; inline;
1199 class procedure CheckSet<T{:set}>(argumentValue: Cardinal; const argumentName: string); overload; static; inline;
1200
1201 class procedure CheckIndex(length, index: Integer; indexBase: Integer = 0); static; inline;
1202
1203 class procedure CheckRange(const buffer: array of Byte; index: Integer); overload; static;
1204 class procedure CheckRange(const buffer: array of Byte; index, count: Integer); overload; static;
1205 class procedure CheckRange(const buffer: array of Char; index: Integer); overload; static;
1206 class procedure CheckRange(const buffer: array of Char; index, count: Integer); overload; static;
1207 class procedure CheckRange<T>(const buffer: array of T; index: Integer); overload; static;
1208 class procedure CheckRange<T>(const buffer: array of T; index, count: Integer); overload; static;
1209 class procedure CheckRange(const s: string; index: Integer); overload; static; inline;
1210 class procedure CheckRange(const s: string; index, count: Integer); overload; static; inline;
1211{$IFNDEF NEXTGEN}
1212 class procedure CheckRange(const s: WideString; index: Integer); overload; static; inline;
1213 class procedure CheckRange(const s: WideString; index, count: Integer); overload; static; inline;
1214 class procedure CheckRange(const s: RawByteString; index: Integer); overload; static; inline;
1215 class procedure CheckRange(const s: RawByteString; index, count: Integer); overload; static; inline;
1216{$ENDIF}
1217 class procedure CheckRange(condition: Boolean; const argumentName: string); overload; static; inline;
1218 class procedure CheckRange(length, index, count: Integer; indexBase: Integer = 0); overload; static; inline;
1219
1220 /// <summary>
1221 /// Checks an argument to ensure it is in the specified range including
1222 /// the bounds.
1223 /// </summary>
1224 /// <param name="value">
1225 /// The argument value to check.
1226 /// </param>
1227 /// <param name="min">
1228 /// The minimum allowed value for the argument.
1229 /// </param>
1230 /// <param name="max">
1231 /// The maximum allowed value for the argument.
1232 /// </param>
1233 /// <exception cref="EArgumentOutOfRangeException">
1234 /// The value is not within the specified range.
1235 /// </exception>
1236 class procedure CheckRangeInclusive(value, min, max: Integer); overload; static; inline;
1237
1238 /// <summary>
1239 /// Checks an argument to ensure it is in the specified range excluding
1240 /// the bounds.
1241 /// </summary>
1242 /// <param name="value">
1243 /// The argument value to check.
1244 /// </param>
1245 /// <param name="min">
1246 /// The minimum allowed value for the argument.
1247 /// </param>
1248 /// <param name="max">
1249 /// The maximum allowed value for the argument. <br />
1250 /// </param>
1251 /// <exception cref="EArgumentOutOfRangeException">
1252 /// The value is not within the specified range.
1253 /// </exception>
1254 class procedure CheckRangeExclusive(value, min, max: Integer); overload; static; inline;
1255
1256 class procedure CheckTypeKind(typeInfo: PTypeInfo; expectedTypeKind: TTypeKind; const argumentName: string); overload; static;
1257 class procedure CheckTypeKind(typeInfo: PTypeInfo; expectedTypeKinds: TTypeKinds; const argumentName: string); overload; static;
1258 class procedure CheckTypeKind(typeKind: TTypeKind; expectedTypeKind: TTypeKind; const argumentName: string); overload; static; inline;
1259 class procedure CheckTypeKind(typeKind: TTypeKind; expectedTypeKinds: TTypeKinds; const argumentName: string); overload; static; inline;
1260 class procedure CheckTypeKind<T>(expectedTypeKind: TTypeKind; const argumentName: string); overload; static; inline;
1261 class procedure CheckTypeKind<T>(expectedTypeKinds: TTypeKinds; const argumentName: string); overload; static; inline;
1262
1263 class function IsNullReference(const value; typeInfo: PTypeInfo): Boolean; static;
1264
1265 /// <summary>
1266 /// Raises an <see cref="EArgumentException" /> exception.
1267 /// </summary>
1268 /// <param name="msg">
1269 /// The general error message.
1270 /// </param>
1271 class procedure RaiseArgumentException(const msg: string); overload; static;
1272
1273 /// <summary>
1274 /// Raises an <see cref="EFormatException" /> exception.
1275 /// </summary>
1276 class procedure RaiseArgumentFormatException(const argumentName: string); overload; static;
1277
1278 /// <summary>
1279 /// Raises an <see cref="EArgumentNullException" /> exception.
1280 /// </summary>
1281 class procedure RaiseArgumentNullException(const argumentName: string); overload; static;
1282
1283 /// <summary>
1284 /// Raises an <see cref="EArgumentOutOfRangeException" /> exception.
1285 /// </summary>
1286 class procedure RaiseArgumentOutOfRangeException(const argumentName: string); overload; static;
1287
1288 /// <summary>
1289 /// Raises an <see cref="EInvalidEnumArgumentException" /> exception.
1290 /// </summary>
1291 class procedure RaiseInvalidEnumArgumentException(const argumentName: string); overload; static;
1292 end;
1293
1294 TArgument = Guard deprecated 'Use Guard instead';
1295
1296 {$ENDREGION}
1297
1298
1299 {$REGION 'Nullable Types'}
1300
1301 Nullable = record
1302 private
1303 const HasValue = 'True';
1304 type Null = interface end;
1305 end;
1306
1307 /// <summary>
1308 /// A nullable type can represent the normal range of values for its
1309 /// underlying value type, plus an additional <c>Null</c> value.
1310 /// </summary>
1311 /// <typeparam name="T">
1312 /// The underlying value type of the <see cref="Nullable<T>" />
1313 /// generic type.
1314 /// </typeparam>
1315 Nullable<T> = record
1316 private
1317 fValue: T;
1318 fHasValue: string;
1319 class var fComparer: IEqualityComparer<T>;
1320 class function EqualsComparer(const left, right: T): Boolean; static;
1321 class function EqualsInternal(const left, right: T): Boolean; static; inline;
1322 function GetValue: T; inline;
1323 function GetHasValue: Boolean; inline;
1324 public
1325 /// <summary>
1326 /// Initializes a new instance of the <see cref="Nullable<T>" />
1327 /// structure to the specified value.
1328 /// </summary>
1329 constructor Create(const value: T); overload;
1330
1331 /// <summary>
1332 /// Initializes a new instance of the <see cref="Nullable<T>" />
1333 /// structure to the specified value.
1334 /// </summary>
1335 constructor Create(const value: Variant); overload;
1336
1337 /// <summary>
1338 /// Retrieves the value of the current <see cref="Nullable<T>" />
1339 /// object, or the object's default value.
1340 /// </summary>
1341 function GetValueOrDefault: T; overload;
1342
1343 /// <summary>
1344 /// Retrieves the value of the current <see cref="Nullable<T>" />
1345 /// object, or the specified default value.
1346 /// </summary>
1347 /// <param name="defaultValue">
1348 /// A value to return if the <see cref="HasValue" /> property is <c>False</c>
1349 /// .
1350 /// </param>
1351 /// <returns>
1352 /// The value of the <see cref="Value" /> property if the <see cref="HasValue" />
1353 /// property is true; otherwise, the <paramref name="defaultValue" />
1354 /// parameter.
1355 /// </returns>
1356 /// <remarks>
1357 /// The <see cref="GetValueOrDefault" /> method returns a value even if
1358 /// the <see cref="HasValue" /> property is false (unlike the <see cref="Value" />
1359 /// property, which throws an exception).
1360 /// </remarks>
1361 function GetValueOrDefault(const defaultValue: T): T; overload;
1362
1363 /// <summary>
1364 /// Determines whether two nullable value are equal.
1365 /// </summary>
1366 /// <remarks>
1367 /// <para>
1368 /// If both two nullable values are null, return true;
1369 /// </para>
1370 /// <para>
1371 /// If either one is null, return false;
1372 /// </para>
1373 /// <para>
1374 /// else compares their values as usual.
1375 /// </para>
1376 /// </remarks>
1377 function Equals(const other: Nullable<T>): Boolean;
1378
1379 function ToString: string;
1380
1381 /// <summary>
1382 /// Returns the stored value as variant.
1383 /// </summary>
1384 /// <exception cref="EInvalidCast">
1385 /// The type of T cannot be cast to Variant
1386 /// </exception>
1387 function ToVariant: Variant;
1388
1389 /// <summary>
1390 /// Gets the stored value. Returns <c>False</c> if it does not contain a
1391 /// value.
1392 /// </summary>
1393 function TryGetValue(out value: T): Boolean; inline;
1394
1395 /// <summary>
1396 /// Gets a value indicating whether the current <see cref="Nullable<T>" />
1397 /// structure has a value.
1398 /// </summary>
1399 property HasValue: Boolean read GetHasValue;
1400
1401 /// <summary>
1402 /// Gets the value of the current <see cref="Nullable<T>" /> value.
1403 /// </summary>
1404 /// <exception cref="Spring|EInvalidOperationException">
1405 /// Raised if the value is null.
1406 /// </exception>
1407 property Value: T read GetValue;
1408
1409 class operator Implicit(const value: Nullable.Null): Nullable<T>;
1410 class operator Implicit(const value: T): Nullable<T>;
1411
1412{$IFDEF IMPLICIT_NULLABLE}
1413 class operator Implicit(const value: Nullable<T>): T; inline;
1414 {$IFDEF IMPLICIT_NULLABLE_WARN}inline; deprecated 'Possible unsafe operation involving implicit operator - use Value property';{$ENDIF}
1415{$ENDIF}
1416
1417{$IFDEF UNSAFE_NULLABLE}
1418 class operator Implicit(const value: Nullable<T>): Variant;
1419 {$IFNDEF DELPHIXE4}
1420 {$IFDEF UNSAFE_NULLABLE_WARN}inline; deprecated 'Possible unsafe operation involving implicit Variant conversion - use ToVariant';{$ENDIF}
1421 {$ENDIF}
1422 class operator Implicit(const value: Variant): Nullable<T>;
1423 {$IFDEF UNSAFE_NULLABLE_WARN}inline; deprecated 'Possible unsafe operation involving implicit Variant conversion - use explicit cast';{$ENDIF}
1424{$ENDIF}
1425
1426 class operator Explicit(const value: Variant): Nullable<T>;
1427 class operator Explicit(const value: Nullable<T>): T; inline;
1428
1429 class operator Equal(const left, right: Nullable<T>): Boolean; inline;
1430 class operator Equal(const left: Nullable<T>; const right: Nullable.Null): Boolean; inline;
1431 class operator Equal(const left: Nullable<T>; const right: T): Boolean; inline;
1432 class operator NotEqual(const left, right: Nullable<T>): Boolean; inline;
1433 class operator NotEqual(const left: Nullable<T>; const right: Nullable.Null): Boolean; inline;
1434 class operator NotEqual(const left: Nullable<T>; const right: T): Boolean; inline;
1435 end;
1436
1437 TNullableString = Nullable<string>;
1438{$IFNDEF NEXTGEN}
1439 TNullableAnsiString = Nullable<AnsiString>;
1440 TNullableWideString = Nullable<WideString>;
1441{$ENDIF}
1442 TNullableInteger = Nullable<Integer>;
1443 TNullableInt64 = Nullable<Int64>;
1444 TNullableNativeInt = Nullable<NativeInt>;
1445 TNullableDateTime = Nullable<TDateTime>;
1446 TNullableCurrency = Nullable<Currency>;
1447 TNullableDouble = Nullable<Double>;
1448 TNullableBoolean = Nullable<Boolean>;
1449 TNullableGuid = Nullable<TGUID>;
1450
1451 /// <summary>
1452 /// Helper record for fast access to nullable value via RTTI.
1453 /// </summary>
1454 TNullableHelper = record
1455 strict private
1456 fValueType: PTypeInfo;
1457 fHasValueOffset: NativeInt;
1458 public
1459 constructor Create(typeInfo: PTypeInfo);
1460 function GetValue(instance: Pointer): TValue; inline;
1461 function HasValue(instance: Pointer): Boolean; inline;
1462 procedure SetValue(instance: Pointer; const value: TValue); inline;
1463 property ValueType: PTypeInfo read fValueType;
1464 end;
1465
1466 {$ENDREGION}
1467
1468
1469 {$REGION 'Lazy Initialization'}
1470
1471 /// <summary>
1472 /// Specifies the kind of a lazy type.
1473 /// </summary>
1474 TLazyKind = (
1475
1476 /// <summary>
1477 /// Not a lazy type.
1478 /// </summary>
1479 lkNone,
1480
1481 /// <summary>
1482 /// Type is <see cref="SysUtils|TFunc<T>" />.
1483 /// </summary>
1484 lkFunc,
1485
1486 /// <summary>
1487 /// Type is <see cref="Spring|Lazy<T>" />.
1488 /// </summary>
1489 lkRecord,
1490
1491 /// <summary>
1492 /// Type is <see cref="Spring|ILazy<T>" />.
1493 /// </summary>
1494 lkInterface
1495 );
1496
1497 /// <summary>
1498 /// Provides support for lazy initialization.
1499 /// </summary>
1500 ILazy = interface(IInvokable)
1501 ['{40223BA9-0C66-49E7-AA33-BDAEF9F506D6}']
1502 {$REGION 'Property Accessors'}
1503 function GetIsValueCreated: Boolean;
1504 function GetValue: TValue;
1505 {$ENDREGION}
1506
1507 /// <summary>
1508 /// Gets a value that indicates whether a value has been created for this
1509 /// <see cref="ILazy" /> instance.
1510 /// </summary>
1511 /// <value>
1512 /// <b>True</b> if a value has been created for this <see cref="ILazy" />
1513 /// instance; otherwise, <b>False</b>.
1514 /// </value>
1515 property IsValueCreated: Boolean read GetIsValueCreated;
1516
1517 /// <summary>
1518 /// Gets the lazily initialized value of the current <see cref="ILazy" />
1519 /// instance.
1520 /// </summary>
1521 /// <value>
1522 /// The lazily initialized value of the current <see cref="ILazy" />
1523 /// instance.
1524 /// </value>
1525 property Value: TValue read GetValue;
1526 end;
1527
1528 /// <summary>
1529 /// Provides support for lazy initialization.
1530 /// </summary>
1531 ILazy<T> = interface(ILazy)
1532 {$REGION 'Property Accessors'}
1533 function GetValue: T;
1534 {$ENDREGION}
1535
1536 /// <summary>
1537 /// Gets the lazily initialized value of the current <see cref="ILazy<T>" />
1538 /// instance.
1539 /// </summary>
1540 /// <value>
1541 /// The lazily initialized value of the current <see cref="ILazy<T>" />
1542 /// instance.
1543 /// </value>
1544 property Value: T read GetValue;
1545 end;
1546
1547 /// <summary>
1548 /// The base class of the lazy initialization type.
1549 /// </summary>
1550 TLazy = class(TInterfacedObject, ILazy)
1551 private
1552 fLock: TCriticalSection;
1553 fIsValueCreated: Boolean;
1554 fOwnsObjects: Boolean;
1555 {$REGION 'Property Accessors'}
1556 function GetIsValueCreated: Boolean;
1557 function GetValueNonGeneric: TValue; virtual; abstract;
1558 function ILazy.GetValue = GetValueNonGeneric;
1559 {$ENDREGION}
1560 public
1561 constructor Create;
1562 destructor Destroy; override;
1563
1564 /// <summary>
1565 /// Gets a value that indicates whether a value has been created for this
1566 /// <see cref="TLazy<T>" /> instance.
1567 /// </summary>
1568 /// <value>
1569 /// <b>True</b> if a value has been created for this <see cref="TLazy<T>" />
1570 /// instance; otherwise, <b>False</b>.
1571 /// </value>
1572 property IsValueCreated: Boolean read GetIsValueCreated;
1573 end;
1574
1575 /// <summary>
1576 /// Provides support for lazy initialization.
1577 /// </summary>
1578 /// <typeparam name="T">
1579 /// The type of object that is being lazily initialized.
1580 /// </typeparam>
1581 TLazy<T> = class(TLazy, ILazy<T>, TFunc<T>)
1582 private
1583 fValueFactory: TFunc<T>;
1584 fValue: T;
1585 procedure InitializeValue;
1586 {$REGION 'Property Accessors'}
1587 function GetValue: T;
1588 function GetValueNonGeneric: TValue; override; final;
1589 function TFunc<T>.Invoke = GetValue;
1590 {$ENDREGION}
1591 public
1592 /// <summary>
1593 /// Initializes a new instance of the <see cref="Lazy<T>" />
1594 /// record. When lazy initialization occurs, the default constructor of
1595 /// the target type is used.
1596 /// </summary>
1597 constructor Create; overload;
1598
1599 /// <summary>
1600 /// Initializes a new instance of the <see cref="TLazy<T>" />
1601 /// class. When lazy initialization occurs, the specified initialization
1602 /// function is used.
1603 /// </summary>
1604 /// <param name="valueFactory">
1605 /// The delegate that is invoked to produce the lazily initialized value
1606 /// when it is needed.
1607 /// </param>
1608 /// <param name="ownsObject">
1609 /// If <b>true</b> the value - if any got created - will be destroyed
1610 /// when going out of scope. Only when T is a class type.
1611 /// </param>
1612 /// <exception cref="EArgumentNullException">
1613 /// <i>valueFactory</i> is <b>nil</b>.
1614 /// </exception>
1615 constructor Create(const valueFactory: TFunc<T>; ownsObject: Boolean = False); overload;
1616
1617 /// <summary>
1618 /// Initializes a new instance of <see cref="TLazy<T>" /> with the
1619 /// specified value.
1620 /// </summary>
1621 /// <param name="value">
1622 /// The initialized value.
1623 /// </param>
1624 /// <param name="ownsObject">
1625 /// If <b>true</b> the value - if any got created - will be destroyed
1626 /// when going out of scope. Only when T is a class type.
1627 /// </param>
1628 constructor CreateFrom(const value: T; ownsObject: Boolean = False);
1629
1630 destructor Destroy; override;
1631
1632 /// <summary>
1633 /// Gets the lazily initialized value of the current <see cref="TLazy<T>" />
1634 /// instance.
1635 /// </summary>
1636 /// <value>
1637 /// The lazily initialized value of the current <see cref="TLazy<T>" />
1638 /// instance.
1639 /// </value>
1640 property Value: T read GetValue;
1641 end;
1642
1643 /// <summary>
1644 /// Provides support for lazy initialization.
1645 /// </summary>
1646 /// <typeparam name="T">
1647 /// The type of object that is being lazily initialized.
1648 /// </typeparam>
1649 Lazy<T> = record
1650 private
1651 fLazy: ILazy<T>; // DO NOT ADD ANY OTHER FIELDS !!!
1652 function GetIsAssigned: Boolean;
1653 function GetIsValueCreated: Boolean;
1654 function GetValue: T; inline;
1655 public
1656 /// <summary>
1657 /// Initializes a new instance of the <see cref="Lazy<T>" />
1658 /// record. When lazy initialization occurs, the default constructor of
1659 /// the target type is used.
1660 /// </summary>
1661 class function Create: Lazy<T>; overload; static;
1662
1663 /// <summary>
1664 /// Initializes a new instance of the <see cref="Lazy<T>" />
1665 /// record. When lazy initialization occurs, the specified initialization
1666 /// function is used.
1667 /// </summary>
1668 /// <param name="valueFactory">
1669 /// The delegate that is invoked to produce the lazily initialized value
1670 /// when it is needed.
1671 /// </param>
1672 /// <param name="ownsObject">
1673 /// If <b>true</b> the value - if any got created - will be destroyed
1674 /// when going out of scope. Only when T is a class type.
1675 /// </param>
1676 /// <exception cref="EArgumentNullException">
1677 /// <i>valueFactory</i> is <b>nil</b>.
1678 /// </exception>
1679 constructor Create(const valueFactory: TFunc<T>; ownsObject: Boolean = False); overload;
1680
1681 /// <summary>
1682 /// Initializes a new instance of <see cref="Lazy<T>" /> with the
1683 /// specified value.
1684 /// </summary>
1685 /// <param name="value">
1686 /// The initialized value.
1687 /// </param>
1688 /// <param name="ownsObject">
1689 /// If <b>true</b> the value - if any got created - will be destroyed
1690 /// when going out of scope. Only when T is a class type.
1691 /// </param>
1692 constructor CreateFrom(const value: T; ownsObject: Boolean = False);
1693
1694 class operator Implicit(const value: Lazy<T>): ILazy<T>;
1695 class operator Implicit(const value: Lazy<T>): T;
1696 class operator Implicit(const value: T): Lazy<T>;
1697 class operator Implicit(const value: TFunc<T>): Lazy<T>;
1698 class operator Implicit(const value: TLazy<T>): Lazy<T>;
1699
1700 /// <summary>
1701 /// Returns true if the value is assigned and contains an ILazy<T>
1702 /// reference; otherwise returns false.
1703 /// </summary>
1704 property IsAssigned: Boolean read GetIsAssigned;
1705
1706 /// <summary>
1707 /// Gets a value that indicates whether a value has been created for this
1708 /// <see cref="Lazy<T>" /> instance.
1709 /// </summary>
1710 /// <value>
1711 /// <b>True</b> if a value has been created for this <see cref="Lazy<T>" />
1712 /// instance; otherwise, <b>False</b>.
1713 /// </value>
1714 property IsValueCreated: Boolean read GetIsValueCreated;
1715
1716 /// <summary>
1717 /// Gets the lazily initialized value of the current <see cref="Lazy<T>" />
1718 /// instance.
1719 /// </summary>
1720 /// <value>
1721 /// The lazily initialized value of the current <see cref="Lazy<T>" />
1722 /// instance.
1723 /// </value>
1724 /// <exception cref="Spring|EInvalidOperationException" />
1725 property Value: T read GetValue;
1726 end;
1727
1728 /// <summary>
1729 /// Provides lazy initialization routines.
1730 /// </summary>
1731 /// <remarks>
1732 /// The methods are using AtomicCmpExchange to ensure thread-safety when
1733 /// initializing instances.
1734 /// </remarks>
1735 TLazyInitializer = record
1736 public
1737 /// <summary>
1738 /// Initializes a target reference type by using a specified function if
1739 /// it hasn't already been initialized.
1740 /// </summary>
1741 /// <remarks>
1742 /// In the event that multiple threads access this method concurrently,
1743 /// multiple instances of T may be created, but only one will be stored
1744 /// into target. In such an occurrence, this method will destroy the
1745 /// instances that were not stored.
1746 /// </remarks>
1747 class function EnsureInitialized<T: class, constructor>(var target: T): T; overload; static;
1748
1749 /// <summary>
1750 /// Initializes a target reference type by using a specified function if
1751 /// it hasn't already been initialized.
1752 /// </summary>
1753 /// <remarks>
1754 /// <para>
1755 /// This method may only be used on reference types, and <i>
1756 /// valueFactory</i> may not return a nil reference.
1757 /// </para>
1758 /// <para>
1759 /// In the event that multiple threads access this method
1760 /// concurrently, multiple instances of T may be created, but only
1761 /// one will be stored into target. In such an occurrence, this
1762 /// method will destroy the instances that were not stored.
1763 /// </para>
1764 /// </remarks>
1765 class function EnsureInitialized<T>(var target: T; const valueFactory: TFunc<T>): T; overload; static;
1766 end;
1767
1768 {$ENDREGION}
1769
1770
1771 {$REGION 'Shared smart pointer'}
1772
1773 IShared<T> = reference to function: T;
1774
1775 Shared<T> = record
1776 strict private
1777 fValue: T;
1778 fFinalizer: IInterface;
1779 class function GetNew: IShared<T>; static;
1780 public
1781 class operator Implicit(const value: T): Shared<T>;
1782 class operator Implicit(const value: Shared<T>): T; {$IFNDEF DELPHIXE4}inline;{$ENDIF}
1783 property Value: T read fValue;
1784
1785 class property New: IShared<T> read GetNew;
1786 end;
1787
1788 Shared = record
1789 private type
1790 TObjectFinalizer = class(TInterfacedObject, IShared<TObject>)
1791 private
1792 fValue: TObject;
1793 function Invoke: TObject;
1794 public
1795 constructor Create(typeInfo: PTypeInfo); overload;
1796 constructor Create(const value: TObject); overload;
1797 {$IFNDEF AUTOREFCOUNT}
1798 destructor Destroy; override;
1799 {$ENDIF}
1800 end;
1801
1802 TRecordFinalizer = class(TInterfacedObject, IShared<Pointer>)
1803 private
1804 fValue: Pointer;
1805 fTypeInfo: PTypeInfo;
1806 function Invoke: Pointer;
1807 public
1808 constructor Create(typeInfo: PTypeInfo); overload;
1809 constructor Create(const value: Pointer; typeInfo: PTypeInfo); overload;
1810 destructor Destroy; override;
1811 end;
1812 public
1813 class function New<T>(const value: T): IShared<T>; overload; static;
1814 end;
1815
1816 {$ENDREGION}
1817
1818
1819 {$REGION 'Weak smart pointer'}
1820
1821 IWeakReference<T> = interface
1822 {$REGION 'Property Accessors'}
1823 function GetIsAlive: Boolean;
1824 function GetTarget: T;
1825 procedure SetTarget(const value: T);
1826 {$ENDREGION}
1827 function TryGetTarget(out target: T): Boolean;
1828 property IsAlive: Boolean read GetIsAlive;
1829 property Target: T read GetTarget write SetTarget;
1830 end;
1831
1832 TWeakReference = class abstract(TInterfacedObject)
1833 private
1834 fTarget: Pointer;
1835 protected
1836 function GetIsAlive: Boolean; inline;
1837 procedure RegisterWeakRef(address: Pointer; instance: Pointer);
1838 procedure UnregisterWeakRef(address: Pointer; instance: Pointer);
1839 public
1840 property IsAlive: Boolean read GetIsAlive;
1841 end;
1842
1843 TWeakReference<T> = class(TWeakReference, IWeakReference<T>)
1844 private
1845 function GetTarget: T;
1846 procedure SetTarget(const value: T);
1847 constructor CreateInternal(const target: T; var ref: PPointer);
1848 public
1849 constructor Create(const target: T);
1850 destructor Destroy; override;
1851
1852 function TryGetTarget(out target: T): Boolean;
1853 property Target: T read GetTarget write SetTarget;
1854 end;
1855
1856 Weak<T> = record
1857 strict private
1858 fTarget: PPointer;
1859 fReference: IWeakReference<T>;
1860 function GetIsAlive: Boolean;
1861 function GetTarget: T;
1862 procedure SetTarget(const value: T);
1863 type PT = ^T;
1864 public
1865 constructor Create(const target: T);
1866
1867 class operator Implicit(const value: Shared<T>): Weak<T>;
1868 class operator Implicit(const value: T): Weak<T>;
1869 class operator Implicit(const value: Weak<T>): T;
1870
1871 class operator Equal(const left: Weak<T>; const right: T): Boolean; inline;
1872 class operator NotEqual(const left: Weak<T>; const right: T): Boolean; inline;
1873
1874 function TryGetTarget(out target: T): Boolean;
1875 property Target: T read GetTarget write SetTarget;
1876 property IsAlive: Boolean read GetIsAlive;
1877 end;
1878
1879 {$ENDREGION}
1880
1881
1882 {$REGION 'Property change notification'}
1883
1884 IEventArgs = interface
1885 ['{162CDCDF-F8FC-4E5A-9CE8-55EABAE42EC3}']
1886 end;
1887
1888 IPropertyChangedEventArgs = interface(IEventArgs)
1889 ['{DC7B4497-FA42-46D1-BE50-C764C4808197}']
1890 function GetPropertyName: string;
1891 property PropertyName: string read GetPropertyName;
1892 end;
1893
1894 TEventArgs = class(TInterfacedObject, IEventArgs)
1895 strict protected
1896 constructor Create;
1897 end;
1898
1899 TPropertyChangedEventArgs = class(TEventArgs, IPropertyChangedEventArgs)
1900 private
1901 fPropertyName: string;
1902 function GetPropertyName: string;
1903 public
1904 constructor Create(const propertyName: string);
1905 property PropertyName: string read GetPropertyName;
1906 end;
1907
1908 {$M+}
1909 TEventHandler<T: IEventArgs> = reference to procedure(Sender: TObject;
1910 const EventArgs: T);
1911 {$M-}
1912
1913 TPropertyChangedEvent = procedure(Sender: TObject;
1914 const EventArgs: IPropertyChangedEventArgs) of object;
1915
1916 IPropertyChangedEvent = IEvent<TPropertyChangedEvent>;
1917
1918 INotifyPropertyChanged = interface
1919 ['{A517EC98-C651-466B-8290-F7EE96877E03}']
1920 function GetOnPropertyChanged: IPropertyChangedEvent;
1921 property OnPropertyChanged: IPropertyChangedEvent read GetOnPropertyChanged;
1922 end;
1923
1924 {$ENDREGION}
1925
1926
1927 {$REGION 'Notification handler'}
1928
1929 TNotificationEvent = procedure(Component: TComponent;
1930 Operation: TOperation) of object;
1931
1932 TNotificationHandler = class(TComponent)
1933 private
1934 fOnNotification: TNotificationEvent;
1935 protected
1936 procedure Notification(Component: TComponent;
1937 Operation: TOperation); override;
1938 public
1939 property OnNotification: TNotificationEvent
1940 read fOnNotification write fOnNotification;
1941 end;
1942
1943 {$ENDREGION}
1944
1945
1946 {$REGION 'Exceptions'}
1947
1948 ENotSupportedException = SysUtils.ENotSupportedException;
1949
1950{$IFNDEF DELPHI2010}
1951 ENotImplementedException = SysUtils.ENotImplemented;
1952 EInvalidOperationException = SysUtils.EInvalidOpException;
1953 EArgumentNilException = SysUtils.EArgumentNilException;
1954{$ELSE}
1955 ENotImplementedException = class(Exception);
1956 EInvalidOperationException = class(Exception);
1957 EArgumentNilException = class(EArgumentException);
1958{$ENDIF}
1959
1960 EInvalidCastException = SysUtils.EInvalidCast;
1961
1962 EInsufficientMemoryException = EOutOfMemory;
1963
1964 EFormatException = class(Exception);
1965 EIndexOutOfRangeException = class(Exception);
1966
1967 EArgumentException = SysUtils.EArgumentException;
1968 EArgumentOutOfRangeException = SysUtils.EArgumentOutOfRangeException;
1969 EArgumentNullException = EArgumentNilException;
1970 EInvalidEnumArgumentException = class(EArgumentException);
1971
1972 ERttiException = class(Exception);
1973
1974 {$ENDREGION}
1975
1976
1977 {$REGION 'TTypeInfoHelper'}
1978
1979 TTypeInfoHelper = record helper for TTypeInfo
1980 strict private
1981 function GetRttiType: TRttiType; inline;
1982 public
1983{$IFNDEF DELPHIXE3_UP}
1984 function TypeData: PTypeData; inline;
1985{$ENDIF}
1986 function TypeName: string; inline;
1987
1988 property RttiType: TRttiType read GetRttiType;
1989 end;
1990
1991 {$ENDREGION}
1992
1993
1994 {$REGION 'TTypeDataHelper'}
1995
1996 TTypeDataHelper = record helper for TTypeData
1997 public
1998{$IFNDEF DELPHIXE3_UP}
1999 function DynArrElType: PPTypeInfo; inline;
2000{$ENDIF}
2001 end;
2002
2003 {$ENDREGION}
2004
2005
2006 {$REGION 'TInterfacedCriticalSection'}
2007
2008 ICriticalSection = interface(IInvokable)
2009 ['{16C21E9C-6450-4EA4-A3D3-1D59277C9BA6}']
2010 procedure Enter;
2011 procedure Leave;
2012 function ScopedLock: IInterface;
2013 end;
2014
2015 TInterfacedCriticalSection = class(TCriticalSection, IInterface, ICriticalSection)
2016 private type
2017 TScopedLock = class(TInterfacedObject)
2018 private
2019 fCriticalSection: ICriticalSection;
2020 public
2021 constructor Create(const criticalSection: ICriticalSection);
2022 destructor Destroy; override;
2023 end;
2024 protected
2025 fRefCount: Integer;
2026 function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
2027 function _AddRef: Integer; stdcall;
2028 function _Release: Integer; stdcall;
2029 function ScopedLock: IInterface;
2030 end;
2031
2032 {$ENDREGION}
2033
2034
2035 {$REGION 'Lock'}
2036
2037 /// <summary>
2038 /// Provides an easy to use wrapper around TCriticalSection. It
2039 /// automatically initializes the TCriticalSection instance when required
2040 /// and destroys it when the Lock goes out of scope.
2041 /// </summary>
2042 Lock = record
2043 private
2044 fCriticalSection: ICriticalSection;
2045 procedure EnsureInitialized;
2046 public
2047 /// <summary>
2048 /// Calls Enter on the underlying TCriticalSection. The first call also
2049 /// initializes the TCriticalSection instance.
2050 /// </summary>
2051 procedure Enter;
2052
2053 /// <summary>
2054 /// Calls Leave on the underlying TCriticalSection. If no call to Enter
2055 /// has been made before it will raise an exception.
2056 /// </summary>
2057 /// <exception cref="EInvalidOperationException">
2058 /// When Enter was not called before
2059 /// </exception>
2060 procedure Leave;
2061
2062 /// <summary>
2063 /// Calls Enter on the underlying TCriticalSection and returns an
2064 /// interface reference that will call Leave once it goes out of scope.
2065 /// </summary>
2066 /// <remarks>
2067 /// Use this to avoid the classic try/finally block but keep in mind that
2068 /// the scope will be the entire method this is used in unless you keep
2069 /// hold of the returned interface and explicitly set it to nil causing
2070 /// its destruction.
2071 /// </remarks>
2072 function ScopedLock: IInterface;
2073 end;
2074
2075 {$ENDREGION}
2076
2077
2078 {$REGION 'Tuples'}
2079
2080 Tuple<T1, T2> = record
2081 private
2082 fValue1: T1;
2083 fValue2: T2;
2084 public
2085 constructor Create(const value1: T1; const value2: T2);
2086 function Equals(const value: Tuple<T1, T2>): Boolean;
2087 procedure Unpack(out value1: T1; out value2: T2); inline;
2088 class operator Equal(const left, right: Tuple<T1, T2>): Boolean;
2089 class operator NotEqual(const left, right: Tuple<T1, T2>): Boolean;
2090 class operator Implicit(const values: Tuple<T1, T2>): TArray<TValue>;
2091 class operator Implicit(const values: TArray<TValue>): Tuple<T1, T2>;
2092 class operator Implicit(const values: array of const): Tuple<T1, T2>;
2093 property Value1: T1 read fValue1;
2094 property Value2: T2 read fValue2;
2095 end;
2096
2097 Tuple<T1, T2, T3> = record
2098 private
2099 fValue1: T1;
2100 fValue2: T2;
2101 fValue3: T3;
2102 public
2103 constructor Create(const value1: T1; const value2: T2; const value3: T3);
2104 function Equals(const value: Tuple<T1, T2, T3>): Boolean;
2105 procedure Unpack(out value1: T1; out value2: T2); overload; inline;
2106 procedure Unpack(out value1: T1; out value2: T2; out value3: T3); overload; inline;
2107 class operator Equal(const left, right: Tuple<T1, T2, T3>): Boolean;
2108 class operator NotEqual(const left, right: Tuple<T1, T2, T3>): Boolean;
2109 class operator Implicit(const values: Tuple<T1, T2, T3>): TArray<TValue>;
2110 class operator Implicit(const values: Tuple<T1, T2, T3>): Tuple<T1, T2>;
2111 class operator Implicit(const values: TArray<TValue>): Tuple<T1, T2, T3>;
2112 class operator Implicit(const values: array of const): Tuple<T1, T2, T3>;
2113 property Value1: T1 read fValue1;
2114 property Value2: T2 read fValue2;
2115 property Value3: T3 read fValue3;
2116 end;
2117
2118 Tuple<T1, T2, T3, T4> = record
2119 private
2120 fValue1: T1;
2121 fValue2: T2;
2122 fValue3: T3;
2123 fValue4: T4;
2124 public
2125 constructor Create(const value1: T1; const value2: T2; const value3: T3; const value4: T4);
2126 function Equals(const value: Tuple<T1, T2, T3, T4>): Boolean;
2127 procedure Unpack(out value1: T1; out value2: T2); overload; inline;
2128 procedure Unpack(out value1: T1; out value2: T2; out value3: T3); overload; inline;
2129 procedure Unpack(out value1: T1; out value2: T2; out value3: T3; out value4: T4); overload; inline;
2130 class operator Equal(const left, right: Tuple<T1, T2, T3, T4>): Boolean;
2131 class operator NotEqual(const left, right: Tuple<T1, T2, T3, T4>): Boolean;
2132 class operator Implicit(const values: Tuple<T1, T2, T3, T4>): TArray<TValue>;
2133 class operator Implicit(const values: Tuple<T1, T2, T3, T4>): Tuple<T1, T2>;
2134 class operator Implicit(const values: Tuple<T1, T2, T3, T4>): Tuple<T1, T2, T3>;
2135 class operator Implicit(const values: TArray<TValue>): Tuple<T1, T2, T3, T4>;
2136 class operator Implicit(const values: array of const): Tuple<T1, T2, T3, T4>;
2137 property Value1: T1 read fValue1;
2138 property Value2: T2 read fValue2;
2139 property Value3: T3 read fValue3;
2140 property Value4: T4 read fValue4;
2141 end;
2142
2143 Tuple = class
2144 public
2145 class function Create<T1, T2>(const value1: T1;
2146 const value2: T2): Tuple<T1, T2>; overload; static; inline;
2147 class function Create<T1, T2, T3>(const value1: T1; const value2: T2;
2148 const value3: T3): Tuple<T1, T2, T3>; overload; static; inline;
2149 class function Create<T1, T2, T3, T4>(const value1: T1; const value2: T2;
2150 const value3: T3; const value4: T4): Tuple<T1, T2, T3, T4>; overload; static; inline;
2151 end;
2152
2153 {$ENDREGION}
2154
2155
2156 {$REGION 'TArray'}
2157
2158 TArray = class
2159 private
2160 const IntrosortSizeThreshold = 16;
2161 class function GetDepthLimit(count: Integer): Integer; static;
2162
2163 class procedure Swap<T>(var left, right: T); static; inline;
2164
2165 class procedure SortTwoItems<T>(const comparer: IComparer<T>; var left, right: T); static;
2166 class procedure SortThreeItems<T>(const comparer: IComparer<T>; var left, mid, right: T); static;
2167
2168 class procedure InsertionSort<T>(var values: array of T; const comparer: IComparer<T>; left, right: Integer); static;
2169
2170 class procedure DownHeap<T>(var values: array of T; const comparer: IComparer<T>; left, count, i: Integer); static;
2171 class procedure HeapSort<T>(var values: array of T; const comparer: IComparer<T>; left, right: Integer); static;
2172
2173 class function QuickSortPartition<T>(var values: array of T; const comparer: IComparer<T>; left, right: Integer): Integer; static;
2174
2175 class procedure IntroSort<T>(var values: array of T; const comparer: IComparer<T>; left, right, depthLimit: Integer); static;
2176 public
2177
2178 /// <summary>
2179 /// Searches a range of elements in a sorted array for the given value,
2180 /// using a binary search algorithm returning the index for the first
2181 /// found value using the specified comparer.
2182 /// </summary>
2183 class function BinarySearch<T>(const values: array of T; const item: T;
2184 out foundIndex: Integer; const comparer: IComparer<T>;
2185 index, count: Integer): Boolean; overload; static;
2186
2187 /// <summary>
2188 /// Searches a sorted array for the given value, using a binary search
2189 /// algorithm returning the index for the first found value using the
2190 /// specified comparer.
2191 /// </summary>
2192 class function BinarySearch<T>(const values: array of T; const item: T;
2193 out foundIndex: Integer; const comparer: IComparer<T>): Boolean; overload; static;
2194
2195 /// <summary>
2196 /// Searches a sorted array for the given value, using a binary search
2197 /// algorithm returning the index for the first found value using the
2198 /// default comparer.
2199 /// </summary>
2200 class function BinarySearch<T>(const values: array of T; const item: T;
2201 out foundIndex: Integer): Boolean; overload; static; static;
2202
2203 /// <summary>
2204 /// Searches a range of elements in a sorted array for the given value,
2205 /// using a binary search algorithm returning the index for the first
2206 /// found value using the specified comparison.
2207 /// </summary>
2208 class function BinarySearch<T>(const values: array of T; const item: T;
2209 out foundIndex: Integer; const comparison: TComparison<T>;
2210 index, count: Integer): Boolean; overload; static;
2211
2212 /// <summary>
2213 /// Searches a sorted array for the given value, using a binary search
2214 /// algorithm returning the index for the first found value using the
2215 /// specified comparison.
2216 /// </summary>
2217 class function BinarySearch<T>(const values: array of T; const item: T;
2218 out foundIndex: Integer; const comparison: TComparison<T>): Boolean; overload; static;
2219
2220 /// <summary>
2221 /// Searches a range of elements in a sorted array for the given value,
2222 /// using a binary search algorithm returning the index for the last
2223 /// found value using the specified comparer.
2224 /// </summary>
2225 class function BinarySearchUpperBound<T>(const values: array of T;
2226 const item: T; out foundIndex: Integer; const comparer: IComparer<T>;
2227 index, count: Integer): Boolean; overload; static;
2228
2229 /// <summary>
2230 /// Searches a range of elements in a sorted array for the given value,
2231 /// using a binary search algorithm returning the index for the last
2232 /// found value using the specified comparison.
2233 /// </summary>
2234 class function BinarySearchUpperBound<T>(const values: array of T;
2235 const item: T; out foundIndex: Integer; const comparison: TComparison<T>;
2236 index, count: Integer): Boolean; overload; static;
2237
2238 /// <summary>
2239 /// Searches a sorted array for the given value, using a binary search
2240 /// algorithm returning the index for the last found value using the
2241 /// specified comparer.
2242 /// </summary>
2243 class function BinarySearchUpperBound<T>(const values: array of T;
2244 const item: T; out foundIndex: Integer;
2245 const comparer: IComparer<T>): Boolean; overload; static;
2246
2247 /// <summary>
2248 /// Searches a sorted array for the given value, using a binary search
2249 /// algorithm returning the index for the last found value using the
2250 /// specified comparer.
2251 /// </summary>
2252 class function BinarySearchUpperBound<T>(const values: array of T;
2253 const item: T; out foundIndex: Integer;
2254 const comparison: TComparison<T>): Boolean; overload; static;
2255
2256 /// <summary>
2257 /// Searches a sorted array for the given value, using a binary search
2258 /// algorithm returning the index for the last found value.
2259 /// </summary>
2260 class function BinarySearchUpperBound<T>(const values: array of T;
2261 const item: T; out foundIndex: Integer): Boolean; overload; static; static;
2262
2263 /// <summary>
2264 /// Concatenates an array of arrays to one array
2265 /// </summary>
2266 class function Concat<T>(const values: array of TArray<T>): TArray<T>; static;
2267
2268 /// <summary>
2269 /// Determines whether the specified item exists as an element in an
2270 /// array.
2271 /// </summary>
2272 class function Contains<T>(const values: array of T;
2273 const item: T): Boolean; static;
2274
2275 /// <summary>
2276 /// Copies an open array to a dynamic array.
2277 /// </summary>
2278 class function Copy<T>(const values: array of T): TArray<T>; overload; static;
2279
2280 /// <summary>
2281 /// Copies the specified count of elements from the source array to the
2282 /// target array.
2283 /// </summary>
2284 class procedure Copy<T>(const source: array of T;
2285 var target: array of T; count: NativeInt); overload; static;
2286
2287 /// <summary>
2288 /// Copies the specified count of elements from the specified position in
2289 /// the source array to the specified position in the target array.
2290 /// </summary>
2291 class procedure Copy<T>(const source: array of T; var target: array of T;
2292 sourceIndex, targetIndex, count: NativeInt); overload; static;
2293
2294 /// <summary>
2295 /// Executes the specified action for each item in the specified array.
2296 /// </summary>
2297 class procedure ForEach<T>(const values: array of T;
2298 const action: TAction<T>); static;
2299
2300 /// <summary>
2301 /// Searches for the specified element and returns the index of the first
2302 /// occurrence within the entire array.
2303 /// </summary>
2304 class function IndexOf<T>(const values: array of T;
2305 const item: T): Integer; overload; static;
2306
2307 /// <summary>
2308 /// Searches for the specified element and returns the index of the first
2309 /// occurrence within the range of elements in the array that extends
2310 /// from the specified index to the last element.
2311 /// </summary>
2312 class function IndexOf<T>(const values: array of T; const item: T;
2313 index: Integer): Integer; overload; static;
2314
2315 /// <summary>
2316 /// Searches for the specified element and returns the index of the first
2317 /// occurrence within the range of elements in the array that starts at
2318 /// the specified index and contains the specified number of elements.
2319 /// </summary>
2320 class function IndexOf<T>(const values: array of T; const item: T;
2321 index, count: Integer): Integer; overload; static;
2322
2323 /// <summary>
2324 /// Searches for the specified element and returns the index of the first
2325 /// occurrence within the range of elements in the array that starts at
2326 /// the specified index and contains the specified number of elements
2327 /// using the specified equality comparer.
2328 /// </summary>
2329 class function IndexOf<T>(const values: array of T; const item: T;
2330 index, count: Integer;
2331 const comparer: IEqualityComparer<T>): Integer; overload; static;
2332
2333 /// <summary>
2334 /// Searches for the specified element and returns the index of the last
2335 /// occurrence within the entire array.
2336 /// </summary>
2337 class function LastIndexOf<T>(const values: array of T;
2338 const item: T): Integer; overload; static;
2339
2340 /// <summary>
2341 /// Searches for the specified element and returns the index of the last
2342 /// occurrence within the range of elements in the array that extends
2343 /// from the specified index to the last element.
2344 /// </summary>
2345 class function LastIndexOf<T>(const values: array of T; const item: T;
2346 index: Integer): Integer; overload; static;
2347
2348 /// <summary>
2349 /// Searches for the specified element and returns the index of the last
2350 /// occurrence within the range of elements in the array that starts at
2351 /// the specified index and contains the specified number of elements.
2352 /// </summary>
2353 class function LastIndexOf<T>(const values: array of T; const item: T;
2354 index, count: Integer): Integer; overload; static;
2355
2356 /// <summary>
2357 /// Searches for the specified element and returns the index of the last
2358 /// occurrence within the range of elements in the array that starts at
2359 /// the specified index and contains the specified number of elements
2360 /// using the specified equality comparer.
2361 /// </summary>
2362 class function LastIndexOf<T>(const values: array of T; const item: T;
2363 index, count: Integer;
2364 const comparer: IEqualityComparer<T>): Integer; overload; static;
2365
2366 /// <summary>
2367 /// Reverses the elements in the entire array.
2368 /// </summary>
2369 class procedure Reverse<T>(var values: array of T); overload; static;
2370
2371 /// <summary>
2372 /// Reverses the elements in the specified range in the array.
2373 /// </summary>
2374 class procedure Reverse<T>(var values: array of T;
2375 index, count: Integer); overload; static;
2376
2377 /// <summary>
2378 /// Shuffles the elements in the array using the Fisher-Yates algorithm.
2379 /// </summary>
2380 class procedure Shuffle<T>(var values: array of T); overload; static;
2381
2382 /// <summary>
2383 /// Shuffles the elements in the array starting at the specified index
2384 /// using the Fisher-Yates algorithm.
2385 /// </summary>
2386 class procedure Shuffle<T>(var values: array of T;
2387 index: Integer); overload; static;
2388
2389 /// <summary>
2390 /// Shuffles the specified count of elements in the array starting at the
2391 /// specified index using the Fisher-Yates algorithm.
2392 /// </summary>
2393 class procedure Shuffle<T>(var values: array of T;
2394 index, count: Integer); overload; static;
2395
2396 /// <summary>
2397 /// Sorts the elements in an array using the default comparer.
2398 /// </summary>
2399 class procedure Sort<T>(var values: array of T); overload; static;
2400
2401 /// <summary>
2402 /// Sorts the elements in an array using the specified comparer.
2403 /// </summary>
2404 class procedure Sort<T>(var values: array of T; const comparer: IComparer<T>); overload; static;
2405
2406 /// <summary>
2407 /// Sorts the specified range of elements in an array using the specified
2408 /// comparer.
2409 /// </summary>
2410 class procedure Sort<T>(var values: array of T;
2411 const comparer: IComparer<T>; index, count: Integer); overload; static;
2412
2413 /// <summary>
2414 /// Sorts the elements in an array using the specified comparison.
2415 /// </summary>
2416 class procedure Sort<T>(var values: array of T; const comparison: TComparison<T>); overload; static;
2417
2418 /// <summary>
2419 /// Sorts the specified range of elements in an array using the specified
2420 /// comparison.
2421 /// </summary>
2422 class procedure Sort<T>(var values: array of T;
2423 const comparison: TComparison<T>; index, count: Integer); overload; static;
2424 end;
2425
2426 {$ENDREGION}
2427
2428
2429 {$REGION 'Vector<T>'}
2430
2431{$IFDEF DELPHI2010}
2432 TArrayEnumerator<T> = class
2433{$ELSE}
2434 TArrayEnumerator<T> = record
2435{$ENDIF}
2436 private
2437 fItems: TArray<T>;
2438 fIndex: Integer;
2439 function GetCurrent: T; inline;
2440 public
2441 constructor Create(const items: TArray<T>);
2442 function MoveNext: Boolean; inline;
2443 property Current: T read GetCurrent;
2444 end;
2445
2446 VectorHelper = record
2447 private
2448 class function InternalIndexOfInt8(const data: Pointer; const item: ShortInt): Integer; static;
2449 class function InternalIndexOfInt16(const data: Pointer; const item: SmallInt): Integer; static;
2450 class function InternalIndexOfInt32(const data: Pointer; const item: Integer): Integer; static;
2451 class function InternalIndexOfInt64(const data: Pointer; const item: Int64): Integer; static;
2452 class function InternalIndexOfStr(const data: Pointer; const item: string): Integer; static;
2453 end;
2454
2455 Vector<T> = record
2456 private
2457 fData: TArray<T>; // DO NOT ADD ANY OTHER FIELDS !!!
2458 function GetCount: Integer; inline;
2459 function GetFirst: T; inline;
2460 function GetItem(index: Integer): T; inline;
2461 function GetLast: T; inline;
2462 procedure SetCount(value: Integer); inline;
2463 procedure SetItem(index: Integer; const value: T); inline;
2464 procedure InternalInsert(index: Integer; const items: array of T);
2465 function InternalEquals(const items: array of T): Boolean;
2466 function InternalIndexOf(const item: T): Integer;
2467 public
2468 class operator Implicit(const value: TArray<T>): Vector<T>; inline;
2469 class operator Implicit(const value: Vector<T>): TArray<T>; inline;
2470 class operator Add(const left, right: Vector<T>): Vector<T>; inline;
2471 class operator Add(const left: Vector<T>; const right: TArray<T>): Vector<T>; inline;
2472 class operator Add(const left: TArray<T>; const right: Vector<T>): Vector<T>; inline;
2473 class operator Add(const left: Vector<T>; const right: T): Vector<T>; inline;
2474 class operator Add(const left: T; const right: Vector<T>): Vector<T>; inline;
2475 class operator Subtract(const left, right: Vector<T>): Vector<T>; inline;
2476 class operator Subtract(const left: Vector<T>; const right: T): Vector<T>; inline;
2477 class operator In(const left: T; const right: Vector<T>): Boolean; inline;
2478 class operator In(const left, right: Vector<T>): Boolean; inline;
2479 class operator In(const left: TArray<T>; const right: Vector<T>): Boolean; inline;
2480 class operator Equal(const left, right: Vector<T>): Boolean; inline;
2481 class operator NotEqual(const left, right: Vector<T>): Boolean; inline;
2482
2483 procedure Assign(const items: array of T);
2484 procedure Clear; inline;
2485
2486 function Add(const item: T): Integer; overload; inline;
2487 procedure Add(const items: array of T); overload;
2488 procedure Add(const items: TArray<T>); overload; inline;
2489 procedure Add(const items: Vector<T>); overload; inline;
2490 procedure Insert(index: Integer; const item: T); overload; inline;
2491 procedure Insert(index: Integer; const items: array of T); overload;
2492 procedure Insert(index: Integer; const items: TArray<T>); overload; inline;
2493 procedure Delete(index: Integer); overload; inline;
2494 procedure Delete(index: Integer; count: Integer); overload; inline;
2495 function Remove: T; overload; inline;
2496 procedure Remove(const item: T); overload; inline;
2497 procedure Remove(const items: array of T); overload;
2498 procedure Remove(const items: TArray<T>); overload; inline;
2499
2500 function Contains(const item: T): Boolean; overload; inline;
2501 function Contains(const item: T; const comparer: IEqualityComparer<T>): Boolean; overload;
2502 function Contains(const item: T; const comparer: TEqualityComparison<T>): Boolean; overload;
2503 function Contains(const items: array of T): Boolean; overload;
2504 function Contains(const items: TArray<T>): Boolean; overload;
2505 function IndexOf(const item: T): Integer; inline;
2506 function Equals(const items: array of T): Boolean; overload;
2507 function Equals(const items: TArray<T>): Boolean; overload; inline;
2508
2509 function Slice(index: Integer): Vector<T>; overload; inline;
2510 function Slice(index: Integer; count: Integer): Vector<T>; overload; inline;
2511 function Splice(index: Integer; count: Integer): Vector<T>; overload; inline;
2512 function Splice(index: Integer; count: Integer; const items: array of T): Vector<T>; overload;
2513
2514 procedure Sort; overload; inline;
2515 procedure Sort(const comparer: IComparer<T>); overload; inline;
2516 procedure Sort(const comparer: TComparison<T>); overload; inline;
2517 procedure Reverse;
2518
2519 procedure ForEach(const action: TAction<T>); inline;
2520
2521 function GetEnumerator: TArrayEnumerator<T>; inline;
2522 property Count: Integer read GetCount;
2523 property Data: TArray<T> read fData;
2524 property First: T read GetFirst;
2525 property Items[index: Integer]: T read GetItem write SetItem; default;
2526 property Last: T read GetLast;
2527 property Length: Integer read GetCount write SetCount;
2528 end;
2529
2530 {$ENDREGION}
2531
2532
2533 {$REGION 'TFormatSettingsHelper'}
2534
2535{$IFDEF DELPHI2010}
2536 TFormatSettingsHelper = record helper for TFormatSettings
2537 public
2538 /// <summary>
2539 /// Creates a TFormatSettings record with current default values provided
2540 /// by the operating system.
2541 /// </summary>
2542 class function Create: TFormatSettings; static; inline;
2543 end;
2544{$ENDIF}
2545
2546 {$ENDREGION}
2547
2548
2549 {$REGION 'Routines'}
2550
2551{$IFDEF DELPHI2010}
2552function SplitString(const s, delimiters: string): TStringDynArray;
2553{$ENDIF}
2554
2555{$IFNDEF DELPHIXE2_UP}
2556function ReturnAddress: Pointer;
2557{$ENDIF}
2558
2559{$IFNDEF DELPHIXE3_UP}
2560function Pos(const SubStr, Str: UnicodeString; Offset: Integer): Integer; overload;
2561{$ENDIF}
2562
2563procedure PlatformNotImplemented;
2564
2565/// <summary>
2566/// Raises an <see cref="Spring|EArgumentNullException" /> if the <paramref name="value" />
2567/// is nil.
2568/// </summary>
2569procedure CheckArgumentNotNull(const value: IInterface; const argumentName: string); overload; deprecated 'Use Guard.CheckNotNull instead';
2570
2571/// <summary>
2572/// Raises an <see cref="Spring|EArgumentNullException" /> if the <paramref name="value" />
2573/// is nil.
2574/// </summary>
2575procedure CheckArgumentNotNull(value: Pointer; const argumentName: string); overload; deprecated 'Use Guard.CheckNotNull instead';
2576
2577function GetQualifiedClassName(AInstance: TObject): string; overload; inline;
2578function GetQualifiedClassName(AClass: TClass): string; overload; {$IFDEF DELPHIXE2_UP}inline;{$ENDIF}
2579
2580/// <summary>
2581/// Determines whether an instance of <c>leftType</c> can be assigned from an
2582/// instance of <c>rightType</c>.
2583/// </summary>
2584function IsAssignableFrom(leftType, rightType: PTypeInfo): Boolean; overload;
2585
2586function IsAssignableFrom(const leftTypes, rightTypes: array of PTypeInfo): Boolean; overload;
2587
2588/// <summary>
2589/// Returns <c>True</c> if the type is a nullable type.
2590/// </summary>
2591function IsNullable(typeInfo: PTypeInfo): Boolean;
2592
2593/// <summary>
2594/// Returns the underlying type argument of the specified nullable type.
2595/// </summary>
2596function GetUnderlyingType(typeInfo: PTypeInfo): PTypeInfo;
2597
2598/// <summary>
2599/// Returns the <see cref="TLazyKind" /> of the typeInfo.
2600/// </summary>
2601function GetLazyKind(typeInfo: PTypeInfo): TLazyKind;
2602
2603/// <summary>
2604/// Returns the underlying type of the lazy type.
2605/// </summary>
2606function GetLazyType(typeInfo: PTypeInfo): PTypeInfo;
2607
2608/// <summary>
2609/// Returns the underlying type name of the lazy type.
2610/// </summary>
2611function GetLazyTypeName(typeInfo: PTypeInfo): string;
2612
2613/// <summary>
2614/// Returns <c>True</c> if the type is a lazy type.
2615/// </summary>
2616function IsLazyType(typeInfo: PTypeInfo): Boolean;
2617
2618/// <summary>
2619/// Returns the size that is needed in order to pass an argument of the given
2620/// type.
2621/// </summary>
2622/// <remarks>
2623/// While in most cases the result is equal to the actual type size for short
2624/// strings it always returns SizeOf(Pointer) as short strings are always
2625/// passed as pointer.
2626/// </remarks>
2627function GetTypeSize(typeInfo: PTypeInfo): Integer;
2628
2629/// <summary>
2630/// Returns the size of the passed set type
2631/// </summary>
2632function GetSetSize(typeInfo: PTypeInfo): Integer;
2633
2634/// <summary>
2635/// Compares two TValue instances.
2636/// </summary>
2637function CompareValue(const left, right: TValue): Integer; overload;
2638
2639/// <summary>
2640/// Returns the types of the values.
2641/// </summary>
2642function TypesOf(const values: array of TValue): TArray<PTypeInfo>;
2643
2644function MethodReferenceToMethodPointer(const methodRef): TMethodPointer;
2645function MethodPointerToMethodReference(const method: TMethodPointer): IInterface;
2646
2647function SkipShortString(P: PByte): Pointer; inline;
2648
2649function StreamToVariant(const stream: TStream): Variant;
2650
2651function GetGenericTypeParameters(const typeName: string): TArray<string>;
2652
2653/// <summary>
2654/// Indicates whether two Variant values are equal. Unlike using the equals
2655/// operator this function also supports variant arrays.
2656/// </summary>
2657function SameValue(const left, right: Variant): Boolean; overload;
2658
2659/// <summary>
2660/// Determines whether a variant value is null or empty.
2661/// </summary>
2662function VarIsNullOrEmpty(const value: Variant): Boolean;
2663
2664/// <summary>
2665/// Returns the length of the variant array for the specified dimension.
2666/// </summary>
2667function VarArrayLength(const value: Variant; dim: Integer): Integer;
2668
2669{$IFDEF USE_VMTAUTOTABLE}
2670function CreateFieldTable(classType: TClass): TInitTable;
2671{$ENDIF}
2672
2673/// <summary>
2674/// Returns the field table for the given class that contains all fields that
2675/// have Default or Managed attribute annotations.
2676/// </summary>
2677function GetInitTable(classType: TClass): TInitTable; {$IFDEF USE_VMTAUTOTABLE}inline;{$ENDIF}
2678
2679function GetVirtualMethod(const classType: TClass; const index: Integer): Pointer; inline;
2680
2681function GetAbstractError: Pointer;
2682
2683{$IFNDEF DELPHIXE3_UP}
2684function AtomicIncrement(var target: Integer): Integer;
2685function AtomicDecrement(var target: Integer): Integer;
2686function AtomicCmpExchange(var target: Integer; newValue, comparand: Integer): Integer; overload;
2687function AtomicCmpExchange(var target: Pointer; newValue, comparand: Pointer): TObject; overload;
2688{$ENDIF}
2689
2690procedure IncUnchecked(var i: Integer; const n: Integer = 1); inline;
2691
2692procedure SwapPtr(var left, right); inline;
2693
2694 {$ENDREGION}
2695
2696
2697const
2698 EmptyValue: TValue = ();
2699
2700implementation
2701
2702uses
2703 DateUtils,
2704 Math,
2705 RTLConsts,
2706 StrUtils,
2707 SysConst,
2708 VarUtils,
2709{$IFDEF MSWINDOWS}
2710 Windows,
2711{$ENDIF}
2712 Spring.Events,
2713 Spring.ResourceStrings,
2714{$IFNDEF DELPHI2010}
2715 Spring.ValueConverters,
2716{$ENDIF}
2717 Spring.VirtualClass;
2718
2719
2720{$REGION 'Routines'}
2721
2722{$IFDEF DELPHI2010}
2723function SplitString(const s, delimiters: string): TStringDynArray;
2724var
2725 splitCount: Integer;
2726 startIndex: Integer;
2727 foundIndex: Integer;
2728 i: Integer;
2729begin
2730 Result := nil;
2731
2732 if s <> '' then
2733 begin
2734 splitCount := 0;
2735 for i := 1 to Length(s) do
2736 if IsDelimiter(delimiters, s, i) then
2737 Inc(splitCount);
2738
2739 SetLength(Result, splitCount + 1);
2740
2741 startIndex := 1;
2742 for i := 0 to splitCount - 1 do
2743 begin
2744 foundIndex := FindDelimiter(delimiters, s, startIndex);
2745 Result[i] := Copy(s, startIndex, foundIndex - startIndex);
2746 startIndex := foundIndex + 1;
2747 end;
2748
2749 Result[splitCount] := Copy(s, startIndex, Length(s) - startIndex + 1);
2750 end;
2751end;
2752{$ENDIF}
2753
2754{$IFNDEF DELPHIXE2_UP}
2755function ReturnAddress: Pointer;
2756asm
2757 mov eax,[ebp+4]
2758end;
2759{$ENDIF}
2760
2761{$IFNDEF DELPHIXE3_UP}
2762function Pos(const SubStr, Str: UnicodeString; Offset: Integer): Integer;
2763asm
2764 jmp PosEx
2765end;
2766{$ENDIF}
2767
2768procedure PlatformNotImplemented;
2769begin
2770 raise ENotImplementedException.Create('Not implemented in present platform.') at ReturnAddress;
2771end;
2772
2773procedure CheckArgumentNotNull(const value: IInterface; const argumentName: string);
2774begin
2775 CheckArgumentNotNull(Pointer(value), argumentName);
2776end;
2777
2778procedure CheckArgumentNotNull(value: Pointer; const argumentName: string);
2779begin
2780 if not Assigned(value) then
2781 Guard.RaiseArgumentNullException(argumentName);
2782end;
2783
2784function GetQualifiedClassName(AInstance: TObject): string;
2785begin
2786 Result := GetQualifiedClassName(AInstance.ClassType);
2787end;
2788
2789function GetQualifiedClassName(AClass: TClass): string;
2790{$IFNDEF DELPHIXE2_UP}
2791var
2792 LUnitName: string;
2793{$ENDIF}
2794begin
2795{$IFDEF DELPHIXE2_UP}
2796 Result := AClass.QualifiedClassName;
2797{$ELSE}
2798 LUnitName := AClass.UnitName;
2799 if LUnitName = '' then
2800 Result := AClass.ClassName
2801 else
2802 Result := LUnitName + '.' + AClass.ClassName;
2803{$ENDIF}
2804end;
2805
2806function IsAssignableFrom(leftType, rightType: PTypeInfo): Boolean;
2807var
2808 leftData, rightData: PTypeData;
2809begin
2810 Guard.CheckNotNull(leftType, 'leftType');
2811 Guard.CheckNotNull(rightType, 'rightType');
2812
2813 if leftType = rightType then
2814 Exit(True);
2815
2816 leftData := leftType.TypeData;
2817 rightData := rightType.TypeData;
2818 if (rightType.Kind = tkClass) and (leftType.Kind = tkClass) then
2819 Result := rightData.ClassType.InheritsFrom(leftData.ClassType)
2820 else if (rightType.Kind = tkClass) and (leftType.Kind = tkInterface) then
2821 begin
2822 Result := (ifHasGuid in leftData.IntfFlags) and
2823 Supports(rightData.ClassType, leftData.Guid);
2824 end
2825 else if (rightType.Kind = tkInterface) and (leftType.Kind = tkInterface) then
2826 begin
2827 if (ifHasGuid in leftData.IntfFlags) and (leftData.Guid = rightData.Guid) then
2828 Exit(True);
2829 Result := Assigned(rightData.IntfParent) and (rightData.IntfParent^ = leftType);
2830 while not Result and Assigned(rightData.IntfParent) do
2831 begin
2832 Result := rightData.IntfParent^ = leftType;
2833 rightData := rightData.IntfParent^.TypeData;
2834 end;
2835 end
2836 else
2837 Result := False;
2838end;
2839
2840function IsAssignableFrom(const leftTypes, rightTypes: array of PTypeInfo): Boolean;
2841var
2842 i: Integer;
2843begin
2844 Result := Length(leftTypes) = Length(rightTypes);
2845 if Result then
2846 for i := Low(leftTypes) to High(leftTypes) do
2847 if not IsAssignableFrom(leftTypes[i], rightTypes[i]) then
2848 Exit(False);
2849end;
2850
2851function IsNullable(typeInfo: PTypeInfo): Boolean;
2852const
2853 PrefixString = 'Nullable<'; // DO NOT LOCALIZE
2854begin
2855 Result := Assigned(typeInfo) and (typeInfo.Kind = tkRecord)
2856 and StartsText(PrefixString, typeInfo.TypeName);
2857end;
2858
2859function GetUnderlyingType(typeInfo: PTypeInfo): PTypeInfo;
2860var
2861 nullable: TNullableHelper;
2862begin
2863 if IsNullable(typeInfo) then
2864 begin
2865 nullable := TNullableHelper.Create(typeInfo);
2866 Result := nullable.ValueType;
2867 end
2868 else
2869 Result := nil;
2870end;
2871
2872const
2873 LazyPrefixStrings: array[lkFunc..High(TLazyKind)] of string = (
2874 'TFunc<', 'Lazy<', 'ILazy<');
2875
2876function GetLazyKind(typeInfo: PTypeInfo): TLazyKind;
2877var
2878 name: string;
2879begin
2880 if Assigned(typeInfo) then
2881 begin
2882 name := typeInfo.TypeName;
2883 for Result := lkFunc to High(TLazyKind) do
2884 if StartsText(LazyPrefixStrings[Result], name)
2885 and (Length(GetGenericTypeParameters(name)) = 1) then
2886 Exit;
2887 end;
2888 Result := lkNone;
2889end;
2890
2891function GetLazyTypeName(typeInfo: PTypeInfo): string;
2892var
2893 lazyKind: TLazyKind;
2894 name: string;
2895 i: Integer;
2896begin
2897 lazyKind := GetLazyKind(typeInfo);
2898 name := typeInfo.TypeName;
2899 if lazyKind > lkNone then
2900 begin
2901 i := Length(LazyPrefixStrings[lazyKind]) + 1;
2902 Result := Copy(name, i, Length(name) - i )
2903 end
2904 else
2905 Result := '';
2906end;
2907
2908function GetLazyType(typeInfo: PTypeInfo): PTypeInfo;
2909
2910 function GetLazyTypeUnsafe(typeInfo: PTypeInfo): PTypeInfo;
2911 var
2912 typeName: string;
2913 rttiType: TrttiType;
2914 begin
2915 typeName := GetGenericTypeParameters(typeInfo.TypeName)[0];
2916 rttiType := TType.Context.FindType(typeName);
2917 if Assigned(rttiType) then
2918 Result := rttiType.Handle
2919 else
2920 begin
2921 for rttiType in TType.Context.GetTypes do
2922 if rttiType.IsPublicType and (rttiType.QualifiedName = typeName) then
2923 Exit(rttiType.Handle);
2924 raise EInvalidOperationException.CreateResFmt(@STypeInfoNotFound, [typeName]);
2925 end;
2926 end;
2927
2928var
2929 lazyKind: TLazyKind;
2930 method: TRttiMethod;
2931begin
2932 lazyKind := GetLazyKind(typeInfo);
2933 case lazyKind of
2934 lkFunc:
2935 begin
2936 method := TType.GetType(typeInfo).GetMethod('Invoke');
2937 if Assigned(method) then
2938 Result := method.ReturnType.Handle
2939 else
2940 Result := GetLazyTypeUnsafe(typeInfo);
2941 end;
2942 lkRecord, lkInterface:
2943 begin
2944 if lazyKind = lkRecord then
2945 typeInfo := PManagedField(PByte(@typeInfo.TypeData.ManagedFldCount) + SizeOf(Integer)).TypeRef^;
2946 method := TType.GetType(typeInfo).GetMethod('GetValue');
2947 if Assigned(method) then
2948 Result := method.ReturnType.Handle
2949 else
2950 Result := nil; // must not happen - ILazy<T> has methodinfo
2951 end;
2952 else
2953 Result := nil;
2954 end;
2955end;
2956
2957function IsLazyType(typeInfo: PTypeInfo): Boolean;
2958begin
2959 Result := GetLazyKind(typeInfo) <> lkNone;
2960end;
2961
2962// TODO: use typekind matrix for comparer functions
2963function CompareValue(const left, right: TValue): Integer;
2964const
2965 EmptyResults: array[Boolean, Boolean] of Integer = ((0, -1), (1, 0));
2966var
2967 leftIsEmpty, rightIsEmpty: Boolean;
2968 leftValue, rightValue: TValue;
2969begin
2970 leftIsEmpty := left.IsEmpty;
2971 rightIsEmpty := right.IsEmpty;
2972 if leftIsEmpty or rightIsEmpty then
2973 Result := EmptyResults[leftIsEmpty, rightIsEmpty]
2974 else if left.IsOrdinal and right.IsOrdinal then
2975 Result := Math.CompareValue(left.AsOrdinal, right.AsOrdinal)
2976 else if left.IsFloat and right.IsFloat then
2977 Result := Math.CompareValue(left.AsExtended, right.AsExtended)
2978 else if left.IsString and right.IsString then
2979 Result := SysUtils.AnsiCompareStr(left.AsString, right.AsString)
2980 else if left.IsObject and right.IsObject then
2981 Result := NativeInt(left.AsObject) - NativeInt(right.AsObject) // TODO: instance comparer
2982 else if left.IsVariant and right.IsVariant then
2983 begin
2984 case VarCompareValue(left.AsVariant, right.AsVariant) of
2985 vrEqual: Result := 0;
2986 vrLessThan: Result := -1;
2987 vrGreaterThan: Result := 1;
2988 vrNotEqual: Result := -1;
2989 else
2990 Result := 0;
2991 end;
2992 end
2993 else if IsNullable(left.TypeInfo) and IsNullable(right.TypeInfo) then
2994 begin
2995 leftIsEmpty := not left.TryGetNullableValue(leftValue);
2996 rightIsEmpty := not right.TryGetNullableValue(rightValue);
2997 if leftIsEmpty or rightIsEmpty then
2998 Result := EmptyResults[leftIsEmpty, rightIsEmpty]
2999 else
3000 Result := CompareValue(leftValue, rightValue);
3001 end else
3002 Result := 0;
3003end;
3004
3005function GetSetSize(typeInfo: PTypeInfo): Integer;
3006var
3007 typeData: PTypeData;
3008 count: Integer;
3009begin
3010 typeData := GetTypeData(typeInfo);
3011 typeData := GetTypeData(typeData.CompType^);
3012 if typeData.MinValue = 0 then
3013 case typeData.MaxValue of
3014 0..7: Exit(1);
3015 8..15: Exit(2);
3016 16..31: Exit(4);
3017 end;
3018 count := typeData.MaxValue - typeData.MinValue + 1;
3019 Result := count div 8;
3020 if count mod 8 <> 0 then
3021 Inc(Result);
3022end;
3023
3024function GetTypeSize(typeInfo: PTypeInfo): Integer;
3025const
3026 COrdinalSizes: array[TOrdType] of Integer = (
3027 SizeOf(ShortInt){1},
3028 SizeOf(Byte){1},
3029 SizeOf(SmallInt){2},
3030 SizeOf(Word){2},
3031 SizeOf(Integer){4},
3032 SizeOf(Cardinal){4});
3033 CFloatSizes: array[TFloatType] of Integer = (
3034 SizeOf(Single){4},
3035 SizeOf(Double){8},
3036{$IFDEF ALIGN_STACK}
3037 16,
3038{$ELSE}
3039 SizeOf(Extended){10},
3040{$ENDIF}
3041 SizeOf(Comp){8},
3042 SizeOf(Currency){8});
3043begin
3044 case typeInfo.Kind of
3045{$IFNDEF NEXTGEN}
3046 tkChar:
3047 Result := SizeOf(AnsiChar){1};
3048{$ENDIF}
3049 tkWChar:
3050 Result := SizeOf(WideChar){2};
3051 tkInteger, tkEnumeration:
3052 Result := COrdinalSizes[typeInfo.TypeData.OrdType];
3053 tkFloat:
3054 Result := CFloatSizes[typeInfo.TypeData.FloatType];
3055 tkString, tkLString, tkUString, tkWString, tkInterface, tkClass, tkClassRef, tkDynArray, tkPointer, tkProcedure:
3056 Result := SizeOf(Pointer);
3057 tkMethod:
3058 Result := SizeOf(TMethod);
3059 tkInt64:
3060 Result := SizeOf(Int64){8};
3061 tkVariant:
3062 Result := SizeOf(Variant);
3063 tkSet:
3064 Result := GetSetSize(typeInfo);
3065 tkRecord:
3066 Result := typeInfo.TypeData.RecSize;
3067 tkArray:
3068 Result := typeInfo.TypeData.ArrayData.Size;
3069 else
3070 Assert(False, 'Unsupported type'); { TODO -o##jwp -cEnhance : add more context to the assert }
3071 Result := -1;
3072 end;
3073end;
3074
3075function TypesOf(const values: array of TValue): TArray<PTypeInfo>;
3076var
3077 i: Integer;
3078begin
3079 SetLength(Result, Length(values));
3080 for i := 0 to High(values) do
3081 Result[i] := values[i].TypeInfo;
3082end;
3083
3084function MethodReferenceToMethodPointer(const methodRef): TMethodPointer;
3085type
3086 TVtable = array[0..3] of Pointer;
3087 PVtable = ^TVtable;
3088 PPVtable = ^PVtable;
3089begin
3090 if Pointer(methodRef) = nil then
3091 Exit(nil);
3092 // 3 is offset of Invoke, after QI, AddRef, Release
3093 TMethod(Result).Code := PPVtable(methodRef)^^[3];
3094 TMethod(Result).Data := Pointer(methodRef);
3095end;
3096
3097function MethodPointerToMethodReference(const method: TMethodPointer): IInterface;
3098begin
3099 Result := IInterface(TMethod(method).Data);
3100end;
3101
3102function SkipShortString(P: PByte): Pointer;
3103begin
3104 Result := P + P^ + 1;
3105end;
3106
3107function StreamToVariant(const stream: TStream): Variant;
3108var
3109 lock: Pointer;
3110 size: Integer;
3111begin
3112 if not Assigned(stream) then
3113 Exit(Null);
3114 size := stream.Size;
3115 if size = 0 then
3116 Exit(Null);
3117 stream.Position := 0;
3118 Result := VarArrayCreate([0, size - 1], varByte);
3119 lock := VarArrayLock(Result);
3120 try
3121 stream.ReadBuffer(lock^, stream.Size);
3122 finally
3123 VarArrayUnlock(Result);
3124 end;
3125end;
3126
3127function GetGenericTypeParameters(const typeName: string): TArray<string>;
3128
3129 function ScanChar(const s: string; var index: Integer): Boolean;
3130 var
3131 level: Integer;
3132 begin
3133 Result := False;
3134 level := 0;
3135 while index <= Length(s) do
3136 begin
3137 case s[index] of
3138 ',': if level = 0 then Exit(True);
3139 '<': Inc(level);
3140 '>': Dec(level);
3141 end;
3142 Inc(index);
3143 Result := level = 0;
3144 end;
3145 end;
3146
3147 function SplitTypes(const s: string): TArray<string>;
3148 var
3149 startPos, index, len: Integer;
3150 begin
3151 Result := nil;
3152 startPos := 1;
3153 index := 1;
3154 while ScanChar(s, index) do
3155 begin
3156 len := Length(Result);
3157 SetLength(Result, len + 1);
3158 Result[len] := Copy(s, startPos, index - startPos);
3159 Inc(index);
3160 startPos := index;
3161 end;
3162 end;
3163
3164var
3165 i: Integer;
3166 s: string;
3167begin
3168 s := typeName;
3169 i := Pos('<', s);
3170 if i = 0 then
3171 Exit(nil);
3172 s := Copy(s, i + 1, Length(s) - i - 1);
3173 Result := SplitTypes(s);
3174end;
3175
3176type
3177 TVarArrayBoundHelper = record helper for TVarArrayBound
3178 function GetHighBound: Integer; inline;
3179 property HighBound: Integer read GetHighBound;
3180 end;
3181
3182function TVarArrayBoundHelper.GetHighBound: Integer;
3183begin
3184 Result := LowBound + ElementCount - 1;
3185end;
3186
3187function SameValue(const left, right: Variant): Boolean;
3188
3189 function MoveNext(const bounds: TArray<TVarArrayBound>;
3190 var indices: TArray<Integer>): Boolean;
3191 var
3192 i: Integer;
3193 begin
3194 for i := Length(indices) - 1 downto 0 do
3195 if indices[i] < bounds[i].HighBound then
3196 begin
3197 Inc(indices[i]);
3198 Exit(True);
3199 end
3200 else
3201 indices[i] := bounds[i].LowBound;
3202 Result := False;
3203 end;
3204
3205var
3206 isArray: Boolean;
3207 leftArr, rightArr: PVarArray;
3208 i, count: Integer;
3209 indices: TArray<Integer>;
3210 bounds: TArray<TVarArrayBound>;
3211begin
3212 isArray := VarType(left) and varArray = varArray;
3213 if isArray <> (VarType(right) and varArray = varArray) then
3214 Exit(False);
3215
3216 if not isArray then
3217 Exit(left = right);
3218
3219 leftArr := VarArrayAsPSafeArray(left);
3220 rightArr := VarArrayAsPSafeArray(right);
3221 if leftArr.DimCount <> rightArr.DimCount then
3222 Exit(False);
3223 SetLength(indices, leftArr.DimCount);
3224 SetLength(bounds, leftArr.DimCount);
3225{$RANGECHECKS OFF}
3226 for i := leftArr.DimCount - 1 downto 0 do
3227 begin
3228 count := leftArr.Bounds[i].ElementCount;
3229 if count = 0 then
3230 Exit(True);
3231 if count <> rightArr.Bounds[i].ElementCount then
3232 Exit(False);
3233 bounds[leftArr.DimCount - 1 - i] := leftArr.Bounds[i];
3234 end;
3235{$IFDEF RANGECHECKS_ON}
3236{$RANGECHECKS ON}
3237{$ENDIF}
3238 repeat
3239 if not SameValue(VarArrayGet(left, indices), VarArrayGet(right, indices)) then
3240 Exit(False);
3241 until not MoveNext(bounds, indices);
3242 Result := True;
3243end;
3244
3245function VarIsNullOrEmpty(const value: Variant): Boolean;
3246begin
3247 Result := FindVarData(value).VType in [varEmpty, varNull];
3248end;
3249
3250function VarArrayLength(const value: Variant; dim: Integer): Integer;
3251var
3252 arrayRef: PVarArray;
3253 lo, hi: Integer;
3254begin
3255 arrayRef := VarArrayAsPSafeArray(value);
3256 VarResultCheck(SafeArrayGetLBound(arrayRef, dim, lo));
3257 VarResultCheck(SafeArrayGetUBound(arrayRef, dim, hi));
3258 Result := hi - lo + 1;
3259end;
3260
3261function GetVirtualMethod(const classType: TClass; const index: Integer): Pointer;
3262begin
3263 Result := PPointer(IntPtr(classType) + IntPtr(index * SizeOf(Pointer)))^;
3264end;
3265
3266type
3267 TAbstractObject = class
3268 procedure AbstractMethod; virtual; abstract;
3269 end;
3270
3271function GetAbstractError: Pointer;
3272begin
3273 Result := PPointer(TAbstractObject)^
3274end;
3275
3276{$IFNDEF DELPHIXE3_UP}
3277function AtomicIncrement(var target: Integer): Integer;
3278asm
3279{$IFDEF CPUX86}
3280 mov ecx,eax
3281 mov eax,1
3282 lock xadd [ecx],eax
3283 inc eax
3284{$ENDIF}
3285{$IFDEF CPUX64}
3286 mov eax,1
3287 lock xadd [rcx],eax
3288 inc eax
3289{$ENDIF}
3290end;
3291
3292function AtomicDecrement(var target: Integer): Integer;
3293asm
3294{$IFDEF CPUX86}
3295 mov ecx,eax
3296 mov eax,-1
3297 lock xadd [ecx],eax
3298 dec eax
3299{$ENDIF}
3300{$IFDEF CPUX64}
3301 mov eax,-1
3302 lock xadd [rcx],eax
3303 dec eax
3304{$ENDIF}
3305end;
3306
3307function AtomicCmpExchange(var target: Integer; newValue, comparand: Integer): Integer;
3308asm
3309{$IFDEF CPUX86}
3310 xchg eax,ecx
3311 lock cmpxchg [ecx],edx
3312{$ENDIF}
3313{$IFDEF CPUX64}
3314 mov rax,r8
3315 lock cmpxchg [rcx],edx
3316{$ENDIF}
3317end;
3318
3319function AtomicCmpExchange(var target: Pointer; newValue, comparand: Pointer): TObject;
3320asm
3321{$IFDEF CPUX86}
3322 xchg eax,ecx
3323 lock cmpxchg [ecx],edx
3324{$ENDIF}
3325{$IFDEF CPUX64}
3326 mov rax,r8
3327 lock cmpxchg [rcx],edx
3328{$ENDIF}
3329end;
3330{$ENDIF}
3331
3332procedure IncUnchecked(var i: Integer; const n: Integer = 1); inline;
3333begin
3334 {$IFOPT Q+}{$DEFINE OVERFLOWCHECKS_ON}{$Q-}{$ENDIF}
3335 Inc(i, n);
3336 {$IFDEF OVERFLOWCHECKS_ON}{$Q+}{$ENDIF}
3337end;
3338
3339{$ENDREGION}
3340
3341
3342{$REGION 'TGuidHelper'}
3343
3344{$IFDEF DELPHI2010}
3345class function TGuidHelper.Create(const B: TBytes): TGUID;
3346begin
3347 if Length(B) <> 16 then
3348 raise EArgumentException.CreateResFmt(@SInvalidGuidArray, [16]);
3349 Move(B[0], Result, SizeOf(Result));
3350end;
3351
3352class function TGuidHelper.Create(const S: string): TGUID;
3353begin
3354 Result := StringToGUID(S);
3355end;
3356
3357class function TGuidHelper.Create(A: Integer; B, C: SmallInt;
3358 const D: TBytes): TGUID;
3359begin
3360 if Length(D) <> 16 then
3361 raise EArgumentException.CreateResFmt(@SInvalidGuidArray, [8]);
3362 Result.D1 := LongWord(A);
3363 Result.D2 := Word(B);
3364 Result.D3 := Word(C);
3365 Move(D[0], Result.D4, SizeOf(Result.D4));
3366end;
3367
3368class function TGuidHelper.Empty: TGuid;
3369begin
3370 FillChar(Result, SizeOf(Result), 0);
3371end;
3372
3373class function TGuidHelper.NewGuid: TGuid;
3374begin
3375 if CreateGUID(Result) <> S_OK then
3376 RaiseLastOSError;
3377end;
3378
3379class function TGuidHelper.&&op_Equality(const left, right: TGUID): Boolean;
3380var
3381 a, b: PIntegerArray;
3382begin
3383 a := PIntegerArray(@left);
3384 b := PIntegerArray(@right);
3385 Result := (a^[0] = b^[0]) and (a^[1] = b^[1]) and (a^[2] = b^[2]) and (a^[3] = b^[3]);
3386end;
3387
3388class function TGuidHelper.&&op_Inequality(const left, right: TGUID): Boolean;
3389begin
3390 Result := not (left = right);
3391end;
3392
3393function TGuidHelper.ToByteArray: TBytes;
3394begin
3395 SetLength(Result, 16);
3396 Move(D1, Result[0], SizeOf(Self));
3397end;
3398
3399function TGuidHelper.ToString: string;
3400begin
3401 Result := GuidToString(Self);
3402end;
3403{$ENDIF}
3404
3405{$ENDREGION}
3406
3407
3408{$REGION 'TMethodHelper'}
3409
3410{$IFNDEF DELPHIXE3_UP}
3411class function TMethodHelper.&&op_Equality(const left, Right: TMethod): Boolean;
3412begin
3413 Result := (left.Data = right.Data) and (left.Code = right.Code);
3414end;
3415
3416class function TMethodHelper.&&op_Inequality(const left, Right: TMethod): Boolean;
3417begin
3418 Result := (left.Data <> right.Data) or (left.Code <> right.Code);
3419end;
3420
3421class function TMethodHelper.&&op_GreaterThan(const left, right: TMethod): Boolean;
3422begin
3423 Result := (UIntPtr(left.Data) > UIntPtr(right.Data))
3424 or ((left.Data = right.Data) and (UIntPtr(left.Code) > UIntPtr(right.Code)));
3425end;
3426
3427class function TMethodHelper.&&op_LessThan(const left, right: TMethod): Boolean;
3428begin
3429 Result := (UIntPtr(left.Data) < UIntPtr(right.Data))
3430 or ((left.Data = right.Data) and (UIntPtr(left.Code) < UIntPtr(right.Code)));
3431end;
3432{$ENDIF}
3433
3434{$ENDREGION}
3435
3436
3437{$REGION 'TType'}
3438
3439class constructor TType.Create;
3440begin
3441 fContext := TRttiContext.Create;
3442end;
3443
3444class destructor TType.Destroy;
3445begin
3446 fContext.Free;
3447end;
3448
3449class function TType.GetType(typeInfo: PTypeInfo): TRttiType;
3450begin
3451 Result := fContext.GetType(typeInfo);
3452end;
3453
3454class function TType.GetType(classType: TClass): TRttiInstanceType;
3455begin
3456 Result := TRttiInstanceType(fContext.GetType(classType));
3457end;
3458
3459class function TType.GetType<T>: TRttiType;
3460begin
3461 Result := fContext.GetType(TypeInfo(T));
3462end;
3463
3464class function TType.HasWeakRef<T>: Boolean;
3465begin
3466{$IFDEF DELPHIXE7_UP}
3467 Result := System.HasWeakRef(T);
3468{$ELSE}
3469 {$IFDEF WEAKREF}
3470 Result := TypInfo.HasWeakRef(TypeInfo(T));
3471 {$ELSE}
3472 Result := False;
3473 {$ENDIF}
3474{$ENDIF}
3475end;
3476
3477class function TType.IsManaged<T>: Boolean;
3478begin
3479{$IFDEF DELPHIXE7_UP}
3480 Result := System.IsManagedType(T);
3481{$ELSE}
3482 Result := Rtti.IsManaged(TypeInfo(T));
3483{$ENDIF}
3484end;
3485
3486class function TType.Kind<T>: TTypeKind;
3487{$IFDEF DELPHIXE7_UP}
3488begin
3489 Result := System.GetTypeKind(T);
3490{$ELSE}
3491var
3492 typeInfo: PTypeInfo;
3493begin
3494 typeInfo := System.TypeInfo(T);
3495 if typeInfo = nil then
3496 Exit(tkUnknown);
3497 Result := typeInfo.Kind;
3498{$ENDIF}
3499end;
3500
3501{$ENDREGION}
3502
3503
3504{$REGION 'TEnum'}
3505
3506class function TEnum.ToInteger<T>(const value: T): Integer;
3507begin
3508 case SizeOf(T) of
3509 1: Result := PByte(@value)^;
3510 2: Result := PWord(@value)^;
3511 4: Result := PInteger(@value)^;
3512 end;
3513end;
3514
3515class function TEnum.IsValid<T>(const value: Integer): Boolean;
3516var
3517 data: PTypeData;
3518begin
3519 Guard.CheckTypeKind<T>(tkEnumeration, 'T');
3520 data := GetTypeData(TypeInfo(T));
3521 Result := (value >= data.MinValue) and (value <= data.MaxValue);
3522end;
3523
3524class function TEnum.IsValid<T>(const value: T): Boolean;
3525var
3526 intValue: Integer;
3527begin
3528 intValue := ToInteger<T>(value);
3529 Result := IsValid<T>(intValue);
3530end;
3531
3532class function TEnum.GetName<T>(const value: Integer): string;
3533begin
3534 Guard.CheckEnum<T>(value, 'value');
3535 Result := GetEnumName(TypeInfo(T), value);
3536end;
3537
3538class function TEnum.GetName<T>(const value: T): string;
3539var
3540 intValue: Integer;
3541begin
3542 intValue := ToInteger<T>(value);
3543 Result := GetName<T>(intValue);
3544end;
3545
3546class function TEnum.GetNames<T>: TStringDynArray;
3547var
3548 typeData: PTypeData;
3549{$IFDEF NEXTGEN}
3550 p: TTypeInfoFieldAccessor;
3551{$ELSE}
3552 p: PShortString;
3553{$ENDIF}
3554 i: Integer;
3555begin
3556 Guard.CheckTypeKind<T>(tkEnumeration, 'T');
3557 typeData := GetTypeData(TypeInfo(T));
3558 SetLength(Result, typeData.MaxValue - typeData.MinValue + 1);
3559{$IFDEF NEXTGEN}
3560 p := typedata^.NameListFld;
3561{$ELSE}
3562 p := @typedata.NameList;
3563{$ENDIF}
3564 for i := Low(Result) to High(Result) do
3565 begin
3566{$IFDEF NEXTGEN}
3567 Result[i] := p.ToString;
3568 p.SetData(p.Tail);
3569{$ELSE}
3570 Result[i] := UTF8ToString(p^);
3571 Inc(PByte(p), Length(p^) + 1);
3572{$ENDIF}
3573 end;
3574end;
3575
3576class function TEnum.GetValue<T>(const value: string): Integer;
3577var
3578 temp: T;
3579begin
3580 temp := Parse<T>(value);
3581 Result := ToInteger<T>(temp);
3582end;
3583
3584class function TEnum.GetValue<T>(const value: T): Integer;
3585begin
3586 Guard.CheckEnum<T>(value, 'value');
3587 Result := ToInteger<T>(value);
3588end;
3589
3590class function TEnum.GetValues<T>: TIntegerDynArray;
3591var
3592 typeData: PTypeData;
3593 i: Integer;
3594begin
3595 Guard.CheckTypeKind<T>(tkEnumeration, 'T');
3596 typeData := GetTypeData(TypeInfo(T));
3597 SetLength(Result, typeData.MaxValue - typeData.MinValue + 1);
3598 for i := Low(Result) to High(Result) do
3599 Result[i] := i;
3600end;
3601
3602class function TEnum.TryParse<T>(const value: Integer; out enum: T): Boolean;
3603begin
3604 Result := IsValid<T>(value);
3605 if Result then
3606 Move(value, enum, SizeOf(T));
3607end;
3608
3609class function TEnum.TryParse<T>(const value: string; out enum: T): Boolean;
3610var
3611 intValue: Integer;
3612begin
3613 Guard.CheckTypeKind<T>(tkEnumeration, 'T');
3614 intValue := GetEnumValue(TypeInfo(T), value);
3615 Result := TryParse<T>(intValue, enum);
3616end;
3617
3618class function TEnum.Parse<T>(const value: Integer): T;
3619begin
3620 if not TryParse<T>(value, Result) then
3621 raise EFormatException.CreateResFmt(@SIncorrectFormat, [IntToStr(value)]);
3622end;
3623
3624class function TEnum.Parse<T>(const value: string): T;
3625begin
3626 if not TryParse<T>(value, Result) then
3627 raise EFormatException.CreateResFmt(@SIncorrectFormat, [value]);
3628end;
3629
3630{$ENDREGION}
3631
3632
3633{$REGION 'TBaseAttribute'}
3634
3635constructor TBaseAttribute.Create;
3636begin
3637 inherited Create;
3638end;
3639
3640{$ENDREGION}
3641
3642
3643{$REGION 'DefaultAttribute'}
3644
3645{$IFNDEF DELPHIXE3_UP}
3646constructor DefaultAttribute.Create(const defaultValue: Integer);
3647begin
3648 inherited Create;
3649 fValue := defaultValue;
3650end;
3651
3652constructor DefaultAttribute.Create(const defaultValue: Boolean);
3653begin
3654 inherited Create;
3655 fValue := Ord(defaultValue);
3656end;
3657
3658constructor DefaultAttribute.Create(const defaultValue: Cardinal);
3659begin
3660 inherited Create;
3661 fValue := defaultValue;
3662end;
3663
3664constructor DefaultAttribute.Create(const defaultValue: string);
3665begin
3666 inherited Create;
3667 fValue := defaultValue;
3668end;
3669
3670constructor DefaultAttribute.Create(const defaultValue: Extended);
3671begin
3672 inherited Create;
3673 fValue := defaultValue;
3674end;
3675
3676constructor DefaultAttribute.Create(const defaultValue: Int64);
3677begin
3678 inherited Create;
3679 fValue := defaultValue;
3680end;
3681
3682constructor DefaultAttribute.Create(const defaultValue: UInt64);
3683begin
3684 inherited Create;
3685 fValue := defaultValue;
3686end;
3687{$ENDIF}
3688
3689{$ENDREGION}
3690
3691
3692{$REGION 'ManagedAttribute'}
3693
3694constructor ManagedAttribute.Create(createInstance: Boolean);
3695begin
3696 inherited Create;
3697 fCreateInstance := createInstance;
3698end;
3699
3700constructor ManagedAttribute.Create(instanceClass: TClass);
3701begin
3702 inherited Create;
3703 fCreateInstance := True;
3704 fInstanceClass := instanceClass;
3705end;
3706
3707constructor ManagedAttribute.Create(const factory: TFunc<PTypeInfo,Pointer>);
3708begin
3709 Create(instanceClass);
3710 fFactory := factory;
3711end;
3712
3713{$ENDREGION}
3714
3715
3716{$REGION 'TInitTable'}
3717
3718class constructor TInitTable.Create;
3719begin
3720{$IFDEF USE_VMTAUTOTABLE}
3721 InitTables := TObjectList<TInitTable>.Create;
3722{$ELSE}
3723 InitTables := TObjectDictionary<TClass,TInitTable>.Create([doOwnsValues]);
3724{$ENDIF}
3725 FormatSettings := TFormatSettings.Create;
3726 FormatSettings.DateSeparator := '-';
3727 FormatSettings.TimeSeparator := ':';
3728 FormatSettings.ShortDateFormat := 'YYYY-MM-DD';
3729 FormatSettings.ShortTimeFormat := 'hh:mm:ss';
3730end;
3731
3732class destructor TInitTable.Destroy;
3733begin
3734 InitTables.Free;
3735end;
3736
3737constructor TInitTable.Create(classType: TClass);
3738var
3739 t: TRttiType;
3740 f: TRttiField;
3741 p: TRttiProperty;
3742 a: TCustomAttribute;
3743 setter: Pointer;
3744begin
3745 t := TType.GetType(classType);
3746 for f in t.GetFields do
3747 for a in f.GetAttributes do
3748 if a is DefaultAttribute then
3749 AddDefaultField(f.FieldType.Handle, DefaultAttribute(a).Value, f.Offset)
3750 else if a is ManagedAttribute then
3751 if f.FieldType.TypeKind in [tkClass, tkInterface] then
3752 AddManagedField(f, ManagedAttribute(a));
3753
3754 for p in t.GetProperties do
3755 for a in p.GetAttributes do
3756 if a is DefaultAttribute then
3757 begin
3758 if p.IsWritable then
3759 setter := TRttiInstanceProperty(p).PropInfo.SetProc
3760 else
3761 begin
3762 // if the property is read-only but backed by a field it can be initialized
3763 setter := TRttiInstanceProperty(p).PropInfo.GetProc;
3764 if IntPtr(setter) and PROPSLOT_MASK <> PROPSLOT_FIELD then
3765 raise EInvalidOperationException.Create('Property not writable'); // TODO
3766 end;
3767
3768 if IntPtr(setter) and PROPSLOT_MASK = PROPSLOT_FIELD then
3769 AddDefaultField(p.PropertyType.Handle, DefaultAttribute(a).Value,
3770 IntPtr(setter) and not PROPSLOT_MASK)
3771 else
3772 AddDefaultProperty(p.PropertyType.Handle, DefaultAttribute(a).Value,
3773 TRttiInstanceProperty(p).PropInfo);
3774 end;
3775end;
3776
3777destructor TInitTable.Destroy;
3778var
3779 i: Integer;
3780begin
3781 for i := 0 to High(DefaultFields) do
3782 FreeAndNil(DefaultFields[i]);
3783 for i := 0 to High(ManagedFields) do
3784 FreeAndNil(ManagedFields[i]);
3785 inherited Destroy;
3786end;
3787
3788procedure TInitTable.AddDefaultField(fieldType: PTypeInfo;
3789 const value: Variant; offset: Integer);
3790var
3791 defaultField: TInitializableField;
3792begin
3793 defaultField := nil;
3794 case fieldType.Kind of
3795 tkInteger, tkEnumeration:
3796 case fieldType.TypeData.OrdType of
3797 otSByte: defaultField := TDefaultField<ShortInt>.Create(offset, value);
3798 otSWord: defaultField := TDefaultField<SmallInt>.Create(offset, value);
3799 otSLong: defaultField := TDefaultField<Integer>.Create(offset, value);
3800 otUByte: defaultField := TDefaultField<Byte>.Create(offset, value);
3801 otUWord: defaultField := TDefaultField<Word>.Create(offset, value);
3802 otULong: defaultField := TDefaultField<Cardinal>.Create(offset, value);
3803 end;
3804 {$IFNDEF NEXTGEN}
3805 tkChar:
3806 defaultField := TDefaultField<AnsiChar>.Create(offset, value);
3807 {$ENDIF}
3808 tkFloat:
3809 if (fieldType = TypeInfo(TDateTime)) and (VarType(value) = varUString) then
3810 defaultField := TDefaultField<TDateTime>.Create(offset, StrToDateTime(value, FormatSettings))
3811 else if (fieldType = TypeInfo(TDate)) and (VarType(value) = varUString) then
3812 defaultField := TDefaultField<TDate>.Create(offset, StrToDate(value, FormatSettings))
3813 else if (fieldType = TypeInfo(TTime)) and (VarType(value) = varUString) then
3814 defaultField := TDefaultField<TTime>.Create(offset, StrToTime(value, FormatSettings))
3815 else
3816 case FieldType.TypeData.FloatType of
3817 ftSingle: defaultField := TDefaultField<Single>.Create(offset, value);
3818 ftDouble: defaultField := TDefaultField<Double>.Create(offset, value);
3819 ftExtended: defaultField := TDefaultField<Extended>.Create(offset, value);
3820 ftComp: defaultField := TDefaultField<Comp>.Create(offset, value);
3821 ftCurr: defaultField := TDefaultField<Currency>.Create(offset, value);
3822 end;
3823 tkWChar:
3824 defaultField := TDefaultField<Char>.Create(offset, value);
3825 {$IFNDEF NEXTGEN}
3826 tkWString:
3827 defaultField := TDefaultField<WideString>.Create(offset, value);
3828 {$ENDIF}
3829 tkVariant:
3830 defaultField := TDefaultField<Variant>.Create(offset, value);
3831 tkInt64:
3832 if fieldType.TypeData.MinInt64Value > fieldType.TypeData.MaxInt64Value then
3833 defaultField := TDefaultField<UInt64>.Create(offset, value)
3834 else
3835 defaultField := TDefaultField<Int64>.Create(offset, value);
3836 tkUString:
3837 defaultField := TDefaultField<UnicodeString>.Create(offset, value);
3838 tkClassRef, tkPointer:
3839 defaultField := TDefaultField<Pointer>.Create(offset, value);
3840 end;
3841 if defaultField <> nil then
3842 begin
3843 DefaultFieldCount := Length(DefaultFields) + 1;
3844 SetLength(DefaultFields, DefaultFieldCount);
3845 DefaultFields[DefaultFieldCount - 1] := defaultField;
3846 end;
3847end;
3848
3849procedure TInitTable.AddDefaultProperty(fieldType: PTypeInfo;
3850 const value: Variant; propInfo: PPropInfo);
3851var
3852 defaultField: TInitializableField;
3853begin
3854 defaultField := nil;
3855 case fieldType.Kind of
3856 tkInteger, tkEnumeration:
3857 case fieldType.TypeData.OrdType of
3858 otSByte: defaultField := TDefaultProperty<ShortInt>.Create(propInfo, value);
3859 otSWord: defaultField := TDefaultProperty<SmallInt>.Create(propInfo, value);
3860 otSLong: defaultField := TDefaultProperty<Integer>.Create(propInfo, value);
3861 otUByte: defaultField := TDefaultProperty<Byte>.Create(propInfo, value);
3862 otUWord: defaultField := TDefaultProperty<Word>.Create(propInfo, value);
3863 otULong: defaultField := TDefaultProperty<Cardinal>.Create(propInfo, value);
3864 end;
3865 {$IFNDEF NEXTGEN}
3866 tkChar:
3867 defaultField := TDefaultProperty<AnsiChar>.Create(propInfo, value);
3868 {$ENDIF}
3869 tkFloat:
3870 if (fieldType = TypeInfo(TDateTime)) and (VarType(value) = varUString) then
3871 defaultField := TDefaultProperty<TDateTime>.Create(propInfo, StrToDateTime(value, FormatSettings))
3872 else if (fieldType = TypeInfo(TDate)) and (VarType(value) = varUString) then
3873 defaultField := TDefaultProperty<TDate>.Create(propInfo, StrToDate(value, FormatSettings))
3874 else if (fieldType = TypeInfo(TTime)) and (VarType(value) = varUString) then
3875 defaultField := TDefaultProperty<TTime>.Create(propInfo, StrToTime(value, FormatSettings))
3876 else
3877 case fieldType.TypeData.FloatType of
3878 ftSingle: defaultField := TDefaultProperty<Single>.Create(propInfo, value);
3879 ftDouble: defaultField := TDefaultProperty<Double>.Create(propInfo, value);
3880 ftExtended: defaultField := TDefaultProperty<Extended>.Create(propInfo, value);
3881 ftComp: defaultField := TDefaultProperty<Comp>.Create(propInfo, value);
3882 ftCurr: defaultField := TDefaultProperty<Currency>.Create(propInfo, value);
3883 end;
3884 tkWChar:
3885 defaultField := TDefaultProperty<Char>.Create(propInfo, value);
3886 {$IFNDEF NEXTGEN}
3887 tkWString:
3888 defaultField := TDefaultProperty<WideString>.Create(propInfo, value);
3889 {$ENDIF}
3890 tkVariant:
3891 defaultField := TDefaultProperty<Variant>.Create(propInfo, value);
3892 tkInt64:
3893 if fieldType.TypeData.MinInt64Value > fieldType.TypeData.MaxInt64Value then
3894 defaultField := TDefaultProperty<UInt64>.Create(propInfo, value)
3895 else
3896 defaultField := TDefaultProperty<Int64>.Create(propInfo, value);
3897 tkUString:
3898 defaultField := TDefaultProperty<UnicodeString>.Create(propInfo, value);
3899 tkClassRef, tkPointer:
3900 defaultField := TDefaultProperty<Pointer>.Create(propInfo, value);
3901 end;
3902 if defaultField <> nil then
3903 begin
3904 DefaultFieldCount := Length(DefaultFields) + 1;
3905 SetLength(DefaultFields, DefaultFieldCount);
3906 DefaultFields[DefaultFieldCount - 1] := defaultField;
3907 end;
3908end;
3909
3910procedure TInitTable.AddManagedField(const field: TRttiField;
3911 const attribute: ManagedAttribute);
3912
3913 function GetInterfaceEntry(cls: TClass; intf: PTypeInfo): PInterfaceEntry;
3914 var
3915 intfGuid: TGUID;
3916 interfaceTable: PInterfaceTable;
3917 {$IFNDEF DELPHI2010}
3918 p: PPPTypeInfo;
3919 {$ENDIF}
3920 i: Integer;
3921 begin
3922 {$IFDEF DELPHI2010}
3923 // Delphi 2010 does not have the PPTypeInfo array
3924 // after the TInterfaceEntry array in TInterfaceTable
3925 // so only interfaces with a GUID can be used
3926 if not (ifHasGuid in intf.TypeData.IntfFlags) then
3927 Exit(nil);
3928 {$ENDIF}
3929 intfGuid := intf.TypeData.Guid;
3930 repeat
3931 interfaceTable := cls.GetInterfaceTable;
3932 if interfaceTable <> nil then
3933 begin
3934 {$IFNDEF DELPHI2010}
3935 p := @interfaceTable.Entries[interfaceTable.EntryCount];
3936 {$ENDIF}
3937 for i := 0 to interfaceTable.EntryCount - 1 do
3938 begin
3939 Result := @interfaceTable.Entries[i];
3940 {$IFNDEF DELPHI2010}
3941 if p^^ = intf then
3942 Exit;
3943 Inc(p);
3944 {$ENDIF}
3945 if Result.IID = intf.TypeData.Guid then
3946 Exit;
3947 end;
3948 end;
3949 cls := cls.ClassParent;
3950 until cls = nil;
3951 Result := nil;
3952 end;
3953
3954var
3955 fieldType: PTypeInfo;
3956 offset: Integer;
3957 createInstance: Boolean;
3958 cls: TClass;
3959 factory: TFunc<PTypeInfo,Pointer>;
3960 managedField: TFinalizableField;
3961 entry: PInterfaceEntry;
3962begin
3963 fieldType := field.FieldType.Handle;
3964 offset := field.Offset;
3965 createInstance := attribute.CreateInstance;
3966 cls := attribute.InstanceClass;
3967 factory := attribute.Factory;
3968 managedField := nil;
3969 case fieldType.Kind of
3970 tkClass:
3971 begin
3972 if not Assigned(factory) and not Assigned(cls) and createInstance then
3973 cls := fieldType.TypeData.ClassType;
3974 managedField := TManagedObjectField.Create(offset, fieldType, cls, factory);
3975 end;
3976 tkInterface:
3977 begin
3978 if Assigned(cls) then
3979 begin
3980 entry := GetInterfaceEntry(cls, fieldType);
3981 if entry = nil then
3982 raise EInvalidOperationException.CreateFmt(
3983 'class %s is not compatible with interface %s (field %s)', [
3984 cls.ClassName, fieldType.TypeName, field.Name]);
3985 end
3986 else
3987 entry := nil;
3988 managedField := TManagedInterfaceField.Create(offset, fieldType, cls, factory, entry);
3989 end;
3990 end;
3991 if managedField <> nil then
3992 begin
3993 ManagedFieldCount := Length(ManagedFields) + 1;
3994 SetLength(ManagedFields, ManagedFieldCount);
3995 ManagedFields[ManagedFieldCount - 1] := managedField;
3996 end;
3997end;
3998
3999{$IFDEF USE_VMTAUTOTABLE}
4000function CreateFieldTable(classType: TClass): TInitTable;
4001var
4002 n: UINT_PTR;
4003begin
4004 Result := TInitTable.Create(classType);
4005 WriteProcessMemory(GetCurrentProcess,
4006 Pointer(NativeInt(classType) + vmtAutoTable), @Result, SizeOf(Pointer), n);
4007 TInitTable.InitTables.Add(Result);
4008end;
4009{$ENDIF}
4010
4011function GetInitTable(classType: TClass): TInitTable;
4012{$IFDEF USE_VMTAUTOTABLE}
4013begin
4014 Result := PPointer(NativeInt(classType) + vmtAutoTable)^;
4015 if Result = nil then
4016 Result := CreateFieldTable(classType);
4017{$ELSE}
4018begin
4019 TMonitor.Enter(TInitTable.InitTables);
4020 try
4021 if not TInitTable.InitTables.TryGetValue(classType, Result) then
4022 begin
4023 Result := TInitTable.Create(classType);
4024 TInitTable.InitTables.Add(classType, Result);
4025 end;
4026 finally
4027 TMonitor.Exit(TInitTable.InitTables);
4028 end;
4029{$ENDIF}
4030end;
4031
4032{$IFDEF RANGECHECKS_ON}{$RANGECHECKS OFF}{$ENDIF}
4033procedure TInitTable.InitInstance(instance: Pointer);
4034var
4035 f: ^TInitializableField;
4036 i: Integer;
4037begin
4038 f := @DefaultFields[0];
4039 for i := 0 to DefaultFieldCount - 1 do //FI:W528
4040 begin
4041 f.InitializeValue(instance);
4042 Inc(f);
4043 end;
4044 f := @ManagedFields[0];
4045 for i := 0 to ManagedFieldCount - 1 do //FI:W528
4046 begin
4047 f.InitializeValue(instance);
4048 Inc(f);
4049 end;
4050end;
4051
4052{$IFNDEF AUTOREFCOUNT}
4053procedure TInitTable.CleanupInstance(instance: Pointer);
4054var
4055 f: ^TFinalizableField;
4056 i: Integer;
4057begin
4058 f := @ManagedFields[0];
4059 for i := 0 to ManagedFieldCount - 1 do //FI:W528
4060 begin
4061 f.FinalizeValue(instance);
4062 Inc(f);
4063 end;
4064end;
4065{$ENDIF}
4066{$IFDEF RANGECHECKS_ON}{$RANGECHECKS ON}{$ENDIF}
4067
4068{$ENDREGION}
4069
4070
4071{$REGION 'TInitTable.TDefaultField<T>'}
4072
4073constructor TInitTable.TDefaultField<T>.Create(offset: Integer; const value: Variant);
4074begin
4075 inherited Create;
4076 fOffset := offset;
4077 fValue := TValue.FromVariant(value).AsType<T>; // TODO
4078end;
4079
4080procedure TInitTable.TDefaultField<T>.InitializeValue(instance: Pointer);
4081begin
4082 PT(PByte(instance) + fOffset)^ := fValue;
4083end;
4084
4085{$ENDREGION}
4086
4087
4088{$REGION 'TInitTable.TDefaultProperty<T>'}
4089
4090constructor TInitTable.TDefaultProperty<T>.Create(propInfo: PPropInfo; const value: Variant);
4091begin
4092 inherited Create;
4093 fPropInfo := propInfo;
4094 fValue := TValue.FromVariant(value).AsType<T>; // TODO
4095end;
4096
4097class function TInitTable.GetCodePointer(instance: TObject; p: Pointer): Pointer;
4098begin
4099 if IntPtr(p) and PROPSLOT_MASK = PROPSLOT_VIRTUAL then
4100 Result := PPointer(PNativeInt(instance)^ + SmallInt(IntPtr(p)))^
4101 else
4102 Result := p;
4103end;
4104
4105procedure TInitTable.TDefaultProperty<T>.InitializeValue(instance: Pointer);
4106var
4107 method: TMethod;
4108begin
4109 method.Code := GetCodePointer(instance, fPropInfo.SetProc);
4110 method.Data := instance;
4111 if fPropInfo.Index = Low(fPropInfo.Index) then
4112 TSetter(method)(fValue)
4113 else
4114 TIndexedSetter(method)(fPropInfo.Index, fValue);
4115end;
4116
4117{$ENDREGION}
4118
4119
4120{$REGION 'TInitTable.TManagedObjectField'}
4121
4122constructor TInitTable.TManagedObjectField.Create(offset: Integer;
4123 fieldType: PTypeInfo; cls: TClass; const factory: TFunc<PTypeInfo,Pointer>);
4124begin
4125 inherited Create;
4126 fOffset := offset;
4127 fFieldType := fieldType;
4128 fCls := cls;
4129 fFactory := factory;
4130 if Assigned(cls) and not Assigned(factory) then
4131 fCtor := TActivator.FindConstructor(cls);
4132end;
4133
4134procedure TInitTable.TManagedObjectField.FinalizeValue(instance: Pointer);
4135begin
4136 FreeAndNil(Pointer(PByte(instance) + fOffset)^);
4137end;
4138
4139procedure TInitTable.TManagedObjectField.InitializeValue(instance: Pointer);
4140begin
4141 if Assigned(fCtor) then
4142 TObject(Pointer(PByte(instance) + fOffset)^) := TObject(fCtor(fCls))
4143 else if Assigned(fFactory) then
4144 TObject(Pointer(PByte(instance) + fOffset)^) := fFactory(fFieldType);
4145end;
4146
4147{$ENDREGION}
4148
4149
4150{$REGION 'TInitTable.TManagedInterfaceField'}
4151
4152function InvokeImplGetter(const Self: TObject; implGetter: NativeUInt): IInterface;
4153var
4154 method: function: IInterface of object;
4155begin
4156 TMethod(method).Data := Self;
4157 {$IF SizeOf(NativeUInt) = 4}
4158 case implGetter of
4159 $FF000000..$FFFFFFFF:
4160 Result := IInterface(PPointer(PByte(Self) + (implGetter and $00FFFFFF))^);
4161 $FE000000..$FEFFFFFF:
4162 begin
4163 TMethod(method).Code := PPointer(PNativeInt(Self)^ + SmallInt(implGetter))^;
4164 Result := method;
4165 end;
4166 else
4167 TMethod(method).Code := Pointer(implGetter);
4168 Result := method;
4169 end;
4170 {$ELSE}
4171 if (implGetter and $FF00000000000000) = $FF00000000000000 then
4172 Result := IInterface(PPointer(PByte(Self) + (implGetter and $00FFFFFFFFFFFFFF))^)
4173 else if (implGetter and $FF00000000000000) = $FE00000000000000 then
4174 begin
4175 TMethod(method).Code := PPointer(PNativeInt(Self)^ + SmallInt(implGetter))^;
4176 Result := method;
4177 end
4178 else
4179 begin
4180 TMethod(method).Code := Pointer(implGetter);
4181 Result := method;
4182 end;
4183 {$IFEND}
4184end;
4185
4186constructor TInitTable.TManagedInterfaceField.Create(offset: Integer;
4187 fieldType: PTypeInfo; cls: TClass; const factory: TFunc<PTypeInfo,Pointer>;
4188 entry: PInterfaceEntry);
4189begin
4190 inherited Create(offset, fieldType, cls, factory);
4191 fEntry := entry;
4192end;
4193
4194function TInitTable.TManagedInterfaceField.CreateInstance: Pointer;
4195var
4196 obj: Pointer;
4197begin
4198 obj := fCtor(fCls);
4199 if fEntry.IOffset <> 0 then
4200 begin
4201 Result := Pointer(PByte(obj) + fEntry.IOffset);
4202 if Result <> nil then
4203 IInterface(Result)._AddRef;
4204 end
4205 else
4206 begin
4207 Result := nil;
4208 IInterface(Result) := InvokeImplGetter(obj, fEntry.ImplGetter);
4209 end;
4210end;
4211
4212procedure TInitTable.TManagedInterfaceField.FinalizeValue(instance: Pointer);
4213begin
4214end;
4215
4216procedure TInitTable.TManagedInterfaceField.InitializeValue(instance: Pointer);
4217var
4218 intf: Pointer;
4219begin
4220 if Assigned(fCtor) then
4221 intf := CreateInstance
4222 else if Assigned(fFactory) then
4223 intf := fFactory(fFieldType)
4224 else
4225 Exit;
4226
4227 PPointer(PByte(instance) + fOffset)^ := intf;
4228end;
4229
4230{$ENDREGION}
4231
4232
4233{$REGION 'TManagedObject'}
4234
4235{$IFNDEF AUTOREFCOUNT}
4236procedure TManagedObject.FreeInstance;
4237begin
4238 GetInitTable(ClassType).CleanupInstance(Self);
4239 inherited FreeInstance;
4240end;
4241{$ENDIF}
4242
4243class function TManagedObject.NewInstance: TObject;
4244begin
4245 Result := inherited NewInstance;
4246 GetInitTable(Self).InitInstance(Result);
4247end;
4248
4249{$ENDREGION}
4250
4251
4252{$REGION 'TManagedInterfacedObject'}
4253
4254{$IFNDEF AUTOREFCOUNT}
4255procedure TManagedInterfacedObject.FreeInstance;
4256begin
4257 GetInitTable(ClassType).CleanupInstance(Self);
4258 inherited FreeInstance;
4259end;
4260{$ENDIF}
4261
4262class function TManagedInterfacedObject.NewInstance: TObject;
4263begin
4264 Result := inherited NewInstance;
4265 GetInitTable(Self).InitInstance(Result);
4266end;
4267
4268{$ENDREGION}
4269
4270
4271{$REGION 'TValueHelper'}
4272
4273var
4274 Nop_Instance: Pointer;
4275
4276procedure TValueHelper.Init(typeInfo: Pointer);
4277begin
4278 with TValueData(Self) do
4279 begin
4280 FTypeInfo := typeInfo;
4281{$IF SizeOf(Extended) > SizeOf(TMethod)}
4282 FAsExtended := 0;
4283{$ELSE SizeOf(Extended) <= SizeOf(TMethod)}
4284 FAsMethod.Code := nil;
4285 FAsMethod.Data := nil;
4286{$IFEND}
4287{$IFDEF DELPHI2010}
4288 FHeapData := nil;
4289 Pointer(FHeapData) := Nop_Instance;
4290{$ELSE}
4291 FValueData := nil;
4292 Pointer(FValueData) := Nop_Instance;
4293{$ENDIF}
4294 end;
4295end;
4296
4297function TValueHelper.AsPointer: Pointer;
4298begin
4299 case Kind of
4300 tkPointer:
4301{$IFDEF DELPHI2010}
4302 Result := Pointer(TValueData(Self).FAsSLong);
4303{$ELSE}
4304 Result := TValueData(Self).FAsPointer;
4305{$ENDIF}
4306 tkClass:
4307 Result := AsObject;
4308 tkInterface:
4309 Result := Pointer(AsInterface);
4310 else
4311 Guard.RaiseInvalidTypeCast(TypeInfo, System.TypeInfo(Pointer));
4312 Result := nil;
4313 end;
4314end;
4315
4316{$IFDEF DELPHI2010}
4317function TValueHelper.AsString: string;
4318begin
4319 Result := AsType<string>;
4320end;
4321{$ENDIF}
4322
4323function TValueHelper.AsType<T>: T;
4324begin
4325{$IFDEF DELPHI2010}
4326 if IsEmpty then
4327 Exit(Default(T));
4328{$ENDIF}
4329 if not TryAsInterface(System.TypeInfo(T), Result) then
4330 if not TryAsType<T>(Result) then
4331 Guard.RaiseInvalidTypeCast(TypeInfo, System.TypeInfo(T));
4332end;
4333
4334function TValueHelper.Cast(typeInfo: PTypeInfo): TValue;
4335var
4336 intf: IInterface;
4337begin
4338 if TryAsInterface(typeInfo, intf) then
4339 TValue.Make(@intf, typeInfo, Result)
4340 else if not TryCast(typeInfo, Result) then
4341 Guard.RaiseInvalidTypeCast(Self.TypeInfo, typeInfo);
4342end;
4343
4344function TValueHelper.CompareTo(const value: TValue): Integer;
4345begin
4346 Result := CompareValue(Self, value);
4347end;
4348
4349function TValueHelper.Convert(targetType: PTypeInfo): TValue;
4350begin
4351 if not TryConvert(targetType, Result) then
4352 RaiseConversionError(TypeInfo, targetType);
4353end;
4354
4355function TValueHelper.Convert(targetType: PTypeInfo;
4356 const formatSettings: TFormatSettings): TValue;
4357begin
4358 if not TryConvert(targetType, Result, formatSettings) then
4359 RaiseConversionError(TypeInfo, targetType);
4360end;
4361
4362function TValueHelper.Convert<T>: TValue;
4363begin
4364 if not TryConvert(System.TypeInfo(T), Result) then
4365 RaiseConversionError(TypeInfo, System.TypeInfo(T));
4366end;
4367
4368function TValueHelper.Convert<T>(const formatSettings: TFormatSettings): TValue;
4369begin
4370 if not TryConvert(System.TypeInfo(T), Result, formatSettings) then
4371 RaiseConversionError(TypeInfo, System.TypeInfo(T));
4372end;
4373
4374
4375{$REGION 'Equals functions'}
4376
4377function EqualsFail(const left, right: TValue): Boolean; //FI:O804
4378begin
4379 Result := False;
4380end;
4381
4382function EqualsInt2Int(const left, right: TValue): Boolean;
4383var
4384 leftValue, rightValue: Int64;
4385begin
4386 case left.TypeInfo.TypeData.OrdType of
4387 otSByte: leftValue := TValueData(left).FAsSByte;
4388 otSWord: leftValue := TValueData(left).FAsSWord;
4389 otSLong: leftValue := TValueData(left).FAsSLong;
4390 else
4391 leftValue := TValueData(left).FAsULong;
4392 end;
4393
4394 case right.TypeInfo.TypeData.OrdType of
4395 otSByte: rightValue := TValueData(right).FAsSByte;
4396 otSWord: rightValue := TValueData(right).FAsSWord;
4397 otSLong: rightValue := TValueData(right).FAsSLong;
4398 else
4399 rightValue := TValueData(right).FAsULong;
4400 end;
4401
4402 Result := leftValue = rightValue;
4403end;
4404
4405function EqualsInt2Float(const left, right: TValue): Boolean;
4406begin
4407 if right.IsType<Single> then
4408 Result := Math.SameValue(left.AsInteger, right.AsType<Single>)
4409 else if right.IsType<Double> then
4410 Result := Math.SameValue(left.AsInteger, right.AsType<Double>)
4411 else
4412 Result := Math.SameValue(left.AsInteger, right.AsExtended);
4413end;
4414
4415function EqualsInt2Int64(const left, right: TValue): Boolean;
4416begin
4417 Result := left.AsInteger = right.AsInt64;
4418end;
4419
4420function EqualsFloat2Int(const left, right: TValue): Boolean;
4421begin
4422 case left.TypeData.FloatType of
4423 ftSingle: Result := Math.SameValue(left.AsType<Single>, right.AsInteger);
4424 ftDouble: Result := Math.SameValue(left.AsType<Double>, right.AsInteger);
4425 else
4426 Result := Math.SameValue(left.AsExtended, right.AsInteger);
4427 end;
4428end;
4429
4430function EqualsFloat2Float(const left, right: TValue): Boolean;
4431begin
4432 case left.TypeData.FloatType of
4433 ftSingle:
4434 case right.TypeData.FloatType of
4435 ftSingle: Result := Math.SameValue(left.AsType<Single>, right.AsType<Single>);
4436 ftDouble: Result := Math.SameValue(left.AsType<Single>, right.AsType<Double>);
4437 else
4438 Result := Math.SameValue(left.AsType<Single>, right.AsExtended);
4439 end;
4440 ftDouble:
4441 case right.TypeData.FloatType of
4442 ftSingle: Result := Math.SameValue(left.AsType<Double>, right.AsType<Single>);
4443 ftDouble: Result := Math.SameValue(left.AsType<Double>, right.AsType<Double>);
4444 else
4445 Result := Math.SameValue(left.AsType<Double>, right.AsExtended);
4446 end;
4447 else
4448 case right.TypeData.FloatType of
4449 ftSingle: Result := Math.SameValue(left.AsExtended, right.AsType<Single>);
4450 ftDouble: Result := Math.SameValue(left.AsExtended, right.AsType<Double>);
4451 else
4452 Result := Math.SameValue(left.AsExtended, right.AsExtended);
4453 end;
4454 end;
4455end;
4456
4457function EqualsFloat2Int64(const left, right: TValue): Boolean;
4458begin
4459 case left.TypeData.FloatType of
4460 ftSingle: Result := Math.SameValue(left.AsType<Single>, right.AsInt64);
4461 ftDouble: Result := Math.SameValue(left.AsType<Double>, right.AsInt64);
4462 else
4463 Result := Math.SameValue(left.AsExtended, right.AsInt64);
4464 end;
4465end;
4466
4467function EqualsInt642Int(const left, right: TValue): Boolean;
4468begin
4469 Result := left.AsInt64 = right.AsInteger;
4470end;
4471
4472function EqualsInt64ToFloat(const left, right: TValue): Boolean;
4473begin
4474 if right.IsType<Single> then
4475 Result := Math.SameValue(left.AsInt64, right.AsType<Single>)
4476 else if right.IsType<Double> then
4477 Result := Math.SameValue(left.AsInt64, right.AsType<Double>)
4478 else
4479 Result := Math.SameValue(left.AsInt64, right.AsExtended);
4480end;
4481
4482function EqualsInt642Int64(const left, right: TValue): Boolean;
4483begin
4484 Result := left.AsInt64 = right.AsInt64;
4485end;
4486
4487function EqualsStr2Str(const left, right: TValue): Boolean;
4488begin
4489 Result := left.AsString = right.AsString;
4490end;
4491
4492function EqualsStr2Var(const left, right: TValue): Boolean;
4493begin
4494 Result := SameValue(left.AsString, right.AsVariant);
4495end;
4496
4497function EqualsClass2Class(const left, right: TValue): Boolean;
4498begin
4499 Result := left.AsObject = right.AsObject;
4500end;
4501
4502function EqualsPointer2Pointer(const left, right: TValue): Boolean;
4503begin
4504 Result := left.AsPointer = right.AsPointer;
4505end;
4506
4507function EqualsIntf2Intf(const left, right: TValue): Boolean;
4508begin
4509 Result := left.AsInterface = right.AsInterface;
4510end;
4511
4512function EqualsClassRef2ClassRef(const left, right: TValue): Boolean;
4513begin
4514 Result := left.AsClass = right.AsClass;
4515end;
4516
4517function EqualsVar2Var(const left, right: TValue): Boolean;
4518begin
4519 Result := SameValue(left.AsVariant, right.AsVariant);
4520end;
4521
4522function EqualsVar2Str(const left, right: TValue): Boolean;
4523begin
4524 Result := SameValue(left.AsVariant, right.AsString);
4525end;
4526
4527function EqualsRec2Rec(const left, right: TValue): Boolean;
4528
4529 function RawEquals(const recordType: TRttiType): Boolean;
4530 var
4531 leftRec, rightRec: Pointer;
4532 field: TRttiField;
4533 leftValue, rightValue: TValue;
4534 begin
4535 if left.TypeInfo = right.TypeInfo then
4536 begin
4537 if IsManaged(left.TypeInfo) then
4538 begin
4539 leftRec := left.GetReferenceToRawData;
4540 rightRec := right.GetReferenceToRawData;
4541 for field in recordType.GetFields do
4542 begin
4543 leftValue := field.GetValue(leftRec);
4544 rightValue := field.GetValue(rightRec);
4545 if not leftValue.Equals(rightValue) then
4546 Exit(False);
4547 end;
4548 Result := True;
4549 end
4550 else
4551 Result := CompareMem(left.GetReferenceToRawData, right.GetReferenceToRawData, left.DataSize)
4552 end
4553 else
4554 Result := False;
4555 end;
4556
4557var
4558 recordType: TRttiType;
4559 method: TRttiMethod;
4560 parameters: TArray<TRttiParameter>;
4561begin
4562 if (left.TypeInfo = TypeInfo(TValue)) and (right.TypeInfo = TypeInfo(TValue)) then
4563 Exit(PValue(left.GetReferenceToRawData).Equals(
4564 PValue(right.GetReferenceToRawData)^));
4565
4566 recordType := left.TypeInfo.RttiType;
4567 for method in recordType.GetMethods('&op_Equality') do
4568 begin
4569 parameters := method.GetParameters;
4570 if (Length(parameters) = 2)
4571 and (parameters[0].ParamType.Handle = left.TypeInfo)
4572 and (parameters[1].ParamType.Handle = right.TypeInfo) then
4573 Exit(method.Invoke(nil, [left, right]).AsBoolean);
4574 end;
4575
4576 Result := RawEquals(recordType);
4577end;
4578
4579function EqualsDynArray2DynArray(const left, right: TValue): Boolean;
4580var
4581 len, i: Integer;
4582begin
4583 if PPointer(left.GetReferenceToRawData)^ = PPointer(right.GetReferenceToRawData)^ then
4584 Exit(True);
4585 len := left.GetArrayLength;
4586 if len <> right.GetArrayLength then
4587 Exit(False);
4588 for i := 0 to len - 1 do
4589 if not left.GetArrayElement(i).Equals(right.GetArrayElement(i)) then
4590 Exit(False);
4591 Result := True;
4592end;
4593
4594function EqualsSet2Set(const left, right: TValue): Boolean;
4595var
4596 size: Integer;
4597begin
4598 size := left.DataSize;
4599 if size <> right.DataSize then
4600 Exit(False);
4601
4602 case size of
4603 1: Result := TValueData(left).FAsUByte = TValueData(right).FAsUByte;
4604 2: Result := TValueData(left).FAsUWord = TValueData(right).FAsUWord;
4605 3..4: Result := TValueData(left).FAsULong = TValueData(right).FAsULong;
4606 5..8: Result := TValueData(left).FAsUInt64 = TValueData(right).FAsUInt64;
4607 else
4608 Result := CompareMem(left.GetReferenceToRawData, right.GetReferenceToRawData, size);
4609 end;
4610end;
4611
4612type
4613 TEqualsFunc = function(const left, right: TValue): Boolean;
4614const
4615 EqualsFunctions: array[TTypeKind,TTypeKind] of TEqualsFunc = (
4616 // tkUnknown
4617 (
4618 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4619 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4620 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4621 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4622 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4623 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4624 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4625 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4626 // tkPointer, tkProcedure
4627 EqualsFail, EqualsFail
4628 ),
4629 // tkInteger
4630 (
4631 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4632 EqualsFail, EqualsInt2Int, EqualsFail, EqualsFail, EqualsInt2Float,
4633 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4634 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4635 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4636 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4637 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4638 EqualsFail, EqualsInt2Int64, EqualsFail, EqualsFail, EqualsFail,
4639 // tkPointer, tkProcedure
4640 EqualsFail, EqualsFail
4641 ),
4642 // tkChar
4643 (
4644 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4645 EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail, EqualsFail,
4646 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4647 EqualsStr2Str, EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str,
4648 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4649 EqualsStr2Str, EqualsStr2Str, EqualsStr2Var, EqualsFail, EqualsFail,
4650 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4651 EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail,
4652 // tkPointer, tkProcedure
4653 EqualsFail, EqualsFail
4654 ),
4655 // tkEnumeration
4656 (
4657 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4658 EqualsFail, EqualsFail, EqualsFail, EqualsInt2Int, EqualsFail,
4659 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4660 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4661 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4662 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4663 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4664 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4665 // tkPointer, tkProcedure
4666 EqualsFail, EqualsFail
4667 ),
4668 // tkFloat
4669 (
4670 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4671 EqualsFail, EqualsFloat2Int, EqualsFail, EqualsFail, EqualsFloat2Float,
4672 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4673 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4674 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4675 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4676 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4677 EqualsFail, EqualsFloat2Int64, EqualsFail, EqualsFail, EqualsFail,
4678 // tkPointer, tkProcedure
4679 EqualsFail, EqualsFail
4680 ),
4681 // tkString
4682 (
4683 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4684 EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail, EqualsFail,
4685 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4686 EqualsStr2Str, EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str,
4687 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4688 EqualsStr2Str, EqualsStr2Str, EqualsStr2Var, EqualsFail, EqualsFail,
4689 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4690 EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail,
4691 // tkPointer, tkProcedure
4692 EqualsFail, EqualsFail
4693 ),
4694 // tkSet
4695 (
4696 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4697 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4698 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4699 EqualsFail, EqualsSet2Set, EqualsFail, EqualsFail, EqualsFail,
4700 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4701 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4702 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4703 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4704 // tkPointer, tkProcedure
4705 EqualsFail, EqualsFail
4706 ),
4707 // tkClass
4708 (
4709 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4710 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4711 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4712 EqualsFail, EqualsFail, EqualsClass2Class, EqualsFail, EqualsFail,
4713 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4714 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4715 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4716 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4717 // tkPointer, tkProcedure
4718 EqualsFail, EqualsFail
4719 ),
4720 // tkMethod
4721 (
4722 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4723 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4724 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4725 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail, // TODO: tkMethod
4726 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4727 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4728 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4729 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4730 // tkPointer, tkProcedure
4731 EqualsFail, EqualsFail
4732 ),
4733 // tkWChar
4734 (
4735 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4736 EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail, EqualsFail,
4737 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4738 EqualsStr2Str, EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str,
4739 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4740 EqualsStr2Str, EqualsStr2Str, EqualsStr2Var, EqualsFail, EqualsFail,
4741 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4742 EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail,
4743 // tkPointer, tkProcedure
4744 EqualsFail, EqualsFail
4745 ),
4746 // tkLString
4747 (
4748 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4749 EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail, EqualsFail,
4750 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4751 EqualsStr2Str, EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str,
4752 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4753 EqualsStr2Str, EqualsStr2Str, EqualsStr2Var, EqualsFail, EqualsFail,
4754 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4755 EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail,
4756 // tkPointer, tkProcedure
4757 EqualsFail, EqualsFail
4758 ),
4759 // tkWString
4760 (
4761 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4762 EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail, EqualsFail,
4763 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4764 EqualsStr2Str, EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str,
4765 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4766 EqualsStr2Str, EqualsStr2Str, EqualsFail, EqualsFail, EqualsFail,
4767 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4768 EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail,
4769 // tkPointer, tkProcedure
4770 EqualsFail, EqualsFail
4771 ),
4772 // tkVariant
4773 (
4774 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4775 EqualsFail, EqualsFail, EqualsVar2Str, EqualsFail, EqualsFail,
4776 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4777 EqualsVar2Str, EqualsFail, EqualsFail, EqualsFail, EqualsVar2Str,
4778 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4779 EqualsVar2Str, EqualsVar2Str, EqualsVar2Var, EqualsFail, EqualsFail,
4780 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4781 EqualsFail, EqualsFail, EqualsFail, EqualsVar2Str, EqualsFail,
4782 // tkPointer, tkProcedure
4783 EqualsFail, EqualsFail
4784 ),
4785 // tkArray
4786 (
4787 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4788 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4789 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4790 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4791 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4792 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4793 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4794 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4795 // tkPointer, tkProcedure
4796 EqualsFail, EqualsFail
4797 ),
4798 // tkRecord
4799 (
4800 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4801 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4802 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4803 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4804 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4805 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsRec2Rec,
4806 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4807 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4808 // tkPointer, tkProcedure
4809 EqualsFail, EqualsFail
4810 ),
4811 // tkInterface
4812 (
4813 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4814 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4815 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4816 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4817 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4818 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4819 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4820 EqualsIntf2Intf, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4821 // tkPointer, tkProcedure
4822 EqualsFail, EqualsFail
4823 ),
4824 // tkInt64
4825 (
4826 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4827 EqualsFail, EqualsInt642Int, EqualsFail, EqualsFail, EqualsInt64ToFloat,
4828 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4829 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4830 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4831 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4832 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4833 EqualsFail, EqualsInt642Int64, EqualsFail, EqualsFail, EqualsFail,
4834 // tkPointer, tkProcedure
4835 EqualsFail, EqualsFail
4836 ),
4837 // tkDynArray
4838 (
4839 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4840 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4841 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4842 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4843 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4844 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4845 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4846 EqualsFail, EqualsFail, EqualsDynArray2DynArray, EqualsFail, EqualsFail,
4847 // tkPointer, tkProcedure
4848 EqualsFail, EqualsFail
4849 ),
4850 // tkUString
4851 (
4852 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4853 EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail, EqualsFail,
4854 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4855 EqualsStr2Str, EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str,
4856 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4857 EqualsStr2Str, EqualsStr2Str, EqualsStr2Var, EqualsFail, EqualsFail,
4858 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4859 EqualsFail, EqualsFail, EqualsFail, EqualsStr2Str, EqualsFail,
4860 // tkPointer, tkProcedure
4861 EqualsFail, EqualsFail
4862 ),
4863 // tkClassRef
4864 (
4865 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4866 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4867 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4868 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4869 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4870 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4871 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4872 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsClassRef2ClassRef,
4873 // tkPointer, tkProcedure
4874 EqualsFail, EqualsFail
4875 ),
4876 // tkPointer
4877 (
4878 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4879 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4880 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4881 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4882 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4883 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4884 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4885 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4886 // tkPointer, tkProcedure
4887 EqualsPointer2Pointer, EqualsFail
4888 ),
4889 // tkProcedure
4890 (
4891 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
4892 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4893 // tkString, tkSet, tkClass, tkMethod, tkWChar,
4894 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4895 // tkLString, tkWString, tkVariant, tkArray, tkRecord,
4896 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4897 // tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef
4898 EqualsFail, EqualsFail, EqualsFail, EqualsFail, EqualsFail,
4899 // tkPointer, tkProcedure
4900 EqualsFail, EqualsFail
4901 )
4902 );
4903{$ENDREGION}
4904
4905
4906function TValueHelper.Equals(const value: TValue): Boolean;
4907begin
4908 if Assigned(TypeInfo) then
4909 Result := EqualsFunctions[Kind, value.Kind](Self, value)
4910 else
4911 Result := value.IsEmpty;
4912end;
4913
4914procedure TValueHelper.Free;
4915begin
4916 if IsObject then
4917{$IFNDEF AUTOREFCOUNT}
4918 AsObject.Free;
4919{$ELSE}
4920 AsObject.DisposeOf;
4921{$ENDIF}
4922end;
4923
4924class function TValueHelper.From(buffer: Pointer; typeInfo: PTypeInfo): TValue;
4925begin
4926 TValue.Make(buffer, typeInfo, Result);
4927end;
4928
4929class function TValueHelper.From(instance: TObject; classType: TClass): TValue;
4930begin
4931 TValue.Make(NativeInt(instance), classType.ClassInfo, Result);
4932end;
4933
4934class function TValueHelper.FromFloat(typeInfo: PTypeInfo;
4935 value: Extended): TValue;
4936begin
4937 case typeInfo.TypeData.FloatType of
4938 ftSingle: Result := TValue.From<Single>(value);
4939 ftDouble: Result := TValue.From<Double>(value);
4940 ftExtended: Result := TValue.From<Extended>(value);
4941 ftComp: Result := TValue.From<Comp>(value);
4942 ftCurr: Result := TValue.From<Currency>(value);
4943 end;
4944end;
4945
4946class function TValueHelper.FromVariant(const value: Variant): TValue;
4947
4948 procedure FromCustomVariant(const value: Variant; out result: TValue);
4949 type
4950 PCustomVariantTypeInfo = ^TCustomVariantTypeInfo;
4951 TCustomVariantTypeInfo = record
4952 Name: string;
4953 VType: TVarType;
4954 end;
4955 const
4956 CustomVariantTypes: array[0..2] of TCustomVariantTypeInfo = (
4957 (Name: 'SQLTimeStampVariantType'; VType: varDouble),
4958 (Name: 'SQLTimeStampOffsetVariantType'; VType: varDouble),
4959 (Name: 'FMTBcdVariantType'; VType: varInt64)
4960 );
4961 var
4962 typeName: string;
4963 i: Integer;
4964 tmp: Int64;
4965 info: PCustomVariantTypeInfo;
4966 begin
4967 typeName := VarTypeAsText(TVarData(value).VType);
4968 for i := 0 to High(CustomVariantTypes) do
4969 begin
4970 info := @CustomVariantTypes[i];
4971 if typeName = info.Name then
4972 begin
4973 case info.VType of
4974 varDouble: result := Double(value);
4975 varInt64:
4976 if TryStrToInt64(VarToStr(value), tmp) then
4977 Result := tmp
4978 else
4979 Result := Double(value);
4980 else
4981 raise EVariantTypeCastError.CreateRes(@SInvalidVarCast);
4982 end;
4983 Exit;
4984 end;
4985 end;
4986 raise EVariantTypeCastError.CreateRes(@SInvalidVarCast);
4987 end;
4988
4989var
4990 typeInfo: PTypeInfo;
4991 arr: Pointer;
4992begin
4993 case TVarData(value).VType of
4994 varEmpty, varNull: Exit(Empty);
4995 varBoolean: Result := TVarData(value).VBoolean;
4996 varShortInt: Result := TVarData(value).VShortInt;
4997 varSmallint: Result := TVarData(value).VSmallInt;
4998 varInteger: Result := TVarData(value).VInteger;
4999{$IFDEF DELPHIXE4_UP}
5000 varSingle: Result := TVarData(value).VSingle;
5001 varDouble: Result := TVarData(value).VDouble;
5002 varCurrency: Result := TVarData(value).VCurrency;
5003{$ELSE}
5004 varSingle: Result := TValue.From<Single>(TVarData(value).VSingle);
5005 varDouble: Result := TValue.From<Double>(TVarData(value).VDouble);
5006 varCurrency: Result := TValue.From<Currency>(TVarData(value).VCurrency);
5007{$ENDIF}
5008 varDate: Result := From<TDateTime>(TVarData(value).VDate);
5009 varOleStr: Result := string(TVarData(value).VOleStr);
5010 varDispatch: Result := From<IDispatch>(IDispatch(TVarData(value).VDispatch));
5011 varError: Result := From<HRESULT>(TVarData(value).VError);
5012 varUnknown: Result := From<IInterface>(IInterface(TVarData(value).VUnknown));
5013 varByte: Result := TVarData(value).VByte;
5014 varWord: Result := TVarData(value).VWord;
5015 varLongWord: Result := TVarData(value).VLongWord;
5016 varInt64: Result := TVarData(value).VInt64;
5017{$IFDEF DELPHIXE4_UP}
5018 varUInt64: Result := TVarData(value).VUInt64;
5019{$ELSE}
5020 varUInt64: Result := TValue.From<UInt64>(TVarData(value).VUInt64);
5021{$ENDIF}
5022{$IFNDEF NEXTGEN}
5023 varString: Result := string(AnsiString(TVarData(value).VString));
5024{$ENDIF}
5025 varUString: Result := UnicodeString(TVarData(value).VUString);
5026 else
5027 if TVarData(value).VType and varArray = varArray then
5028 begin
5029 case TVarData(value).VType and not varArray of
5030 varSmallint: typeInfo := System.TypeInfo(TArray<SmallInt>);
5031 varInteger: typeInfo := System.TypeInfo(TArray<Integer>);
5032 varSingle: typeInfo := System.TypeInfo(TArray<Single>);
5033 varDouble: typeInfo := System.TypeInfo(TArray<Double>);
5034 varCurrency: typeInfo := System.TypeInfo(TArray<Currency>);
5035 varDate: typeInfo := System.TypeInfo(TArray<TDateTime>);
5036 varOleStr: typeInfo := System.TypeInfo(TArray<string>);
5037 varDispatch: typeInfo := System.TypeInfo(TArray<IDispatch>);
5038 varError: typeInfo := System.TypeInfo(TArray<HRESULT>);
5039 varBoolean: typeInfo := System.TypeInfo(TArray<Boolean>);
5040 varVariant: typeInfo := System.TypeInfo(TArray<Variant>);
5041 varUnknown: typeInfo := System.TypeInfo(TArray<IInterface>);
5042 varShortInt: typeInfo := System.TypeInfo(TArray<ShortInt>);
5043 varByte: typeInfo := System.TypeInfo(TArray<Byte>);
5044 varWord: typeInfo := System.TypeInfo(TArray<Word>);
5045 varLongWord: typeInfo := System.TypeInfo(TArray<Cardinal>);
5046 varInt64: typeInfo := System.TypeInfo(TArray<Int64>);
5047 varUInt64: typeInfo := System.TypeInfo(TArray<UInt64>);
5048 varUString: typeInfo := System.TypeInfo(TArray<string>);
5049 else
5050 raise EVariantTypeCastError.CreateRes(@SInvalidVarCast);
5051 end;
5052 arr := nil;
5053 DynArrayFromVariant(arr, value, typeInfo);
5054 TValue.MakeWithoutCopy(@arr, typeInfo, Result);
5055 end
5056 else
5057 FromCustomVariant(value, Result);
5058 end;
5059end;
5060
5061class function TValueHelper.FromVarRec(const value: TVarRec): TValue;
5062begin
5063 case value.VType of
5064 vtInteger: Result := value.VInteger;
5065 vtBoolean: Result := value.VBoolean;
5066{$IF Declared(AnsiChar)}
5067 vtChar: Result := string(value.VChar);
5068{$IFEND}
5069 vtExtended: Result := value.VExtended^;
5070{$IF Declared(ShortString)}
5071 vtString: Result := string(value.VString^);
5072{$IFEND}
5073 vtPointer: Result := value.VPointer;
5074{$IF Declared(PAnsiChar)}
5075 vtPChar: Result := string(value.VPChar);
5076{$IFEND}
5077 vtObject: Result := TObject(value.VObject);
5078 vtClass: Result := value.VClass;
5079 vtWideChar: Result := value.VWideChar;
5080 vtPWideChar: Result := string(value.VPWideChar);
5081{$IF Declared(AnsiString)}
5082 vtAnsiString: Result := string(value.VAnsiString);
5083{$IFEND}
5084 vtCurrency: Result := value.VCurrency^;
5085 vtVariant: Result := TValue.FromVariant(value.VVariant^);
5086 vtInterface: Result := TValue.From<IInterface>(IInterface(value.VInterface));
5087{$IF Declared(WideString)}
5088 vtWideString: Result := string(value.VWideString);
5089{$IFEND}
5090 vtInt64: Result := value.VInt64^;
5091 vtUnicodeString: Result := string(value.VUnicodeString);
5092 end;
5093end;
5094
5095function TValueHelper.GetArray: TArray<TValue>;
5096var
5097 len: Integer;
5098 i: Integer;
5099begin
5100 len := GetArrayLength;
5101 SetLength(Result, len);
5102 for i := 0 to len - 1 do
5103 Result[i] := GetArrayElement(i);
5104end;
5105
5106function TValueHelper.GetNullableValue: TValue;
5107var
5108 nullable: TNullableHelper;
5109 instance: Pointer;
5110begin
5111 if not IsNullable(TypeInfo) then
5112 raise EInvalidOperationException.CreateRes(@SValueDoesNotContainNullable);
5113
5114 instance := GetReferenceToRawData;
5115 if instance = nil then
5116 Exit(TValue.Empty);
5117 nullable := TNullableHelper.Create(TypeInfo);
5118 if nullable.HasValue(instance) then
5119 Result := nullable.GetValue(instance)
5120 else
5121 Result := TValue.Empty;
5122end;
5123
5124{$IFNDEF DELPHIXE8_UP}
5125function TValueHelper.GetTypeKind: TTypeKind;
5126begin
5127{$IFDEF DELPHI2010}
5128 if (TValueData(Self).FTypeInfo = nil) or (TValueData(Self).FHeapData = nil) then
5129{$ELSE}
5130 if (TValueData(Self).FTypeInfo = nil) or (TValueData(Self).FValueData = nil) then
5131{$ENDIF}
5132 Result := tkUnknown
5133 else
5134 Result := TValueData(Self).FTypeInfo.Kind;
5135end;
5136{$ENDIF}
5137
5138function TValueHelper.GetValueType: TRttiType;
5139begin
5140 Result := TypeInfo.RttiType;
5141end;
5142
5143function TValueHelper.IsFloat: Boolean;
5144begin
5145 Result := Kind in [tkInteger, tkFloat, tkInt64];
5146end;
5147
5148function TValueHelper.IsInstance: Boolean;
5149begin
5150 Result := Kind in [tkClass, tkInterface];
5151end;
5152
5153function TValueHelper.IsInterface: Boolean;
5154begin
5155 Result := Kind = tkInterface;
5156end;
5157
5158function TValueHelper.IsNumeric: Boolean;
5159const
5160 NumericKinds = [tkInteger, tkChar, tkEnumeration, tkFloat, tkWChar, tkInt64];
5161begin
5162 Result := Kind in NumericKinds;
5163end;
5164
5165function TValueHelper.IsString: Boolean;
5166const
5167 StringKinds = [tkString, tkLString, tkWString, tkUString, tkChar, tkWChar];
5168begin
5169 Result := Kind in StringKinds;
5170end;
5171
5172{$IFDEF DELPHI2010}
5173function TValueHelper.IsType(ATypeInfo: PTypeInfo): Boolean;
5174var
5175 unused: TValue;
5176begin
5177 Result := IsEmpty or TryCast(ATypeInfo, unused);
5178end;
5179
5180function TValueHelper.IsType<T>: Boolean;
5181begin
5182 Result := IsType(System.TypeInfo(T));
5183end;
5184{$ENDIF}
5185
5186function TValueHelper.IsVariant: Boolean;
5187begin
5188 Result := TypeInfo = System.TypeInfo(Variant);
5189end;
5190
5191class function TValueHelper.&&op_Equality(const left, right: TValue): Boolean;
5192begin
5193 Result := left.Equals(right);
5194end;
5195
5196{$IFNDEF DELPHIXE4_UP}
5197class function TValueHelper.&&op_Implicit(value: Double): TValue;
5198begin
5199 Result.Init(System.TypeInfo(Double));
5200 TValueData(Result).FAsDouble := value;
5201end;
5202
5203class function TValueHelper.&&op_Implicit(value: Single): TValue;
5204begin
5205 Result.Init(System.TypeInfo(Single));
5206 TValueData(Result).FAsSingle := value;
5207end;
5208
5209class function TValueHelper.&&op_Implicit(value: UInt64): TValue;
5210begin
5211 Result.Init(System.TypeInfo(UInt64));
5212 TValueData(Result).FAsUInt64 := value;
5213end;
5214
5215class function TValueHelper.&&op_Implicit(value: Currency): TValue;
5216begin
5217 Result.Init(System.TypeInfo(Currency));
5218 TValueData(Result).FAsCurr := value;
5219end;
5220{$ENDIF}
5221
5222{$IFNDEF DELPHIXE8_UP}
5223class function TValueHelper.&&op_Implicit(const value: TVarRec): TValue;
5224begin
5225 Result := TValue.FromVarRec(value);
5226end;
5227{$ENDIF}
5228
5229class function TValueHelper.&&op_Implicit(value: TDate): TValue;
5230begin
5231 Result.Init(System.TypeInfo(TDate));
5232 TValueData(Result).FAsDouble := value;
5233end;
5234
5235class function TValueHelper.&&op_Implicit(value: TTime): TValue;
5236begin
5237 Result.Init(System.TypeInfo(TTime));
5238 TValueData(Result).FAsDouble := value;
5239end;
5240
5241class function TValueHelper.&&op_Implicit(value: TDateTime): TValue;
5242begin
5243 Result.Init(System.TypeInfo(TDateTime));
5244 TValueData(Result).FAsDouble := value;
5245end;
5246
5247class function TValueHelper.&&op_Inequality(const left, right: TValue): Boolean;
5248begin
5249 Result := not left.Equals(right);
5250end;
5251
5252class procedure TValueHelper.RaiseConversionError(source, target: PTypeInfo);
5253var
5254 sourceTypeName: string;
5255begin
5256 if Assigned(source) then
5257 sourceTypeName := source.TypeName
5258 else
5259 sourceTypeName := '<unknown>';
5260 raise EConvertError.CreateResFmt(@STypeConversionError, [
5261 sourceTypeName, target.TypeName]) at ReturnAddress;
5262end;
5263
5264procedure TValueHelper.SetNullableValue(const value: TValue);
5265var
5266 typeInfo: PTypeInfo;
5267 nullable: TNullableHelper;
5268 instance: Pointer;
5269begin
5270 typeInfo := TValueData(Self).FTypeInfo;
5271 if IsNullable(typeInfo) then
5272 begin
5273 instance := GetReferenceToRawData;
5274 nullable := TNullableHelper.Create(typeInfo);
5275 nullable.SetValue(instance, value);
5276 end;
5277end;
5278
5279function TValueHelper.ToObject: TObject;
5280begin
5281 if IsInterface then
5282 Result := AsInterface as TObject
5283 else
5284 Result := AsObject;
5285end;
5286
5287type
5288 TValueHack = type TValue; // make an alias to access "inherited" ToString
5289
5290function TValueHelper.ToString: string;
5291var
5292 value: TValue;
5293begin
5294 if IsNullable(TypeInfo) then
5295 if TryGetNullableValue(value) then
5296 Result := value.ToString
5297 else
5298 Result := '(null)'
5299 else
5300 Result := TValueHack(Self).ToString;
5301end;
5302
5303function TValueHelper.ToType<T>: T;
5304begin
5305 if not TryToType<T>(Result) then
5306 RaiseConversionError(TypeInfo, System.TypeInfo(T));
5307end;
5308
5309function TValueHelper.ToType<T>(const formatSettings: TFormatSettings): T;
5310begin
5311 if not TryToType<T>(Result, formatSettings) then
5312 RaiseConversionError(TypeInfo, System.TypeInfo(T));
5313end;
5314
5315function TValueHelper.ToVariant: Variant;
5316var
5317 value: TValue;
5318 obj: TObject;
5319 stream: TStream;
5320 persist: IStreamPersist;
5321
5322{$IFNDEF DELPHI2010}
5323 function TryConvertToVariant(out returnValue: Variant): Boolean;
5324 begin
5325 Result := TValueConverter.Default.TryConvertTo(Self, System.TypeInfo(Variant), value);
5326 if Result then
5327 returnValue := value.AsVariant
5328 else
5329 returnValue := Null;
5330 end;
5331{$ENDIF}
5332
5333begin
5334 Result := Null;
5335 case Kind of
5336 tkEnumeration:
5337 if IsType<Boolean> then
5338 Exit(AsBoolean)
5339 else
5340 Exit(AsOrdinal);
5341 tkFloat:
5342 if (TypeInfo = System.TypeInfo(TDateTime))
5343 or (TypeInfo = System.TypeInfo(TDate))
5344 or (TypeInfo = System.TypeInfo(TTime)) then
5345 Exit(AsType<TDateTime>)
5346 else if TypeInfo = System.TypeInfo(Currency) then
5347 Exit(AsCurrency)
5348 else
5349 Exit(AsExtended);
5350 tkRecord:
5351 begin
5352 if IsNullable(TypeInfo) then
5353 if TryGetNullableValue(value) then
5354 Exit(value.ToVariant);
5355
5356 if IsLazyType(TypeInfo) then
5357 if TryGetLazyValue(value) then
5358 Exit(value.ToVariant);
5359
5360 if TypeInfo = System.TypeInfo(TGUID) then
5361 Exit(AsType<TGUID>.ToString);
5362 end;
5363 tkClass:
5364 begin
5365 {$IFNDEF DELPHI2010}
5366 if TryConvertToVariant(Result) then
5367 Exit;
5368 {$ENDIF}
5369
5370 obj := AsObject;
5371 if obj is TStream then
5372 begin
5373 stream := TStream(obj);
5374 stream.Position := 0;
5375 Exit(StreamToVariant(stream));
5376 end
5377 else if Supports(obj, IStreamPersist, persist) then
5378 begin
5379 stream := TMemoryStream.Create;
5380 try
5381 persist.SaveToStream(stream);
5382 stream.Position := 0;
5383 Exit(StreamToVariant(stream));
5384 finally
5385 stream.Free;
5386 end;
5387 end;
5388 end;
5389 tkInterface:
5390 Exit(AsInterface);
5391 else
5392 Exit(AsVariant);
5393 end;
5394{$IFNDEF DELPHI2010}
5395 TryConvertToVariant(Result);
5396{$ENDIF}
5397end;
5398
5399function TValueHelper.TryAsInterface(typeInfo: PTypeInfo; out Intf): Boolean;
5400var
5401 typeData: PTypeData;
5402 obj: TObject;
5403begin
5404 if not (Kind in [tkClass, tkInterface]) then
5405 Exit(False);
5406 if typeInfo.Kind <> tkInterface then
5407 Exit(False);
5408 if Self.TypeInfo = typeInfo then
5409 Result := True
5410 else
5411 begin
5412 typeData := typeInfo.TypeData;
5413 if Kind = tkClass then
5414 begin
5415{$IFDEF AUTOREFCOUNT}
5416 TValueData(Self).FValueData.ExtractRawData(@obj);
5417{$ELSE}
5418 obj := TObject(TValueData(Self).FAsObject);
5419{$ENDIF}
5420 Exit(obj.GetInterface(typeData.Guid, Intf));
5421 end;
5422 Result := False;
5423 typeData := Self.TypeData;
5424 while Assigned(typeData) and Assigned(typeData.IntfParent) do
5425 begin
5426 if typeData.IntfParent^ = typeInfo then
5427 begin
5428 Result := True;
5429 Break;
5430 end;
5431 typeData := typeData.IntfParent^.TypeData;
5432 end;
5433 end;
5434 if Result then
5435 IInterface(Intf) := AsInterface;
5436end;
5437
5438
5439{$REGION 'Conversion functions'}
5440type
5441 TConvertFunc = function(const source: TValue; target: PTypeInfo;
5442 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5443
5444function ConvFail(const source: TValue; target: PTypeInfo; out value: TValue;
5445 const formatSettings: TFormatSettings): Boolean; //FI:O804
5446begin
5447 Result := False;
5448end;
5449
5450function ConvClass2Class(const source: TValue; target: PTypeInfo;
5451 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5452begin
5453 Result := source.TryCast(target, value);
5454end;
5455
5456function ConvClass2Enum(const source: TValue; target: PTypeInfo;
5457 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5458begin
5459 Result := target = TypeInfo(Boolean);
5460 if Result then
5461 value := source.AsObject <> nil;
5462end;
5463
5464function ConvFloat2Ord(const source: TValue; target: PTypeInfo;
5465 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5466begin
5467 Result := Frac(source.AsExtended) = 0;
5468 if Result then
5469 value := TValue.FromOrdinal(target, Trunc(source.AsExtended));
5470end;
5471
5472function ConvFloat2Str(const source: TValue; target: PTypeInfo;
5473 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5474var
5475 temp: TValue;
5476begin
5477 if source.TypeInfo = TypeInfo(TDate) then
5478 temp := DateToStr(source.AsExtended, formatSettings)
5479 else if source.TypeInfo = TypeInfo(TDateTime) then
5480 temp := DateTimeToStr(source.AsExtended, formatSettings)
5481 else if source.TypeInfo = TypeInfo(TTime) then
5482 temp := TimeToStr(source.AsExtended, formatSettings)
5483 else
5484 temp := FloatToStr(source.AsExtended, formatSettings);
5485 Result := temp.TryCast(target, value);
5486end;
5487
5488function ConvIntf2Class(const source: TValue; target: PTypeInfo;
5489 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5490begin
5491 Result := ConvClass2Class(source.AsInterface as TObject, target, value, formatSettings);
5492end;
5493
5494function ConvIntf2Intf(const source: TValue; target: PTypeInfo;
5495 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5496var
5497 intf: IInterface;
5498begin
5499 Result := source.TryAsInterface(target, intf);
5500 if Result then
5501 TValue.Make(@intf, target, value)
5502 else
5503 value := TValue.Empty;
5504end;
5505
5506function ConvOrd2Float(const source: TValue; target: PTypeInfo;
5507 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5508begin
5509 value := TValue.FromFloat(target, source.AsOrdinal);
5510 Result := True;
5511end;
5512
5513function ConvOrd2Ord(const source: TValue; target: PTypeInfo;
5514 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5515var
5516 i: Int64;
5517begin
5518 i := source.AsOrdinal;
5519 with target.TypeData^ do
5520 if (i < MinValue) or (i > MaxValue) then
5521 Exit(False);
5522 value := TValue.FromOrdinal(target, i);
5523 Result := True;
5524end;
5525
5526function ConvOrd2Str(const source: TValue; target: PTypeInfo;
5527 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5528var
5529 temp: TValue;
5530begin
5531 temp := source.ToString;
5532 Result := temp.TryCast(target, value);
5533end;
5534
5535function ConvRec2Meth(const source: TValue; target: PTypeInfo;
5536 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5537begin
5538 Result := source.TypeInfo = TypeInfo(TMethod);
5539 if Result then
5540 begin
5541 value := TValue.From(source.GetReferenceToRawData, target);
5542 Result := True;
5543 end
5544end;
5545
5546function ConvStr2Enum(const source: TValue; target: PTypeInfo;
5547 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5548var
5549 temp: Integer;
5550begin
5551 temp := GetEnumValue(target, source.AsString);
5552 Result := (temp >= 0) or (target.TypeData.MinValue < 0);
5553 if Result then
5554 value := TValue.FromOrdinal(target, temp);
5555end;
5556
5557function ConvStr2Float(const source: TValue; target: PTypeInfo;
5558 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5559var
5560 s: string;
5561 d: TDateTime;
5562 f: Extended;
5563begin
5564 s := source.AsString;
5565 if target = TypeInfo(TDateTime) then
5566 begin
5567 Result := TryStrToDateTime(s, d, formatSettings);
5568 if Result then
5569 value := TValue.From<TDateTime>(d);
5570 end else
5571 if target = TypeInfo(TDate) then
5572 begin
5573 Result := TryStrToDate(s, d, formatSettings);
5574 if Result then
5575 value := TValue.From<TDate>(d);
5576 end else
5577 if target = TypeInfo(TTime) then
5578 begin
5579 Result := TryStrToTime(s, d, formatSettings);
5580 if Result then
5581 value := TValue.From<TTime>(d);
5582 end else
5583 begin
5584 Result := TryStrToFloat(s, f, formatSettings);
5585 if Result then
5586 value := TValue.FromFloat(target, f);
5587 end;
5588end;
5589
5590function ConvStr2Ord(const source: TValue; target: PTypeInfo;
5591 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5592var
5593 i: Int64;
5594begin
5595 Result := TryStrToInt64(source.AsString, i);
5596 if Result then
5597 value := TValue.FromOrdinal(target, i);
5598end;
5599
5600function ConvStr2DynArray(const source: TValue; target: PTypeInfo;
5601 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5602var
5603 s: string;
5604 values: TStringDynArray;
5605 i: Integer;
5606 p: Pointer;
5607 res, v1, v2: TValue;
5608 elType: PTypeInfo;
5609begin
5610 s := source.AsString;
5611 if StartsStr('[', s) and EndsStr(']', s) then
5612 s := Copy(s, 2, Length(s) - 2);
5613 values := SplitString(s, ',');
5614 i := Length(values);
5615 p := nil;
5616 DynArraySetLength(p, target, 1, @i);
5617 TValue.MakeWithoutCopy(@p, target, res);
5618 elType := target.TypeData.DynArrElType^;
5619 for i := 0 to High(values) do
5620 begin
5621 v1 := TValue.From(values[i]);
5622 if not v1.TryConvert(elType, v2) then
5623 Exit(False);
5624 res.SetArrayElement(i, v2);
5625 end;
5626 value := res;
5627 Result := True;
5628end;
5629
5630function ConvStr2Array(const source: TValue; target: PTypeInfo;
5631 out value: TValue; const formatSettings: TFormatSettings): Boolean;
5632var
5633 s: string;
5634 values: TStringDynArray;
5635 arrData: TArrayTypeData;
5636 elType: PTypeInfo;
5637 i: Integer;
5638 res, v1, v2: TValue;
5639begin
5640 s := source.AsString;
5641 if StartsStr('[', s) and EndsStr(']', s) then
5642 s := Copy(s, 2, Length(s) - 2);
5643 values := SplitString(s, ',');
5644
5645 // todo: support multi dim arrays - assume one dim for now
5646 arrData := GetTypeData(target).ArrayData;
5647 elType := arrData.ElType^;
5648 if Length(values) <> arrData.ElCount then
5649 Exit(False);
5650
5651 TValue.Make(nil, target, res);
5652 for i := 0 to arrData.ElCount - 1 do
5653 begin
5654 v1 := TValue.From(values[i]);
5655 if not v1.TryConvert(elType, v2) then
5656 Exit(False);
5657 res.SetArrayElement(i, v2);
5658 end;
5659 value := res;
5660 Result := True;
5661end;
5662
5663{$ENDREGION}
5664
5665
5666{$REGION 'Conversions'}
5667const
5668 Conversions: array[TTypeKind, TTypeKind] of TConvertFunc = (
5669 // tkUnknown
5670 (
5671 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5672 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5673 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5674 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5675 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5676 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5677 // tkUString, tkClassRef, tkPointer, tkProcedure
5678 ConvFail, ConvFail, ConvFail, ConvFail
5679 ),
5680 // tkInteger
5681 (
5682 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5683 ConvFail, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Float, ConvOrd2Str,
5684 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5685 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5686 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5687 ConvFail, ConvFail, ConvFail, ConvFail, ConvOrd2Ord, ConvFail,
5688 // tkUString, tkClassRef, tkPointer, tkProcedure
5689 ConvOrd2Str, ConvFail, ConvFail, ConvFail
5690 ),
5691 // tkChar
5692 (
5693 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5694 ConvFail, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Float, ConvFail,
5695 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5696 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5697 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5698 ConvFail, ConvFail, ConvFail, ConvFail, ConvOrd2Ord, ConvFail,
5699 // tkUString, tkClassRef, tkPointer, tkProcedure
5700 ConvFail, ConvFail, ConvFail, ConvFail
5701 ),
5702 // tkEnumeration
5703 (
5704 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5705 ConvFail, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Float, ConvFail,
5706 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5707 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5708 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5709 ConvFail, ConvFail, ConvFail, ConvFail, ConvOrd2Ord, ConvFail,
5710 // tkUString, tkClassRef, tkPointer, tkProcedure
5711 ConvOrd2Str, ConvFail, ConvFail, ConvFail
5712 ),
5713 // tkFloat
5714 (
5715 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5716 ConvFail, ConvFloat2Ord, ConvFail, ConvFail, ConvFail, ConvFail,
5717 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5718 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5719 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5720 ConvFail, ConvFail, ConvFail, ConvFail, ConvFloat2Ord, ConvFail,
5721 // tkUString, tkClassRef, tkPointer, tkProcedure
5722 ConvFloat2Str, ConvFail, ConvFail, ConvFail
5723 ),
5724 // tkString
5725 (
5726 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5727 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5728 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5729 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5730 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5731 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5732 // tkUString, tkClassRef, tkPointer, tkProcedure
5733 ConvFail, ConvFail, ConvFail, ConvFail
5734 ),
5735 // tkSet
5736 (
5737 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5738 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5739 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5740 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5741 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5742 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5743 // tkUString, tkClassRef, tkPointer, tkProcedure
5744 ConvFail, ConvFail, ConvFail, ConvFail
5745 ),
5746 // tkClass
5747 (
5748 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5749 ConvFail, ConvFail, ConvFail, ConvClass2Enum, ConvFail, ConvFail,
5750 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5751 ConvFail, ConvClass2Class, ConvFail, ConvFail, ConvFail, ConvFail,
5752 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5753 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5754 // tkUString, tkClassRef, tkPointer, tkProcedure
5755 ConvFail, ConvFail, ConvFail, ConvFail
5756 ),
5757 // tkMethod
5758 (
5759 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5760 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5761 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5762 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5763 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5764 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5765 // tkUString, tkClassRef, tkPointer, tkProcedure
5766 ConvFail, ConvFail, ConvFail, ConvFail
5767 ),
5768 // tkWChar
5769 (
5770 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5771 ConvFail, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Float, ConvFail,
5772 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5773 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5774 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5775 ConvFail, ConvFail, ConvFail, ConvFail, ConvOrd2Ord, ConvFail,
5776 // tkUString, tkClassRef, tkPointer, tkProcedure
5777 ConvFail, ConvFail, ConvFail, ConvFail
5778 ),
5779 // tkLString
5780 (
5781 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5782 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5783 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5784 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5785 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5786 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5787 // tkUString, tkClassRef, tkPointer, tkProcedure
5788 ConvFail, ConvFail, ConvFail, ConvFail
5789 ),
5790 // tkWString
5791 (
5792 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5793 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5794 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5795 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5796 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5797 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5798 // tkUString, tkClassRef, tkPointer, tkProcedure
5799 ConvFail, ConvFail, ConvFail, ConvFail
5800 ),
5801 // tkVariant
5802 (
5803 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5804 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5805 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5806 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5807 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5808 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5809 // tkUString, tkClassRef, tkPointer, tkProcedure
5810 ConvFail, ConvFail, ConvFail, ConvFail
5811 ),
5812 // tkArray
5813 (
5814 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5815 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5816 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5817 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5818 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5819 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5820 // tkUString, tkClassRef, tkPointer, tkProcedure
5821 ConvFail, ConvFail, ConvFail, ConvFail
5822 ),
5823 // tkRecord
5824 (
5825 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5826 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5827 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5828 ConvFail, ConvFail, ConvRec2Meth, ConvFail, ConvFail, ConvFail,
5829 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5830 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5831 // tkUString, tkClassRef, tkPointer, tkProcedure
5832 ConvFail, ConvFail, ConvFail, ConvFail
5833 ),
5834 // tkInterface
5835 (
5836 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5837 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5838 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5839 ConvFail, ConvIntf2Class, ConvFail, ConvFail, ConvFail, ConvFail,
5840 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5841 ConvFail, ConvFail, ConvFail, ConvIntf2Intf, ConvFail, ConvFail,
5842 // tkUString, tkClassRef, tkPointer, tkProcedure
5843 ConvFail, ConvFail, ConvFail, ConvFail
5844 ),
5845 // tkInt64
5846 (
5847 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5848 ConvFail, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Ord, ConvOrd2Float, ConvFail,
5849 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5850 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5851 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5852 ConvFail, ConvFail, ConvFail, ConvFail, ConvOrd2Ord, ConvFail,
5853 // tkUString, tkClassRef, tkPointer, tkProcedure
5854 ConvOrd2Str, ConvFail, ConvFail, ConvFail
5855 ),
5856 // tkDynArray
5857 (
5858 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5859 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5860 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5861 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5862 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5863 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5864 // tkUString, tkClassRef, tkPointer, tkProcedure
5865 ConvFail, ConvFail, ConvFail, ConvFail
5866 ),
5867 // tkUString
5868 (
5869 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5870 ConvFail, ConvStr2Ord, ConvFail, ConvStr2Enum, ConvStr2Float, ConvFail,
5871 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5872 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5873 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5874 ConvFail, ConvStr2Array, ConvFail, ConvFail, ConvStr2Ord, ConvStr2DynArray,
5875 // tkUString, tkClassRef, tkPointer, tkProcedure
5876 ConvFail, ConvFail, ConvFail, ConvFail
5877 ),
5878 // tkClassRef
5879 (
5880 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5881 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5882 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5883 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5884 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5885 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5886 // tkUString, tkClassRef, tkPointer, tkProcedure
5887 ConvFail, ConvFail, ConvFail, ConvFail
5888 ),
5889 // tkPointer
5890 (
5891 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5892 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5893 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5894 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5895 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5896 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5897 // tkUString, tkClassRef, tkPointer, tkProcedure
5898 ConvFail, ConvFail, ConvFail, ConvFail
5899 ),
5900 // tkProcedure
5901 (
5902 // tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
5903 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5904 // tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString
5905 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5906 // tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
5907 ConvFail, ConvFail, ConvFail, ConvFail, ConvFail, ConvFail,
5908 // tkUString, tkClassRef, tkPointer, tkProcedure
5909 ConvFail, ConvFail, ConvFail, ConvFail
5910 )
5911 );
5912{$ENDREGION}
5913
5914
5915function TValueHelper.TryConvert(targetType: PTypeInfo;
5916 out targetValue: TValue): Boolean;
5917var
5918 formatSettings: TFormatSettings;
5919begin
5920 formatSettings := TFormatSettings.Create;
5921 Result := TryConvert(targetType, targetValue, formatSettings);
5922end;
5923
5924function TValueHelper.TryConvert(targetType: PTypeInfo;
5925 out targetValue: TValue; const formatSettings: TFormatSettings): Boolean;
5926var
5927 value: TValue;
5928begin
5929 {$IFDEF DELPHI2010}
5930 // Fix for TValue.Cast not converting TValue.Empty to any type
5931 if (TypeInfo = nil) and (targetType <> nil) then
5932 begin
5933 TValue.Make(nil, targetType, targetValue);
5934 Exit(True);
5935 end;
5936 {$ENDIF}
5937
5938 if (TypeInfo = nil) or (targetType = nil) then
5939 begin
5940 targetValue := EmptyValue;
5941 Exit(True);
5942 end;
5943
5944 if TypeInfo = targetType then
5945 begin
5946 targetValue := Self;
5947 Exit(True);
5948 end;
5949
5950 Result := Conversions[Kind, targetType.Kind](Self, targetType, targetValue, formatSettings);
5951 if not Result then
5952 begin
5953 if TryGetNullableValue(value) and value.TryCast(targetType, targetValue) then
5954 Exit(True);
5955
5956 if TryGetLazyValue(value) and value.TryCast(targetType, targetValue) then
5957 Exit(True);
5958
5959 if IsNullable(targetType) and TryConvert(GetUnderlyingType(targetType), value) then
5960 begin
5961 TValue.Make(nil, targetType, targetValue);
5962 targetValue.SetNullableValue(value);
5963 Exit(True);
5964 end;
5965
5966 case Kind of
5967 tkRecord:
5968 if TypeInfo = System.TypeInfo(TValue) then
5969 Exit(AsType<TValue>.TryConvert(targetType, targetValue));
5970 {$IFDEF DELPHI2010}
5971 // workaround for bug in RTTI.pas (fixed in XE)
5972 tkUnknown:
5973 begin
5974 case targetType.Kind of
5975 tkInteger, tkEnumeration, tkChar, tkWChar, tkInt64:
5976 begin
5977 targetValue := TValue.FromOrdinal(targetType, 0);
5978 Exit(True);
5979 end;
5980 tkFloat:
5981 begin
5982 targetValue := TValue.From<Extended>(0);
5983 Exit(True);
5984 end;
5985 tkUString:
5986 begin
5987 targetValue := '';
5988 Exit(True);
5989 end;
5990 end;
5991 end;
5992 {$ENDIF}
5993 end;
5994
5995 {$IFNDEF DELPHI2010}
5996 Result := TValueConverter.Default.TryConvertTo(Self, targetType, targetValue, TValue.From(formatSettings));
5997 {$ELSE}
5998 Result := False;
5999 {$ENDIf}
6000 end;
6001end;
6002
6003function TValueHelper.TryGetLazyValue(out value: TValue): Boolean;
6004var
6005 instance: PInterface;
6006 lazy: ILazy;
6007begin
6008 case GetLazyKind(TValueData(Self).FTypeInfo) of
6009 lkRecord:
6010 begin
6011 instance := GetReferenceToRawData;
6012 if instance = nil then
6013 Exit(False);
6014 lazy := instance^ as ILazy;
6015 Result := Assigned(lazy);
6016 if Result then
6017 value := lazy.Value;
6018 end;
6019 else
6020 Result := False;
6021 end;
6022end;
6023
6024function TValueHelper.TryGetNullableValue(out value: TValue): Boolean;
6025var
6026 typeInfo: PTypeInfo;
6027 nullable: TNullableHelper;
6028 instance: Pointer;
6029begin
6030 typeInfo := TValueData(Self).FTypeInfo;
6031 Result := IsNullable(typeInfo);
6032 if Result then
6033 begin
6034 instance := GetReferenceToRawData;
6035 if instance = nil then
6036 Exit(False);
6037 nullable := TNullableHelper.Create(typeInfo);
6038 Result := nullable.HasValue(instance);
6039 if Result then
6040 value := nullable.GetValue(instance);
6041 end;
6042end;
6043
6044function TValueHelper.TryToType<T>(out targetValue: T): Boolean;
6045var
6046 value: TValue;
6047begin
6048 Result := TryConvert(System.TypeInfo(T), value);
6049 if Result then
6050 begin
6051 // avoid extra overhead of value.AsType<T>
6052 // since we know value contains the exact type of T
6053 // use the same code as the private TValue.Get<T> method
6054 if TValueData(value).FTypeInfo = nil then
6055 begin
6056 FillChar(Pointer(@targetValue)^, SizeOf(T), 0);
6057 Exit;
6058 end;
6059 value.ExtractRawData(@targetValue);
6060 end;
6061end;
6062
6063function TValueHelper.TryToType<T>(out targetValue: T;
6064 const formatSettings: TFormatSettings): Boolean;
6065var
6066 value: TValue;
6067begin
6068 Result := TryConvert(System.TypeInfo(T), value, formatSettings);
6069 if Result then
6070 begin
6071 // avoid extra overhead of value.AsType<T>
6072 // since we know value contains the exact type of T
6073 // use the same code as the private TValue.Get<T> method
6074 if TValueData(value).FTypeInfo = nil then
6075 begin
6076 FillChar(Pointer(@targetValue)^, SizeOf(T), 0);
6077 Exit;
6078 end;
6079 value.ExtractRawData(@targetValue);
6080 end;
6081end;
6082
6083{$ENDREGION}
6084
6085
6086{$REGION 'TRttiMethodHelper'}
6087
6088function TRttiMethodHelper.GetIsAbstract: Boolean;
6089var
6090 code: Pointer;
6091begin
6092 case DispatchKind of
6093 dkVtable: code := GetVirtualMethod(Parent.AsInstance.MetaclassType, VirtualIndex);
6094 dkDynamic: code := GetDynaMethod(Parent.AsInstance.MetaclassType, VirtualIndex);
6095 else
6096 code := nil;
6097 end;
6098 Result := code = GetAbstractError;
6099end;
6100
6101function TRttiMethodHelper.GetReturnTypeHandle: PTypeInfo;
6102var
6103 returnType: TRttiType;
6104begin
6105 returnType := Self.ReturnType;
6106 if Assigned(returnType) then
6107 Result := returnType.Handle
6108 else
6109 Result := nil;
6110end;
6111
6112{$IF CompilerVersion < 31}
6113procedure TRttiMethodHelper.DispatchValue(const value: TValue;
6114 typeInfo: PTypeInfo);
6115type
6116 PValueData = ^TValueData;
6117begin
6118 if (value.TypeInfo <> typeInfo) and (value.Kind = tkInterface)
6119 and (typeInfo.Kind = tkInterface)
6120 and IsAssignableFrom(typeInfo, value.TypeInfo) then
6121 PValueData(@value).FTypeInfo := typeInfo;
6122end;
6123
6124type
6125 TRttiObjectHelper = class helper for TRttiObject
6126 private
6127 procedure SetParent(const parent: TRttiObject); inline;
6128 end;
6129
6130procedure TRttiObjectHelper.SetParent(const parent: TRttiObject);
6131begin
6132 Self.FParent := parent;
6133end;
6134
6135procedure TRttiMethodHelper.FixParameters(
6136 const parameters: TArray<TRttiParameter>);
6137var
6138 i: Integer;
6139begin
6140 for i := 0 to High(parameters) do
6141 parameters[i].SetParent(Self);
6142end;
6143
6144function TRttiMethodHack.GetParameters: TArray<TRttiParameter>; //FI:W521
6145begin //FI:W519
6146end;
6147
6148function TRttiMethodHelper.GetParameters: TArray<TRttiParameter>;
6149begin
6150 Result := TRttiMethodHack(Self).GetParameters;
6151 FixParameters(Result);
6152end;
6153
6154function TRttiMethodHelper.Invoke(Instance: TObject;
6155 const Args: array of TValue): TValue;
6156begin
6157 Result := Invoke(TValue(Instance), Args);
6158end;
6159
6160function TRttiMethodHelper.Invoke(Instance: TClass;
6161 const Args: array of TValue): TValue;
6162begin
6163 Result := Invoke(TValue(Instance), Args);
6164end;
6165
6166function TRttiMethodHelper.Invoke(Instance: TValue;
6167 const Args: array of TValue): TValue;
6168var
6169 parameters: TArray<TRttiParameter>;
6170 i: Integer;
6171begin
6172 parameters := GetParameters;
6173 if Length(Args) <> Length(parameters) then
6174 raise EInvocationError.CreateRes(@SParameterCountMismatch);
6175 for i := Low(Args) to High(Args) do
6176 DispatchValue(Args[i], parameters[i].ParamType.Handle);
6177 if MethodKind = mkOperatorOverload then
6178 Result := Rtti.Invoke(CodeAddress, TArray.Copy<TValue>(Args),
6179 CallingConvention, ReturnTypeHandle{$IFDEF DELPHIXE2_UP}, IsStatic{$ENDIF})
6180 else
6181 Result := Self.DispatchInvoke(Instance, Args);
6182end;
6183{$IFEND}
6184
6185{$ENDREGION}
6186
6187
6188{$REGION 'TRttiInvokableTypeHelper'}
6189
6190{$IFDEF DELPHIXE2_UP}
6191type
6192 // this is the class used to create a TMethodImplementation for a
6193 // TRttiInvokableType by passing in an instance of TRttiInvokableType
6194 // and "overriding" its private virtual methods
6195 TRttiInvokableMethod = class(TRttiMethod)
6196 private
6197 FType: TRttiInvokableType;
6198 constructor Create(AType: TRttiInvokableType);
6199 end;
6200
6201 // this classes is needed to access FParent
6202 // it needs to have the exact same fields as System.Rtti.TRttiObject
6203 TRttiObjectHack = class abstract
6204 protected
6205 FHandle: Pointer;
6206 FRttiDataSize: Integer;
6207 {$IFDEF WEAKINSTREF}[Weak]{$ENDIF}
6208 FPackage: TRttiPackage;
6209 {$IFDEF WEAKINSTREF}[Weak]{$ENDIF}
6210 FParent: TRttiObject;
6211 end;
6212
6213 // this class is needed to "override" private virtual methods
6214 // it needs to have the exact same virtual methods as System.Rtti.TRttiMethod
6215 TRttiInvokableMethodHack = class(TRttiMember)
6216 protected
6217 FInvokeInfo: TObject; //TMethodImplementation.TInvokeInfo
6218 FType: TRttiInvokableType;
6219 function GetMethodKind: TMethodKind; virtual; abstract;
6220 function GetCallingConvention: TCallConv; virtual;
6221 function GetReturnType: TRttiType; virtual;
6222 function GetDispatchKind: TDispatchKind; virtual; abstract;
6223 function GetHasExtendedInfo: Boolean; virtual; abstract;
6224 function GetVirtualIndex: SmallInt; virtual; abstract;
6225 function GetCodeAddress: Pointer; virtual; abstract;
6226 function GetIsClassMethod: Boolean; virtual;
6227 function GetIsStatic: Boolean; virtual;
6228 function DispatchInvoke(Instance: TValue; const Args: array of TValue): TValue; virtual; abstract;
6229 public
6230 function GetParameters: TArray<TRttiParameter>; virtual;
6231 end;
6232
6233 // this class is needed to "override" the destructor of
6234 // the TMethodImplementation instances that are created inside of
6235 // TRttiMethod.CreateImplementation
6236 TMethodImplementationHack = class(TMethodImplementation)
6237 {$IFDEF DELPHIXE2}
6238 private
6239 function FInvokeInfo: TObject; inline;
6240 {$ENDIF}
6241 public
6242 destructor Destroy; override;
6243 end;
6244
6245function TRttiInvokableMethodHack.GetCallingConvention: TCallConv;
6246begin
6247 Result := FType.CallingConvention;
6248end;
6249
6250function TRttiInvokableMethodHack.GetIsClassMethod: Boolean;
6251begin
6252 Result := False;
6253end;
6254
6255function TRttiInvokableMethodHack.GetIsStatic: Boolean;
6256begin
6257 Result := FType is TRttiProcedureType;
6258end;
6259
6260function TRttiInvokableMethodHack.GetParameters: TArray<TRttiParameter>;
6261begin
6262 Result := FType.GetParameters;
6263end;
6264
6265function TRttiInvokableMethodHack.GetReturnType: TRttiType;
6266begin
6267 Result := FType.ReturnType;
6268end;
6269
6270{$IFDEF DELPHIXE2}
6271function TMethodImplementationHack.FInvokeInfo: TObject;
6272begin
6273 Result := PPointer(PByte(Self) + SizeOf(Pointer) * 2)^;
6274end;
6275{$ENDIF}
6276
6277destructor TMethodImplementationHack.Destroy;
6278begin
6279 if FInvokeInfo <> nil then
6280 FInvokeInfo.Free;
6281 inherited Destroy;
6282end;
6283
6284constructor TRttiInvokableMethod.Create(AType: TRttiInvokableType);
6285var
6286 ctx: TRttiContext;
6287begin
6288 inherited Create;
6289 // GetInvokeInfo need the Parent property
6290 TRttiObjectHack(Self).FParent := ctx.GetType(TObject);
6291 FType := AType;
6292 // change the type of this class to the class that has its private
6293 // methods "overridden"
6294 PPointer(Self)^ := TRttiInvokableMethodHack;
6295end;
6296
6297function TRttiInvokableTypeHelper.CreateImplementation(AUserData: Pointer; //FI:O804
6298 const ACallback: TMethodImplementationCallback): TMethodImplementation;
6299var
6300 m: TRttiMethod;
6301begin
6302 {$WARN CONSTRUCTING_ABSTRACT OFF}
6303 m := TRttiInvokableMethod.Create(Self);
6304 try
6305 // there is no way to directly create a TMethodImplementation instance
6306 // because it requires an instance of the private TInvokeInfo class to be
6307 // passed which can only be produced by the private method GetInvokeInfo
6308
6309 // since TRttiInvokableMethod has the necessary private virtual methods
6310 // "overridden" it will create the correct TMethodImplementation instance
6311 // for the given TRttiInvokableType
6312 Result := m.CreateImplementation(Self, ACallback);
6313 // "override" the destructor so FInvokeMethod which is not owned by the
6314 // TRttiInvokableMethod is properly destroyed at the end
6315 PPointer(Result)^ := TMethodImplementationHack;
6316 finally
6317 m.Free;
6318 end;
6319end;
6320{$ENDIF}
6321
6322{$ENDREGION}
6323
6324
6325{$REGION 'TMethodImplementationHelper'}
6326
6327{$IFNDEF DELPHI2010}
6328function TMethodImplementationHelper.AsMethod: TMethod;
6329begin
6330 Result.Code := CodeAddress;
6331 Result.Data := Self;
6332end;
6333{$ENDIF}
6334
6335{$ENDREGION}
6336
6337
6338{$REGION 'TNamedValue'}
6339
6340constructor TNamedValue.Create(const value: TValue; const name: string);
6341begin
6342 fValue := value;
6343 fName := name;
6344end;
6345
6346class function TNamedValue.From<T>(const value: T;
6347 const name: string): TNamedValue;
6348begin
6349 Result.fValue := TValue.From<T>(value);
6350 Result.fName := name;
6351end;
6352
6353class operator TNamedValue.Implicit(const value: TNamedValue): TValue;
6354begin
6355 Result := TValue.From(value);
6356end;
6357
6358class operator TNamedValue.Implicit(const value: TValue): TNamedValue;
6359begin
6360 Result := value.AsType<TNamedValue>;
6361end;
6362
6363{$ENDREGION}
6364
6365
6366{$REGION 'TTypedValue'}
6367
6368constructor TTypedValue.Create(const value: TValue; const typeInfo: PTypeInfo);
6369begin
6370 fValue := value;
6371 fTypeInfo := typeInfo;
6372end;
6373
6374class function TTypedValue.From<T>(const value: T): TTypedValue;
6375begin
6376 Result.fValue := TValue.From<T>(value);
6377 Result.fTypeInfo := System.TypeInfo(T);
6378end;
6379
6380class function TTypedValue.From<T>(const value: T;
6381 const typeInfo: PTypeInfo): TTypedValue;
6382begin
6383 Result.fValue := TValue.From<T>(value);
6384 Result.fTypeInfo := typeInfo;
6385end;
6386
6387class operator TTypedValue.Implicit(const value: TTypedValue): TValue;
6388begin
6389 Result := TValue.From(value);
6390end;
6391
6392class operator TTypedValue.Implicit(const value: TValue): TTypedValue;
6393begin
6394 Result := value.AsType<TTypedValue>;
6395end;
6396
6397{$ENDREGION}
6398
6399
6400{$REGION 'TInterfaceBase'}
6401
6402function TInterfaceBase.QueryInterface(const IID: TGUID; out Obj): HResult;
6403begin
6404 if GetInterface(IID, obj) then
6405 Result := S_OK
6406 else
6407 Result := E_NOINTERFACE;
6408end;
6409
6410function TInterfaceBase._AddRef: Integer;
6411begin
6412 Result := -1;
6413end;
6414
6415function TInterfaceBase._Release: Integer;
6416begin
6417 Result := -1;
6418end;
6419
6420{$ENDREGION}
6421
6422
6423{$REGION 'TInterfacedObjectEx'}
6424
6425{$IF not defined(DELPHIXE7_UP) and not defined(AUTOREFCOUNT)}
6426procedure TInterfacedObjectEx.BeforeDestruction;
6427begin
6428 inherited BeforeDestruction;
6429 FRefCount := objDestroyingFlag;
6430end;
6431
6432function TInterfacedObjectEx.GetRefCount: Integer;
6433begin
6434 Result := FRefCount and not objDestroyingFlag;
6435end;
6436{$IFEND}
6437
6438{$ENDREGION}
6439
6440
6441{$REGION 'Guard'}
6442
6443class procedure Guard.RaiseArgumentException(const msg: string);
6444begin
6445 raise EArgumentException.Create(msg) at ReturnAddress;
6446end;
6447
6448class procedure Guard.RaiseArgumentNullException(const argumentName: string);
6449begin
6450 raise EArgumentNullException.CreateResFmt(
6451 @SArgumentNullException, [argumentName]) at ReturnAddress;
6452end;
6453
6454class procedure Guard.RaiseArgumentOutOfRangeException(const argumentName: string);
6455begin
6456 raise EArgumentOutOfRangeException.CreateResFmt(
6457 @SArgumentOutOfRangeException, [argumentName]) at ReturnAddress;
6458end;
6459
6460class procedure Guard.RaiseArgumentException(typeKind: TTypeKind; const argumentName: string);
6461begin
6462 raise EArgumentException.CreateResFmt(@SUnexpectedTypeKindArgument,
6463 [GetEnumName(TypeInfo(TTypeKind), Ord(typeKind)), argumentName]) at ReturnAddress;
6464end;
6465
6466class procedure Guard.RaiseArgumentFormatException(const argumentName: string);
6467begin
6468 raise EFormatException.CreateResFmt(
6469 @SInvalidArgumentFormat, [argumentName]) at ReturnAddress;
6470end;
6471
6472class procedure Guard.RaiseInvalidEnumArgumentException(const argumentName: string);
6473begin
6474 raise EInvalidEnumArgumentException.CreateResFmt(
6475 @SInvalidEnumArgument, [argumentName]) at ReturnAddress;
6476end;
6477
6478class procedure Guard.RaiseInvalidTypeCast(sourceType, targetType: PTypeInfo);
6479begin
6480 raise EInvalidCastException.CreateResFmt(@SInvalidTypeCast, [
6481 sourceType.TypeName, targetType.TypeName]) at ReturnAddress;
6482end;
6483
6484class procedure Guard.RaiseNullableHasNoValue;
6485begin
6486 raise EInvalidOperationException.CreateRes(@SNullableHasNoValue) at ReturnAddress;
6487end;
6488
6489class procedure Guard.RaiseNoDelegateAssigned;
6490begin
6491 raise EInvalidOperationException.CreateRes(@SNoDelegateAssigned) at ReturnAddress;
6492end;
6493
6494class procedure Guard.CheckIndex(length, index, indexBase: Integer);
6495const
6496 IndexArgName = 'index';
6497begin
6498 if (index < indexBase) or (index >= indexBase + length) then
6499 Guard.RaiseArgumentOutOfRangeException(IndexArgName);
6500end;
6501
6502class procedure Guard.CheckRange(length, index, count, indexBase: Integer);
6503const
6504 CountArgName = 'count';
6505begin
6506 Guard.CheckIndex(length, index, indexBase);
6507 if (count < 0) or (index + count > indexBase + length) then
6508 Guard.RaiseArgumentOutOfRangeException(CountArgName);
6509end;
6510
6511class procedure Guard.CheckRange<T>(const buffer: array of T; index: Integer);
6512begin
6513 Guard.CheckIndex(Length(buffer), index);
6514end;
6515
6516class procedure Guard.CheckRange<T>(const buffer: array of T;
6517 index, count: Integer);
6518begin
6519 Guard.CheckRange(Length(buffer), index, count);
6520end;
6521
6522class procedure Guard.CheckTrue(condition: Boolean; const msg: string);
6523begin
6524 if not condition then
6525 Guard.RaiseArgumentException(msg);
6526end;
6527
6528class procedure Guard.CheckTypeKind(typeKind: TTypeKind;
6529 expectedTypeKind: TTypeKind; const argumentName: string);
6530begin
6531 if typeKind <> expectedTypeKind then
6532 Guard.RaiseArgumentException(typeKind, argumentName);
6533end;
6534
6535class procedure Guard.CheckTypeKind(typeKind: TTypeKind;
6536 expectedTypeKinds: TTypeKinds; const argumentName: string);
6537begin
6538 if not (typeKind in expectedTypeKinds) then
6539 RaiseArgumentException(typeKind, argumentName);
6540end;
6541
6542class procedure Guard.CheckTypeKind<T>(expectedTypeKind: TTypeKind;
6543 const argumentName: string);
6544begin
6545 if TType.Kind<T> <> expectedTypeKind then
6546 RaiseArgumentException(TType.Kind<T>, argumentName);
6547end;
6548
6549class procedure Guard.CheckTypeKind<T>(expectedTypeKinds: TTypeKinds;
6550 const argumentName: string);
6551begin
6552 if not (TType.Kind<T> in expectedTypeKinds) then
6553 RaiseArgumentException(TType.Kind<T>, argumentName);
6554end;
6555
6556class procedure Guard.CheckFalse(condition: Boolean; const msg: string);
6557begin
6558 if condition then
6559 Guard.RaiseArgumentException(msg);
6560end;
6561
6562class procedure Guard.CheckInheritsFrom(cls, parentClass: TClass;
6563 const argumentName: string);
6564begin
6565 Guard.CheckNotNull(cls, 'cls');
6566 Guard.CheckNotNull(parentClass, 'parentClass');
6567
6568 if not cls.InheritsFrom(parentClass) then
6569 raise EArgumentException.CreateResFmt(@SBadObjectInheritance, [argumentName,
6570 cls.ClassName, parentClass.ClassName]);
6571end;
6572
6573class procedure Guard.CheckInheritsFrom(const obj: TObject; parentClass: TClass;
6574 const argumentName: string);
6575begin
6576 if Assigned(obj) then
6577 Guard.CheckInheritsFrom(obj.ClassType, parentClass, argumentName);
6578end;
6579
6580class procedure Guard.CheckNotNull(condition: Boolean;
6581 const parameterName: string);
6582begin
6583 if not condition then
6584 Guard.RaiseArgumentNullException(parameterName);
6585end;
6586
6587class procedure Guard.CheckNotNull(argumentValue: Pointer;
6588 const argumentName: string);
6589begin
6590 Guard.CheckNotNull(Assigned(argumentValue), argumentName);
6591end;
6592
6593class procedure Guard.CheckNotNull(const argumentValue: IInterface;
6594 const argumentName: string);
6595begin
6596 Guard.CheckNotNull(Assigned(argumentValue), argumentName);
6597end;
6598
6599class procedure Guard.CheckNotNull(const argumentValue: TObject;
6600 const argumentName: string);
6601begin
6602 Guard.CheckNotNull(Assigned(argumentValue), argumentName);
6603end;
6604
6605class procedure Guard.CheckNotNull<T>(const argumentValue: T;
6606 const argumentName: string);
6607begin
6608 if Guard.IsNullReference(argumentValue, TypeInfo(T)) then
6609 Guard.RaiseArgumentNullException(argumentName);
6610end;
6611
6612class procedure Guard.CheckEnum<T>(const argumentValue: T;
6613 const argumentName: string);
6614var
6615 intValue: Integer;
6616begin
6617 intValue := 0;
6618 Move(argumentValue, intValue, SizeOf(T));
6619 Guard.CheckEnum<T>(intValue, argumentName);
6620end;
6621
6622class procedure Guard.CheckEnum<T>(argumentValue: Integer;
6623 const argumentName: string);
6624var
6625 typeInfo: PTypeInfo;
6626 data: PTypeData;
6627begin
6628 Guard.CheckTypeKind<T>(tkEnumeration, 'T');
6629
6630 typeInfo := System.TypeInfo(T);
6631 data := typeInfo.TypeData;
6632 Guard.CheckNotNull(data, 'data');
6633
6634 if (argumentValue < data.MinValue) or (argumentValue > data.MaxValue) then
6635 raise EInvalidEnumArgumentException.CreateResFmt(@SInvalidEnumArgument, [
6636 argumentName, typeInfo.TypeName, argumentValue]);
6637end;
6638
6639class procedure Guard.CheckRange(condition: Boolean;
6640 const argumentName: string);
6641begin
6642 if not condition then
6643 Guard.RaiseArgumentOutOfRangeException(argumentName);
6644end;
6645
6646class procedure Guard.CheckRange(const buffer: array of Byte;
6647 index, count: Integer);
6648begin
6649 Guard.CheckRange(Length(buffer), index, count);
6650end;
6651
6652class procedure Guard.CheckRange(const buffer: array of Char;
6653 index, count: Integer);
6654begin
6655 Guard.CheckRange(Length(buffer), index, count);
6656end;
6657
6658class procedure Guard.CheckRange(const buffer: array of Byte; index: Integer);
6659begin
6660 Guard.CheckIndex(Length(buffer), index);
6661end;
6662
6663class procedure Guard.CheckRange(const buffer: array of Char; index: Integer);
6664begin
6665 Guard.CheckIndex(Length(buffer), index);
6666end;
6667
6668class procedure Guard.CheckRange(const s: string; index: Integer);
6669begin
6670 Guard.CheckIndex(Length(s), index, 1);
6671end;
6672
6673class procedure Guard.CheckRange(const s: string; index, count: Integer);
6674begin
6675 Guard.CheckRange(Length(s), index, count, 1);
6676end;
6677
6678class procedure Guard.CheckRangeInclusive(value, min, max: Integer);
6679const
6680 ValueArgName = 'value';
6681begin
6682 if (value < min) or (value > max) then
6683 Guard.RaiseArgumentOutOfRangeException(ValueArgName);
6684end;
6685
6686class procedure Guard.CheckSet<T>(const argumentValue: T;
6687 const argumentName: string);
6688var
6689 value: Integer;
6690begin
6691 value := 0;
6692 Move(argumentValue, value, SizeOf(T));
6693 Guard.CheckSet<T>(value, argumentName);
6694end;
6695
6696class procedure Guard.CheckSet<T>(argumentValue: Cardinal;
6697 const argumentName: string);
6698var
6699 typeInfo: PTypeInfo;
6700 data: PTypeData;
6701 maxValue: Cardinal;
6702begin
6703 Guard.CheckTypeKind<T>(tkSet, 'T');
6704
6705 typeInfo := System.TypeInfo(T);
6706 data := typeInfo.TypeData;
6707 Guard.CheckNotNull(data, 'data');
6708
6709 if Assigned(data.CompType) then
6710 begin
6711 data := data.CompType^.TypeData;
6712 maxValue := (1 shl (data.MaxValue - data.MinValue + 1)) - 1;
6713 end
6714 else
6715 case data^.OrdType of
6716 otSByte, otUByte: maxValue := High(Byte);
6717 otSWord, otUWord: maxValue := High(Word);
6718 otSLong, otULong: Exit;
6719 else
6720 maxValue := 0;
6721 end;
6722
6723 if argumentValue > maxValue then
6724 raise EInvalidEnumArgumentException.CreateResFmt(@SInvalidSetArgument, [
6725 argumentName, typeInfo.TypeName, argumentValue]);
6726end;
6727
6728class procedure Guard.CheckRangeExclusive(value, min, max: Integer);
6729const
6730 ValueArgName = 'value';
6731begin
6732 if (value <= min) or (value >= max) then
6733 Guard.RaiseArgumentOutOfRangeException(ValueArgName);
6734end;
6735
6736
6737{$IFNDEF NEXTGEN}
6738class procedure Guard.CheckRange(const s: WideString; index: Integer);
6739begin
6740 Guard.CheckIndex(Length(s), index, 1);
6741end;
6742
6743class procedure Guard.CheckRange(const s: WideString; index, count: Integer);
6744begin
6745 Guard.CheckRange(Length(s), index, count, 1);
6746end;
6747
6748class procedure Guard.CheckRange(const s: RawByteString; index: Integer);
6749begin
6750 Guard.CheckIndex(Length(s), index, 1);
6751end;
6752
6753class procedure Guard.CheckRange(const s: RawByteString; index, count: Integer);
6754begin
6755 Guard.CheckRange(Length(s), index, count, 1);
6756end;
6757{$ENDIF}
6758
6759class procedure Guard.CheckTypeKind(typeInfo: PTypeInfo;
6760 expectedTypeKind: TTypeKind; const argumentName: string);
6761begin
6762 Guard.CheckNotNull(typeInfo, argumentName);
6763 if typeInfo.Kind <> expectedTypeKind then
6764 RaiseArgumentException(typeInfo.Kind, argumentName);
6765end;
6766
6767class procedure Guard.CheckTypeKind(typeInfo: PTypeInfo;
6768 expectedTypeKinds: TTypeKinds; const argumentName: string);
6769begin
6770 Guard.CheckNotNull(typeInfo, argumentName);
6771 if not (typeInfo.Kind in expectedTypeKinds) then
6772 RaiseArgumentException(typeInfo.Kind, argumentName);
6773end;
6774
6775class function Guard.IsNullReference(const value; typeInfo: PTypeInfo): Boolean;
6776const
6777 ReferenceKinds = [
6778 tkClass, tkMethod, tkInterface, tkClassRef, tkPointer, tkProcedure];
6779begin
6780 Result := False;
6781 if Assigned(typeInfo) and (typeInfo.Kind in ReferenceKinds) then
6782 if typeInfo.Kind = tkMethod then
6783 Result := not Assigned(TMethod(value).Code) and not Assigned(TMethod(value).Data)
6784 else
6785 Result := not Assigned(PPointer(@value)^);
6786end;
6787
6788{$ENDREGION}
6789
6790
6791{$REGION 'Nullable<T>'}
6792
6793constructor Nullable<T>.Create(const value: T);
6794begin
6795 fValue := value;
6796 fHasValue := Nullable.HasValue;
6797end;
6798
6799constructor Nullable<T>.Create(const value: Variant);
6800var
6801 v: TValue;
6802begin
6803 if not VarIsNullOrEmpty(value) then
6804 begin
6805 v := TValue.FromVariant(value);
6806 fValue := v.AsType<T>;
6807 fHasValue := Nullable.HasValue;
6808 end
6809 else
6810 begin
6811 fHasValue := '';
6812 fValue := Default(T);
6813 end;
6814end;
6815
6816function Nullable<T>.GetHasValue: Boolean;
6817begin
6818 Result := fHasValue <> '';
6819end;
6820
6821function Nullable<T>.GetValue: T;
6822begin
6823 if not HasValue then
6824 Guard.RaiseNullableHasNoValue;
6825 Result := fValue;
6826end;
6827
6828function Nullable<T>.GetValueOrDefault: T;
6829begin
6830 if HasValue then
6831 Result := fValue
6832 else
6833 Result := Default(T);
6834end;
6835
6836function Nullable<T>.GetValueOrDefault(const defaultValue: T): T;
6837begin
6838 if HasValue then
6839 Result := fValue
6840 else
6841 Result := defaultValue;
6842end;
6843
6844class function Nullable<T>.EqualsComparer(const left, right: T): Boolean;
6845begin
6846 if not Assigned(fComparer) then
6847 fComparer := TEqualityComparer<T>.Default;
6848 Result := fComparer.Equals(left, right);
6849end;
6850
6851class function Nullable<T>.EqualsInternal(const left, right: T): Boolean;
6852begin
6853 case TType.Kind<T> of
6854 tkInteger, tkEnumeration:
6855 begin
6856 case SizeOf(T) of
6857 1: Result := PByte(@left)^ = PByte(@right)^;
6858 2: Result := PWord(@left)^ = PWord(@right)^;
6859 4: Result := PCardinal(@left)^ = PCardinal(@right)^;
6860 end;
6861 end;
6862{$IFNDEF NEXTGEN}
6863 tkChar: Result := PAnsiChar(@left)^ = PAnsiChar(@right)^;
6864 tkString: Result := PShortString(@left)^ = PShortString(@right)^;
6865 tkLString: Result := PAnsiString(@left)^ = PAnsiString(@right)^;
6866 tkWString: Result := PWideString(@left)^ = PWideString(@right)^;
6867{$ENDIF}
6868 tkFloat:
6869 begin
6870 if TypeInfo(T) = TypeInfo(Single) then
6871 Result := Math.SameValue(PSingle(@left)^, PSingle(@right)^)
6872 else if TypeInfo(T) = TypeInfo(Double) then
6873 Result := Math.SameValue(PDouble(@left)^, PDouble(@right)^)
6874 else if TypeInfo(T) = TypeInfo(Extended) then
6875 Result := Math.SameValue(PExtended(@left)^, PExtended(@right)^)
6876 else if TypeInfo(T) = TypeInfo(TDateTime) then
6877 Result := SameDateTime(PDateTime(@left)^, PDateTime(@right)^)
6878 else
6879 case GetTypeData(TypeInfo(T)).FloatType of
6880 ftSingle: Result := Math.SameValue(PSingle(@left)^, PSingle(@right)^);
6881 ftDouble: Result := Math.SameValue(PDouble(@left)^, PDouble(@right)^);
6882 ftExtended: Result := Math.SameValue(PExtended(@left)^, PExtended(@right)^);
6883 ftComp: Result := PComp(@left)^ = PComp(@right)^;
6884 ftCurr: Result := PCurrency(@left)^ = PCurrency(@right)^;
6885 end;
6886 end;
6887 tkWChar: Result := PWideChar(@left)^ = PWideChar(@right)^;
6888 tkInt64: Result := PInt64(@left)^ = PInt64(@right)^;
6889 tkUString: Result := PUnicodeString(@left)^ = PUnicodeString(@right)^;
6890 else
6891 Result := EqualsComparer(left, right);
6892 end;
6893end;
6894
6895function Nullable<T>.Equals(const other: Nullable<T>): Boolean;
6896begin
6897 if not HasValue then
6898 Exit(not other.HasValue);
6899 if not other.HasValue then
6900 Exit(False);
6901 Result := EqualsInternal(fValue, other.fValue);
6902end;
6903
6904class operator Nullable<T>.Implicit(const value: T): Nullable<T>;
6905begin
6906 Result.fValue := value;
6907 Result.fHasValue := Nullable.HasValue;
6908end;
6909
6910{$IFDEF IMPLICIT_NULLABLE}
6911class operator Nullable<T>.Implicit(const value: Nullable<T>): T;
6912begin
6913 Result := value.Value;
6914end;
6915{$ENDIF}
6916
6917{$IFDEF UNSAFE_NULLABLE}
6918class operator Nullable<T>.Implicit(const value: Nullable<T>): Variant;
6919var
6920 v: TValue;
6921begin
6922 if value.HasValue then
6923 begin
6924 v := TValue.From<T>(value.fValue);
6925 if v.IsType<Boolean> then
6926 Result := v.AsBoolean
6927 else
6928 Result := v.AsVariant;
6929 end
6930 else
6931 Result := Null;
6932end;
6933
6934class operator Nullable<T>.Implicit(const value: Variant): Nullable<T>;
6935var
6936 v: TValue;
6937begin
6938 if not VarIsNullOrEmpty(value) then
6939 begin
6940 v := TValue.FromVariant(value);
6941 Result.fValue := v.AsType<T>;
6942 Result.fHasValue := Nullable.HasValue;
6943 end
6944 else
6945 Result := Default(Nullable<T>);
6946end;
6947{$ENDIF}
6948
6949class operator Nullable<T>.Explicit(const value: Variant): Nullable<T>;
6950var
6951 v: TValue;
6952begin
6953 if not VarIsNullOrEmpty(value) then
6954 begin
6955 v := TValue.FromVariant(value);
6956 Result.fValue := v.AsType<T>;
6957 Result.fHasValue := Nullable.HasValue;
6958 end
6959 else
6960 Result := Default(Nullable<T>);
6961end;
6962
6963class operator Nullable<T>.Explicit(const value: Nullable<T>): T;
6964begin
6965 Result := value.Value;
6966end;
6967
6968class operator Nullable<T>.Implicit(const value: Nullable.Null): Nullable<T>;
6969begin
6970 Result.fValue := Default(T);
6971 Result.fHasValue := '';
6972end;
6973
6974class operator Nullable<T>.Equal(const left, right: Nullable<T>): Boolean;
6975begin
6976 Result := left.Equals(right);
6977end;
6978
6979class operator Nullable<T>.Equal(const left: Nullable<T>;
6980 const right: T): Boolean;
6981begin
6982 if left.fHasValue = '' then
6983 Exit(False);
6984 Result := EqualsInternal(left.fValue, right);
6985end;
6986
6987class operator Nullable<T>.Equal(const left: Nullable<T>;
6988 const right: Nullable.Null): Boolean;
6989begin
6990 Result := left.fHasValue = '';
6991end;
6992
6993class operator Nullable<T>.NotEqual(const left, right: Nullable<T>): Boolean;
6994begin
6995 Result := not left.Equals(right);
6996end;
6997
6998class operator Nullable<T>.NotEqual(const left: Nullable<T>;
6999 const right: Nullable.Null): Boolean;
7000begin
7001 Result := left.fHasValue <> '';
7002end;
7003
7004class operator Nullable<T>.NotEqual(const left: Nullable<T>;
7005 const right: T): Boolean;
7006begin
7007 if left.fHasValue = '' then
7008 Exit(True);
7009 Result := not EqualsInternal(left.fValue, right);
7010end;
7011
7012function Nullable<T>.ToString: string;
7013var
7014 v: TValue;
7015begin
7016 if HasValue then
7017 begin
7018 v := TValue.From<T>(fValue);
7019 Result := v.ToString;
7020 end
7021 else
7022 Result := 'Null';
7023end;
7024
7025function Nullable<T>.ToVariant: Variant;
7026var
7027 v: TValue;
7028begin
7029 if HasValue then
7030 begin
7031 v := TValue.From<T>(fValue);
7032 if v.IsType<Boolean> then
7033 Result := v.AsBoolean
7034 else
7035 Result := v.AsVariant;
7036 end
7037 else
7038 Result := Null;
7039end;
7040
7041function Nullable<T>.TryGetValue(out value: T): Boolean;
7042begin
7043 Result := fHasValue <> '';
7044 if Result then
7045 value := fValue;
7046end;
7047
7048{$ENDREGION}
7049
7050
7051{$REGION 'TNullableHelper'}
7052
7053constructor TNullableHelper.Create(typeInfo: PTypeInfo);
7054var
7055 p: PByte;
7056 field: PRecordTypeField;
7057begin
7058 p := @typeInfo.TypeData.ManagedFldCount;
7059 // skip TTypeData.ManagedFldCount and TTypeData.ManagedFields
7060 Inc(p, SizeOf(Integer) + SizeOf(TManagedField) * PInteger(p)^);
7061 // skip TTypeData.NumOps and TTypeData.RecOps
7062 Inc(p, SizeOf(Byte) + SizeOf(Pointer) * p^);
7063 // skip TTypeData.RecFldCnt
7064 Inc(p, SizeOf(Integer));
7065 // get TTypeData.RecFields[0]
7066 field := PRecordTypeField(p);
7067 fValueType := field.Field.TypeRef^;
7068 // get TTypeData.RecFields[1]
7069 field := PRecordTypeField(PByte(SkipShortString(@field.Name)) + SizeOf(TAttrData));
7070 fHasValueOffset := field.Field.FldOffset;
7071end;
7072
7073function TNullableHelper.GetValue(instance: Pointer): TValue;
7074begin
7075 TValue.Make(instance, fValueType, Result);
7076end;
7077
7078function TNullableHelper.HasValue(instance: Pointer): Boolean;
7079begin
7080 Result := PUnicodeString(PByte(instance) + fHasValueOffset)^ <> '';
7081end;
7082
7083procedure TNullableHelper.SetValue(instance: Pointer; const value: TValue);
7084begin
7085 value.Cast(fValueType).ExtractRawData(instance);
7086 if value.IsEmpty then
7087 PUnicodeString(PByte(instance) + fHasValueOffset)^ := ''
7088 else
7089 PUnicodeString(PByte(instance) + fHasValueOffset)^ := Nullable.HasValue;
7090end;
7091
7092{$ENDREGION}
7093
7094
7095{$REGION 'TLazy'}
7096
7097constructor TLazy.Create;
7098begin
7099 inherited Create;
7100 fLock := TCriticalSection.Create;
7101end;
7102
7103destructor TLazy.Destroy;
7104begin
7105 fLock.Free;
7106 inherited Destroy;
7107end;
7108
7109function TLazy.GetIsValueCreated: Boolean;
7110begin
7111 Result := fIsValueCreated;
7112end;
7113
7114{$ENDREGION}
7115
7116
7117{$REGION 'TLazy<T>'}
7118
7119constructor TLazy<T>.Create;
7120var
7121 classType: TClass;
7122 ctor: TConstructor;
7123begin
7124 Guard.CheckTypeKind<T>([tkClass], 'T');
7125
7126 classType := GetTypeData(TypeInfo(T)).ClassType;
7127 ctor := TActivator.FindConstructor(classType);
7128
7129 inherited Create;
7130 fValueFactory :=
7131 function: T
7132 begin
7133 PObject(@Result)^ := ctor(classType);
7134 end;
7135end;
7136
7137constructor TLazy<T>.Create(const valueFactory: TFunc<T>; ownsObject: Boolean);
7138begin
7139 Guard.CheckNotNull(Assigned(valueFactory), 'valueFactory');
7140
7141 inherited Create;
7142 fOwnsObjects := ownsObject;
7143 fValueFactory := valueFactory;
7144end;
7145
7146constructor TLazy<T>.CreateFrom(const value: T; ownsObject: Boolean);
7147begin
7148 inherited Create;
7149 fValue := value;
7150 fIsValueCreated := True;
7151 fOwnsObjects := ownsObject;
7152end;
7153
7154destructor TLazy<T>.Destroy;
7155begin
7156 inherited Destroy;
7157 if TType.Kind<T> = tkClass then
7158{$IFNDEF AUTOREFCOUNT}
7159 if fOwnsObjects then
7160 FreeAndNil(fValue);
7161{$ENDIF}
7162end;
7163
7164procedure TLazy<T>.InitializeValue;
7165begin
7166 fLock.Enter;
7167 try
7168 if fIsValueCreated then
7169 Exit;
7170
7171 fValue := fValueFactory();
7172 fValueFactory := nil;
7173 fIsValueCreated := True;
7174 finally
7175 fLock.Leave;
7176 end;
7177end;
7178
7179function TLazy<T>.GetValue: T;
7180begin
7181 if not fIsValueCreated then
7182 InitializeValue;
7183 Result := fValue;
7184end;
7185
7186function TLazy<T>.GetValueNonGeneric: TValue;
7187begin
7188 Result := TValue.From<T>(Value);
7189end;
7190
7191{$ENDREGION}
7192
7193
7194{$REGION 'Lazy<T>'}
7195
7196class function Lazy<T>.Create: Lazy<T>;
7197begin
7198 Result.fLazy := TLazy<T>.Create;
7199end;
7200
7201constructor Lazy<T>.Create(const valueFactory: TFunc<T>; ownsObject: Boolean);
7202begin
7203 fLazy := TLazy<T>.Create(valueFactory, ownsObject);
7204end;
7205
7206constructor Lazy<T>.CreateFrom(const value: T; ownsObject: Boolean);
7207begin
7208 fLazy := TLazy<T>.CreateFrom(value, ownsObject);
7209end;
7210
7211function Lazy<T>.GetValue: T;
7212begin
7213 if not Assigned(fLazy) then
7214 Guard.RaiseNoDelegateAssigned;
7215 Result := fLazy.Value;
7216end;
7217
7218function Lazy<T>.GetIsValueCreated: Boolean;
7219begin
7220 Result := Assigned(fLazy) and fLazy.IsValueCreated;
7221end;
7222
7223function Lazy<T>.GetIsAssigned: Boolean;
7224begin
7225 Result := Assigned(fLazy);
7226end;
7227
7228class operator Lazy<T>.Implicit(const value: Lazy<T>): ILazy<T>;
7229begin
7230 Result := value.fLazy;
7231end;
7232
7233class operator Lazy<T>.Implicit(const value: Lazy<T>): T;
7234begin
7235 Result := value.Value;
7236end;
7237
7238class operator Lazy<T>.Implicit(const value: T): Lazy<T>;
7239begin
7240 Result.fLazy := TLazy<T>.CreateFrom(value);
7241end;
7242
7243class operator Lazy<T>.Implicit(const value: TFunc<T>): Lazy<T>;
7244begin
7245 Result.fLazy := TLazy<T>.Create(value);
7246end;
7247
7248class operator Lazy<T>.Implicit(const value: TLazy<T>): Lazy<T>;
7249begin
7250 Result.fLazy := value;
7251end;
7252
7253{$ENDREGION}
7254
7255
7256{$REGION 'TLazyInitializer'}
7257
7258class function TLazyInitializer.EnsureInitialized<T>(var target: T): T;
7259var
7260 value: T;
7261begin
7262 if target = nil then
7263 begin
7264 value := T.Create;
7265 if AtomicCmpExchange(PPointer(@target)^, PPointer(@value)^, nil) <> nil then
7266 value.Free;
7267 end;
7268 Result := target;
7269end;
7270
7271class function TLazyInitializer.EnsureInitialized<T>(var target: T;
7272 const valueFactory: TFunc<T>): T;
7273var
7274 value: T;
7275begin
7276 Guard.CheckTypeKind<T>([tkClass, tkInterface], 'T');
7277
7278 if PPointer(@target)^ = nil then
7279 begin
7280 value := valueFactory;
7281 if PPointer(@value)^ = nil then
7282 raise EInvalidOperationException.CreateRes(@SValueFactoryReturnedNil);
7283 case TType.Kind<T> of
7284 tkClass:
7285 if AtomicCmpExchange(PPointer(@target)^, PPointer(@value)^, nil) <> nil then
7286 PObject(@value)^.Free;
7287 tkInterface:
7288 if AtomicCmpExchange(PPointer(@target)^, PPointer(@value)^, nil) <> nil then
7289 value := Default(T);
7290 end;
7291 end;
7292 Result := target;
7293end;
7294
7295{$ENDREGION}
7296
7297
7298{$REGION 'Shared<T>'}
7299
7300class operator Shared<T>.Implicit(const value: T): Shared<T>;
7301begin
7302 Result.fValue := value;
7303 case TType.Kind<T> of
7304{$IFNDEF AUTOREFCOUNT}
7305 tkClass:
7306 if PPointer(@value)^ = nil then
7307 Result.fFinalizer := nil
7308 else
7309 Result.fFinalizer := Shared.TObjectFinalizer.Create(PObject(@value)^);
7310{$ENDIF}
7311 tkPointer:
7312 if PPointer(@value)^ = nil then
7313 Result.fFinalizer := nil
7314 else
7315 Result.fFinalizer := Shared.TRecordFinalizer.Create(PPointer(@value)^, TypeInfo(T));
7316 end;
7317end;
7318
7319class function Shared<T>.GetNew: IShared<T>;
7320begin
7321 case TType.Kind<T> of
7322 tkClass: IShared<TObject>(Result) := Shared.TObjectFinalizer.Create(TypeInfo(T));
7323 tkPointer: IShared<Pointer>(Result) := Shared.TRecordFinalizer.Create(TypeInfo(T));
7324 end;
7325end;
7326
7327class operator Shared<T>.Implicit(const value: Shared<T>): T;
7328begin
7329 Result := value.fValue;
7330end;
7331
7332{$ENDREGION}
7333
7334
7335{$REGION 'Shared'}
7336
7337class function Shared.New<T>(const value: T): IShared<T>;
7338begin
7339 case TType.Kind<T> of
7340 tkClass: IShared<TObject>(Result) := Shared.TObjectFinalizer.Create(PObject(@value)^);
7341 tkPointer: IShared<Pointer>(Result) := Shared.TRecordFinalizer.Create(PPointer(@value)^, TypeInfo(T));
7342 end;
7343end;
7344
7345{$ENDREGION}
7346
7347
7348{$REGION 'Shared.TObjectFinalizer'}
7349
7350constructor Shared.TObjectFinalizer.Create(typeInfo: PTypeInfo);
7351begin
7352 inherited Create;
7353 fValue := TActivator.CreateInstance(typeInfo.TypeData.ClassType);
7354end;
7355
7356constructor Shared.TObjectFinalizer.Create(const value: TObject);
7357begin
7358 inherited Create;
7359 fValue := value;
7360end;
7361
7362{$IFNDEF AUTOREFCOUNT}
7363destructor Shared.TObjectFinalizer.Destroy;
7364begin
7365 fValue.Free;
7366 inherited;
7367end;
7368{$ENDIF}
7369
7370function Shared.TObjectFinalizer.Invoke: TObject;
7371begin
7372 Result := fValue;
7373end;
7374
7375{$ENDREGION}
7376
7377
7378{$REGION 'Shared.TRecordFinalizer'}
7379
7380constructor Shared.TRecordFinalizer.Create(typeInfo: PTypeInfo);
7381begin
7382 inherited Create;
7383 fTypeInfo := typeInfo.TypeData.RefType^;
7384 fValue := AllocMem(GetTypeSize(fTypeInfo));
7385end;
7386
7387constructor Shared.TRecordFinalizer.Create(const value: Pointer; typeInfo: PTypeInfo);
7388begin
7389 inherited Create;
7390 fTypeInfo := typeInfo.TypeData.RefType^;
7391 fValue := value;
7392end;
7393
7394destructor Shared.TRecordFinalizer.Destroy;
7395begin
7396 FinalizeArray(fValue, fTypeInfo, 1);
7397 FillChar(fValue^, fTypeInfo.TypeData.RecSize, 0);
7398 FreeMem(fValue);
7399 inherited;
7400end;
7401
7402function Shared.TRecordFinalizer.Invoke: Pointer;
7403begin
7404 Result := fValue;
7405end;
7406
7407{$ENDREGION}
7408
7409
7410{$REGION 'TWeakReferences'}
7411
7412type
7413 TWeakReferences = class
7414 strict private
7415 fLock: TCriticalSection;
7416 fWeakReferences: TDictionary<Pointer, TList>;
7417 class var fDefault: TWeakReferences;
7418 protected
7419 class property Default: TWeakReferences read fDefault;
7420 public
7421 constructor Create;
7422 destructor Destroy; override;
7423
7424 class constructor Create;
7425 class destructor Destroy;
7426
7427 procedure RegisterWeakRef(address: Pointer; instance: Pointer);
7428 procedure UnregisterWeakRef(address: Pointer; instance: Pointer);
7429 end;
7430
7431constructor TWeakReferences.Create;
7432begin
7433 inherited Create;
7434 fLock := TCriticalSection.Create;
7435 fWeakReferences := TObjectDictionary<Pointer, TList>.Create([doOwnsValues]);
7436end;
7437
7438destructor TWeakReferences.Destroy;
7439begin
7440 fWeakReferences.Free;
7441 fLock.Free;
7442 inherited Destroy;
7443end;
7444
7445class constructor TWeakReferences.Create;
7446begin
7447 fDefault := TWeakReferences.Create;
7448end;
7449
7450class destructor TWeakReferences.Destroy;
7451begin
7452 fDefault.Free;
7453end;
7454
7455procedure TWeakReferences.RegisterWeakRef(address, instance: Pointer);
7456var
7457 addresses: TList;
7458begin
7459 fLock.Enter;
7460 try
7461 if not fWeakReferences.TryGetValue(instance, addresses) then
7462 begin
7463 addresses := TList.Create;
7464 fWeakReferences.Add(instance, addresses);
7465 end;
7466 addresses.Add(address);
7467 finally
7468 fLock.Leave;
7469 end;
7470end;
7471
7472procedure TWeakReferences.UnregisterWeakRef(address, instance: Pointer);
7473var
7474 addresses: TList;
7475begin
7476 fLock.Enter;
7477 try
7478 if fWeakReferences.TryGetValue(instance, addresses) then
7479 begin
7480 if Assigned(address) then
7481 begin
7482 PPointer(address)^ := nil;
7483 addresses.Remove(address);
7484 if addresses.Count = 0 then
7485 fWeakReferences.Remove(instance);
7486 end
7487 else
7488 begin
7489 for address in addresses do
7490 PPointer(address)^ := nil;
7491 fWeakReferences.Remove(instance);
7492 end;
7493 end;
7494 finally
7495 fLock.Leave;
7496 end;
7497end;
7498
7499{$ENDREGION}
7500
7501
7502{$REGION 'TWeakReference'}
7503
7504type
7505 TVirtualClasses = class(Spring.VirtualClass.TVirtualClasses);
7506
7507function TWeakReference.GetIsAlive: Boolean;
7508begin
7509 Result := Assigned(fTarget);
7510end;
7511
7512procedure WeakRefFreeInstance(const Self: TObject);
7513var
7514 freeInstance: TFreeInstance;
7515begin
7516 freeInstance := GetClassData(Self.ClassParent).FreeInstance;
7517 TWeakReferences.Default.UnregisterWeakRef(nil, Self);
7518 freeInstance(Self);
7519end;
7520
7521procedure TWeakReference.RegisterWeakRef(address, instance: Pointer); //FI:O804
7522begin
7523 TVirtualClasses.Default.Proxify(instance);
7524 GetClassData(TObject(instance).ClassType).FreeInstance := WeakRefFreeInstance;
7525 TWeakReferences.Default.RegisterWeakRef(@fTarget, instance);
7526end;
7527
7528procedure TWeakReference.UnregisterWeakRef(address, instance: Pointer);
7529begin
7530 TWeakReferences.Default.UnregisterWeakRef(address, instance);
7531end;
7532
7533{$ENDREGION}
7534
7535
7536{$REGION 'TWeakReference<T>'}
7537
7538constructor TWeakReference<T>.Create(const target: T);
7539begin
7540 inherited Create;
7541 SetTarget(target);
7542end;
7543
7544constructor TWeakReference<T>.CreateInternal(const target: T;
7545 var ref: PPointer);
7546begin
7547 inherited Create;
7548 SetTarget(target);
7549 ref := @fTarget;
7550end;
7551
7552destructor TWeakReference<T>.Destroy;
7553begin
7554 SetTarget(Default(T));
7555 inherited Destroy;
7556end;
7557
7558function TWeakReference<T>.GetTarget: T;
7559begin
7560 if IsAlive then
7561 case PTypeInfo(TypeInfo(T)).Kind of
7562 tkClass: PObject(@Result)^ := TObject(fTarget);
7563 tkInterface: PInterface(@Result)^ := IInterface(fTarget)
7564 end
7565 else
7566 Result := Default(T);
7567end;
7568
7569procedure TWeakReference<T>.SetTarget(const value: T);
7570var
7571 typeInfo: PTypeInfo;
7572begin
7573 typeInfo := System.TypeInfo(T);
7574 if Assigned(fTarget) then
7575 case typeInfo.Kind of
7576 tkClass: UnregisterWeakRef(@fTarget, fTarget);
7577 tkInterface: UnregisterWeakRef(@fTarget, IInterface(fTarget) as TObject);
7578 end;
7579 fTarget := PPointer(@value)^;
7580 if Assigned(fTarget) then
7581 case typeInfo.Kind of
7582 tkClass: RegisterWeakRef(@fTarget, fTarget);
7583 tkInterface: RegisterWeakRef(@fTarget, IInterface(fTarget) as TObject);
7584 end;
7585end;
7586
7587function TWeakReference<T>.TryGetTarget(out target: T): Boolean;
7588begin
7589 target := GetTarget;
7590 Result := IsAlive;
7591end;
7592
7593{$ENDREGION}
7594
7595
7596{$REGION 'Weak<T>'}
7597
7598constructor Weak<T>.Create(const target: T);
7599begin
7600 fReference := TWeakReference<T>.CreateInternal(target, fTarget);
7601end;
7602
7603function Weak<T>.GetIsAlive: Boolean;
7604begin
7605 Result := Assigned(fReference) and Assigned(fTarget^);
7606end;
7607
7608function Weak<T>.GetTarget: T;
7609begin
7610 if Assigned(fReference) then
7611 Result := PT(fTarget)^
7612 else
7613 Result := Default(T);
7614end;
7615
7616procedure Weak<T>.SetTarget(const value: T);
7617begin
7618 if Assigned(fReference) then
7619 fReference.Target := value
7620 else
7621 fReference := TWeakReference<T>.CreateInternal(value, fTarget);
7622end;
7623
7624function Weak<T>.TryGetTarget(out target: T): Boolean;
7625begin
7626 Result := Assigned(fReference) and Assigned(fTarget^);
7627 if Result then
7628 target := PT(fTarget)^
7629 else
7630 target := Default(T);
7631end;
7632
7633class operator Weak<T>.Implicit(const value: Shared<T>): Weak<T>;
7634begin
7635 Result.Target := value.Value;
7636end;
7637
7638class operator Weak<T>.Implicit(const value: T): Weak<T>;
7639begin
7640 Result.Target := value;
7641end;
7642
7643class operator Weak<T>.Implicit(const value: Weak<T>): T;
7644begin
7645 Result := value.Target;
7646end;
7647
7648class operator Weak<T>.Equal(const left: Weak<T>;
7649 const right: T): Boolean;
7650begin
7651 if Assigned(left.fReference) then
7652 Result := PPointer(@right)^ = left.fTarget^
7653 else
7654 Result := PPointer(@right)^ = nil;
7655end;
7656
7657class operator Weak<T>.NotEqual(const left: Weak<T>;
7658 const right: T): Boolean;
7659begin
7660 if Assigned(left.fReference) then
7661 Result := PPointer(@right)^ <> left.fTarget^
7662 else
7663 Result := PPointer(@right)^ <> nil;
7664end;
7665
7666{$ENDREGION}
7667
7668
7669{$REGION 'Event<T>'}
7670
7671procedure Event<T>.Add(const handler: T);
7672begin
7673 EnsureInitialized;
7674 fInstance.Add(handler);
7675end;
7676
7677procedure Event<T>.Clear;
7678begin
7679 if Assigned(fInstance) then
7680 fInstance.Clear;
7681end;
7682
7683procedure Event<T>.EnsureInitialized;
7684begin
7685 if not Assigned(fInstance) then
7686 fInstance := TEvent<T>.Create;
7687end;
7688
7689function Event<T>.GetCanInvoke: Boolean;
7690begin
7691 Result := Assigned(fInstance) and fInstance.CanInvoke;
7692end;
7693
7694function Event<T>.GetEnabled: Boolean;
7695begin
7696 Result := not Assigned(fInstance) or fInstance.Enabled;
7697end;
7698
7699function Event<T>.GetInvoke: T;
7700begin
7701 EnsureInitialized;
7702 Result := fInstance.Invoke;
7703end;
7704
7705function Event<T>.GetOnChanged: TNotifyEvent;
7706begin
7707 EnsureInitialized;
7708 Result := fInstance.OnChanged;
7709end;
7710
7711function Event<T>.GetUseFreeNotification: Boolean;
7712begin
7713 Result := not Assigned(fInstance) or fInstance.UseFreeNotification;
7714end;
7715
7716procedure Event<T>.Remove(const handler: T);
7717begin
7718 if Assigned(fInstance) then
7719 fInstance.Remove(handler);
7720end;
7721
7722procedure Event<T>.RemoveAll(instance: Pointer);
7723begin
7724 if Assigned(fInstance) then
7725 fInstance.RemoveAll(instance);
7726end;
7727
7728procedure Event<T>.SetEnabled(const value: Boolean);
7729begin
7730 EnsureInitialized;
7731 fInstance.Enabled := value;
7732end;
7733
7734procedure Event<T>.SetOnChanged(value: TNotifyEvent);
7735begin
7736 EnsureInitialized;
7737 fInstance.OnChanged := value;
7738end;
7739
7740procedure Event<T>.SetUseFreeNotification(const value: Boolean);
7741begin
7742 EnsureInitialized;
7743 fInstance.UseFreeNotification := value;
7744end;
7745
7746class operator Event<T>.Implicit(const value: IEvent<T>): Event<T>;
7747begin
7748 Result.fInstance := value;
7749end;
7750
7751class operator Event<T>.Implicit(var value: Event<T>): IEvent<T>;
7752begin
7753 value.EnsureInitialized;
7754 Result := value.fInstance;
7755end;
7756
7757class operator Event<T>.Implicit(var value: Event<T>): T;
7758begin
7759 Result := value.Invoke;
7760end;
7761
7762{$ENDREGION}
7763
7764
7765{$REGION 'TTypeInfoHelper'}
7766
7767function TTypeInfoHelper.GetRttiType: TRttiType;
7768begin
7769 Result := TType.GetType(@Self);
7770end;
7771
7772{$IFNDEF DELPHIXE3_UP}
7773function TTypeInfoHelper.TypeData: PTypeData;
7774begin
7775 Result := GetTypeData(@Self);
7776end;
7777{$ENDIF}
7778
7779function TTypeInfoHelper.TypeName: string;
7780begin
7781{$IFNDEF NEXTGEN}
7782 Result := UTF8ToString(Name);
7783{$ELSE}
7784 Result := NameFld.ToString;
7785{$ENDIF}
7786end;
7787
7788{$ENDREGION}
7789
7790
7791{$REGION 'TTypeDataHelper'}
7792
7793{$IFNDEF DELPHIXE3_UP}
7794function TTypeDataHelper.DynArrElType: PPTypeInfo;
7795begin
7796 Result := PPointer(SkipShortString(@DynUnitName))^;
7797end;
7798{$ENDIF}
7799
7800{$ENDREGION}
7801
7802
7803{$REGION 'TEventArgs'}
7804
7805constructor TEventArgs.Create;
7806begin
7807 inherited Create;
7808end;
7809
7810{$ENDREGION}
7811
7812
7813{$REGION 'TPropertyChangedEventArgs'}
7814
7815constructor TPropertyChangedEventArgs.Create(const propertyName: string);
7816begin
7817 inherited Create;
7818 fPropertyName := propertyName;
7819end;
7820
7821function TPropertyChangedEventArgs.GetPropertyName: string;
7822begin
7823 Result := fPropertyName;
7824end;
7825
7826{$ENDREGION}
7827
7828
7829{$REGION 'TNotificationHandler'}
7830
7831procedure TNotificationHandler.Notification(Component: TComponent;
7832 Operation: TOperation);
7833begin
7834 inherited Notification(Component, Operation);
7835 if Assigned(fOnNotification) then
7836 fOnNotification(Component, Operation);
7837end;
7838
7839{$ENDREGION}
7840
7841
7842{$REGION 'TInterfacedCriticalSection'}
7843
7844function TInterfacedCriticalSection.QueryInterface(const IID: TGUID; out Obj): HResult;
7845begin
7846 if GetInterface(IID, Obj) then
7847 Result := 0
7848 else
7849 Result := E_NOINTERFACE;
7850end;
7851
7852function TInterfacedCriticalSection._AddRef: Integer;
7853begin
7854{$IFNDEF AUTOREFCOUNT}
7855 Result := AtomicIncrement(fRefCount);
7856{$ELSE}
7857 Result := __ObjAddRef;
7858{$ENDIF}
7859end;
7860
7861function TInterfacedCriticalSection._Release: Integer;
7862begin
7863{$IFNDEF AUTOREFCOUNT}
7864 Result := AtomicDecrement(fRefCount);
7865 if Result = 0 then
7866 Destroy;
7867{$ELSE}
7868 Result := __ObjRelease;
7869{$ENDIF}
7870end;
7871
7872function TInterfacedCriticalSection.ScopedLock: IInterface;
7873begin
7874 Result := TScopedLock.Create(Self);
7875end;
7876
7877{$ENDREGION}
7878
7879
7880{$REGION 'TInterfacedCriticalSection.TScopedLock'}
7881
7882constructor TInterfacedCriticalSection.TScopedLock.Create(
7883 const criticalSection: ICriticalSection);
7884begin
7885 inherited Create;
7886 fCriticalSection := criticalSection;
7887 fCriticalSection.Enter;
7888end;
7889
7890destructor TInterfacedCriticalSection.TScopedLock.Destroy;
7891begin
7892 fCriticalSection.Leave;
7893 inherited Destroy;
7894end;
7895
7896{$ENDREGION}
7897
7898
7899{$REGION 'Lock'}
7900
7901procedure Lock.EnsureInitialized;
7902var
7903 criticalSection: ICriticalSection;
7904begin
7905 if not Assigned(fCriticalSection) then
7906 begin
7907 criticalSection := TInterfacedCriticalSection.Create;
7908 if AtomicCmpExchange(Pointer(fCriticalSection),
7909 Pointer(criticalSection), nil) = nil then
7910 Pointer(criticalSection) := nil;
7911 end;
7912end;
7913
7914procedure Lock.Enter;
7915begin
7916 EnsureInitialized;
7917 fCriticalSection.Enter;
7918end;
7919
7920procedure Lock.Leave;
7921begin
7922 if not Assigned(fCriticalSection) then
7923 raise EInvalidOperationException.CreateRes(@SCriticalSectionNotInitialized);
7924 fCriticalSection.Leave;
7925end;
7926
7927function Lock.ScopedLock: IInterface;
7928begin
7929 EnsureInitialized;
7930 Result := fCriticalSection.ScopedLock;
7931end;
7932
7933{$ENDREGION}
7934
7935
7936{$REGION 'TActivator'}
7937
7938class constructor TActivator.Create;
7939begin
7940 ConstructorCache := TDictionary<PTypeInfo,TConstructor>.Create;
7941end;
7942
7943class destructor TActivator.Destroy;
7944begin
7945 ConstructorCache.Free;
7946end;
7947
7948class procedure TActivator.ClearCache;
7949begin
7950 ConstructorCache.Clear;
7951end;
7952
7953class function TActivator.CreateInstance(
7954 const classType: TRttiInstanceType): TValue;
7955begin
7956 Result := CreateInstance(classType, []);
7957end;
7958
7959class function TActivator.CreateInstance(const classType: TRttiInstanceType;
7960 const arguments: array of TValue): TValue;
7961var
7962 method: TRttiMethod;
7963begin
7964 method := FindConstructor(classType, arguments);
7965 if not Assigned(method) then
7966 RaiseNoConstructorFound(classType.MetaclassType);
7967 Result := CreateInstance(classType, method, arguments)
7968end;
7969
7970class function TActivator.CreateInstance(const classType: TRttiInstanceType;
7971 const constructorMethod: TRttiMethod; const arguments: array of TValue): TValue;
7972begin
7973 Result := constructorMethod.Invoke(classType.MetaclassType, arguments);
7974end;
7975
7976class function TActivator.CreateInstance(typeInfo: PTypeInfo): TObject;
7977begin
7978 Result := CreateInstance(typeInfo.TypeData.ClassType);
7979end;
7980
7981class function TActivator.CreateInstance(const typeName: string): TObject;
7982begin
7983 Result := CreateInstance(typeName, []);
7984end;
7985
7986class function TActivator.CreateInstance(const typeName: string;
7987 const arguments: array of TValue): TObject;
7988var
7989 rttiType: TRttiType;
7990begin
7991 rttiType := TType.Context.FindType(typeName);
7992 Result := CreateInstance(TRttiInstanceType(rttiType), arguments).AsObject;
7993end;
7994
7995class function TActivator.CreateInstance(classType: TClass): TObject;
7996var
7997 ctor: TConstructor;
7998begin
7999 ctor := FindConstructor(classType);
8000 Result := ctor(classType);
8001end;
8002
8003class function TActivator.CreateInstance(classType: TClass;
8004 const arguments: array of TValue): TObject;
8005var
8006 ctor: TRttiMethod;
8007begin
8008 if Length(arguments) = 0 then
8009 Exit(CreateInstance(classType));
8010 ctor := FindConstructor(TType.GetType(classType), arguments);
8011 if not Assigned(ctor) then
8012 RaiseNoConstructorFound(classType);
8013 Result := ctor.Invoke(classType, arguments).AsObject;
8014end;
8015
8016class function TActivator.CreateInstance<T>: T;
8017begin
8018 Result := T(CreateInstance(TClass(T)));
8019end;
8020
8021class function TActivator.CreateInstance<T>(
8022 const arguments: array of TValue): T;
8023begin
8024 Result := T(CreateInstance(TClass(T), arguments));
8025end;
8026
8027class function TActivator.FindConstructor(classType: TClass): TConstructor;
8028var
8029 classInfo: PTypeInfo;
8030 method: TRttiMethod;
8031begin
8032 Assert(Assigned(classType));
8033 classInfo := classType.ClassInfo;
8034 if ConstructorCache.TryGetValue(classInfo, Result) then
8035 Exit;
8036
8037 for method in TType.GetType(classInfo).GetMethods do
8038 begin
8039 if not method.IsConstructor then
8040 Continue;
8041
8042 if Length(method.GetParameters) = 0 then
8043 begin
8044 Result := method.CodeAddress;
8045 ConstructorCache.AddOrSetValue(classInfo, Result);
8046 Exit;
8047 end;
8048 end;
8049 Result := nil;
8050end;
8051
8052class function TActivator.FindConstructor(const classType: TRttiInstanceType;
8053 const arguments: array of TValue): TRttiMethod;
8054
8055 function Assignable(const params: TArray<TRttiParameter>;
8056 const args: array of TValue): Boolean;
8057 var
8058 i: Integer;
8059 v: TValue;
8060 begin
8061 Result := Length(params) = Length(args);
8062 if Result then
8063 for i := Low(args) to High(args) do
8064 if not args[i].TryCast(params[i].paramType.Handle, v) then
8065 Exit(False);
8066 end;
8067
8068var
8069 method: TRttiMethod;
8070begin
8071 for method in classType.GetMethods do
8072 begin
8073 if not method.IsConstructor then
8074 Continue;
8075
8076 if Assignable(method.GetParameters, arguments) then
8077 begin
8078 if Length(arguments) = 0 then
8079 ConstructorCache.AddOrSetValue(classType.Handle, method.CodeAddress);
8080 Exit(method);
8081 end;
8082 end;
8083 Result := nil;
8084end;
8085
8086class procedure TActivator.RaiseNoConstructorFound(classType: TClass);
8087begin
8088 raise ENotSupportedException.CreateResFmt(
8089 @SNoConstructorFound, [classType.ClassName]);
8090end;
8091
8092{$ENDREGION}
8093
8094
8095{$REGION 'Tuple<T1, T2>'}
8096
8097constructor Tuple<T1, T2>.Create(const value1: T1; const value2: T2);
8098begin
8099 fValue1 := value1;
8100 fValue2 := value2;
8101end;
8102
8103function Tuple<T1, T2>.Equals(const value: Tuple<T1, T2>): Boolean;
8104var
8105 comparer1: IEqualityComparer<T1>;
8106 comparer2: IEqualityComparer<T2>;
8107begin
8108 comparer1 := TEqualityComparer<T1>.Default;
8109 comparer2 := TEqualityComparer<T2>.Default;
8110 Result := comparer1.Equals(fValue1, value.Value1)
8111 and comparer2.Equals(fValue2, value.Value2);
8112end;
8113
8114class operator Tuple<T1, T2>.Equal(const left, right: Tuple<T1, T2>): Boolean;
8115begin
8116 Result := left.Equals(right);
8117end;
8118
8119class operator Tuple<T1, T2>.Implicit(
8120 const values: Tuple<T1, T2>): TArray<TValue>;
8121begin
8122 SetLength(Result, 2);
8123 Result[0] := TValue.From<T1>(values.Value1);
8124 Result[1] := TValue.From<T2>(values.Value2);
8125end;
8126
8127class operator Tuple<T1, T2>.Implicit(
8128 const values: TArray<TValue>): Tuple<T1, T2>;
8129begin
8130 Result.fValue1 := values[0].AsType<T1>;
8131 Result.fValue2 := values[1].AsType<T2>;
8132end;
8133
8134class operator Tuple<T1, T2>.Implicit(
8135 const values: array of const): Tuple<T1, T2>;
8136var
8137 value: TValue;
8138begin
8139 value := TValue.FromVarRec(values[0]);
8140 Result.fValue1 := value.AsType<T1>;
8141 value := TValue.FromVarRec(values[1]);
8142 Result.fValue2 := value.AsType<T2>;
8143end;
8144
8145class operator Tuple<T1, T2>.NotEqual(const left,
8146 right: Tuple<T1, T2>): Boolean;
8147begin
8148 Result := not left.Equals(right);
8149end;
8150
8151procedure Tuple<T1, T2>.Unpack(out value1: T1; out value2: T2);
8152begin
8153 value1 := fValue1;
8154 value2 := fValue2;
8155end;
8156
8157{$ENDREGION}
8158
8159
8160{$REGION 'Tuple<T1, T2, T3>'}
8161
8162constructor Tuple<T1, T2, T3>.Create(const value1: T1; const value2: T2;
8163 const value3: T3);
8164begin
8165 fValue1 := value1;
8166 fValue2 := value2;
8167 fValue3 := value3;
8168end;
8169
8170function Tuple<T1, T2, T3>.Equals(const value: Tuple<T1, T2, T3>): Boolean;
8171var
8172 comparer1: IEqualityComparer<T1>;
8173 comparer2: IEqualityComparer<T2>;
8174 comparer3: IEqualityComparer<T3>;
8175begin
8176 comparer1 := TEqualityComparer<T1>.Default;
8177 comparer2 := TEqualityComparer<T2>.Default;
8178 comparer3 := TEqualityComparer<T3>.Default;
8179 Result := comparer1.Equals(fValue1, value.Value1)
8180 and comparer2.Equals(fValue2, value.Value2)
8181 and comparer3.Equals(fValue3, value.Value3);
8182end;
8183
8184class operator Tuple<T1, T2, T3>.Equal(const left,
8185 right: Tuple<T1, T2, T3>): Boolean;
8186begin
8187 Result := left.Equals(right);
8188end;
8189
8190class operator Tuple<T1, T2, T3>.Implicit(
8191 const values: Tuple<T1, T2, T3>): TArray<TValue>;
8192begin
8193 SetLength(Result, 3);
8194 Result[0] := TValue.From<T1>(values.Value1);
8195 Result[1] := TValue.From<T2>(values.Value2);
8196 Result[2] := TValue.From<T3>(values.Value3);
8197end;
8198
8199class operator Tuple<T1, T2, T3>.Implicit(
8200 const values: Tuple<T1, T2, T3>): Tuple<T1, T2>;
8201begin
8202 Result.fValue1 := values.Value1;
8203 Result.fValue2 := values.Value2;
8204end;
8205
8206class operator Tuple<T1, T2, T3>.Implicit(
8207 const values: TArray<TValue>): Tuple<T1, T2, T3>;
8208begin
8209 Result.fValue1 := values[0].AsType<T1>;
8210 Result.fValue2 := values[1].AsType<T2>;
8211 Result.fValue3 := values[2].AsType<T3>;
8212end;
8213
8214class operator Tuple<T1, T2, T3>.Implicit(
8215 const values: array of const): Tuple<T1, T2, T3>;
8216var
8217 value: TValue;
8218begin
8219 value := TValue.FromVarRec(values[0]);
8220 Result.fValue1 := value.AsType<T1>;
8221 value := TValue.FromVarRec(values[1]);
8222 Result.fValue2 := value.AsType<T2>;
8223 value := TValue.FromVarRec(values[2]);
8224 Result.fValue3 := value.AsType<T3>;
8225end;
8226
8227class operator Tuple<T1, T2, T3>.NotEqual(const left,
8228 right: Tuple<T1, T2, T3>): Boolean;
8229begin
8230 Result := not left.Equals(right);
8231end;
8232
8233procedure Tuple<T1, T2, T3>.Unpack(out value1: T1; out value2: T2);
8234begin
8235 value1 := fValue1;
8236 value2 := fValue2;
8237end;
8238
8239procedure Tuple<T1, T2, T3>.Unpack(out value1: T1; out value2: T2;
8240 out value3: T3);
8241begin
8242 value1 := fValue1;
8243 value2 := fValue2;
8244 value3 := fValue3;
8245end;
8246
8247{$ENDREGION}
8248
8249
8250{$REGION 'Tuple<T1, T2, T3, T4>'}
8251
8252constructor Tuple<T1, T2, T3, T4>.Create(const value1: T1; const value2: T2;
8253 const value3: T3; const value4: T4);
8254begin
8255 fValue1 := value1;
8256 fValue2 := value2;
8257 fValue3 := value3;
8258 fValue4 := value4;
8259end;
8260
8261function Tuple<T1, T2, T3, T4>.Equals(
8262 const value: Tuple<T1, T2, T3, T4>): Boolean;
8263var
8264 comparer1: IEqualityComparer<T1>;
8265 comparer2: IEqualityComparer<T2>;
8266 comparer3: IEqualityComparer<T3>;
8267 comparer4: IEqualityComparer<T4>;
8268begin
8269 comparer1 := TEqualityComparer<T1>.Default;
8270 comparer2 := TEqualityComparer<T2>.Default;
8271 comparer3 := TEqualityComparer<T3>.Default;
8272 comparer4 := TEqualityComparer<T4>.Default;
8273 Result := comparer1.Equals(fValue1, value.Value1)
8274 and comparer2.Equals(fValue2, value.Value2)
8275 and comparer3.Equals(fValue3, value.Value3)
8276 and comparer4.Equals(fValue4, value.Value4);
8277end;
8278
8279class operator Tuple<T1, T2, T3, T4>.Equal(const left,
8280 right: Tuple<T1, T2, T3, T4>): Boolean;
8281begin
8282 Result := left.Equals(right);
8283end;
8284
8285class operator Tuple<T1, T2, T3, T4>.Implicit(
8286 const values: Tuple<T1, T2, T3, T4>): TArray<TValue>;
8287begin
8288 SetLength(Result, 4);
8289 Result[0] := TValue.From<T1>(values.Value1);
8290 Result[1] := TValue.From<T2>(values.Value2);
8291 Result[2] := TValue.From<T3>(values.Value3);
8292 Result[3] := TValue.From<T4>(values.Value4);
8293end;
8294
8295class operator Tuple<T1, T2, T3, T4>.Implicit(
8296 const values: Tuple<T1, T2, T3, T4>): Tuple<T1, T2>;
8297begin
8298 Result.fValue1 := values.Value1;
8299 Result.fValue2 := values.Value2;
8300end;
8301
8302class operator Tuple<T1, T2, T3, T4>.Implicit(
8303 const values: Tuple<T1, T2, T3, T4>): Tuple<T1, T2, T3>;
8304begin
8305 Result.fValue1 := values.Value1;
8306 Result.fValue2 := values.Value2;
8307 Result.fValue3 := values.Value3;
8308end;
8309
8310class operator Tuple<T1, T2, T3, T4>.Implicit(
8311 const values: TArray<TValue>): Tuple<T1, T2, T3, T4>;
8312begin
8313 Result.fValue1 := values[0].AsType<T1>;
8314 Result.fValue2 := values[1].AsType<T2>;
8315 Result.fValue3 := values[2].AsType<T3>;
8316 Result.fValue4 := values[3].AsType<T4>;
8317end;
8318
8319class operator Tuple<T1, T2, T3, T4>.Implicit(
8320 const values: array of const): Tuple<T1, T2, T3, T4>;
8321var
8322 value: TValue;
8323begin
8324 value := TValue.FromVarRec(values[0]);
8325 Result.fValue1 := value.AsType<T1>;
8326 value := TValue.FromVarRec(values[1]);
8327 Result.fValue2 := value.AsType<T2>;
8328 value := TValue.FromVarRec(values[2]);
8329 Result.fValue3 := value.AsType<T3>;
8330 value := TValue.FromVarRec(values[3]);
8331 Result.fValue4 := value.AsType<T4>;
8332end;
8333
8334class operator Tuple<T1, T2, T3, T4>.NotEqual(const left,
8335 right: Tuple<T1, T2, T3, T4>): Boolean;
8336begin
8337 Result := not left.Equals(right);
8338end;
8339
8340procedure Tuple<T1, T2, T3, T4>.Unpack(out value1: T1; out value2: T2);
8341begin
8342 value1 := fValue1;
8343 value2 := fValue2;
8344end;
8345
8346procedure Tuple<T1, T2, T3, T4>.Unpack(out value1: T1; out value2: T2;
8347 out value3: T3);
8348begin
8349 value1 := fValue1;
8350 value2 := fValue2;
8351 value3 := fValue3;
8352end;
8353
8354procedure Tuple<T1, T2, T3, T4>.Unpack(out value1: T1; out value2: T2;
8355 out value3: T3; out value4: T4);
8356begin
8357 value1 := fValue1;
8358 value2 := fValue2;
8359 value3 := fValue3;
8360 value4 := fValue4;
8361end;
8362
8363{$ENDREGION}
8364
8365
8366{$REGION 'Tuple'}
8367
8368class function Tuple.Create<T1, T2>(const value1: T1;
8369 const value2: T2): Tuple<T1, T2>;
8370begin
8371 Result.fValue1 := value1;
8372 Result.fValue2 := value2;
8373end;
8374
8375class function Tuple.Create<T1, T2, T3>(const value1: T1; const value2: T2;
8376 const value3: T3): Tuple<T1, T2, T3>;
8377begin
8378 Result.fValue1 := value1;
8379 Result.fValue2 := value2;
8380 Result.fValue3 := value3;
8381end;
8382
8383class function Tuple.Create<T1, T2, T3, T4>(const value1: T1; const value2: T2;
8384 const value3: T3; const value4: T4): Tuple<T1, T2, T3, T4>;
8385begin
8386 Result.fValue1 := value1;
8387 Result.fValue2 := value2;
8388 Result.fValue3 := value3;
8389 Result.fValue4 := value4;
8390end;
8391
8392{$ENDREGION}
8393
8394
8395{$REGION 'TArray'}
8396
8397class function TArray.BinarySearch<T>(const values: array of T; const item: T;
8398 out foundIndex: Integer; const comparer: IComparer<T>; index,
8399 count: Integer): Boolean;
8400var
8401 left, right, i, c: Integer;
8402begin
8403{$IFDEF SPRING_ENABLE_GUARD}
8404 Guard.CheckNotNull(Assigned(comparer), 'comparer');
8405 Guard.CheckRange((index >= 0) and (index <= Length(values)), 'index');
8406 Guard.CheckRange((count >= 0) and (count <= Length(values) - index), 'count');
8407{$ENDIF}
8408
8409 if count = 0 then
8410 begin
8411 foundIndex := index;
8412 Exit(False);
8413 end;
8414
8415 Result := False;
8416 left := index;
8417 right := index + count - 1;
8418 while left <= right do
8419 begin
8420 i := left + (right - left) shr 1;
8421 c := comparer.Compare(values[i], Item);
8422 if c < 0 then
8423 left := i + 1
8424 else
8425 begin
8426 right := i - 1;
8427 if c = 0 then
8428 Result := True;
8429 end;
8430 end;
8431 foundIndex := left;
8432end;
8433
8434class function TArray.BinarySearch<T>(const values: array of T; const item: T;
8435 out foundIndex: Integer; const comparer: IComparer<T>): Boolean;
8436begin
8437 Result := BinarySearch<T>(values, item, foundIndex, comparer,
8438 Low(values), Length(values));
8439end;
8440
8441class function TArray.BinarySearch<T>(const values: array of T; const item: T;
8442 out foundIndex: Integer): Boolean;
8443begin
8444 Result := BinarySearch<T>(values, item, foundIndex, TComparer<T>.Default(),
8445 Low(values), Length(values));
8446end;
8447
8448class function TArray.BinarySearch<T>(const values: array of T; const item: T;
8449 out foundIndex: Integer; const comparison: TComparison<T>; index,
8450 count: Integer): Boolean;
8451begin
8452 Result := BinarySearch<T>(values, item, foundIndex,
8453 IComparer<T>(PPointer(@comparison)^), index, count);
8454end;
8455
8456class function TArray.BinarySearch<T>(const values: array of T; const item: T;
8457 out foundIndex: Integer; const comparison: TComparison<T>): Boolean;
8458begin
8459 Result := BinarySearch<T>(values, item, foundIndex,
8460 IComparer<T>(PPointer(@comparison)^));
8461end;
8462
8463class function TArray.BinarySearchUpperBound<T>(const values: array of T;
8464 const item: T; out foundIndex: Integer; const comparer: IComparer<T>;
8465 index, count: Integer): Boolean;
8466var
8467 left, right, i, c: Integer;
8468begin
8469{$IFDEF SPRING_ENABLE_GUARD}
8470 Guard.CheckNotNull(Assigned(comparer), 'comparer');
8471 Guard.CheckRange((index >= 0) and (index <= Length(values)), 'index');
8472 Guard.CheckRange((count >= 0) and (count <= Length(values) - index), 'count');
8473{$ENDIF}
8474
8475 if count = 0 then
8476 begin
8477 foundIndex := index;
8478 Exit(False);
8479 end;
8480
8481 Result := False;
8482 left := index;
8483 right := index + count - 1;
8484 while left <= right do
8485 begin
8486 i := left + (right - left) shr 1;
8487 c := comparer.Compare(values[i], item);
8488 if c > 0 then
8489 right := i - 1
8490 else
8491 begin
8492 left := i + 1;
8493 if c = 0 then
8494 Result := True;
8495 end;
8496 end;
8497 foundIndex := right;
8498end;
8499
8500class function TArray.BinarySearchUpperBound<T>(const values: array of T;
8501 const item: T; out foundIndex: Integer;
8502 const comparer: IComparer<T>): Boolean;
8503begin
8504 Result := BinarySearchUpperBound<T>(values, item, foundIndex, comparer,
8505 Low(values), Length(values));
8506end;
8507
8508class function TArray.BinarySearchUpperBound<T>(const values: array of T;
8509 const item: T; out foundIndex: Integer): Boolean;
8510begin
8511 Result := BinarySearchUpperBound<T>(values, item, foundIndex,
8512 TComparer<T>.Default(), Low(values), Length(values));
8513end;
8514
8515class function TArray.BinarySearchUpperBound<T>(const values: array of T;
8516 const item: T; out foundIndex: Integer; const comparison: TComparison<T>;
8517 index, count: Integer): Boolean;
8518begin
8519 Result := BinarySearchUpperBound<T>(values, item, foundIndex,
8520 IComparer<T>(PPointer(@comparison)^), index, count);
8521end;
8522
8523class function TArray.BinarySearchUpperBound<T>(const values: array of T;
8524 const item: T; out foundIndex: Integer;
8525 const comparison: TComparison<T>): Boolean;
8526begin
8527 Result := BinarySearchUpperBound<T>(values, item, foundIndex,
8528 IComparer<T>(PPointer(@comparison)^), Low(values), Length(values));
8529end;
8530
8531class function TArray.Concat<T>(const values: array of TArray<T>): TArray<T>;
8532var
8533 i, k, n: Integer;
8534begin
8535 n := 0;
8536 for i := Low(values) to High(values) do
8537 Inc(n, Length(values[i]));
8538 SetLength(Result, n);
8539 n := 0;
8540 for i := Low(values) to High(values) do
8541 for k := Low(values[i]) to High(values[i]) do
8542 begin
8543 Result[n] := values[i, k];
8544 Inc(n);
8545 end;
8546end;
8547
8548class function TArray.Contains<T>(const values: array of T;
8549 const item: T): Boolean;
8550var
8551 comparer: IEqualityComparer<T>;
8552 i: Integer;
8553begin
8554 comparer := TEqualityComparer<T>.Default;
8555 for i := Low(Values) to High(Values) do
8556 if comparer.Equals(values[i], item) then
8557 Exit(True);
8558 Result := False;
8559end;
8560
8561class function TArray.Copy<T>(const values: array of T): TArray<T>;
8562var
8563 i: Integer;
8564begin
8565 SetLength(Result, Length(values));
8566 for i := Low(values) to High(values) do
8567 Result[i] := values[i];
8568end;
8569
8570class procedure TArray.Copy<T>(const source: array of T;
8571 var target: array of T; count: NativeInt);
8572begin
8573 Copy<T>(source, target, 0, 0, count);
8574end;
8575
8576class procedure TArray.Copy<T>(const source: array of T;
8577 var target: array of T; sourceIndex, targetIndex, count: NativeInt);
8578var
8579 sourceLength, targetLength: NativeInt;
8580begin
8581{$IFDEF SPRING_ENABLE_GUARD}
8582 sourceLength := Length(source);
8583 targetLength := Length(target);
8584 Guard.CheckRange((sourceIndex >= 0) and (sourceIndex <= sourceLength), 'sourceIndex');
8585 Guard.CheckRange((targetIndex >= 0) and (targetIndex <= targetLength), 'targetIndex');
8586 Guard.CheckRange((count >= 0)
8587 and (count <= sourceLength - sourceIndex)
8588 and (count <= targetLength - targetIndex), 'count');
8589 if Pointer(@source[0]) = Pointer(@target[0]) then
8590 raise EArgumentException.CreateRes(@SArraysIdentical);
8591{$ENDIF}
8592 if TType.IsManaged<T> then
8593 System.CopyArray(Pointer(@target[targetIndex]), Pointer(@source[sourceIndex]), TypeInfo(T), count)
8594 else
8595 System.Move(Pointer(@source[sourceIndex])^, Pointer(@target[targetIndex])^, count * SizeOf(T));
8596end;
8597
8598class procedure TArray.ForEach<T>(const values: array of T;
8599 const action: TAction<T>);
8600var
8601 i: Integer;
8602begin
8603 for i := Low(values) to High(values) do
8604 action(values[i]);
8605end;
8606
8607class function TArray.IndexOf<T>(const values: array of T;
8608 const item: T): Integer;
8609begin
8610 Result := IndexOf<T>(values, item,
8611 0, Length(values), TEqualityComparer<T>.Default);
8612end;
8613
8614class function TArray.IndexOf<T>(const values: array of T; const item: T;
8615 index: Integer): Integer;
8616begin
8617 Result := IndexOf<T>(values, item,
8618 index, Length(values) - index, TEqualityComparer<T>.Default);
8619end;
8620
8621class function TArray.IndexOf<T>(const values: array of T; const item: T;
8622 index, count: Integer): Integer;
8623begin
8624 Result := IndexOf<T>(values, item,
8625 index, count, TEqualityComparer<T>.Default);
8626end;
8627
8628class function TArray.IndexOf<T>(const values: array of T; const item: T;
8629 index, count: Integer; const comparer: IEqualityComparer<T>): Integer;
8630var
8631 i: Integer;
8632begin
8633{$IFDEF SPRING_ENABLE_GUARD}
8634 Guard.CheckNotNull(Assigned(comparer), 'comparer');
8635 Guard.CheckRange((index >= 0) and (index <= Length(values)), 'index');
8636 Guard.CheckRange((count >= 0) and (count <= Length(values) - index), 'count');
8637{$ENDIF}
8638
8639 for i := index to index + count - 1 do
8640 if comparer.Equals(values[i], item) then
8641 Exit(i);
8642 Result := -1;
8643end;
8644
8645class function TArray.LastIndexOf<T>(const values: array of T;
8646 const item: T): Integer;
8647begin
8648 Result := LastIndexOf<T>(values, item,
8649 0, Length(values), TEqualityComparer<T>.Default);
8650end;
8651
8652class function TArray.LastIndexOf<T>(const values: array of T; const item: T;
8653 index: Integer): Integer;
8654begin
8655 Result := LastIndexOf<T>(values, item,
8656 index, Length(values) - index, TEqualityComparer<T>.Default);
8657end;
8658
8659class function TArray.LastIndexOf<T>(const values: array of T; const item: T;
8660 index, count: Integer): Integer;
8661begin
8662 Result := LastIndexOf<T>(values, item,
8663 index, count, TEqualityComparer<T>.Default);
8664end;
8665
8666class function TArray.LastIndexOf<T>(const values: array of T; const item: T;
8667 index, count: Integer; const comparer: IEqualityComparer<T>): Integer;
8668var
8669 i: Integer;
8670begin
8671{$IFDEF SPRING_ENABLE_GUARD}
8672 Guard.CheckRange((index >= 0) and (index <= Length(values)), 'index');
8673 Guard.CheckRange((count >= 0) and (count <= Length(values) - index), 'count');
8674{$ENDIF}
8675
8676 for i := index + count - 1 downto index do
8677 if comparer.Equals(values[i], item) then
8678 Exit(i);
8679 Result := -1;
8680end;
8681
8682class procedure TArray.Reverse<T>(var values: array of T);
8683begin
8684 Reverse<T>(values, 0, Length(values));
8685end;
8686
8687class procedure TArray.Reverse<T>(var values: array of T; index,
8688 count: Integer);
8689var
8690 temp: T;
8691 index1, index2: Integer;
8692begin
8693{$IFDEF SPRING_ENABLE_GUARD}
8694 Guard.CheckRange((index >= 0) and (index <= Length(values)), 'index');
8695 Guard.CheckRange((count >= 0) and (count <= Length(values) - index), 'count');
8696{$ENDIF}
8697
8698 index1 := index;
8699 index2 := index + count - 1;
8700 while index1 < index2 do
8701 begin
8702 temp := values[index1];
8703 values[index1] := values[index2];
8704 values[index2] := temp;
8705 Inc(index1);
8706 Dec(index2);
8707 end;
8708end;
8709
8710class procedure TArray.Shuffle<T>(var values: array of T);
8711begin
8712 Shuffle<T>(values, 0, Length(values));
8713end;
8714
8715class procedure TArray.Shuffle<T>(var values: array of T; index: Integer);
8716begin
8717 Shuffle<T>(values, index, Length(values) - index);
8718end;
8719
8720class procedure TArray.Shuffle<T>(var values: array of T; index,
8721 count: Integer);
8722var
8723 i: Integer;
8724 temp: T;
8725begin
8726{$IFDEF SPRING_ENABLE_GUARD}
8727 Guard.CheckRange((index >= 0) and (index <= Length(values)), 'index');
8728 Guard.CheckRange((count >= 0) and (count <= Length(values) - index), 'count');
8729{$ENDIF}
8730
8731 while count > 1 do
8732 begin
8733 i := Random(count) + index;
8734 Dec(count);
8735 temp := values[index];
8736 values[index] := values[i];
8737 values[i] := temp;
8738 Inc(index);
8739 end;
8740end;
8741
8742procedure SwapPtr(var left, right);
8743var
8744 temp: Pointer;
8745begin
8746 temp := Pointer(left);
8747 Pointer(left) := Pointer(right);
8748 Pointer(right) := temp;
8749end;
8750
8751class function TArray.GetDepthLimit(count: Integer): Integer;
8752begin
8753 Result := 0;
8754 while count > 0 do
8755 begin
8756 Inc(Result);
8757 count := count div 2;
8758 end;
8759 Result := Result * 2;
8760end;
8761
8762class procedure TArray.Swap<T>(var left, right: T);
8763var
8764 temp: T;
8765begin
8766{$IFDEF DELPHIXE7_UP} // XE7 and higher
8767 case GetTypeKind(T) of
8768{$IFDEF AUTOREFCOUNT}
8769 tkClass,
8770{$ENDIF AUTOREFCOUNT}
8771 tkInterface,
8772 tkDynArray,
8773 tkUString:
8774 SwapPtr(left, right);
8775 else
8776 temp := left;
8777 left := right;
8778 right := temp;
8779 end;
8780{$ELSE}
8781 temp := left;
8782 left := right;
8783 right := temp;
8784{$ENDIF}
8785end;
8786
8787class procedure TArray.SortTwoItems<T>(const comparer: IComparer<T>;
8788 var left, right: T);
8789begin
8790 if comparer.Compare(left, right) > 0 then
8791 Swap<T>(left, right);
8792end;
8793
8794class procedure TArray.SortThreeItems<T>(const comparer: IComparer<T>;
8795 var left, mid, right: T);
8796begin
8797 if comparer.Compare(left, mid) > 0 then
8798 Swap<T>(left, mid);
8799 if comparer.Compare(left, right) > 0 then
8800 Swap<T>(left, right);
8801 if comparer.Compare(mid, right) > 0 then
8802 Swap<T>(mid, right);
8803end;
8804
8805class procedure TArray.DownHeap<T>(var values: array of T;
8806 const comparer: IComparer<T>; left, count, i: Integer);
8807var
8808 temp: T;
8809 child, n, x: Integer;
8810begin
8811 temp := values[left + i - 1];
8812 n := count div 2;
8813 while i <= n do
8814 begin
8815 child := i * 2;
8816 if (child < count) and (comparer.Compare(values[left + child - 1], values[left + child]) < 0) then
8817 Inc(child);
8818 if not comparer.Compare(temp, values[left + child - 1]) < 0 then
8819 Break;
8820 values[left + i - 1] := values[left + child - 1];
8821 i := child;
8822 end;
8823 values[left + i - 1] := temp;
8824end;
8825
8826class procedure TArray.HeapSort<T>(var values: array of T;
8827 const comparer: IComparer<T>; left, right: Integer);
8828var
8829 count, i: Integer;
8830begin
8831 count := right - left + 1;
8832 for i := count div 2 downto 1 do
8833 DownHeap<T>(values, comparer, left, count, i);
8834 for i := count downto 2 do
8835 begin
8836 Swap<T>(values[left], values[left + i - 1]);
8837 DownHeap<T>(values, comparer, left, i - 1, 1);
8838 end;
8839end;
8840
8841class procedure TArray.InsertionSort<T>(var values: array of T;
8842 const comparer: IComparer<T>; left, right: Integer);
8843var
8844 i, j: Integer;
8845 temp: T;
8846begin
8847 for i := left + 1 to right do
8848 begin
8849 j := i;
8850 temp := values[i];
8851 while (j > left) and (comparer.Compare(temp, values[j - 1]) < 0) do
8852 begin
8853 values[j] := values[j - 1];
8854 Dec(j);
8855 end;
8856 values[j] := temp;
8857 end;
8858end;
8859
8860class function TArray.QuickSortPartition<T>(var values: array of T;
8861 const comparer: IComparer<T>; left, right: Integer): Integer;
8862var
8863 mid, pivotIndex: Integer;
8864 pivot: T;
8865begin
8866 mid := left + (right - left) div 2;
8867
8868 SortThreeItems<T>(comparer, values[left], values[mid], values[right]);
8869
8870 Dec(right);
8871 pivotIndex := right;
8872
8873 pivot := values[mid];
8874 Swap<T>(values[mid], values[right]);
8875
8876 while left < right do
8877 begin
8878 repeat
8879 Inc(left);
8880 until comparer.Compare(values[left], pivot) >= 0;
8881 repeat
8882 Dec(right);
8883 until comparer.Compare(pivot, values[right]) >= 0;
8884
8885 if left >= right then
8886 Break;
8887
8888 Swap<T>(values[left], values[right]);
8889 end;
8890
8891 Swap<T>(values[left], values[pivotIndex]);
8892 Result := left;
8893end;
8894
8895class procedure TArray.IntroSort<T>(var values: array of T;
8896 const comparer: IComparer<T>; left, right, depthLimit: Integer);
8897var
8898 count, pivot: Integer;
8899begin
8900 while right > left do
8901 begin
8902 count := right - left + 1;
8903 if count = 1 then
8904 Exit;
8905 if count = 2 then
8906 begin
8907 SortTwoItems<T>(comparer, values[left], values[right]);
8908 Exit;
8909 end;
8910 if count = 3 then
8911 begin
8912 SortThreeItems<T>(comparer, values[left], values[right - 1], values[right]);
8913 Exit;
8914 end;
8915 if count <= IntrosortSizeThreshold then
8916 begin
8917 InsertionSort<T>(values, comparer, left, right);
8918 Exit;
8919 end;
8920
8921 if depthLimit = 0 then
8922 begin
8923 HeapSort<T>(values, comparer, left, right);
8924 Exit;
8925 end;
8926
8927 Dec(depthLimit);
8928 pivot := QuickSortPartition<T>(values, comparer, left, right);
8929 IntroSort<T>(values, comparer, pivot + 1, right, depthLimit);
8930 right := pivot - 1;
8931 end;
8932end;
8933
8934class procedure TArray.Sort<T>(var values: array of T);
8935begin
8936 IntroSort<T>(values, TComparer<T>.Default,
8937 Low(values), High(values), GetDepthLimit(Length(values)));
8938end;
8939
8940class procedure TArray.Sort<T>(var values: array of T;
8941 const comparer: IComparer<T>);
8942begin
8943 IntroSort<T>(values, comparer,
8944 Low(values), High(values), GetDepthLimit(Length(values)));
8945end;
8946
8947class procedure TArray.Sort<T>(var values: array of T;
8948 const comparer: IComparer<T>; index, count: Integer);
8949begin
8950{$IFDEF SPRING_ENABLE_GUARD}
8951 Guard.CheckNotNull(Assigned(comparer), 'comparer');
8952 Guard.CheckRange((index >= 0) and (index <= Length(values)), 'index');
8953 Guard.CheckRange((count >= 0) and (count <= Length(values) - index), 'count');
8954{$ENDIF}
8955
8956 if count <= 1 then
8957 Exit;
8958 IntroSort<T>(values, comparer, index, index + count - 1, GetDepthLimit(count));
8959end;
8960
8961class procedure TArray.Sort<T>(var values: array of T;
8962 const comparison: TComparison<T>);
8963begin
8964 IntroSort<T>(values, IComparer<T>(PPointer(@comparison)^),
8965 Low(values), High(values), GetDepthLimit(Length(values)));
8966end;
8967
8968class procedure TArray.Sort<T>(var values: array of T;
8969 const comparison: TComparison<T>; index, count: Integer);
8970begin
8971{$IFDEF SPRING_ENABLE_GUARD}
8972 Guard.CheckNotNull(Assigned(comparison), 'comparison');
8973 Guard.CheckRange((index >= 0) and (index <= Length(values)), 'index');
8974 Guard.CheckRange((count >= 0) and (count <= Length(values) - index), 'count');
8975{$ENDIF}
8976
8977 if count <= 1 then
8978 Exit;
8979 IntroSort<T>(values, IComparer<T>(PPointer(@comparison)^),
8980 index, index + count - 1, GetDepthLimit(count));
8981end;
8982
8983{$ENDREGION}
8984
8985
8986{$REGION 'Vector<T>'}
8987
8988class function VectorHelper.InternalIndexOfInt8(const data: Pointer;
8989 const item: ShortInt): Integer;
8990begin
8991 for Result := 0 to High(TArray<ShortInt>(data)) do
8992 if TArray<ShortInt>(data)[Result] = item then
8993 Exit;
8994 Result := -1;
8995end;
8996
8997class function VectorHelper.InternalIndexOfInt16(const data: Pointer;
8998 const item: SmallInt): Integer;
8999begin
9000 for Result := 0 to High(TArray<SmallInt>(data)) do
9001 if TArray<SmallInt>(data)[Result] = item then
9002 Exit;
9003 Result := -1;
9004end;
9005
9006class function VectorHelper.InternalIndexOfInt32(const data:Pointer;
9007 const item: Integer): Integer;
9008begin
9009 for Result := 0 to High(TArray<Integer>(data)) do
9010 if TArray<Integer>(data)[Result] = item then
9011 Exit;
9012 Result := -1;
9013end;
9014
9015class function VectorHelper.InternalIndexOfInt64(const data: Pointer;
9016 const item: Int64): Integer;
9017begin
9018 for Result := 0 to High(TArray<Int64>(data)) do
9019 if TArray<Int64>(data)[Result] = item then
9020 Exit;
9021 Result := -1;
9022end;
9023
9024class function VectorHelper.InternalIndexOfStr(const data: Pointer;
9025 const item: string): Integer;
9026begin
9027 for Result := 0 to High(TArray<string>(data)) do
9028 if TArray<string>(data)[Result] = item then
9029 Exit;
9030 Result := -1;
9031end;
9032
9033class operator Vector<T>.Add(const left, right: Vector<T>): Vector<T>;
9034begin
9035 Result := left;
9036 Result.Add(right.fData);
9037end;
9038
9039class operator Vector<T>.Add(const left: Vector<T>;
9040 const right: TArray<T>): Vector<T>;
9041begin
9042 Result := left;
9043 Result.Add(right);
9044end;
9045
9046class operator Vector<T>.Add(const left: TArray<T>;
9047 const right: Vector<T>): Vector<T>;
9048begin
9049 Result := left;
9050 Result.Add(right.fData);
9051end;
9052
9053class operator Vector<T>.Add(const left: Vector<T>;
9054 const right: T): Vector<T>;
9055begin
9056 Result := left;
9057 Result.Add(right);
9058end;
9059
9060class operator Vector<T>.Add(const left: T;
9061 const right: Vector<T>): Vector<T>;
9062begin
9063 SetLength(Result.fData, 1);
9064 Result.fData[0] := left;
9065 Result.Add(right);
9066end;
9067
9068function Vector<T>.Add(const item: T): Integer;
9069begin
9070 Result := System.Length(fData);
9071 SetLength(fData, Result + 1);
9072 fData[Result] := item;
9073end;
9074
9075procedure Vector<T>.Add(const items: array of T);
9076begin
9077 InternalInsert(System.Length(fData), items);
9078end;
9079
9080procedure Vector<T>.Add(const items: TArray<T>);
9081begin
9082{$IFNDEF DELPHIXE7_UP}
9083 InternalInsert(System.Length(fData), items);
9084{$ELSE}
9085 System.Insert(items, fData, System.Length(fData));
9086{$ENDIF}
9087end;
9088
9089procedure Vector<T>.Add(const items: Vector<T>);
9090begin
9091{$IFNDEF DELPHIXE7_UP}
9092 InternalInsert(System.Length(items.fData), items.fData);
9093{$ELSE}
9094 System.Insert(items.fData, fData, System.Length(items.fData));
9095{$ENDIF}
9096end;
9097
9098procedure Vector<T>.Assign(const items: array of T);
9099begin
9100 fData := TArray.Copy<T>(items);
9101end;
9102
9103procedure Vector<T>.Clear;
9104begin
9105 fData := nil;
9106end;
9107
9108function Vector<T>.IndexOf(const item: T): Integer;
9109begin
9110 case TType.Kind<T> of
9111 tkInteger:
9112 case SizeOf(T) of
9113 1: Result := VectorHelper.InternalIndexOfInt8(fData, PShortInt(@item)^);
9114 2: Result := VectorHelper.InternalIndexOfInt16(fData, PSmallInt(@item)^);
9115 4: Result := VectorHelper.InternalIndexOfInt32(fData, PInteger(@item)^);
9116 end;
9117 tkInt64: Result := VectorHelper.InternalIndexOfInt64(fData, PInt64(@item)^);
9118 tkUString: Result := VectorHelper.InternalIndexOfStr(fData, PUnicodeString(@item)^);
9119 else
9120 Result := InternalIndexOf(item);
9121 end;
9122end;
9123
9124function Vector<T>.Contains(const item: T): Boolean;
9125begin
9126 Result := IndexOf(item) > -1;
9127end;
9128
9129function Vector<T>.Contains(const item: T;
9130 const comparer: IEqualityComparer<T>): Boolean;
9131var
9132 i: Integer;
9133begin
9134 for i := 0 to High(fData) do
9135 if comparer.Equals(fData[i], item) then
9136 Exit(True);
9137 Result := False;
9138end;
9139
9140function Vector<T>.Contains(const item: T;
9141 const comparer: TEqualityComparison<T>): Boolean;
9142var
9143 i: Integer;
9144begin
9145 for i := 0 to High(fData) do
9146 if comparer(fData[i], item) then
9147 Exit(True);
9148 Result := False;
9149end;
9150
9151function Vector<T>.Contains(const items: array of T): Boolean;
9152var
9153 i: Integer;
9154begin
9155 for i := 0 to High(items) do
9156 if IndexOf(items[i]) = -1 then
9157 Exit(False);
9158 Result := True;
9159end;
9160
9161function Vector<T>.Contains(const items: TArray<T>): Boolean;
9162var
9163 i: Integer;
9164begin
9165 for i := 0 to System.Length(items) - 1 do
9166 if IndexOf(items[i]) = -1 then
9167 Exit(False);
9168 Result := True;
9169end;
9170
9171procedure Vector<T>.Delete(index: Integer);
9172{$IFNDEF DELPHIXE7_UP}
9173var
9174 n, i: Integer;
9175{$ENDIF}
9176begin
9177{$IFNDEF DELPHIXE7_UP}
9178 n := System.Length(fData);
9179 if (index < 0) or (index >= n) then
9180 Exit;
9181 Dec(n);
9182 fData[index] := Default(T);
9183 if index <> n then
9184{$IFDEF WEAKREF}
9185 if TType.HasWeakRef<T> then
9186 begin
9187 for i := index to n - 1 do
9188 fData[i] := fData[i + 1];
9189 end
9190 else
9191{$ENDIF}
9192 begin
9193 System.Move(fData[index + 1], fData[index], (n - index) * SizeOf(T));
9194 System.FillChar(fData[n], SizeOf(T), 0);
9195 end;
9196 SetLength(fData, n);
9197{$ELSE}
9198 System.Delete(fData, index, 1);
9199{$ENDIF}
9200end;
9201
9202procedure Vector<T>.Delete(index, count: Integer);
9203{$IFNDEF DELPHIXE7_UP}
9204var
9205 n, i: Integer;
9206{$ENDIF}
9207begin
9208{$IFNDEF DELPHIXE7_UP}
9209 n := System.Length(fData);
9210 if (index < 0) or (index >= n) then
9211 Exit;
9212 if count > n - index then
9213 count := n - index;
9214 Dec(n, count);
9215 for i := index to index + count - 1 do
9216 fData[i] := Default(T);
9217 if index <> n then
9218{$IFDEF WEAKREF}
9219 if TType.HasWeakRef<T> then
9220 begin
9221 for i := index to n - count do
9222 fData[i] := fData[i + count];
9223 end
9224 else
9225{$ENDIF}
9226 begin
9227 System.Move(fData[index + count], fData[index], (n - index) * SizeOf(T));
9228 System.FillChar(fData[n], count * SizeOf(T), 0);
9229 end;
9230 SetLength(fData, n);
9231{$ELSE}
9232 System.Delete(fData, index, count);
9233{$ENDIF}
9234end;
9235
9236class operator Vector<T>.Equal(const left, right: Vector<T>): Boolean;
9237begin
9238 Result := left.Equals(right.fData);
9239end;
9240
9241function Vector<T>.Equals(const items: array of T): Boolean;
9242var
9243 n, i: Integer;
9244begin
9245 n := System.Length(fData);
9246 if n <> System.Length(items) then
9247 Exit(False);
9248 Result := True;
9249 case TType.Kind<T> of
9250 tkInteger:
9251 for i := 0 to n - 1 do
9252 if PInteger(@fData[i])^ <> PInteger(@items[i])^ then
9253 Exit(False);
9254 tkUString:
9255 for i := 0 to n - 1 do
9256 if PUnicodeString(@fData[i])^ <> PUnicodeString(@items[i])^ then
9257 Exit(False);
9258 else
9259 Result := InternalEquals(items);
9260 end;
9261end;
9262
9263function Vector<T>.Equals(const items: TArray<T>): Boolean;
9264var
9265 n, i: Integer;
9266begin
9267 n := System.Length(fData);
9268 if n <> System.Length(items) then
9269 Exit(False);
9270 Result := True;
9271 case TType.Kind<T> of
9272 tkInteger:
9273 for i := 0 to n - 1 do
9274 if PInteger(@fData[i])^ <> PInteger(@items[i])^ then
9275 Exit(False);
9276 tkUString:
9277 for i := 0 to n - 1 do
9278 if PUnicodeString(@fData[i])^ <> PUnicodeString(@items[i])^ then
9279 Exit(False);
9280 else
9281 Result := InternalEquals(items);
9282 end;
9283end;
9284
9285procedure Vector<T>.ForEach(const action: TAction<T>);
9286var
9287 i: Integer;
9288begin
9289 for i := Low(fData) to High(fData) do
9290 action(fData[i]);
9291end;
9292
9293function Vector<T>.GetCount: Integer;
9294begin
9295 Result := System.Length(fData);
9296end;
9297
9298function Vector<T>.GetEnumerator: TArrayEnumerator<T>;
9299begin
9300{$IFDEF DELPHI2010}
9301 Result := TArrayEnumerator<T>.Create(fData);
9302{$ELSE}
9303 Result.fItems := fData;
9304 Result.fIndex := -1;
9305{$ENDIF}
9306end;
9307
9308function Vector<T>.GetFirst: T;
9309begin
9310 Result := fData[0];
9311end;
9312
9313function Vector<T>.GetItem(index: Integer): T;
9314begin
9315 Result := fData[index];
9316end;
9317
9318function Vector<T>.GetLast: T;
9319begin
9320 Result := fData[High(fData)];
9321end;
9322
9323class operator Vector<T>.Implicit(const value: TArray<T>): Vector<T>;
9324begin
9325 Result.fData := value;
9326end;
9327
9328class operator Vector<T>.Implicit(const value: Vector<T>): TArray<T>;
9329begin
9330 Result := value.fData;
9331end;
9332
9333class operator Vector<T>.In(const left: T;
9334 const right: Vector<T>): Boolean;
9335begin
9336 Result := right.Contains(left);
9337end;
9338
9339class operator Vector<T>.In(const left, right: Vector<T>): Boolean;
9340begin
9341 Result := right.Contains(left.fData);
9342end;
9343
9344class operator Vector<T>.In(const left: TArray<T>;
9345 const right: Vector<T>): Boolean;
9346begin
9347 Result := right.Contains(left);
9348end;
9349
9350procedure Vector<T>.Insert(index: Integer; const item: T);
9351{$IFNDEF DELPHIXE7_UP}
9352var
9353 count: Integer;
9354 i: Integer;
9355{$ENDIF}
9356begin
9357{$IFNDEF DELPHIXE7_UP}
9358 count := System.Length(fData);
9359 SetLength(fData, count + 1);
9360 if index <> count then
9361{$IFDEF WEAKREF}
9362 if TType.HasWeakRef<T> then
9363 begin
9364 for i := count - 1 downto index do
9365 fData[i + 1] := fData[i];
9366 end
9367 else
9368{$ENDIF}
9369 begin
9370 System.Move(fData[index], fData[index + 1], (count - index) * SizeOf(T));
9371 System.FillChar(fData[index], SizeOf(T), 0);
9372 end;
9373 fData[index] := item;
9374{$ELSE}
9375 System.Insert(item, fData, index);
9376{$ENDIF}
9377end;
9378
9379procedure Vector<T>.Insert(index: Integer; const items: array of T);
9380begin
9381 InternalInsert(index, items);
9382end;
9383
9384procedure Vector<T>.Insert(index: Integer; const items: TArray<T>);
9385begin
9386{$IFNDEF DELPHIXE7_UP}
9387 InternalInsert(index, items);
9388{$ELSE}
9389 System.Insert(items, fData, index);
9390{$ENDIF}
9391end;
9392
9393function Vector<T>.InternalEquals(const items: array of T): Boolean;
9394var
9395 comparer: IEqualityComparer<T>;
9396 i: Integer;
9397begin
9398 comparer := TEqualityComparer<T>.Default;
9399 for i := 0 to System.Length(fData) - 1 do
9400 if not comparer.Equals(fData[i], items[i]) then
9401 Exit(False);
9402 Result := True;
9403end;
9404
9405function Vector<T>.InternalIndexOf(const item: T): Integer;
9406var
9407 comparer: IEqualityComparer<T>;
9408begin
9409 comparer := TEqualityComparer<T>.Default;
9410 for Result := 0 to High(fData) do
9411 if comparer.Equals(fData[Result], item) then
9412 Exit;
9413 Result := -1;
9414end;
9415
9416procedure Vector<T>.InternalInsert(index: Integer; const items: array of T);
9417var
9418 count, len, i: Integer;
9419begin
9420 count := System.Length(fData);
9421 len := System.Length(items);
9422 SetLength(fData, count + len);
9423 if index <> count then
9424{$IFDEF WEAKREF}
9425 if TType.HasWeakRef<T> then
9426 begin
9427 for i := count - 1 downto index do
9428 fData[i + len] := fData[i];
9429 end
9430 else
9431{$ENDIF}
9432 begin
9433 System.Move(fData[index], fData[index + len], (count - index) * SizeOf(T));
9434 if TType.IsManaged<T> then
9435 System.FillChar(fData[index], len * SizeOf(T), 0);
9436 end;
9437 if TType.IsManaged<T> then
9438 begin
9439 for i := Low(items) to High(items) do
9440 begin
9441 fData[index] := items[i];
9442 Inc(index);
9443 end;
9444 end
9445 else
9446 System.Move(items[0], fData[index], len * SizeOf(T));
9447end;
9448
9449class operator Vector<T>.NotEqual(const left, right: Vector<T>): Boolean;
9450begin
9451 Result := not left.Equals(right.fData);
9452end;
9453
9454function Vector<T>.Remove: T;
9455var
9456 n: Integer;
9457begin
9458 n := High(fData);
9459 Result := fData[n];
9460 SetLength(fData, n);
9461end;
9462
9463procedure Vector<T>.Remove(const item: T);
9464var
9465 index: Integer;
9466begin
9467 index := IndexOf(item);
9468 if index > -1 then
9469 Delete(index);
9470end;
9471
9472procedure Vector<T>.Remove(const items: array of T);
9473var
9474 i, index: Integer;
9475begin
9476 for i := Low(items) to High(items) do
9477 begin
9478 index := IndexOf(items[i]);
9479 if index > -1 then
9480 Delete(index);
9481 end;
9482end;
9483
9484procedure Vector<T>.Remove(const items: TArray<T>);
9485var
9486 i, index: Integer;
9487begin
9488 for i := 0 to System.Length(items) - 1 do
9489 begin
9490 index := IndexOf(items[i]);
9491 if index > -1 then
9492 Delete(index);
9493 end;
9494end;
9495
9496procedure Vector<T>.Reverse;
9497var
9498 tmp: T;
9499 b, e: Integer;
9500begin
9501 b := 0;
9502 e := Count - 1;
9503 while b < e do
9504 begin
9505 tmp := fData[b];
9506 fData[b] := fData[e];
9507 fData[e] := tmp;
9508 Inc(b);
9509 Dec(e);
9510 end;
9511end;
9512
9513procedure Vector<T>.SetCount(value: Integer);
9514begin
9515 SetLength(fData, value);
9516end;
9517
9518procedure Vector<T>.SetItem(index: Integer; const value: T);
9519begin
9520 fData[index] := value;
9521end;
9522
9523function Vector<T>.Slice(index: Integer): Vector<T>;
9524begin
9525 Result.fData := Copy(fData, index);
9526end;
9527
9528function Vector<T>.Slice(index, count: Integer): Vector<T>;
9529begin
9530 Result.fData := Copy(fData, index, count);
9531end;
9532
9533procedure Vector<T>.Sort;
9534begin
9535 TArray.Sort<T>(fData);
9536end;
9537
9538procedure Vector<T>.Sort(const comparer: IComparer<T>);
9539begin
9540 TArray.Sort<T>(fData, comparer);
9541end;
9542
9543procedure Vector<T>.Sort(const comparer: TComparison<T>);
9544begin
9545 TArray.Sort<T>(fData, IComparer<T>(PPointer(@comparer)^));
9546end;
9547
9548function Vector<T>.Splice(index, count: Integer): Vector<T>;
9549begin
9550 Result := Splice(index, count, []);
9551end;
9552
9553function Vector<T>.Splice(index, count: Integer;
9554 const items: array of T): Vector<T>;
9555var
9556 i: Integer;
9557begin
9558 i := System.Length(fData);
9559 if (index < 0) or (index >= i) then
9560 Exit;
9561 if count > i - index then
9562 count := i - index;
9563 Result.fData := Copy(fData, index, count);
9564 Delete(index, count);
9565 Insert(index, items);
9566end;
9567
9568class operator Vector<T>.Subtract(const left,
9569 right: Vector<T>): Vector<T>;
9570begin
9571 Result := left;
9572 Result.Remove(right.fData);
9573end;
9574
9575class operator Vector<T>.Subtract(const left: Vector<T>;
9576 const right: T): Vector<T>;
9577begin
9578 Result := left;
9579 Result.Remove(right);
9580end;
9581
9582{$ENDREGION}
9583
9584
9585{$REGION 'TArrayEnumerator<T>' }
9586
9587constructor TArrayEnumerator<T>.Create(const items: TArray<T>);
9588begin
9589 fItems := items;
9590 fIndex := -1;
9591end;
9592
9593function TArrayEnumerator<T>.GetCurrent: T;
9594begin
9595 Result := fItems[fIndex];
9596end;
9597
9598function TArrayEnumerator<T>.MoveNext: Boolean;
9599begin
9600 Inc(fIndex);
9601 Result := fIndex < System.Length(fItems);
9602end;
9603
9604{$ENDREGION}
9605
9606
9607{$REGION 'TFormatSettingsHelper'}
9608
9609{$IFDEF DELPHI2010}
9610class function TFormatSettingsHelper.Create: TFormatSettings;
9611begin
9612 GetLocaleFormatSettings(LOCALE_SYSTEM_DEFAULT, Result);
9613end;
9614{$ENDIF}
9615
9616{$ENDREGION}
9617
9618
9619procedure Init;
9620begin
9621{$IFDEF DELPHI2010}
9622 Nop_Instance := Pointer(TValueData(TValue.Empty).FHeapData);
9623{$ELSE}
9624 Nop_Instance := Pointer(TValueData(TValue.Empty).FValueData);
9625{$ENDIF}
9626end;
9627
9628initialization
9629 Init;
9630
9631finalization
9632 // make sure this properly gets freed because it appears
9633 // the class destructor is not running all the time
9634 TType.fContext.Free;
9635
9636end.
9637