├── .gitattributes ├── .gitignore ├── LICENSE.md ├── Part1 ├── 3.3 Invalid pointers │ ├── Dangling.dpr │ ├── Stale.dpr │ ├── Wild.dpr │ └── WildWorking.dpr ├── 3.4 Scope │ ├── Scope1.dpr │ ├── Scope2.dpr │ └── Scope3.dpr └── 4 Classes │ ├── Classy.dpr │ ├── Differences.dpr │ ├── DynamicHidding.dpr │ ├── DynamicOverriding.dpr │ ├── Overloading1.dpr │ ├── Overloading2.dpr │ ├── PrintTest.dpr │ ├── StaticBinding.dpr │ ├── uQuestion.pas │ └── uShip.pas ├── Part2 └── 5 Nil │ ├── AssignedCheck.dpr │ ├── NilComparison.dpr │ ├── NilComparisonFunc.dpr │ ├── NilException.dpr │ ├── NullObjectPattern.dpr │ ├── Nullable.pas │ ├── TreeNil.dpr │ ├── TreeNullObject.dpr │ ├── TreeNullObjectSingle.dpr │ └── Weather.dpr ├── Part5 ├── Lazy │ ├── LazyDeathStar.dpr │ └── ReallyLazyDeathStar.dpr ├── SmartPointer │ ├── Smart.dpr │ ├── uLifeMgr.pas │ └── uSmartPtr.pas └── Weak │ ├── SimplerWeakMagic.dpr │ ├── WeakMagic.dpr │ └── uZWeak.pas └── README.md /.gitattributes: -------------------------------------------------------------------------------- 1 | # Set the default behavior, in case people don't have core.autocrlf set. 2 | * binary 3 | 4 | # Declare text files that will always have CRLF line endings on checkout 5 | *.gitattributes text eol=lf diff 6 | *.gitignore text eol=lf diff 7 | 8 | *.txt text eol=crlf diff 9 | *.md text eol=crlf diff 10 | *.xml text eol=crlf diff 11 | *.json text eol=crlf diff 12 | *.manifest text eol=crlf diff 13 | *.rc text eol=crlf diff 14 | *.bat text eol=crlf diff 15 | 16 | *.pas text eol=crlf diff 17 | *.inc text eol=crlf diff 18 | *.dfm text eol=crlf diff 19 | *.fmx text eol=crlf diff 20 | *.dpr text eol=crlf diff 21 | *.dpk text eol=crlf diff 22 | *.dproj text eol=crlf diff 23 | *.groupproj text eol=crlf diff 24 | *.deployproj text eol=crlf diff 25 | *.plist text eol=lf diff 26 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Delphi compiler-generated binaries (safe to delete) 2 | *.exe 3 | *.dll 4 | *.bpl 5 | *.bpi 6 | *.dcp 7 | *.so 8 | *.apk 9 | *.drc 10 | *.map 11 | *.dres 12 | *.rsm 13 | *.tds 14 | *.dcu 15 | *.lib 16 | *.a 17 | *.o 18 | *.ocx 19 | 20 | # Delphi autogenerated files (duplicated info) 21 | *.cfg 22 | *.hpp 23 | *Resource.rc 24 | 25 | # Delphi local files (user-specific info) 26 | *.local 27 | *.identcache 28 | *.projdata 29 | *.tvsconfig 30 | *.dsk 31 | *.stat 32 | 33 | # Delphi history and backups 34 | __history/ 35 | __recovery/ 36 | *.~* 37 | 38 | # Delphi build folders 39 | Win32/ 40 | Win64/ 41 | OSX32/ 42 | OSX64/ 43 | Linux64/ 44 | Android/ 45 | Android64 46 | iOSDevice64/ 47 | iOSDevice32/ 48 | iOSSimulator/ 49 | 50 | # VCS 51 | .hg/ -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Code examples from Delphi Memory Management for Classic and ARC Compilers 4 | Copyright (c) 2017 Dalija Prasnikar, Neven Prasnikar Jr. 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this repository - code examples (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | -------------------------------------------------------------------------------- /Part1/3.3 Invalid pointers/Dangling.dpr: -------------------------------------------------------------------------------- 1 | program Dangling; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | // FastMM4, 7 | System.SysUtils, 8 | System.Classes; 9 | 10 | procedure Proc; 11 | var 12 | Obj: TObject; 13 | Owner, Child: TComponent; 14 | begin 15 | // initialize Obj to nil for testing purposes 16 | Obj := nil; 17 | Writeln('Obj initialized'); 18 | Writeln('Obj address ', NativeUInt(Obj), ', is nil ', Obj = nil, ', assigned ', Assigned(Obj)); 19 | Obj := TObject.Create; 20 | Writeln('Obj created'); 21 | Writeln('Obj address ', NativeUInt(Obj), ', is nil ', Obj = nil, ', assigned ', Assigned(Obj)); 22 | Writeln(Obj.ToString); 23 | Obj.Free; 24 | // at this point, Obj is a dangling pointer 25 | Writeln('Obj released'); 26 | Writeln('Obj address ', NativeUInt(Obj), ', is nil ', Obj = nil, ', assigned ', Assigned(Obj)); 27 | Writeln(Obj.ToString); 28 | // Some unrelated code that will overwrite memory 29 | // Note: whether or not Obj memory will actually be overwritten with following code, depends on the Delphi version. 30 | // That does not mean that some Delphi versions are protected from dangling references, only that slightly diferent 31 | // code is needed to produce dangling reference you can easily detect with simple Obj.ToString code 32 | // FastMM4 in full debug mode can be used to detect access to released objects - stale and dangling references 33 | Owner := TComponent.Create(nil); 34 | Child := TComponent.Create(Owner); 35 | Writeln('Obj address ', NativeUInt(Obj), ', is nil ', Obj = nil, ', assigned ', Assigned(Obj)); 36 | Writeln(Obj.ToString); 37 | Owner.Free; 38 | end; 39 | 40 | begin 41 | Proc; 42 | Readln; 43 | end. 44 | -------------------------------------------------------------------------------- /Part1/3.3 Invalid pointers/Stale.dpr: -------------------------------------------------------------------------------- 1 | program Stale; 2 | 3 | uses 4 | //FastMM4, 5 | System.Classes; 6 | 7 | procedure Proc; 8 | var 9 | Obj, Ref: TObject; 10 | Owner, Child: TComponent; 11 | begin 12 | Obj := TObject.Create; 13 | Ref := Obj; 14 | Writeln('Obj created, Ref assigned'); 15 | Writeln('Obj address ', NativeInt(Obj), ', is nil ', Obj = nil, ', assigned ', Assigned(Obj)); 16 | Writeln('Ref address ', NativeInt(Ref), ', is nil ', Ref = nil, ', assigned ', Assigned(Ref)); 17 | Writeln(Ref.ToString); 18 | Obj.Free; 19 | Obj := nil; 20 | 21 | // at this point, Ref is a stale pointer 22 | Writeln('Obj released'); 23 | Writeln('Obj address ', NativeInt(Obj), ', is nil ', Obj = nil, ', assigned ', Assigned(Obj)); 24 | Writeln('Ref address ', NativeInt(Ref), ', is nil ', Ref = nil, ', assigned ', Assigned(Ref)); 25 | Writeln(Ref.ToString); 26 | 27 | // Some unrelated code that will overwrite memory 28 | // Note: whether or not Obj memory will actually be overwritten with following code, depends on the Delphi version. 29 | // That does not mean that some Delphi versions are protected from stale references, only that slightly diferent 30 | // code is needed to produce stale reference you can easily detect with simple Ref.ToString code 31 | // FastMM4 in full debug mode can be used to detect access to released objects - stale and dangling references 32 | 33 | Owner := TComponent.Create(nil); 34 | Child := TComponent.Create(Owner); 35 | Writeln('Ref address ', NativeInt(Ref), ', is nil ', Ref = nil, ', assigned ', Assigned(Ref)); 36 | Writeln(Ref.ToString); 37 | Owner.Free; 38 | end; 39 | 40 | begin 41 | Proc; 42 | Readln; 43 | end. 44 | 45 | -------------------------------------------------------------------------------- /Part1/3.3 Invalid pointers/Wild.dpr: -------------------------------------------------------------------------------- 1 | program Wild; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | procedure Proc; 9 | var 10 | Obj: TObject; 11 | begin 12 | Writeln('Object address ', NativeUInt(Obj), ', is nil ', Obj = nil, ', assigned ', Assigned(Obj)); 13 | Writeln(Obj.ToString); 14 | end; 15 | 16 | begin 17 | try 18 | Proc; 19 | except 20 | on E: Exception do 21 | Writeln(E.ClassName, ': ', E.Message); 22 | end; 23 | Readln; 24 | end. 25 | 26 | -------------------------------------------------------------------------------- /Part1/3.3 Invalid pointers/WildWorking.dpr: -------------------------------------------------------------------------------- 1 | program WildWorking; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | procedure Clear; 9 | var 10 | x: NativeUInt; 11 | begin 12 | x := 0; 13 | end; 14 | 15 | procedure Proc; 16 | var 17 | Obj: TObject; 18 | begin 19 | Writeln('Object address ', NativeUInt(Obj), ', is nil ', Obj = nil, ', assigned ', Assigned(Obj)); 20 | if Assigned(Obj) then Writeln(Obj.ToString) 21 | else Writeln('Obj is nil'); 22 | end; 23 | 24 | begin 25 | try 26 | Clear; 27 | Proc; 28 | except 29 | on E: Exception do Writeln(E.ClassName, ': ', E.Message); 30 | end; 31 | Readln; 32 | end. 33 | -------------------------------------------------------------------------------- /Part1/3.4 Scope/Scope1.dpr: -------------------------------------------------------------------------------- 1 | program Scope1; 2 | 3 | var 4 | x: Integer; 5 | 6 | procedure Proc; 7 | var 8 | x: Integer; 9 | begin 10 | x := 5; 11 | Writeln('Local ', x); 12 | Writeln('Global accessed from Proc ', Scope1.x); 13 | end; 14 | 15 | begin 16 | x := 3; 17 | writeln('Global ', x); 18 | Proc; 19 | Writeln('Global ', x); 20 | Readln; 21 | end. 22 | 23 | 24 | -------------------------------------------------------------------------------- /Part1/3.4 Scope/Scope2.dpr: -------------------------------------------------------------------------------- 1 | program Scope2; 2 | 3 | procedure Proc; 4 | var 5 | x: Integer; 6 | begin 7 | x := 5; 8 | Writeln('Local ', x); 9 | end; 10 | 11 | begin 12 | x := 3; 13 | writeln('Global ', x); 14 | Proc; 15 | Writeln('Global ', x); 16 | Readln; 17 | end. 18 | 19 | -------------------------------------------------------------------------------- /Part1/3.4 Scope/Scope3.dpr: -------------------------------------------------------------------------------- 1 | program Scope3; 2 | 3 | var 4 | x: Integer; 5 | 6 | procedure Proc; 7 | begin 8 | x := 5; 9 | Writeln('Local ', x); 10 | end; 11 | 12 | begin 13 | x := 3; 14 | writeln('Global ', x); 15 | Proc; 16 | Writeln('Global ', x); 17 | Readln; 18 | end. 19 | 20 | -------------------------------------------------------------------------------- /Part1/4 Classes/Classy.dpr: -------------------------------------------------------------------------------- 1 | program Classy; 2 | 3 | {$APPTYPE CONSOLE} 4 | {$R *.res} 5 | 6 | uses 7 | System.SysUtils; 8 | 9 | type 10 | TClassy = class 11 | public 12 | class var ClassLevel: integer; 13 | class procedure DoSomethingClassy; 14 | end; 15 | 16 | class procedure TClassy.DoSomethingClassy; 17 | begin 18 | Inc(ClassLevel); // Increases ClassLevel by 1. 19 | WriteLn('We''ve called a class method ', ClassLevel, ' times'); 20 | end; 21 | 22 | var 23 | Obj: TClassy; 24 | begin 25 | Obj := TClassy.Create; 26 | try 27 | Obj.DoSomethingClassy; 28 | // Let's short-circuit the counter a bit, shall we? 29 | TClassy.ClassLevel := 4; 30 | TClassy.DoSomethingClassy; 31 | finally 32 | Obj.Free; 33 | end; 34 | 35 | Readln; 36 | 37 | end. 38 | -------------------------------------------------------------------------------- /Part1/4 Classes/Differences.dpr: -------------------------------------------------------------------------------- 1 | program Differences; 2 | 3 | {$APPTYPE CONSOLE} 4 | {$R *.res} 5 | 6 | uses 7 | System.SysUtils; 8 | 9 | type 10 | TType1 = class(TObject) 11 | public 12 | procedure OverriddenMethod; virtual; 13 | procedure HiddenMethod; virtual; 14 | procedure IgnoredMethod; virtual; 15 | end; 16 | 17 | TType2 = class(TType1) 18 | public 19 | procedure OverriddenMethod; override; 20 | procedure HiddenMethod; reintroduce; virtual; 21 | procedure TestMethod; 22 | end; 23 | 24 | procedure TType1.OverriddenMethod; 25 | begin 26 | WriteLn('TType1 Override'); 27 | end; 28 | 29 | procedure TType1.HiddenMethod; 30 | begin 31 | WriteLn('TType1 Hidden'); 32 | end; 33 | 34 | procedure TType1.IgnoredMethod; 35 | begin 36 | WriteLn('Calling Override ...'); 37 | OverriddenMethod; 38 | end; 39 | 40 | procedure TType2.OverriddenMethod; 41 | begin 42 | WriteLn('TType2 Override'); 43 | end; 44 | 45 | procedure TType2.HiddenMethod; 46 | begin 47 | WriteLn('TType2 Hidden'); 48 | end; 49 | 50 | procedure TType2.TestMethod; 51 | begin 52 | WriteLn('Internal inheritance test ...'); 53 | inherited OverriddenMethod; 54 | OverriddenMethod; 55 | inherited HiddenMethod; 56 | HiddenMethod; 57 | inherited IgnoredMethod; 58 | IgnoredMethod; 59 | end; 60 | 61 | var 62 | Object1: TType1; 63 | Object2: TType2; 64 | begin 65 | Object1 := TType1.Create; 66 | try 67 | Object1.OverriddenMethod; 68 | Object1.HiddenMethod; 69 | Object1.IgnoredMethod; 70 | finally 71 | Object1.Free; 72 | end; 73 | 74 | Object1 := TType2.Create; 75 | try 76 | Object1.OverriddenMethod; 77 | Object1.HiddenMethod; 78 | Object1.IgnoredMethod; 79 | finally 80 | Object1.Free; 81 | end; 82 | 83 | Object2 := TType2.Create; 84 | try 85 | Object2.OverriddenMethod; 86 | Object2.HiddenMethod; 87 | Object2.IgnoredMethod; 88 | Object2.TestMethod; 89 | finally 90 | Object2.Free; 91 | end; 92 | 93 | Readln; 94 | 95 | end. 96 | -------------------------------------------------------------------------------- /Part1/4 Classes/DynamicHidding.dpr: -------------------------------------------------------------------------------- 1 | program DynamicHidding; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | type 9 | TSomeObject = class(TObject) 10 | public 11 | // We could just as easily have used 'dynamic' here. 12 | procedure DoSomething; virtual; 13 | end; 14 | 15 | TAnotherObject = class(TSomeObject) 16 | public 17 | procedure DoSomething; 18 | end; 19 | 20 | procedure TSomeObject.DoSomething; 21 | begin 22 | WriteLn('I identify with the number 42.'); 23 | end; 24 | 25 | procedure TAnotherObject.DoSomething; 26 | begin 27 | WriteLn('I prefer the number 47.'); 28 | end; 29 | 30 | var 31 | AnOverrideTest: TSomeObject; 32 | begin 33 | AnOverrideTest := TSomeObject.Create; 34 | try 35 | AnOverrideTest.DoSomething; 36 | finally 37 | AnOverrideTest.Free; 38 | end; 39 | 40 | AnOverrideTest := TAnotherObject.Create; 41 | try 42 | AnOverrideTest.DoSomething; 43 | finally 44 | AnOverrideTest.Free; 45 | end; 46 | 47 | Readln; 48 | end. 49 | -------------------------------------------------------------------------------- /Part1/4 Classes/DynamicOverriding.dpr: -------------------------------------------------------------------------------- 1 | program DynamicOverriding; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | type 9 | TSomeObject = class(TObject) 10 | public 11 | // We could just as easily have used 'dynamic' here. 12 | procedure DoSomething; virtual; 13 | end; 14 | 15 | TAnotherObject = class(TSomeObject) 16 | public 17 | procedure DoSomething; override; 18 | end; 19 | 20 | procedure TSomeObject.DoSomething; 21 | begin 22 | WriteLn('I identify with the number 42.'); 23 | end; 24 | 25 | procedure TAnotherObject.DoSomething; 26 | begin 27 | WriteLn('I prefer the number 47.'); 28 | end; 29 | 30 | var 31 | AnOverrideTest: TSomeObject; 32 | begin 33 | AnOverrideTest := TSomeObject.Create; 34 | try 35 | AnOverrideTest.DoSomething; 36 | finally 37 | AnOverrideTest.Free; 38 | end; 39 | 40 | AnOverrideTest := TAnotherObject.Create; 41 | try 42 | AnOverrideTest.DoSomething; 43 | finally 44 | AnOverrideTest.Free; 45 | end; 46 | 47 | Readln; 48 | end. 49 | -------------------------------------------------------------------------------- /Part1/4 Classes/Overloading1.dpr: -------------------------------------------------------------------------------- 1 | program Overloading1; 2 | 3 | {$APPTYPE CONSOLE} 4 | {$R *.res} 5 | 6 | uses 7 | System.SysUtils; 8 | 9 | type 10 | TRectangle = class 11 | public 12 | // We don't have to make Draw a virtual method here, 13 | // but we're going to do it anyway. 14 | procedure Draw(AWidth, AHeight: integer); virtual; 15 | end; 16 | 17 | TSquare = class(TRectangle) 18 | public 19 | // This is why we made Draw virtual - to point out that 20 | // overloading a virtual method will prompt the compiler 21 | // to throw W1010 warnings at us again unless we reintroduce it. 22 | // Overloading a static method doesn't 23 | // require the 'reintroduce' keyword, though. 24 | procedure Draw(ASize: integer); reintroduce; overload; 25 | end; 26 | 27 | procedure TRectangle.Draw(AWidth, AHeight: integer); 28 | begin 29 | Writeln('Drawing rectangle'); 30 | end; 31 | 32 | procedure TSquare.Draw(ASize: integer); 33 | begin 34 | Writeln('Drawing square'); 35 | end; 36 | 37 | var 38 | Square: TSquare; 39 | begin 40 | Square := TSquare.Create; 41 | try 42 | // Will actually draw a rectangle. Oops. 43 | // Maybe we need to override Draw and force it to sanitize its inputs? 44 | Square.Draw(10, 5); 45 | // Will draw a square using our overloaded Draw variant. 46 | Square.Draw(10); 47 | finally 48 | Square.Free; 49 | end; 50 | 51 | Readln; 52 | 53 | end. 54 | -------------------------------------------------------------------------------- /Part1/4 Classes/Overloading2.dpr: -------------------------------------------------------------------------------- 1 | program Overloading2; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | type 9 | TRectangle = class 10 | public 11 | procedure Draw(AWidth, AHeight: integer); overload; 12 | procedure Draw(ASize: integer); overload; 13 | end; 14 | 15 | procedure TRectangle.Draw(AWidth, AHeight: integer); 16 | begin 17 | Writeln('Drawing rectangle'); 18 | end; 19 | 20 | procedure TRectangle.Draw(ASize: integer); 21 | begin 22 | Writeln('Drawing square'); 23 | end; 24 | 25 | var 26 | Rectangle: TRectangle; 27 | 28 | begin 29 | Rectangle := TRectangle.Create; 30 | try 31 | Rectangle.Draw(10, 5); 32 | Rectangle.Draw(10); 33 | finally 34 | Rectangle.Free; 35 | end; 36 | 37 | Readln; 38 | 39 | end. 40 | -------------------------------------------------------------------------------- /Part1/4 Classes/PrintTest.dpr: -------------------------------------------------------------------------------- 1 | program PrintTest; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | type 9 | TParent = class 10 | public 11 | // The virtual keyword is necessary for method overriding. 12 | procedure Print; virtual; 13 | end; 14 | 15 | TChild = class(TParent) 16 | public 17 | procedure Print; override; 18 | procedure DifferentPrint; 19 | end; 20 | 21 | procedure TParent.Print; 22 | begin 23 | WriteLn('This is the parent''s output.'); 24 | end; 25 | 26 | procedure TChild.Print; 27 | begin 28 | // We are not calling inherited here because we want to print our own stuff. 29 | WriteLn('This is the child''s output.'); 30 | end; 31 | 32 | procedure TChild.DifferentPrint; 33 | begin 34 | // Calls TChild's immediate parent's Print function. 35 | // In this case, that's TParent.Print. 36 | inherited Print; 37 | end; 38 | 39 | var 40 | c: TChild; 41 | begin 42 | c := TChild.Create; 43 | try 44 | c.Print; 45 | c.DifferentPrint; 46 | finally 47 | c.Free; 48 | end; 49 | Readln; 50 | end. 51 | -------------------------------------------------------------------------------- /Part1/4 Classes/StaticBinding.dpr: -------------------------------------------------------------------------------- 1 | program StaticBinding; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | type 9 | TRectangle = class(TObject) 10 | public 11 | procedure Draw; 12 | end; 13 | 14 | TSquare = class(TRectangle) 15 | public 16 | procedure Draw; 17 | end; 18 | 19 | procedure TRectangle.Draw; 20 | begin 21 | Writeln('Draw rectangle'); 22 | end; 23 | 24 | procedure TSquare.Draw; 25 | begin 26 | Writeln('Draw square'); 27 | end; 28 | 29 | var 30 | Rectangle: TRectangle; 31 | Square: TSquare; 32 | 33 | begin 34 | Rectangle := TRectangle.Create; 35 | try 36 | // Calls TRectangle.Draw 37 | Rectangle.Draw; 38 | finally 39 | Rectangle.Free; 40 | end; 41 | 42 | Rectangle := TSquare.Create; 43 | try 44 | // Still calls TRectangle.Draw, 45 | // even though the TSquare subclass has a Draw function of its own 46 | Rectangle.Draw; 47 | // Casts Rectangle to a TSquare and calls TSquare.Draw on it. 48 | // This would crash the program if Rectangle weren't a TSquare. 49 | TSquare(Rectangle).Draw; 50 | finally 51 | Rectangle.Free; 52 | end; 53 | 54 | Square := TSquare.Create; 55 | try 56 | // Calls TSquare.Draw 57 | Square.Draw; 58 | finally 59 | Square.Free; 60 | end; 61 | 62 | Readln; 63 | 64 | end. 65 | -------------------------------------------------------------------------------- /Part1/4 Classes/uQuestion.pas: -------------------------------------------------------------------------------- 1 | unit uQuestion; 2 | 3 | interface 4 | 5 | type 6 | TQuestion = class(TObject) 7 | public 8 | FAnswer: string; 9 | constructor Create; 10 | destructor Destroy; override; 11 | end; 12 | 13 | implementation 14 | 15 | constructor TQuestion.Create; 16 | begin 17 | // Calls the parent class' constructor 18 | inherited; 19 | // Do whatever special initialization our class requires. 20 | // For instance, let's answer all questions with "42" until 21 | // they receive a different answer. 22 | FAnswer := '42'; 23 | end; 24 | 25 | destructor TQuestion.Destroy; 26 | begin 27 | // Do whatever special destruction our class requires. 28 | // In this case, we don't actually need to define a destructor, 29 | // because there is nothing to destroy. 30 | // Calls the parent's destructor. This should always be done in a destructor. 31 | inherited; 32 | end; 33 | 34 | end. 35 | -------------------------------------------------------------------------------- /Part1/4 Classes/uShip.pas: -------------------------------------------------------------------------------- 1 | unit uShip; 2 | 3 | interface 4 | 5 | type 6 | TPart = class; 7 | 8 | TShip = class(TObject) 9 | private 10 | // Some kind of array or collection of TPart instances. 11 | // The details don't matter right now. 12 | public 13 | destructor Destroy; override; 14 | procedure AddPart(APart: TPart); 15 | end; 16 | 17 | TPart = class(TObject) 18 | public 19 | constructor Create(AShip: TShip); 20 | end; 21 | 22 | implementation 23 | 24 | destructor TShip.Destroy; 25 | begin 26 | // Make sure to do whatever destruction is necessary on our part storage class. 27 | inherited; 28 | end; 29 | 30 | procedure TShip.AddPart(APart: TPart); 31 | begin 32 | // Add APart to whatever we're using to store parts. 33 | end; 34 | 35 | constructor TPart.Create(AShip: TShip); 36 | begin 37 | inherited Create; 38 | // Our constructor's parameter list differs from that of our parent, 39 | // so we need to be more specific while invoking its constructor. 40 | // Tell the ship to add us to its part list. 41 | AShip.AddPart(Self); 42 | end; 43 | 44 | end. 45 | -------------------------------------------------------------------------------- /Part2/5 Nil/AssignedCheck.dpr: -------------------------------------------------------------------------------- 1 | program AssignedCheck; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | var 6 | Obj: TObject; 7 | 8 | begin 9 | Obj := TObject.Create; 10 | Obj.Free; 11 | // following check will be True even though Obj is no longer valid object 12 | if Assigned(Obj) then Writeln('Obj is assigned'); 13 | 14 | Readln; 15 | end. 16 | -------------------------------------------------------------------------------- /Part2/5 Nil/NilComparison.dpr: -------------------------------------------------------------------------------- 1 | program NilComparison; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | type 6 | TProcedure = procedure; 7 | 8 | procedure Print; 9 | begin 10 | Writeln('Printing'); 11 | end; 12 | 13 | var 14 | p: TProcedure; 15 | 16 | begin 17 | p := Print; 18 | // following line cannot be compiled 19 | // if p <> nil then p; 20 | 21 | if @p <> nil then p; 22 | 23 | Readln; 24 | end. 25 | -------------------------------------------------------------------------------- /Part2/5 Nil/NilComparisonFunc.dpr: -------------------------------------------------------------------------------- 1 | program NilComparisonFunc; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | type 6 | TObjectFunction = function: TObject; 7 | 8 | function GetObject: TObject; 9 | begin 10 | Result := nil; 11 | end; 12 | 13 | var 14 | f: TObjectFunction; 15 | begin 16 | f := GetObject; 17 | if f <> nil then Writeln('f is not nil') 18 | else Writeln('f is nil'); 19 | 20 | Readln; 21 | end. 22 | -------------------------------------------------------------------------------- /Part2/5 Nil/NilException.dpr: -------------------------------------------------------------------------------- 1 | program NilException; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes; 8 | 9 | type 10 | TFoo = class(TObject) 11 | public 12 | First: integer; 13 | Second: string; 14 | end; 15 | 16 | var 17 | Foo: TFoo; 18 | 19 | begin 20 | Foo := nil; 21 | try 22 | Foo.Destroy; 23 | except 24 | on E: Exception do Writeln(E.Message); 25 | end; 26 | 27 | try 28 | Writeln(Foo.First); 29 | except 30 | on E: Exception do Writeln(E.Message); 31 | end; 32 | 33 | try 34 | Writeln(Foo.Second); 35 | except 36 | on E: Exception do Writeln(E.Message); 37 | end; 38 | 39 | Readln;; 40 | 41 | end. 42 | -------------------------------------------------------------------------------- /Part2/5 Nil/NullObjectPattern.dpr: -------------------------------------------------------------------------------- 1 | program NullObjectPattern; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes; 8 | 9 | type 10 | TLogger = class(TObject) 11 | public 12 | procedure Log(const Msg: string); virtual; abstract; 13 | end; 14 | 15 | TNullLogger = class(TLogger) 16 | public 17 | procedure Log(const Msg: string); override; 18 | end; 19 | 20 | TConsoleLogger = class(TLogger) 21 | public 22 | procedure Log(const Msg: string); override; 23 | end; 24 | 25 | TRocket = class(TObject) 26 | protected 27 | Logger: TLogger; 28 | public 29 | constructor Create(ALogger: TLogger); 30 | procedure Design; 31 | procedure Build; 32 | procedure Launch; 33 | procedure Go; 34 | end; 35 | 36 | procedure TNullLogger.Log(const Msg: string); 37 | begin 38 | // do nothing 39 | end; 40 | 41 | procedure TConsoleLogger.Log(const Msg: string); 42 | begin 43 | Writeln('Log: ', Msg); 44 | end; 45 | 46 | constructor TRocket.Create(ALogger: TLogger); 47 | begin 48 | inherited Create; 49 | Logger := ALogger; 50 | end; 51 | 52 | procedure TRocket.Design; 53 | begin 54 | Logger.Log('Designing'); 55 | // designing code goes here 56 | end; 57 | 58 | procedure TRocket.Build; 59 | begin 60 | Logger.Log('Building'); 61 | // rocket building code goes here 62 | end; 63 | 64 | procedure TRocket.Launch; 65 | begin 66 | Logger.Log('Launching'); 67 | // whatever you need to launch the rocket 68 | Logger.Log('Looking good'); 69 | end; 70 | 71 | procedure TRocket.Go; 72 | begin 73 | Logger.Log('Going to the Moon'); 74 | Design; 75 | Build; 76 | Launch; 77 | Logger.Log('See you there...'); 78 | end; 79 | 80 | var 81 | SomeLogger: TLogger; 82 | Rocket: TRocket; 83 | begin 84 | SomeLogger := TConsoleLogger.Create; 85 | try 86 | Rocket := TRocket.Create(SomeLogger); 87 | try 88 | Rocket.Go; 89 | finally 90 | Rocket.Free; 91 | end; 92 | finally 93 | SomeLogger.Free; 94 | end; 95 | 96 | Readln; 97 | end. 98 | -------------------------------------------------------------------------------- /Part2/5 Nil/Nullable.pas: -------------------------------------------------------------------------------- 1 | unit Nullable; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes, 8 | System.Generics.Defaults; 9 | 10 | type 11 | TNullable = record 12 | strict private 13 | FValue: T; 14 | FHasValue: IInterface; 15 | function GetValue: T; 16 | function GetHasValue: boolean; 17 | public 18 | constructor Create(AValue: T); 19 | function ValueOrDefault: T; overload; 20 | function ValueOrDefault(Default: T): T; overload; 21 | property HasValue: boolean read GetHasValue; 22 | property Value: T read GetValue; 23 | class operator Implicit(Value: TNullable): T; 24 | class operator Implicit(Value: T): TNullable; 25 | class operator Explicit(Value: TNullable): T; 26 | class operator NotEqual(const Left, Right: TNullable): boolean; 27 | class operator Equal(const Left, Right: TNullable): boolean; 28 | end; 29 | 30 | procedure SetFakeInterface(var Intf: IInterface); 31 | 32 | implementation 33 | 34 | function NopAddRef(inst: Pointer): integer; stdcall; 35 | begin 36 | Result := -1; 37 | end; 38 | 39 | function NopRelease(inst: Pointer): integer; stdcall; 40 | begin 41 | Result := -1; 42 | end; 43 | 44 | function NopQueryInterface(inst: Pointer; const IID: TGUID; out Obj): HResult; stdcall; 45 | begin 46 | Result := E_NOINTERFACE; 47 | end; 48 | 49 | const 50 | FakeInterfaceVTable: array [0 .. 2] of Pointer = (@NopQueryInterface, @NopAddRef, @NopRelease); 51 | FakeInterfaceInstance: Pointer = @FakeInterfaceVTable; 52 | 53 | procedure SetFakeInterface(var Intf: IInterface); 54 | begin 55 | Intf := IInterface(@FakeInterfaceInstance); 56 | end; 57 | 58 | constructor TNullable.Create(AValue: T); 59 | begin 60 | FValue := AValue; 61 | SetFakeInterface(FHasValue); 62 | end; 63 | 64 | function TNullable.GetHasValue: boolean; 65 | begin 66 | Result := FHasValue <> nil; 67 | end; 68 | 69 | function TNullable.GetValue: T; 70 | begin 71 | if not HasValue then raise Exception.Create('Invalid operation, Nullable type has no value'); 72 | Result := FValue; 73 | end; 74 | 75 | function TNullable.ValueOrDefault: T; 76 | begin 77 | if HasValue then Result := FValue 78 | else Result := default (T); 79 | end; 80 | 81 | function TNullable.ValueOrDefault(Default: T): T; 82 | begin 83 | if not HasValue then Result := default 84 | else Result := FValue; 85 | end; 86 | 87 | class operator TNullable.Explicit(Value: TNullable): T; 88 | begin 89 | Result := Value.Value; 90 | end; 91 | 92 | class operator TNullable.Implicit(Value: TNullable): T; 93 | begin 94 | Result := Value.Value; 95 | end; 96 | 97 | class operator TNullable.Implicit(Value: T): TNullable; 98 | begin 99 | Result := TNullable.Create(Value); 100 | end; 101 | 102 | class operator TNullable.Equal(const Left, Right: TNullable): boolean; 103 | var 104 | Comparer: IEqualityComparer; 105 | begin 106 | if Left.HasValue and Right.HasValue then 107 | begin 108 | Comparer := TEqualityComparer.Default; 109 | Result := Comparer.Equals(Left.Value, Right.Value); 110 | end 111 | else Result := Left.HasValue = Right.HasValue; 112 | end; 113 | 114 | class operator TNullable.NotEqual(const Left, Right: TNullable): boolean; 115 | var 116 | Comparer: IEqualityComparer; 117 | begin 118 | if Left.HasValue and Right.HasValue then 119 | begin 120 | Comparer := TEqualityComparer.Default; 121 | Result := not Comparer.Equals(Left.Value, Right.Value); 122 | end 123 | else Result := Left.HasValue <> Right.HasValue; 124 | end; 125 | 126 | end. 127 | -------------------------------------------------------------------------------- /Part2/5 Nil/TreeNil.dpr: -------------------------------------------------------------------------------- 1 | program TreeNil; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | var 6 | Count: Integer; 7 | 8 | type 9 | TNode = class(TObject) 10 | strict private 11 | FValue: Integer; 12 | FLeft, FRight: TNode; 13 | public 14 | constructor Create(AValue: Integer); 15 | destructor Destroy; override; 16 | property Value: Integer read FValue; 17 | property Left: TNode read FLeft write FLeft; 18 | property Right: TNode read FRight write FRight; 19 | end; 20 | 21 | TBinarySearchTree = class(TObject) 22 | protected 23 | function DoSearch(AValue: Integer; ANode: TNode): TNode; 24 | procedure DoPrint(ANode: TNode); 25 | public 26 | Root: TNode; 27 | destructor Destroy; override; 28 | procedure Insert(AValue: Integer); 29 | function Search(AValue: Integer): TNode; 30 | procedure Print; 31 | end; 32 | 33 | constructor TNode.Create(AValue: Integer); 34 | begin 35 | Inc(Count); 36 | FValue := AValue; 37 | end; 38 | 39 | destructor TNode.Destroy; 40 | begin 41 | FLeft.Free; 42 | FRight.Free; 43 | inherited; 44 | end; 45 | 46 | destructor TBinarySearchTree.Destroy; 47 | begin 48 | Root.Free; 49 | inherited; 50 | end; 51 | 52 | procedure TBinarySearchTree.Insert(AValue: Integer); 53 | var 54 | Node, Current, Parent: TNode; 55 | begin 56 | Node := TNode.Create(AValue); 57 | if Root = nil then Root := Node 58 | else 59 | begin 60 | Current := Root; 61 | while true do 62 | begin 63 | Parent := Current; 64 | if AValue < Parent.Value then 65 | begin 66 | Current := Current.Left; 67 | if Current = nil then 68 | begin 69 | Parent.Left := Node; 70 | break; 71 | end; 72 | end 73 | else 74 | begin 75 | Current := Current.Right; 76 | if Current = nil then 77 | begin 78 | Parent.Right := Node; 79 | break; 80 | end; 81 | end; 82 | end; 83 | end; 84 | end; 85 | 86 | function TBinarySearchTree.DoSearch(AValue: Integer; ANode: TNode): TNode; 87 | begin 88 | if (ANode = nil) or (AValue = ANode.Value) then Result := ANode 89 | else 90 | if AValue < ANode.Value then Result := DoSearch(AValue, ANode.Left) 91 | else Result := DoSearch(AValue, ANode.Right); 92 | end; 93 | 94 | function TBinarySearchTree.Search(AValue: Integer): TNode; 95 | begin 96 | Result := DoSearch(AValue, Root); 97 | end; 98 | 99 | procedure TBinarySearchTree.DoPrint(ANode: TNode); 100 | begin 101 | if ANode <> nil then 102 | begin 103 | DoPrint(ANode.Left); 104 | Writeln(ANode.Value); 105 | DoPrint(ANode.Right); 106 | end; 107 | end; 108 | 109 | procedure TBinarySearchTree.Print; 110 | begin 111 | DoPrint(Root); 112 | end; 113 | 114 | var 115 | Tree: TBinarySearchTree; 116 | begin 117 | ReportMemoryLeaksOnShutdown := true; 118 | Tree := TBinarySearchTree.Create; 119 | try 120 | Tree.Insert(6); 121 | Tree.Insert(5); 122 | Tree.Insert(3); 123 | Tree.Insert(2); 124 | Tree.Insert(9); 125 | Tree.Insert(4); 126 | Tree.Insert(7); 127 | Tree.Insert(8); 128 | Tree.Insert(1); 129 | Tree.Print; 130 | if Tree.Search(10) = nil then Writeln('10 not found') 131 | else Writeln('10 found'); 132 | finally 133 | Tree.Free; 134 | end; 135 | Writeln('Total count: ', Count); 136 | 137 | Readln; 138 | end. 139 | -------------------------------------------------------------------------------- /Part2/5 Nil/TreeNullObject.dpr: -------------------------------------------------------------------------------- 1 | program TreeNullObject; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | var 6 | Count: Integer; 7 | 8 | type 9 | TNode = class(TObject) 10 | strict protected 11 | FValue: Integer; 12 | FLeft, FRight: TNode; 13 | function GetLeft: TNode; virtual; 14 | function GetRight: TNode; virtual; 15 | procedure SetLeft(const Value: TNode); 16 | procedure SetRight(const Value: TNode); 17 | public 18 | constructor Create(AValue: Integer); 19 | destructor Destroy; override; 20 | function IsNull: boolean; virtual; 21 | property Value: Integer read FValue; 22 | property Left: TNode read GetLeft write SetLeft; 23 | property Right: TNode read GetRight write SetRight; 24 | end; 25 | 26 | TNullNode = class(TNode) 27 | strict protected 28 | function GetLeft: TNode; override; 29 | function GetRight: TNode; override; 30 | public 31 | constructor Create; 32 | function IsNull: boolean; override; 33 | end; 34 | 35 | TBinarySearchTree = class(TObject) 36 | protected 37 | function DoSearch(AValue: Integer; ANode: TNode): TNode; 38 | procedure DoPrint(ANode: TNode); 39 | public 40 | Root: TNode; 41 | constructor Create; 42 | destructor Destroy; override; 43 | procedure Insert(AValue: Integer); 44 | function Search(AValue: Integer): TNode; 45 | procedure Print; 46 | end; 47 | 48 | constructor TNode.Create(AValue: Integer); 49 | begin 50 | Inc(Count); 51 | FValue := AValue; 52 | FLeft := TNullNode.Create; 53 | FRight := TNullNode.Create; 54 | end; 55 | 56 | destructor TNode.Destroy; 57 | begin 58 | FLeft.Free; 59 | FRight.Free; 60 | inherited; 61 | end; 62 | 63 | function TNode.GetLeft: TNode; 64 | begin 65 | Result := FLeft; 66 | end; 67 | 68 | function TNode.GetRight: TNode; 69 | begin 70 | Result := FRight; 71 | end; 72 | 73 | function TNode.IsNull: boolean; 74 | begin 75 | Result := false; 76 | end; 77 | 78 | procedure TNode.SetLeft(const Value: TNode); 79 | begin 80 | if FLeft.IsNull then FLeft.Free; 81 | FLeft := Value; 82 | end; 83 | 84 | procedure TNode.SetRight(const Value: TNode); 85 | begin 86 | if FRight.IsNull then FRight.Free; 87 | FRight := Value; 88 | end; 89 | 90 | constructor TNullNode.Create; 91 | begin 92 | Inc(Count); 93 | end; 94 | 95 | function TNullNode.GetLeft: TNode; 96 | begin 97 | Result := Self; 98 | end; 99 | 100 | function TNullNode.GetRight: TNode; 101 | begin 102 | Result := Self; 103 | end; 104 | 105 | function TNullNode.IsNull: boolean; 106 | begin 107 | Result := true; 108 | end; 109 | 110 | constructor TBinarySearchTree.Create; 111 | begin 112 | Root := TNullNode.Create; 113 | end; 114 | 115 | destructor TBinarySearchTree.Destroy; 116 | begin 117 | Root.Free; 118 | inherited; 119 | end; 120 | 121 | procedure TBinarySearchTree.Insert(AValue: Integer); 122 | var 123 | Node, Current, Parent: TNode; 124 | begin 125 | Node := TNode.Create(AValue); 126 | if Root.IsNull then 127 | begin 128 | Root.Free; 129 | Root := Node; 130 | end 131 | else 132 | begin 133 | Current := Root; 134 | while true do 135 | begin 136 | Parent := Current; 137 | if AValue < Parent.Value then 138 | begin 139 | Current := Current.Left; 140 | if Current.IsNull then 141 | begin 142 | Parent.Left := Node; 143 | break; 144 | 145 | end; 146 | end 147 | else 148 | begin 149 | Current := Current.Right; 150 | if Current.IsNull then 151 | begin 152 | Parent.Right := Node; 153 | break; 154 | end; 155 | end; 156 | end; 157 | end; 158 | end; 159 | 160 | function TBinarySearchTree.DoSearch(AValue: Integer; ANode: TNode): TNode; 161 | begin 162 | if ANode.IsNull or (AValue = ANode.Value) then Result := ANode 163 | else 164 | if AValue < ANode.Value then Result := DoSearch(AValue, ANode.Left) 165 | else Result := DoSearch(AValue, ANode.Right); 166 | end; 167 | 168 | function TBinarySearchTree.Search(AValue: Integer): TNode; 169 | begin 170 | Result := DoSearch(AValue, Root); 171 | end; 172 | 173 | procedure TBinarySearchTree.DoPrint(ANode: TNode); 174 | begin 175 | if not ANode.IsNull then 176 | begin 177 | DoPrint(ANode.Left); 178 | Writeln(ANode.Value); 179 | DoPrint(ANode.Right); 180 | end; 181 | end; 182 | 183 | procedure TBinarySearchTree.Print; 184 | begin 185 | DoPrint(Root); 186 | end; 187 | 188 | var 189 | Tree: TBinarySearchTree; 190 | begin 191 | ReportMemoryLeaksOnShutdown := true; 192 | 193 | Tree := TBinarySearchTree.Create; 194 | try 195 | Tree.Insert(6); 196 | Tree.Insert(5); 197 | Tree.Insert(3); 198 | Tree.Insert(2); 199 | Tree.Insert(9); 200 | Tree.Insert(4); 201 | Tree.Insert(7); 202 | Tree.Insert(8); 203 | Tree.Insert(1); 204 | Tree.Print; 205 | if Tree.Search(10).IsNull then Writeln('10 not found') 206 | else Writeln('10 found'); 207 | finally 208 | Tree.Free; 209 | end; 210 | Writeln('Total Count: ', Count); 211 | 212 | Readln; 213 | end. 214 | -------------------------------------------------------------------------------- /Part2/5 Nil/TreeNullObjectSingle.dpr: -------------------------------------------------------------------------------- 1 | program TreeNullObjectSingle; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | var 6 | Count: Integer; 7 | 8 | type 9 | TNode = class(TObject) 10 | strict protected 11 | FValue: Integer; 12 | FLeft, FRight: TNode; 13 | function GetLeft: TNode; virtual; 14 | function GetRight: TNode; virtual; 15 | procedure SetLeft(const Value: TNode); 16 | procedure SetRight(const Value: TNode); 17 | public 18 | constructor Create(AValue: Integer); 19 | destructor Destroy; override; 20 | function IsNull: boolean; virtual; 21 | property Value: Integer read FValue; 22 | property Left: TNode read GetLeft write SetLeft; 23 | property Right: TNode read GetRight write SetRight; 24 | end; 25 | 26 | TNullNode = class(TNode) 27 | public 28 | class var Instance: TNode; 29 | class constructor ClassCreate; 30 | class destructor ClassDestroy; 31 | strict protected 32 | function GetLeft: TNode; override; 33 | function GetRight: TNode; override; 34 | public 35 | constructor Create; 36 | function IsNull: boolean; override; 37 | end; 38 | 39 | TBinarySearchTree = class(TObject) 40 | protected 41 | function DoSearch(AValue: Integer; ANode: TNode): TNode; 42 | procedure DoPrint(ANode: TNode); 43 | public 44 | Root: TNode; 45 | constructor Create; 46 | destructor Destroy; override; 47 | procedure Insert(AValue: Integer); 48 | function Search(AValue: Integer): TNode; 49 | procedure Print; 50 | end; 51 | 52 | constructor TNode.Create(AValue: Integer); 53 | begin 54 | Inc(Count); 55 | FValue := AValue; 56 | FLeft := TNullNode.Instance; 57 | FRight := TNullNode.Instance; 58 | end; 59 | 60 | destructor TNode.Destroy; 61 | begin 62 | if not Left.IsNull then FLeft.Free; 63 | if not Right.IsNull then FRight.Free; 64 | inherited; 65 | end; 66 | 67 | function TNode.GetLeft: TNode; 68 | begin 69 | Result := FLeft; 70 | end; 71 | 72 | function TNode.GetRight: TNode; 73 | begin 74 | Result := FRight; 75 | end; 76 | 77 | function TNode.IsNull: boolean; 78 | begin 79 | Result := false; 80 | end; 81 | 82 | procedure TNode.SetLeft(const Value: TNode); 83 | begin 84 | FLeft := Value; 85 | end; 86 | 87 | procedure TNode.SetRight(const Value: TNode); 88 | begin 89 | FRight := Value; 90 | end; 91 | 92 | class constructor TNullNode.ClassCreate; 93 | begin 94 | Instance := TNullNode.Create; 95 | end; 96 | 97 | class destructor TNullNode.ClassDestroy; 98 | begin 99 | Instance.Free; 100 | end; 101 | 102 | constructor TNullNode.Create; 103 | begin 104 | Inc(Count); 105 | end; 106 | 107 | function TNullNode.GetLeft: TNode; 108 | begin 109 | Result := Self; 110 | end; 111 | 112 | function TNullNode.GetRight: TNode; 113 | begin 114 | Result := Self; 115 | end; 116 | 117 | function TNullNode.IsNull: boolean; 118 | begin 119 | Result := true; 120 | end; 121 | 122 | constructor TBinarySearchTree.Create; 123 | begin 124 | Root := TNullNode.Instance; 125 | end; 126 | 127 | destructor TBinarySearchTree.Destroy; 128 | begin 129 | if not Root.IsNull then Root.Free; 130 | inherited; 131 | end; 132 | 133 | procedure TBinarySearchTree.Insert(AValue: Integer); 134 | var 135 | Node, Current, Parent: TNode; 136 | begin 137 | Node := TNode.Create(AValue); 138 | if Root.IsNull then Root := Node 139 | else 140 | begin 141 | Current := Root; 142 | while true do 143 | begin 144 | Parent := Current; 145 | if AValue < Parent.Value then 146 | begin 147 | Current := Current.Left; 148 | if Current.IsNull then 149 | begin 150 | Parent.Left := Node; 151 | break; 152 | end; 153 | end 154 | else 155 | begin 156 | Current := Current.Right; 157 | if Current.IsNull then 158 | begin 159 | Parent.Right := Node; 160 | break; 161 | end; 162 | end; 163 | end; 164 | end; 165 | end; 166 | 167 | function TBinarySearchTree.DoSearch(AValue: Integer; ANode: TNode): TNode; 168 | begin 169 | if ANode.IsNull or (AValue = ANode.Value) then Result := ANode 170 | else 171 | if AValue < ANode.Value then Result := DoSearch(AValue, ANode.Left) 172 | else Result := DoSearch(AValue, ANode.Right); 173 | end; 174 | 175 | function TBinarySearchTree.Search(AValue: Integer): TNode; 176 | begin 177 | Result := DoSearch(AValue, Root); 178 | end; 179 | 180 | procedure TBinarySearchTree.DoPrint(ANode: TNode); 181 | begin 182 | if not ANode.IsNull then 183 | begin 184 | DoPrint(ANode.Left); 185 | Writeln(ANode.Value); 186 | DoPrint(ANode.Right); 187 | end; 188 | end; 189 | 190 | procedure TBinarySearchTree.Print; 191 | begin 192 | DoPrint(Root); 193 | end; 194 | 195 | var 196 | Tree: TBinarySearchTree; 197 | // code using single null object implementation 198 | // is the same as code using multiple one 199 | begin 200 | ReportMemoryLeaksOnShutdown := true; 201 | 202 | Tree := TBinarySearchTree.Create; 203 | try 204 | Tree.Insert(6); 205 | Tree.Insert(5); 206 | Tree.Insert(3); 207 | Tree.Insert(2); 208 | Tree.Insert(9); 209 | Tree.Insert(4); 210 | Tree.Insert(7); 211 | Tree.Insert(8); 212 | Tree.Insert(1); 213 | Tree.Print; 214 | if Tree.Search(10).IsNull then Writeln('10 not found') 215 | else Writeln('10 found'); 216 | finally 217 | Tree.Free; 218 | end; 219 | Writeln('Total Count: ', Count); 220 | 221 | Readln; 222 | end. 223 | -------------------------------------------------------------------------------- /Part2/5 Nil/Weather.dpr: -------------------------------------------------------------------------------- 1 | program Weather; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | Nullable; 7 | 8 | type 9 | TWeatherReport = record 10 | public 11 | Hour: Integer; 12 | Temperature: TNullable; 13 | Wind: TNullable; 14 | procedure Print; 15 | end; 16 | 17 | procedure TWeatherReport.Print; 18 | begin 19 | write('Hour: ', Hour); 20 | if Temperature.HasValue then write(', Temp: ', Temperature.Value) 21 | else write(', Temp: not measured'); 22 | if Wind.HasValue then Writeln(', Wind: ', Wind.Value) 23 | else Writeln(', Wind: not measured'); 24 | end; 25 | 26 | var 27 | Report: TWeatherReport; 28 | begin 29 | Report.Hour := 23; 30 | Report.Wind := 6; 31 | Report.Print; 32 | 33 | Readln; 34 | end. 35 | -------------------------------------------------------------------------------- /Part5/Lazy/LazyDeathStar.dpr: -------------------------------------------------------------------------------- 1 | program LazyDeathStar; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | type 9 | TTIEFighter = class(TObject) 10 | public 11 | procedure Fight; 12 | constructor Create; 13 | destructor Destroy; override; 14 | end; 15 | 16 | TDeathStar = class(TObject) 17 | public 18 | constructor Create; 19 | destructor Destroy; override; 20 | procedure DestroyPlanet(const Planet: string); 21 | end; 22 | 23 | TDeathStarLazyWrapper = class(TObject) 24 | strict private 25 | FInstance: TDeathStar; 26 | function GetIsAssigned: boolean; 27 | function GetInstance: TDeathStar; 28 | public 29 | destructor Destroy; override; 30 | property IsAssigned: boolean read GetIsAssigned; 31 | property Instance: TDeathStar read GetInstance; 32 | end; 33 | 34 | TImperialFleet = class(TObject) 35 | strict protected 36 | TIE: TTIEFighter; 37 | DeathStar: TDeathStarLazyWrapper; 38 | public 39 | constructor Create; 40 | destructor Destroy; override; 41 | procedure Fight; 42 | procedure DestroyPlanet(const Planet: string); 43 | end; 44 | 45 | constructor TTIEFighter.Create; 46 | begin 47 | inherited; 48 | Writeln('TIE ready'); 49 | end; 50 | 51 | destructor TTIEFighter.Destroy; 52 | begin 53 | Writeln('TIE destroyed'); 54 | inherited; 55 | end; 56 | 57 | procedure TTIEFighter.Fight; 58 | begin 59 | Writeln('TIE engaged'); 60 | end; 61 | 62 | constructor TDeathStar.Create; 63 | begin 64 | inherited; 65 | Writeln('Death Star constructed'); 66 | end; 67 | 68 | destructor TDeathStar.Destroy; 69 | begin 70 | Writeln('Death Star destroyed'); 71 | inherited; 72 | end; 73 | 74 | procedure TDeathStar.DestroyPlanet(const Planet: string); 75 | begin 76 | Writeln(Planet, ' has been destroyed!!!'); 77 | end; 78 | 79 | destructor TDeathStarLazyWrapper.Destroy; 80 | begin 81 | FInstance.Free; 82 | inherited; 83 | end; 84 | 85 | function TDeathStarLazyWrapper.GetIsAssigned: boolean; 86 | begin 87 | Result := Assigned(FInstance); 88 | end; 89 | 90 | function TDeathStarLazyWrapper.GetInstance: TDeathStar; 91 | begin 92 | if not Assigned(FInstance) then FInstance := TDeathStar.Create; 93 | Result := FInstance; 94 | end; 95 | 96 | constructor TImperialFleet.Create; 97 | begin 98 | inherited; 99 | TIE := TTIEFighter.Create; 100 | DeathStar := TDeathStarLazyWrapper.Create; 101 | end; 102 | 103 | destructor TImperialFleet.Destroy; 104 | begin 105 | Writeln('Destroying Imperial Fleet'); 106 | if DeathStar.IsAssigned then Writeln('Death Star is operational'); 107 | TIE.Free; 108 | DeathStar.Free; 109 | inherited; 110 | end; 111 | 112 | procedure TImperialFleet.DestroyPlanet(const Planet: string); 113 | begin 114 | DeathStar.Instance.DestroyPlanet(Planet); 115 | end; 116 | 117 | procedure TImperialFleet.Fight; 118 | begin 119 | TIE.Fight; 120 | end; 121 | 122 | var 123 | Fleet: TImperialFleet; 124 | 125 | begin 126 | Fleet := TImperialFleet.Create; 127 | try 128 | Fleet.Fight; 129 | Fleet.Fight; 130 | Fleet.DestroyPlanet('Alderaan'); 131 | Fleet.Fight; 132 | finally 133 | Fleet.Free; 134 | end; 135 | Readln; 136 | end. 137 | -------------------------------------------------------------------------------- /Part5/Lazy/ReallyLazyDeathStar.dpr: -------------------------------------------------------------------------------- 1 | program ReallyLazyDeathStar; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | // Death Star will not only be lazily constructed, 6 | // but will also be released when not needed 7 | 8 | uses 9 | System.SysUtils; 10 | 11 | type 12 | TTIEFighter = class(TObject) 13 | public 14 | procedure Fight; 15 | constructor Create; 16 | destructor Destroy; override; 17 | end; 18 | 19 | TDeathStar = class(TObject) 20 | public 21 | constructor Create; 22 | destructor Destroy; override; 23 | procedure DestroyPlanet(const Planet: string); 24 | end; 25 | 26 | TDeathStarLazyWrapper = class(TObject) 27 | strict private 28 | FInstance: TDeathStar; 29 | function GetIsAssigned: boolean; 30 | function GetInstance: TDeathStar; 31 | public 32 | destructor Destroy; override; 33 | procedure Clear; 34 | property IsAssigned: boolean read GetIsAssigned; 35 | property Instance: TDeathStar read GetInstance; 36 | end; 37 | 38 | TImperialFleet = class(TObject) 39 | strict protected 40 | TIE: TTIEFighter; 41 | DeathStar: TDeathStarLazyWrapper; 42 | public 43 | constructor Create; 44 | destructor Destroy; override; 45 | procedure Fight; 46 | procedure DestroyPlanet(const Planet: string); 47 | procedure PackDeathStar; 48 | end; 49 | 50 | constructor TTIEFighter.Create; 51 | begin 52 | inherited; 53 | Writeln('TIE ready'); 54 | end; 55 | 56 | destructor TTIEFighter.Destroy; 57 | begin 58 | Writeln('TIE destroyed'); 59 | inherited; 60 | end; 61 | 62 | procedure TTIEFighter.Fight; 63 | begin 64 | Writeln('TIE engaged'); 65 | end; 66 | 67 | constructor TDeathStar.Create; 68 | begin 69 | inherited; 70 | Writeln('Death Star constructed'); 71 | end; 72 | 73 | destructor TDeathStar.Destroy; 74 | begin 75 | Writeln('Death Star destroyed'); 76 | inherited; 77 | end; 78 | 79 | procedure TDeathStar.DestroyPlanet(const Planet: string); 80 | begin 81 | Writeln(Planet, ' has been destroyed!!!'); 82 | end; 83 | 84 | procedure TDeathStarLazyWrapper.Clear; 85 | begin 86 | FreeAndNil(FInstance); 87 | end; 88 | 89 | destructor TDeathStarLazyWrapper.Destroy; 90 | begin 91 | FInstance.Free; 92 | inherited; 93 | end; 94 | 95 | function TDeathStarLazyWrapper.GetIsAssigned: boolean; 96 | begin 97 | Result := Assigned(FInstance); 98 | end; 99 | 100 | function TDeathStarLazyWrapper.GetInstance: TDeathStar; 101 | begin 102 | if not Assigned(FInstance) then FInstance := TDeathStar.Create; 103 | Result := FInstance; 104 | end; 105 | 106 | constructor TImperialFleet.Create; 107 | begin 108 | inherited; 109 | TIE := TTIEFighter.Create; 110 | DeathStar := TDeathStarLazyWrapper.Create; 111 | end; 112 | 113 | destructor TImperialFleet.Destroy; 114 | begin 115 | Writeln('Destroying Imperial Fleet'); 116 | if DeathStar.IsAssigned then Writeln('Death Star is operational'); 117 | TIE.Free; 118 | DeathStar.Free; 119 | inherited; 120 | end; 121 | 122 | procedure TImperialFleet.DestroyPlanet(const Planet: string); 123 | begin 124 | DeathStar.Instance.DestroyPlanet(Planet); 125 | end; 126 | 127 | procedure TImperialFleet.PackDeathStar; 128 | begin 129 | DeathStar.Clear; 130 | end; 131 | 132 | procedure TImperialFleet.Fight; 133 | begin 134 | TIE.Fight; 135 | end; 136 | 137 | var 138 | Fleet: TImperialFleet; 139 | 140 | begin 141 | Fleet := TImperialFleet.Create; 142 | try 143 | Fleet.Fight; 144 | Fleet.Fight; 145 | Fleet.DestroyPlanet('Despayre'); 146 | Fleet.DestroyPlanet('Alderaan'); 147 | Fleet.PackDeathStar; 148 | Fleet.Fight; 149 | Fleet.DestroyPlanet('Yavin IV'); 150 | finally 151 | Fleet.Free; 152 | end; 153 | Readln; 154 | end. 155 | -------------------------------------------------------------------------------- /Part5/SmartPointer/Smart.dpr: -------------------------------------------------------------------------------- 1 | program Smart; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | {$R *.res} 6 | 7 | uses 8 | System.SysUtils, 9 | System.Classes, 10 | uSmartPtr in 'uSmartPtr.pas', 11 | uLifeMgr in 'uLifeMgr.pas'; 12 | 13 | procedure UseStrings(Strings: TStrings); 14 | begin 15 | Writeln(Trim(Strings.Text)); 16 | end; 17 | 18 | procedure Unmanaged; 19 | var 20 | sl: TStringList; 21 | begin 22 | sl := TStringList.Create; 23 | try 24 | sl.Add('I am inside regular StringList'); 25 | UseStrings(sl); 26 | finally 27 | sl.Free; 28 | writeln('Manual Free'); 29 | end; 30 | end; 31 | 32 | procedure SmartPtr; 33 | var 34 | sl: ISmartPointer; 35 | begin 36 | sl := TSmartPointer.Create(); 37 | sl.Add('I am inside automanaged StringList'); 38 | 39 | UseStrings(sl); 40 | end; // TStringList object instance inside sl wrapper will be destoyed at this point 41 | 42 | procedure LifeManager; 43 | var 44 | sl: ILifeTimeManager; 45 | begin 46 | sl := TLifeTimeManager.Create(); 47 | sl.Value.Add('I am inside automanaged StringList'); 48 | UseStrings(sl.Value); 49 | end; // TStringList object instance inside sl wrapper will be destoyed at this point 50 | 51 | begin 52 | ReportMemoryLeaksOnShutdown := true; 53 | try 54 | SmartPtr; 55 | 56 | LifeManager; 57 | 58 | Unmanaged; 59 | except 60 | on E: Exception do 61 | Writeln(E.ClassName, ': ', E.Message); 62 | end; 63 | 64 | Readln; 65 | end. 66 | -------------------------------------------------------------------------------- /Part5/SmartPointer/uLifeMgr.pas: -------------------------------------------------------------------------------- 1 | unit uLifeMgr; 2 | 3 | interface 4 | 5 | // SmartPointer implementation with regular interface 6 | // for disctinction named LifetimeManager 7 | 8 | type 9 | ILifetimeManager = interface 10 | function Value: T; 11 | end; 12 | 13 | TLifetimeManager = class(TInterfacedObject, ILifetimeManager) 14 | private 15 | FValue: T; 16 | function Value: T; 17 | public 18 | constructor Create; overload; 19 | constructor Create(AValue: T); overload; 20 | destructor Destroy; override; 21 | end; 22 | 23 | implementation 24 | 25 | constructor TLifetimeManager.Create; 26 | begin 27 | inherited Create; 28 | FValue := T.Create; 29 | end; 30 | 31 | constructor TLifetimeManager.Create(AValue: T); 32 | begin 33 | inherited Create; 34 | FValue := AValue; 35 | end; 36 | 37 | destructor TLifetimeManager.Destroy; 38 | begin 39 | writeln('Lifetime Manager Free ' + FValue.ClassName); 40 | FValue.Free; 41 | inherited; 42 | end; 43 | 44 | function TLifetimeManager.Value: T; 45 | begin 46 | Result := FValue; 47 | end; 48 | 49 | end. 50 | -------------------------------------------------------------------------------- /Part5/SmartPointer/uSmartPtr.pas: -------------------------------------------------------------------------------- 1 | unit uSmartPtr; 2 | 3 | interface 4 | 5 | // SmartPointer implementation with anonymous method 6 | 7 | type 8 | ISmartPointer = reference to function: T; 9 | 10 | TSmartPointer = class(TInterfacedObject, ISmartPointer) 11 | private 12 | FValue: T; 13 | function Invoke: T; 14 | public 15 | constructor Create; overload; 16 | constructor Create(AValue: T); overload; 17 | destructor Destroy; override; 18 | end; 19 | 20 | implementation 21 | 22 | constructor TSmartPointer.Create; 23 | begin 24 | inherited Create; 25 | FValue := T.Create; 26 | end; 27 | 28 | constructor TSmartPointer.Create(AValue: T); 29 | begin 30 | inherited Create; 31 | FValue := AValue; 32 | end; 33 | 34 | destructor TSmartPointer.Destroy; 35 | begin 36 | writeln('Smart Pointer Free ' + FValue.ClassName); 37 | FValue.Free; 38 | inherited; 39 | end; 40 | 41 | function TSmartPointer.Invoke: T; 42 | begin 43 | Result := FValue; 44 | end; 45 | 46 | end. 47 | -------------------------------------------------------------------------------- /Part5/Weak/SimplerWeakMagic.dpr: -------------------------------------------------------------------------------- 1 | program SimplerWeakMagic; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils, 7 | uZWeak in 'uZWeak.pas'; 8 | 9 | type 10 | TMaterial = (Wood, Stone, Metal); 11 | 12 | TMagicWand = class(TObject) 13 | public 14 | Material: TMaterial; 15 | procedure Magic; 16 | function MaterialToString: string; 17 | destructor Destroy; override; 18 | end; 19 | 20 | TWizard = class(TObject) 21 | strict protected 22 | FWand: IWeak; 23 | function GetWand: TMagicWand; 24 | procedure SetWand(const Value: TMagicWand); 25 | public 26 | procedure UseWand; 27 | property Wand: TMagicWand read GetWand write SetWand; 28 | end; 29 | 30 | procedure TMagicWand.Magic; 31 | begin 32 | case Material of 33 | Wood: Writeln('Casting magic with wooden wand'); 34 | Stone: Writeln('Casting magic with stone wand'); 35 | Metal: Writeln('Casting magic with metal wand'); 36 | end; 37 | end; 38 | 39 | function TMagicWand.MaterialToString: string; 40 | begin 41 | case Material of 42 | Wood: Result := 'wood'; 43 | Stone: Result := 'stone'; 44 | Metal: Result := 'metal'; 45 | end; 46 | end; 47 | 48 | destructor TMagicWand.Destroy; 49 | begin 50 | Writeln('Wand has been destroyed: ', MaterialToString); 51 | inherited; 52 | end; 53 | 54 | function TWizard.GetWand: TMagicWand; 55 | begin 56 | if Assigned(FWand) then Result := FWand.Ref 57 | else Result := nil; 58 | end; 59 | 60 | procedure TWizard.SetWand(const Value: TMagicWand); 61 | begin 62 | FWand := TWeak.Create(Value); 63 | end; 64 | 65 | procedure TWizard.UseWand; 66 | begin 67 | if Assigned(FWand) and Assigned(FWand.Ref) then FWand.Ref.Magic 68 | else Writeln('Cannot cast magic without a wand'); 69 | end; 70 | 71 | var 72 | Wizard: TWizard; 73 | WoodenWand, MetalWand: TMagicWand; 74 | 75 | begin 76 | ReportMemoryLeaksOnShutdown := true; 77 | // creating wooden wand 78 | WoodenWand := TMagicWand.Create; 79 | WoodenWand.Material := Wood; 80 | // creating metal wand 81 | MetalWand := TMagicWand.Create; 82 | MetalWand.Material := Metal; 83 | // creating wizard 84 | Wizard := TWizard.Create; 85 | // wizard uses wand before he has one 86 | Wizard.UseWand; 87 | // wizard picks up metal wand and uses it 88 | Wizard.Wand := MetalWand; 89 | Wizard.UseWand; 90 | // wizard picks up wooden wand and uses it 91 | Wizard.Wand := WoodenWand; 92 | Wizard.UseWand; 93 | // fire destroys all wooden wands 94 | WoodenWand.Free; 95 | // wizard tries to use wand but he no longer has one 96 | Wizard.UseWand; 97 | // clean up 98 | MetalWand.Free; 99 | Wizard.Free; 100 | Readln; 101 | 102 | end. 103 | -------------------------------------------------------------------------------- /Part5/Weak/WeakMagic.dpr: -------------------------------------------------------------------------------- 1 | program WeakMagic; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | System.SysUtils, 7 | uZWeak in 'uZWeak.pas'; 8 | 9 | type 10 | TMaterial = (Wood, Stone, Metal); 11 | 12 | TMagicWand = class(TObject) 13 | public 14 | Material: TMaterial; 15 | procedure Magic; 16 | function MaterialToString: string; 17 | destructor Destroy; override; 18 | end; 19 | 20 | TWizard = class(TObject) 21 | strict protected 22 | FWand: IWeak; 23 | public 24 | procedure UseWand; 25 | property Wand: IWeak read FWand write FWand; 26 | end; 27 | 28 | procedure TMagicWand.Magic; 29 | begin 30 | case Material of 31 | Wood: Writeln('Casting magic with wooden wand'); 32 | Stone: Writeln('Casting magic with stone wand'); 33 | Metal: Writeln('Casting magic with metal wand'); 34 | end; 35 | end; 36 | 37 | function TMagicWand.MaterialToString: string; 38 | begin 39 | case Material of 40 | Wood: Result := 'wood'; 41 | Stone: Result := 'stone'; 42 | Metal: Result := 'metal'; 43 | end; 44 | end; 45 | 46 | destructor TMagicWand.Destroy; 47 | begin 48 | Writeln('Wand has been destroyed: ', MaterialToString); 49 | inherited; 50 | end; 51 | 52 | procedure TWizard.UseWand; 53 | begin 54 | if Assigned(FWand) and Assigned(FWand.Ref) then FWand.Ref.Magic 55 | else Writeln('Cannot cast magic without a wand'); 56 | end; 57 | 58 | var 59 | Wizard: TWizard; 60 | WoodenWand, MetalWand: TMagicWand; 61 | 62 | begin 63 | ReportMemoryLeaksOnShutdown := true; 64 | // creating wooden wand 65 | WoodenWand := TMagicWand.Create; 66 | WoodenWand.Material := Wood; 67 | // creating metal wand 68 | MetalWand := TMagicWand.Create; 69 | MetalWand.Material := Metal; 70 | // creating wizard 71 | Wizard := TWizard.Create; 72 | // wizard uses wand before he has one 73 | Wizard.UseWand; 74 | // wizard picks up metal wand and uses it 75 | Wizard.Wand := TWeak.Create(MetalWand); 76 | Wizard.UseWand; 77 | // wizard picks up wooden wand and uses it 78 | Wizard.Wand := TWeak.Create(WoodenWand); 79 | Wizard.UseWand; 80 | // fire destroys all wooden wands 81 | WoodenWand.Free; 82 | // wizard tries to use wand but he no longer has one 83 | Wizard.UseWand; 84 | // clean up 85 | MetalWand.Free; 86 | Wizard.Free; 87 | Readln; 88 | end. 89 | -------------------------------------------------------------------------------- /Part5/Weak/uZWeak.pas: -------------------------------------------------------------------------------- 1 | unit uZWeak; 2 | 3 | interface 4 | 5 | uses 6 | System.TypInfo, 7 | System.Rtti, 8 | System.Classes, 9 | System.Generics.Collections; 10 | 11 | type 12 | // support declarations 13 | PInterface = ^IInterface; 14 | 15 | IWeak = interface 16 | procedure Zero; 17 | end; 18 | 19 | WeakReferences = class 20 | strict private 21 | class var Interceptors: TObjectDictionary; 22 | class var Instances: TObjectDictionary>; 23 | class constructor ClassCreate; 24 | class destructor ClassDestroy; 25 | public 26 | class procedure AddInterceptor(const Instance: TObject); static; 27 | class procedure RemoveInstance(const Instance: TObject); static; 28 | class procedure AddReference(const Ref: IWeak; const Instance: TObject); static; 29 | class procedure RemoveReference(const Ref: IWeak; const Instance: Pointer); static; 30 | end; 31 | 32 | // Zeroing weak reference container 33 | IWeak = interface 34 | procedure Clear; 35 | function GetRef: T; 36 | property Ref: T read GetRef; 37 | end; 38 | 39 | TWeak = class(TInterfacedObject, IWeak, IWeak) 40 | protected 41 | FRef: Pointer; 42 | function GetRef: T; 43 | procedure Zero; 44 | public 45 | constructor Create(const Instance: T); 46 | destructor Destroy; override; 47 | procedure Clear; 48 | property Ref: T read GetRef; 49 | end; 50 | 51 | implementation 52 | 53 | class constructor WeakReferences.ClassCreate; 54 | begin 55 | Interceptors := TObjectDictionary.Create([doOwnsValues]); 56 | Instances := TObjectDictionary < Pointer, TList < IWeak >>.Create([doOwnsValues]); 57 | end; 58 | 59 | class destructor WeakReferences.ClassDestroy; 60 | begin 61 | Instances.Free; 62 | Interceptors.Free; 63 | end; 64 | 65 | class procedure WeakReferences.AddInterceptor(const Instance: TObject); 66 | var 67 | Interceptor: TVirtualMethodInterceptor; 68 | FreeMethod: TRttiMethod; 69 | begin 70 | if not Interceptors.TryGetValue(Instance.ClassType, Interceptor) then 71 | begin 72 | FreeMethod := TRttiContext.Create.GetType(Instance.ClassType).GetMethod('FreeInstance'); 73 | Interceptor := TVirtualMethodInterceptor.Create(Instance.ClassType); 74 | Interceptor.OnBefore := procedure(Intercepted: TObject; Method: TRttiMethod; const Args: TArray; out DoInvoke: boolean; out Result: TValue) 75 | begin 76 | if Method = FreeMethod then 77 | begin 78 | RemoveInstance(Intercepted); 79 | DoInvoke := true; 80 | end; 81 | end; 82 | Interceptors.Add(Instance.ClassType, Interceptor); 83 | end; 84 | Interceptor.Proxify(Instance); 85 | end; 86 | 87 | class procedure WeakReferences.RemoveInstance(const Instance: TObject); 88 | var 89 | Value: TList; 90 | i: integer; 91 | begin 92 | TMonitor.Enter(Instances); 93 | try 94 | if Instances.TryGetValue(Instance, Value) then 95 | begin 96 | for i := 0 to Value.Count - 1 do Value[i].Zero; 97 | Instances.Remove(Instance); 98 | end; 99 | finally 100 | TMonitor.Exit(Instances); 101 | end; 102 | end; 103 | 104 | class procedure WeakReferences.AddReference(const Ref: IWeak; const Instance: TObject); 105 | var 106 | Value: TList; 107 | begin 108 | TMonitor.Enter(Instances); 109 | try 110 | AddInterceptor(Instance); 111 | if not Instances.TryGetValue(Instance, Value) then 112 | begin 113 | Value := TList.Create; 114 | Instances.Add(Instance, Value); 115 | end; 116 | Value.Add(Ref); 117 | finally 118 | TMonitor.Exit(Instances); 119 | end; 120 | end; 121 | 122 | class procedure WeakReferences.RemoveReference(const Ref: IWeak; const Instance: Pointer); 123 | var 124 | Value: TList; 125 | i: integer; 126 | begin 127 | TMonitor.Enter(Instances); 128 | try 129 | if Instances.TryGetValue(Instance, Value) then 130 | begin 131 | i := Value.IndexOf(Ref); 132 | if i >= 0 then Value.Delete(i); 133 | end 134 | finally 135 | TMonitor.Exit(Instances); 136 | end; 137 | end; 138 | 139 | constructor TWeak.Create(const Instance: T); 140 | var 141 | Obj: TObject; 142 | Intf: IInterface; 143 | begin 144 | inherited Create; 145 | if PPointer(@Instance)^ <> nil then 146 | case PTypeInfo(TypeInfo(T)).Kind of 147 | tkClass: 148 | begin 149 | FRef := PPointer(@Instance)^; 150 | PObject(@Obj)^ := FRef; 151 | WeakReferences.AddReference(Self, Obj); 152 | end; 153 | tkInterface: 154 | begin 155 | FRef := PPointer(@Instance)^; 156 | Intf := IInterface(FRef); 157 | Obj := TObject(Intf); 158 | WeakReferences.AddReference(Self, Obj); 159 | end; 160 | end; 161 | end; 162 | 163 | destructor TWeak.Destroy; 164 | begin 165 | Clear; 166 | inherited; 167 | end; 168 | 169 | function TWeak.GetRef: T; 170 | begin 171 | if FRef <> nil then 172 | case PTypeInfo(TypeInfo(T)).Kind of 173 | tkClass: PObject(@Result)^ := FRef; 174 | tkInterface: PInterface(@Result)^ := IInterface(FRef); 175 | else Result := default (T); 176 | end 177 | else Result := default (T); 178 | end; 179 | 180 | procedure TWeak.Zero; 181 | begin 182 | FRef := nil; 183 | end; 184 | 185 | procedure TWeak.Clear; 186 | var 187 | Tmp: Pointer; 188 | Obj: TObject; 189 | Intf: IInterface; 190 | begin 191 | if FRef = nil then Exit; 192 | Tmp := FRef; 193 | FRef := nil; 194 | case PTypeInfo(TypeInfo(T)).Kind of 195 | tkClass: 196 | begin 197 | PObject(@Obj)^ := Tmp; 198 | WeakReferences.RemoveReference(Self, Obj); 199 | end; 200 | tkInterface: 201 | begin 202 | Intf := IInterface(Tmp); 203 | Obj := TObject(Intf); 204 | WeakReferences.RemoveReference(Self, Obj); 205 | end; 206 | end; 207 | end; 208 | 209 | end. 210 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Code examples from Delphi Memory Management for Classic and ARC Compilers Book 2 | 3 | [https://igoto.co/DelphiMM](https://igoto.co/DelphiMM) 4 | 5 | [https://dalija.prasnikar.info](https://dalija.prasnikar.info) 6 | 7 | 8 | ## Part 1. Memory management basics and terminology 9 | 10 | ### Chapter 3. Variables and types 11 | 12 | + ### 3.3.1 Wild reference 13 | 14 | Wild.dpr 15 | 16 | WildWorking.dpr 17 | 18 | + ### 3.3.2 Dangling reference 19 | 20 | Dangling.dpr 21 | 22 | + ### 3.3.3 Stale reference 23 | 24 | Stale.dpr 25 | 26 | + ### 3.4 Scope and lifetime 27 | 28 | Scope1.dpr 29 | 30 | Scope2.dpr 31 | 32 | Scope3.dpr 33 | 34 | ### Chapter 4. Classes 35 | 36 | + ### 4.3.2 Self 37 | 38 | uShip.pas 39 | 40 | + ### 4.3.3 inherited 41 | 42 | uQuestion.pas 43 | 44 | PrintTest.dpr 45 | 46 | + ### 4.4.1 Static binding 47 | 48 | StaticBinding.dpr 49 | 50 | + ### 4.4.4 Method overriding (Dynamic binding) 51 | 52 | DynamicHidding.dpr 53 | 54 | DynamicOverriding.dpr 55 | 56 | + ### 4.4.8 The differences between overriding, hiding, or doing nothing with a virtual method 57 | 58 | Differences.dpr 59 | 60 | + ### 4.4.9 Method overloading 61 | 62 | Overloading1.dpr 63 | 64 | Overloading2.dpr 65 | 66 | + ### 4.4.10 Class methods 67 | 68 | Classy.dpr 69 | 70 | 71 | ## Part 2. Object instances 72 | 73 | ### Chapter 5. To be, or not to be 74 | 75 | + ### 5.1.4 Nil exception 76 | 77 | NilException.dpr 78 | 79 | + ### 5.1.5 How to test for nil 80 | 81 | AssignedCheck.dpr 82 | 83 | NilComparison.dpr 84 | 85 | NilComparisonFunc.dpr 86 | 87 | + ### 5.3.1 A use case for null object 88 | 89 | NullObjectPattern.dpr 90 | 91 | + ### 5.3.2 A case against null object 92 | 93 | TreeNil.dpr 94 | 95 | TreeNullObject.dpr 96 | 97 | TreeNullObjectSingle.dpr 98 | 99 | + ### 5.4 Nullable types 100 | 101 | Following nullable implementation is based on Allen Bauer's blog post "A Nullable Post" https://blog.therealoracleatdelphi.com/2008/09/a-post_18.html 102 | 103 | Nullable.pas 104 | 105 | Weather.dpr 106 | 107 | 108 | ### Chapter 6, 7, 8 109 | 110 | ... 111 | 112 | 113 | ## Part 3. Manual memory management 114 | 115 | ... 116 | 117 | ## Part 4. Automatic Reference Counting 118 | 119 | ... 120 | 121 | ## Part 5. Coding patterns 122 | 123 | + ### 17.6 Smart Pointers 124 | 125 | Smart.dpr + uLifeMgr.pas + uSmartPrt.pas 126 | 127 | + ### 17.7 Lazy 128 | 129 | LazyDeathStar.dpr 130 | 131 | ReallyLazyDeathStar.dpr 132 | 133 | + ### 17.8 Weak 134 | 135 | WeakMagic.dpr + uZWeak.pas 136 | 137 | SimplerWeakMagic.dpr + uZWeak.pas 138 | --------------------------------------------------------------------------------