├── .gitignore ├── AutoScope.pas ├── COPYING.FPC ├── LICENSE ├── README.md └── tests ├── AutoScopeTest.dpr ├── AutoScopeTest.dproj ├── AutoScopeTest.ico ├── AutoScopeTest.lpi ├── AutoScopeTest.res ├── AutoScopeTest_2007.dproj └── TestScoped.pas /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | *.bak 68 | *.lps 69 | /tests/*.~dsk 70 | /tests/Win32 71 | /tests/Win64 72 | -------------------------------------------------------------------------------- /AutoScope.pas: -------------------------------------------------------------------------------- 1 | {********************************************************************** 2 | ● Copyright(c) 2017 Dmitriy Pomerantsev 3 | 4 | See the file COPYING.FPC, included in this distribution, 5 | for details about the copyright. 6 | 7 | This program is distributed in the hope that it will be useful, 8 | but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | https://github.com/pda0/AutoScope 12 | 13 | Ver 1.0.2 14 | + Added some new tests. 15 | + Added `paranoia' mode (disabled by default). Define WITH_PARANOIA if you 16 | want. TScoped will place a reference to itself in an external variable to 17 | prevent too smart compiler from removing the record prematurely. 18 | 19 | Ver 1.0.1 20 | * Now cleanup process is protected from destructor's exceptions. 21 | It may not work temporarily in llvm-based compiler because of the bug 22 | https://quality.embarcadero.com/browse/RSP-18031 23 | 24 | Ver 1.0.0 25 | * Initial release. 26 | 27 | **********************************************************************} 28 | unit AutoScope; 29 | {$IFDEF FPC} 30 | {$CODEPAGE UTF8} 31 | {$MODE DELPHI}{$H+} 32 | {$MODESWITCH ADVANCEDRECORDS} 33 | {$ENDIF} 34 | 35 | interface 36 | 37 | {$IFDEF FPC} 38 | { #%^$! delphi compiller!!! } 39 | {$IFDEF VER1}{$ERROR Too old compiller.}{$ENDIF} 40 | {$IFDEF VER2} 41 | {$IFDEF VER2_0}{$ERROR Too old compiller.}{$ENDIF} 42 | {$IFDEF VER2_2}{$ERROR Too old compiller.}{$ENDIF} 43 | {$IFDEF VER2_4}{$ERROR Too old compiller.}{$ENDIF} 44 | {$ENDIF} 45 | {$DEFINE USE_INTERFACE} 46 | {$IFNDEF VER_3_0} 47 | {$IFDEF USE_INTERFACE}{$UNDEF USE_INTERFACE}{$ENDIF} 48 | {$DEFINE USE_OPERATORS} 49 | {$ENDIF} 50 | {$ELSE} 51 | {$DEFINE USE_INTERFACE} 52 | {$ENDIF} 53 | 54 | type 55 | TScopedPtr = record 56 | Ptr: Pointer; 57 | {$IFNDEF NEXTGEN} 58 | IsObject: Boolean; 59 | {$ENDIF} 60 | end; 61 | {$IFDEF USE_INTERFACE} 62 | {$DEFINE NEED_SCOPED_PTR} 63 | {$ENDIF} 64 | {$IFDEF WITH_PARANOIA} 65 | {$IFNDEF NEED_SCOPED_PTR}{$DEFINE NEED_SCOPED_PTR}{$ENDIF} 66 | {$ENDIF} 67 | 68 | {$IFDEF NEED_SCOPED_PTR} 69 | PScoped = ^TScoped; 70 | {$ENDIF} 71 | 72 | /// The automatic memory deallocation object. 73 | /// 74 | /// TScoped automatically free memory when it's instance runs out of scope. 75 | /// Do not declare it as const or threadvar variable. 76 | /// 77 | /// 78 | TScoped = record 79 | {$IFDEF USE_INTERFACE} 80 | private type 81 | TScopedGuardian = class(TInterfacedObject) 82 | private 83 | FScopedRec: PScoped; 84 | public 85 | constructor Create(ScopedRec: PScoped); 86 | destructor Destroy; override; 87 | end; 88 | {$ENDIF} 89 | private 90 | {$IFDEF USE_INTERFACE} 91 | FGuardian: IInterface; 92 | {$ENDIF} 93 | FPointers: array of TScopedPtr; 94 | FLastIndex: {$IFDEF FPC}TDynArrayIndex{$ELSE}Integer{$ENDIF}; 95 | {$IFDEF USE_OPERATORS} 96 | class operator Initialize(var AScope: TScoped); 97 | class operator Finalize(var AScope: TScoped); 98 | {$ENDIF} 99 | {$IFDEF USE_INTERFACE} 100 | class procedure Initialize(var AScope: TScoped); static; 101 | class procedure Finalize(var AScope: TScoped); static; 102 | {$ENDIF} 103 | procedure RegisterPointer(Ptr: Pointer; IsObject: Boolean); 104 | procedure UnregisterPointer(Ptr: Pointer); 105 | public 106 | /// Adds the object to the automatic deletion list. 107 | /// A class instance for automatic deletion. 108 | /// AnObject value as is. 109 | /// 110 | /// 111 | /// When an instance of TScoped runs out of a scope, all objects 112 | /// will be deleted in the reverse order to the addition. 113 | /// 114 | /// 115 | /// Does nothing in NextGen mode due of ARC. 116 | /// 117 | /// 118 | function AddObject(const AnObject: TObject): TObject; 119 | /// Removes the object from the automatic deletion list. 120 | /// A class instance for removal from list. 121 | /// 122 | /// 123 | /// After calling this method, you have to remove the class instance 124 | /// by yourself. 125 | /// 126 | /// 127 | /// This method have O(n) complexity because it's not a primary case 128 | /// scenario of TScoped usage. If you want to create and destroy 129 | /// some class often, please use normal methods like 130 | /// Create/Free. 131 | /// 132 | /// 133 | /// Does nothing in NextGen mode due of ARC. 134 | /// 135 | /// 136 | procedure RemoveObject(const AnObject: TObject); 137 | /// Allocates an automatically releasing memory block. 138 | /// Returns a pointer to allocated memory block. 139 | /// Is a size in bytes of required memory. 140 | /// 141 | /// When an instance of TScoped runs out of a scope, all memory 142 | /// block will be released in the reverse order to the allocation. 143 | /// 144 | procedure GetMem(out P: Pointer; Size: {$IFDEF FPC}PtrUInt{$ELSE}Integer{$ENDIF}); 145 | /// Releases previously allocated memory block. 146 | /// 147 | /// Is a pointer to memory block, allocated by 148 | /// or added by . 149 | /// 150 | /// 151 | /// This method have O(n) complexity because it's not a primary case 152 | /// scenario of TScoped usage. If you want to allocate and release 153 | /// memory often, please use normal functions like 154 | /// System.GetMem/System.FreeMem. 155 | /// 156 | procedure FreeMem(var P: Pointer); 157 | /// Adds a memory block to the automatically releasing list. 158 | /// 159 | /// Is a pointer to memory block, allocated by somewhere else. 160 | /// 161 | /// 162 | /// 163 | /// When an instance of TScoped runs out of a scope, all memory 164 | /// block will be released in the reverse order to the addition. 165 | /// 166 | /// 167 | /// Do not try to add pointer to memory block, allocated by 168 | /// , do not add some pointer more than one 169 | /// time. 170 | /// 171 | /// 172 | /// Use only pointer which have to be releasev via 173 | /// . Do not use typed pointers, allocated 174 | /// by . TScoped is incompatible with typed 175 | /// pointers. 176 | /// 177 | /// 178 | procedure AddMem(const P: Pointer); 179 | /// Reallocates a memory block. 180 | /// 181 | /// Is a pointer to memory block, allocated by 182 | /// or added by . 183 | /// 184 | /// 185 | /// This method have O(n) complexity because it's not a primary case 186 | /// scenario of TScoped usage. If you want to allocate and release 187 | /// memory often, please use normal functions like 188 | /// System.GetMem/System.FreeMem. 189 | /// 190 | procedure ReallocMem(var P: Pointer; Size: {$IFDEF FPC}PtrUInt{$ELSE}Integer{$ENDIF}); 191 | /// Removes a memory block from the automatic deletion list. 192 | /// 193 | /// Is a pointer to memory block, allocated by 194 | /// or added by . 195 | /// 196 | /// 197 | /// 198 | /// After calling this method, you have to release the memory block 199 | /// by yourself. 200 | /// 201 | /// 202 | /// This method have O(n) complexity because it's not a primary case 203 | /// scenario of TScoped usage. If you want to allocate and 204 | /// release memory often, please use normal functions like 205 | /// System.GetMem/System.FreeMem. 206 | /// 207 | /// 208 | procedure RemoveMem(const P: Pointer); 209 | /// A syntax sugar for the AddObject method. 210 | property Objects[const AnObject: TObject]: TObject read AddObject; default; 211 | end; 212 | 213 | {$IFDEF WITH_PARANOIA} 214 | var 215 | __no_use_ptr: PScoped; 216 | {$ENDIF} 217 | 218 | implementation 219 | 220 | { TScoped } 221 | 222 | {$IFDEF USE_INTERFACE} 223 | constructor TScoped.TScopedGuardian.Create(ScopedRec: PScoped); 224 | begin 225 | FScopedRec := ScopedRec; 226 | TScoped.Initialize(FScopedRec^); 227 | end; 228 | 229 | destructor TScoped.TScopedGuardian.Destroy; 230 | begin 231 | inherited; 232 | try 233 | TScoped.Finalize(FScopedRec^); 234 | except 235 | FreeInstance; 236 | raise; 237 | end; 238 | end; 239 | {$ENDIF} 240 | 241 | {$IFDEF USE_OPERATORS} 242 | class operator TScoped.Initialize(var AScope: TScoped); 243 | {$ENDIF} 244 | {$IFDEF USE_INTERFACE} 245 | class procedure TScoped.Initialize(var AScope: TScoped); 246 | {$ENDIF} 247 | begin 248 | {$IFDEF WITH_PARANOIA} 249 | __no_use_ptr := @AScope; 250 | {$ENDIF} 251 | AScope.FLastIndex := -1; 252 | SetLength(AScope.FPointers, 16); 253 | end; 254 | 255 | {$IFDEF USE_OPERATORS} 256 | class operator TScoped.Finalize(var AScope: TScoped); 257 | {$ENDIF} 258 | {$IFDEF USE_INTERFACE} 259 | class procedure TScoped.Finalize(var AScope: TScoped); 260 | {$ENDIF} 261 | var 262 | {$IFNDEF NEXTGEN} 263 | FirstException: Pointer; 264 | {$ENDIF} 265 | i: {$IFDEF FPC}TDynArrayIndex{$ELSE}Integer{$ENDIF}; 266 | begin 267 | FirstException := nil; 268 | 269 | for i := AScope.FLastIndex downto 0 do 270 | {$IFNDEF NEXTGEN} 271 | try 272 | if AScope.FPointers[i].IsObject then 273 | TObject(AScope.FPointers[i].Ptr).Free 274 | else begin 275 | {$ENDIF} 276 | if Assigned(AScope.FPointers[i].Ptr) then 277 | System.FreeMem(AScope.FPointers[i].Ptr); 278 | {$IFNDEF NEXTGEN} 279 | end; 280 | except 281 | if not Assigned(FirstException) then 282 | FirstException := AcquireExceptionObject; 283 | end; 284 | 285 | if Assigned(FirstException) then 286 | begin 287 | SetLength(AScope.FPointers, 0); 288 | raise TObject(FirstException); 289 | end; 290 | {$ENDIF} 291 | end; 292 | 293 | { TScoped is for small amount of local objects or memory blocks, which will be 294 | created at start of a routine, deleted at the end, and very rarely at the 295 | middle of the execution. Therefore there is no need for complex methods of 296 | low `big O' complexity. The simplicity and fast of primary case scenario speed 297 | is preferred. } 298 | 299 | procedure TScoped.RegisterPointer(Ptr: Pointer; IsObject: Boolean); 300 | begin 301 | if FLastIndex > High(FPointers) then 302 | SetLength(FPointers, Length(FPointers) * 2); 303 | 304 | Inc(FLastIndex); 305 | FPointers[FLastIndex].Ptr := Ptr; 306 | {$IFNDEF NEXTGEN} 307 | FPointers[FLastIndex].IsObject := IsObject; 308 | {$ENDIF} 309 | end; 310 | 311 | procedure TScoped.UnregisterPointer(Ptr: Pointer); 312 | var 313 | i: {$IFDEF FPC}TDynArrayIndex{$ELSE}Integer{$ENDIF}; 314 | begin 315 | for i := 0 to FLastIndex do 316 | if FPointers[i].Ptr = Ptr then 317 | begin 318 | FPointers[i].Ptr := nil; 319 | Break; 320 | end; 321 | end; 322 | 323 | function TScoped.AddObject(const AnObject: TObject): TObject; 324 | begin 325 | {$IFNDEF NEXTGEN} 326 | {$IFDEF USE_INTERFACE} 327 | if not Assigned(FGuardian) then 328 | FGuardian := TScopedGuardian.Create(@Self); 329 | {$ENDIF} 330 | 331 | RegisterPointer(Pointer(AnObject), True); 332 | {$ENDIF} 333 | Result := AnObject; 334 | end; 335 | 336 | procedure TScoped.RemoveObject(const AnObject: TObject); 337 | begin 338 | {$IFNDEF NEXTGEN} 339 | {$IFDEF USE_INTERFACE} 340 | if not Assigned(FGuardian) then 341 | FGuardian := TScopedGuardian.Create(@Self); 342 | {$ENDIF} 343 | 344 | UnregisterPointer(Pointer(AnObject)); 345 | {$ENDIF} 346 | end; 347 | 348 | procedure TScoped.GetMem(out P: Pointer; Size: 349 | {$IFDEF FPC}PtrUInt{$ELSE}Integer{$ENDIF}); 350 | begin 351 | System.GetMem(P, Size); 352 | AddMem(P); 353 | end; 354 | 355 | procedure TScoped.FreeMem(var P: Pointer); 356 | begin 357 | {$IFDEF USE_INTERFACE} 358 | if not Assigned(FGuardian) then 359 | FGuardian := TScopedGuardian.Create(@Self); 360 | {$ENDIF} 361 | 362 | UnregisterPointer(P); 363 | System.FreeMem(P); 364 | end; 365 | 366 | procedure TScoped.AddMem(const P: Pointer); 367 | begin 368 | {$IFDEF USE_INTERFACE} 369 | if not Assigned(FGuardian) then 370 | FGuardian := TScopedGuardian.Create(@Self); 371 | {$ENDIF} 372 | 373 | RegisterPointer(P, False); 374 | end; 375 | 376 | procedure TScoped.ReallocMem(var P: Pointer; Size: 377 | {$IFDEF FPC}PtrUInt{$ELSE}Integer{$ENDIF}); 378 | var 379 | i: {$IFDEF FPC}TDynArrayIndex{$ELSE}Integer{$ENDIF}; 380 | begin 381 | {$IFDEF USE_INTERFACE} 382 | if not Assigned(FGuardian) then 383 | FGuardian := TScopedGuardian.Create(@Self); 384 | {$ENDIF} 385 | 386 | for i := FLastIndex downto 0 do 387 | if not FPointers[i].IsObject and (FPointers[i].Ptr = P) then 388 | begin 389 | System.ReallocMem(FPointers[i].Ptr, Size); 390 | P := FPointers[i].Ptr; 391 | Break; 392 | end; 393 | end; 394 | 395 | procedure TScoped.RemoveMem(const P: Pointer); 396 | begin 397 | {$IFDEF USE_INTERFACE} 398 | if not Assigned(FGuardian) then 399 | FGuardian := TScopedGuardian.Create(@Self); 400 | {$ENDIF} 401 | 402 | UnregisterPointer(P); 403 | end; 404 | 405 | end. 406 | -------------------------------------------------------------------------------- /COPYING.FPC: -------------------------------------------------------------------------------- 1 | This is the file COPYING.FPC, it applies to the Free Pascal NGPlus Library. 2 | 3 | The source code of the Free Pascal NGPlus Library distributed under the 4 | Library GNU General Public License (see the file COPYING) with the following 5 | modification: 6 | 7 | As a special exception, the copyright holders of this library give you 8 | permission to link this library with independent modules to produce an 9 | executable, regardless of the license terms of these independent modules, 10 | and to copy and distribute the resulting executable under terms of your choice, 11 | provided that you also meet, for each linked independent module, the terms 12 | and conditions of the license of that module. An independent module is a module 13 | which is not derived from or based on this library. If you modify this 14 | library, you may extend this exception to your version of the library, but you are 15 | not obligated to do so. If you do not wish to do so, delete this exception 16 | statement from your version. 17 | 18 | If you didn't receive a copy of the file COPYING, contact: 19 | Free Software Foundation 20 | 675 Mass Ave 21 | Cambridge, MA 02139 22 | USA 23 | 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 2.1, February 1999 3 | 4 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | (This is the first released version of the Lesser GPL. It also counts 10 | as the successor of the GNU Library Public License, version 2, hence 11 | the version number 2.1.) 12 | 13 | Preamble 14 | 15 | The licenses for most software are designed to take away your 16 | freedom to share and change it. By contrast, the GNU General Public 17 | Licenses are intended to guarantee your freedom to share and change 18 | free software--to make sure the software is free for all its users. 19 | 20 | This license, the Lesser General Public License, applies to some 21 | specially designated software packages--typically libraries--of the 22 | Free Software Foundation and other authors who decide to use it. You 23 | can use it too, but we suggest you first think carefully about whether 24 | this license or the ordinary General Public License is the better 25 | strategy to use in any particular case, based on the explanations below. 26 | 27 | When we speak of free software, we are referring to freedom of use, 28 | not price. Our General Public Licenses are designed to make sure that 29 | you have the freedom to distribute copies of free software (and charge 30 | for this service if you wish); that you receive source code or can get 31 | it if you want it; that you can change the software and use pieces of 32 | it in new free programs; and that you are informed that you can do 33 | these things. 34 | 35 | To protect your rights, we need to make restrictions that forbid 36 | distributors to deny you these rights or to ask you to surrender these 37 | rights. These restrictions translate to certain responsibilities for 38 | you if you distribute copies of the library or if you modify it. 39 | 40 | For example, if you distribute copies of the library, whether gratis 41 | or for a fee, you must give the recipients all the rights that we gave 42 | you. You must make sure that they, too, receive or can get the source 43 | code. If you link other code with the library, you must provide 44 | complete object files to the recipients, so that they can relink them 45 | with the library after making changes to the library and recompiling 46 | it. And you must show them these terms so they know their rights. 47 | 48 | We protect your rights with a two-step method: (1) we copyright the 49 | library, and (2) we offer you this license, which gives you legal 50 | permission to copy, distribute and/or modify the library. 51 | 52 | To protect each distributor, we want to make it very clear that 53 | there is no warranty for the free library. Also, if the library is 54 | modified by someone else and passed on, the recipients should know 55 | that what they have is not the original version, so that the original 56 | author's reputation will not be affected by problems that might be 57 | introduced by others. 58 | 59 | Finally, software patents pose a constant threat to the existence of 60 | any free program. We wish to make sure that a company cannot 61 | effectively restrict the users of a free program by obtaining a 62 | restrictive license from a patent holder. Therefore, we insist that 63 | any patent license obtained for a version of the library must be 64 | consistent with the full freedom of use specified in this license. 65 | 66 | Most GNU software, including some libraries, is covered by the 67 | ordinary GNU General Public License. This license, the GNU Lesser 68 | General Public License, applies to certain designated libraries, and 69 | is quite different from the ordinary General Public License. We use 70 | this license for certain libraries in order to permit linking those 71 | libraries into non-free programs. 72 | 73 | When a program is linked with a library, whether statically or using 74 | a shared library, the combination of the two is legally speaking a 75 | combined work, a derivative of the original library. The ordinary 76 | General Public License therefore permits such linking only if the 77 | entire combination fits its criteria of freedom. The Lesser General 78 | Public License permits more lax criteria for linking other code with 79 | the library. 80 | 81 | We call this license the "Lesser" General Public License because it 82 | does Less to protect the user's freedom than the ordinary General 83 | Public License. It also provides other free software developers Less 84 | of an advantage over competing non-free programs. These disadvantages 85 | are the reason we use the ordinary General Public License for many 86 | libraries. However, the Lesser license provides advantages in certain 87 | special circumstances. 88 | 89 | For example, on rare occasions, there may be a special need to 90 | encourage the widest possible use of a certain library, so that it becomes 91 | a de-facto standard. To achieve this, non-free programs must be 92 | allowed to use the library. A more frequent case is that a free 93 | library does the same job as widely used non-free libraries. In this 94 | case, there is little to gain by limiting the free library to free 95 | software only, so we use the Lesser General Public License. 96 | 97 | In other cases, permission to use a particular library in non-free 98 | programs enables a greater number of people to use a large body of 99 | free software. For example, permission to use the GNU C Library in 100 | non-free programs enables many more people to use the whole GNU 101 | operating system, as well as its variant, the GNU/Linux operating 102 | system. 103 | 104 | Although the Lesser General Public License is Less protective of the 105 | users' freedom, it does ensure that the user of a program that is 106 | linked with the Library has the freedom and the wherewithal to run 107 | that program using a modified version of the Library. 108 | 109 | The precise terms and conditions for copying, distribution and 110 | modification follow. Pay close attention to the difference between a 111 | "work based on the library" and a "work that uses the library". The 112 | former contains code derived from the library, whereas the latter must 113 | be combined with the library in order to run. 114 | 115 | GNU LESSER GENERAL PUBLIC LICENSE 116 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 117 | 118 | 0. This License Agreement applies to any software library or other 119 | program which contains a notice placed by the copyright holder or 120 | other authorized party saying it may be distributed under the terms of 121 | this Lesser General Public License (also called "this License"). 122 | Each licensee is addressed as "you". 123 | 124 | A "library" means a collection of software functions and/or data 125 | prepared so as to be conveniently linked with application programs 126 | (which use some of those functions and data) to form executables. 127 | 128 | The "Library", below, refers to any such software library or work 129 | which has been distributed under these terms. A "work based on the 130 | Library" means either the Library or any derivative work under 131 | copyright law: that is to say, a work containing the Library or a 132 | portion of it, either verbatim or with modifications and/or translated 133 | straightforwardly into another language. (Hereinafter, translation is 134 | included without limitation in the term "modification".) 135 | 136 | "Source code" for a work means the preferred form of the work for 137 | making modifications to it. For a library, complete source code means 138 | all the source code for all modules it contains, plus any associated 139 | interface definition files, plus the scripts used to control compilation 140 | and installation of the library. 141 | 142 | Activities other than copying, distribution and modification are not 143 | covered by this License; they are outside its scope. The act of 144 | running a program using the Library is not restricted, and output from 145 | such a program is covered only if its contents constitute a work based 146 | on the Library (independent of the use of the Library in a tool for 147 | writing it). Whether that is true depends on what the Library does 148 | and what the program that uses the Library does. 149 | 150 | 1. You may copy and distribute verbatim copies of the Library's 151 | complete source code as you receive it, in any medium, provided that 152 | you conspicuously and appropriately publish on each copy an 153 | appropriate copyright notice and disclaimer of warranty; keep intact 154 | all the notices that refer to this License and to the absence of any 155 | warranty; and distribute a copy of this License along with the 156 | Library. 157 | 158 | You may charge a fee for the physical act of transferring a copy, 159 | and you may at your option offer warranty protection in exchange for a 160 | fee. 161 | 162 | 2. You may modify your copy or copies of the Library or any portion 163 | of it, thus forming a work based on the Library, and copy and 164 | distribute such modifications or work under the terms of Section 1 165 | above, provided that you also meet all of these conditions: 166 | 167 | a) The modified work must itself be a software library. 168 | 169 | b) You must cause the files modified to carry prominent notices 170 | stating that you changed the files and the date of any change. 171 | 172 | c) You must cause the whole of the work to be licensed at no 173 | charge to all third parties under the terms of this License. 174 | 175 | d) If a facility in the modified Library refers to a function or a 176 | table of data to be supplied by an application program that uses 177 | the facility, other than as an argument passed when the facility 178 | is invoked, then you must make a good faith effort to ensure that, 179 | in the event an application does not supply such function or 180 | table, the facility still operates, and performs whatever part of 181 | its purpose remains meaningful. 182 | 183 | (For example, a function in a library to compute square roots has 184 | a purpose that is entirely well-defined independent of the 185 | application. Therefore, Subsection 2d requires that any 186 | application-supplied function or table used by this function must 187 | be optional: if the application does not supply it, the square 188 | root function must still compute square roots.) 189 | 190 | These requirements apply to the modified work as a whole. If 191 | identifiable sections of that work are not derived from the Library, 192 | and can be reasonably considered independent and separate works in 193 | themselves, then this License, and its terms, do not apply to those 194 | sections when you distribute them as separate works. But when you 195 | distribute the same sections as part of a whole which is a work based 196 | on the Library, the distribution of the whole must be on the terms of 197 | this License, whose permissions for other licensees extend to the 198 | entire whole, and thus to each and every part regardless of who wrote 199 | it. 200 | 201 | Thus, it is not the intent of this section to claim rights or contest 202 | your rights to work written entirely by you; rather, the intent is to 203 | exercise the right to control the distribution of derivative or 204 | collective works based on the Library. 205 | 206 | In addition, mere aggregation of another work not based on the Library 207 | with the Library (or with a work based on the Library) on a volume of 208 | a storage or distribution medium does not bring the other work under 209 | the scope of this License. 210 | 211 | 3. You may opt to apply the terms of the ordinary GNU General Public 212 | License instead of this License to a given copy of the Library. To do 213 | this, you must alter all the notices that refer to this License, so 214 | that they refer to the ordinary GNU General Public License, version 2, 215 | instead of to this License. (If a newer version than version 2 of the 216 | ordinary GNU General Public License has appeared, then you can specify 217 | that version instead if you wish.) Do not make any other change in 218 | these notices. 219 | 220 | Once this change is made in a given copy, it is irreversible for 221 | that copy, so the ordinary GNU General Public License applies to all 222 | subsequent copies and derivative works made from that copy. 223 | 224 | This option is useful when you wish to copy part of the code of 225 | the Library into a program that is not a library. 226 | 227 | 4. You may copy and distribute the Library (or a portion or 228 | derivative of it, under Section 2) in object code or executable form 229 | under the terms of Sections 1 and 2 above provided that you accompany 230 | it with the complete corresponding machine-readable source code, which 231 | must be distributed under the terms of Sections 1 and 2 above on a 232 | medium customarily used for software interchange. 233 | 234 | If distribution of object code is made by offering access to copy 235 | from a designated place, then offering equivalent access to copy the 236 | source code from the same place satisfies the requirement to 237 | distribute the source code, even though third parties are not 238 | compelled to copy the source along with the object code. 239 | 240 | 5. A program that contains no derivative of any portion of the 241 | Library, but is designed to work with the Library by being compiled or 242 | linked with it, is called a "work that uses the Library". Such a 243 | work, in isolation, is not a derivative work of the Library, and 244 | therefore falls outside the scope of this License. 245 | 246 | However, linking a "work that uses the Library" with the Library 247 | creates an executable that is a derivative of the Library (because it 248 | contains portions of the Library), rather than a "work that uses the 249 | library". The executable is therefore covered by this License. 250 | Section 6 states terms for distribution of such executables. 251 | 252 | When a "work that uses the Library" uses material from a header file 253 | that is part of the Library, the object code for the work may be a 254 | derivative work of the Library even though the source code is not. 255 | Whether this is true is especially significant if the work can be 256 | linked without the Library, or if the work is itself a library. The 257 | threshold for this to be true is not precisely defined by law. 258 | 259 | If such an object file uses only numerical parameters, data 260 | structure layouts and accessors, and small macros and small inline 261 | functions (ten lines or less in length), then the use of the object 262 | file is unrestricted, regardless of whether it is legally a derivative 263 | work. (Executables containing this object code plus portions of the 264 | Library will still fall under Section 6.) 265 | 266 | Otherwise, if the work is a derivative of the Library, you may 267 | distribute the object code for the work under the terms of Section 6. 268 | Any executables containing that work also fall under Section 6, 269 | whether or not they are linked directly with the Library itself. 270 | 271 | 6. As an exception to the Sections above, you may also combine or 272 | link a "work that uses the Library" with the Library to produce a 273 | work containing portions of the Library, and distribute that work 274 | under terms of your choice, provided that the terms permit 275 | modification of the work for the customer's own use and reverse 276 | engineering for debugging such modifications. 277 | 278 | You must give prominent notice with each copy of the work that the 279 | Library is used in it and that the Library and its use are covered by 280 | this License. You must supply a copy of this License. If the work 281 | during execution displays copyright notices, you must include the 282 | copyright notice for the Library among them, as well as a reference 283 | directing the user to the copy of this License. Also, you must do one 284 | of these things: 285 | 286 | a) Accompany the work with the complete corresponding 287 | machine-readable source code for the Library including whatever 288 | changes were used in the work (which must be distributed under 289 | Sections 1 and 2 above); and, if the work is an executable linked 290 | with the Library, with the complete machine-readable "work that 291 | uses the Library", as object code and/or source code, so that the 292 | user can modify the Library and then relink to produce a modified 293 | executable containing the modified Library. (It is understood 294 | that the user who changes the contents of definitions files in the 295 | Library will not necessarily be able to recompile the application 296 | to use the modified definitions.) 297 | 298 | b) Use a suitable shared library mechanism for linking with the 299 | Library. A suitable mechanism is one that (1) uses at run time a 300 | copy of the library already present on the user's computer system, 301 | rather than copying library functions into the executable, and (2) 302 | will operate properly with a modified version of the library, if 303 | the user installs one, as long as the modified version is 304 | interface-compatible with the version that the work was made with. 305 | 306 | c) Accompany the work with a written offer, valid for at 307 | least three years, to give the same user the materials 308 | specified in Subsection 6a, above, for a charge no more 309 | than the cost of performing this distribution. 310 | 311 | d) If distribution of the work is made by offering access to copy 312 | from a designated place, offer equivalent access to copy the above 313 | specified materials from the same place. 314 | 315 | e) Verify that the user has already received a copy of these 316 | materials or that you have already sent this user a copy. 317 | 318 | For an executable, the required form of the "work that uses the 319 | Library" must include any data and utility programs needed for 320 | reproducing the executable from it. However, as a special exception, 321 | the materials to be distributed need not include anything that is 322 | normally distributed (in either source or binary form) with the major 323 | components (compiler, kernel, and so on) of the operating system on 324 | which the executable runs, unless that component itself accompanies 325 | the executable. 326 | 327 | It may happen that this requirement contradicts the license 328 | restrictions of other proprietary libraries that do not normally 329 | accompany the operating system. Such a contradiction means you cannot 330 | use both them and the Library together in an executable that you 331 | distribute. 332 | 333 | 7. You may place library facilities that are a work based on the 334 | Library side-by-side in a single library together with other library 335 | facilities not covered by this License, and distribute such a combined 336 | library, provided that the separate distribution of the work based on 337 | the Library and of the other library facilities is otherwise 338 | permitted, and provided that you do these two things: 339 | 340 | a) Accompany the combined library with a copy of the same work 341 | based on the Library, uncombined with any other library 342 | facilities. This must be distributed under the terms of the 343 | Sections above. 344 | 345 | b) Give prominent notice with the combined library of the fact 346 | that part of it is a work based on the Library, and explaining 347 | where to find the accompanying uncombined form of the same work. 348 | 349 | 8. You may not copy, modify, sublicense, link with, or distribute 350 | the Library except as expressly provided under this License. Any 351 | attempt otherwise to copy, modify, sublicense, link with, or 352 | distribute the Library is void, and will automatically terminate your 353 | rights under this License. However, parties who have received copies, 354 | or rights, from you under this License will not have their licenses 355 | terminated so long as such parties remain in full compliance. 356 | 357 | 9. You are not required to accept this License, since you have not 358 | signed it. However, nothing else grants you permission to modify or 359 | distribute the Library or its derivative works. These actions are 360 | prohibited by law if you do not accept this License. Therefore, by 361 | modifying or distributing the Library (or any work based on the 362 | Library), you indicate your acceptance of this License to do so, and 363 | all its terms and conditions for copying, distributing or modifying 364 | the Library or works based on it. 365 | 366 | 10. Each time you redistribute the Library (or any work based on the 367 | Library), the recipient automatically receives a license from the 368 | original licensor to copy, distribute, link with or modify the Library 369 | subject to these terms and conditions. You may not impose any further 370 | restrictions on the recipients' exercise of the rights granted herein. 371 | You are not responsible for enforcing compliance by third parties with 372 | this License. 373 | 374 | 11. If, as a consequence of a court judgment or allegation of patent 375 | infringement or for any other reason (not limited to patent issues), 376 | conditions are imposed on you (whether by court order, agreement or 377 | otherwise) that contradict the conditions of this License, they do not 378 | excuse you from the conditions of this License. If you cannot 379 | distribute so as to satisfy simultaneously your obligations under this 380 | License and any other pertinent obligations, then as a consequence you 381 | may not distribute the Library at all. For example, if a patent 382 | license would not permit royalty-free redistribution of the Library by 383 | all those who receive copies directly or indirectly through you, then 384 | the only way you could satisfy both it and this License would be to 385 | refrain entirely from distribution of the Library. 386 | 387 | If any portion of this section is held invalid or unenforceable under any 388 | particular circumstance, the balance of the section is intended to apply, 389 | and the section as a whole is intended to apply in other circumstances. 390 | 391 | It is not the purpose of this section to induce you to infringe any 392 | patents or other property right claims or to contest validity of any 393 | such claims; this section has the sole purpose of protecting the 394 | integrity of the free software distribution system which is 395 | implemented by public license practices. Many people have made 396 | generous contributions to the wide range of software distributed 397 | through that system in reliance on consistent application of that 398 | system; it is up to the author/donor to decide if he or she is willing 399 | to distribute software through any other system and a licensee cannot 400 | impose that choice. 401 | 402 | This section is intended to make thoroughly clear what is believed to 403 | be a consequence of the rest of this License. 404 | 405 | 12. If the distribution and/or use of the Library is restricted in 406 | certain countries either by patents or by copyrighted interfaces, the 407 | original copyright holder who places the Library under this License may add 408 | an explicit geographical distribution limitation excluding those countries, 409 | so that distribution is permitted only in or among countries not thus 410 | excluded. In such case, this License incorporates the limitation as if 411 | written in the body of this License. 412 | 413 | 13. The Free Software Foundation may publish revised and/or new 414 | versions of the Lesser General Public License from time to time. 415 | Such new versions will be similar in spirit to the present version, 416 | but may differ in detail to address new problems or concerns. 417 | 418 | Each version is given a distinguishing version number. If the Library 419 | specifies a version number of this License which applies to it and 420 | "any later version", you have the option of following the terms and 421 | conditions either of that version or of any later version published by 422 | the Free Software Foundation. If the Library does not specify a 423 | license version number, you may choose any version ever published by 424 | the Free Software Foundation. 425 | 426 | 14. If you wish to incorporate parts of the Library into other free 427 | programs whose distribution conditions are incompatible with these, 428 | write to the author to ask for permission. For software which is 429 | copyrighted by the Free Software Foundation, write to the Free 430 | Software Foundation; we sometimes make exceptions for this. Our 431 | decision will be guided by the two goals of preserving the free status 432 | of all derivatives of our free software and of promoting the sharing 433 | and reuse of software generally. 434 | 435 | NO WARRANTY 436 | 437 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 438 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 439 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 440 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 441 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 442 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 443 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 444 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 445 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 446 | 447 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 448 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 449 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 450 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 451 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 452 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 453 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 454 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 455 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 456 | DAMAGES. 457 | 458 | END OF TERMS AND CONDITIONS 459 | 460 | How to Apply These Terms to Your New Libraries 461 | 462 | If you develop a new library, and you want it to be of the greatest 463 | possible use to the public, we recommend making it free software that 464 | everyone can redistribute and change. You can do so by permitting 465 | redistribution under these terms (or, alternatively, under the terms of the 466 | ordinary General Public License). 467 | 468 | To apply these terms, attach the following notices to the library. It is 469 | safest to attach them to the start of each source file to most effectively 470 | convey the exclusion of warranty; and each file should have at least the 471 | "copyright" line and a pointer to where the full notice is found. 472 | 473 | {description} 474 | Copyright (C) {year} {fullname} 475 | 476 | This library is free software; you can redistribute it and/or 477 | modify it under the terms of the GNU Lesser General Public 478 | License as published by the Free Software Foundation; either 479 | version 2.1 of the License, or (at your option) any later version. 480 | 481 | This library is distributed in the hope that it will be useful, 482 | but WITHOUT ANY WARRANTY; without even the implied warranty of 483 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 484 | Lesser General Public License for more details. 485 | 486 | You should have received a copy of the GNU Lesser General Public 487 | License along with this library; if not, write to the Free Software 488 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 489 | USA 490 | 491 | Also add information on how to contact you by electronic and paper mail. 492 | 493 | You should also get your employer (if you work as a programmer) or your 494 | school, if any, to sign a "copyright disclaimer" for the library, if 495 | necessary. Here is a sample; alter the names: 496 | 497 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 498 | library `Frob' (a library for tweaking knobs) written by James Random 499 | Hacker. 500 | 501 | {signature of Ty Coon}, 1 April 1990 502 | Ty Coon, President of Vice 503 | 504 | That's all there is to it! 505 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # AutoScope 2 | Have you tired of infinite `try`/`finally` of proper class handling like: 3 | ```delphi 4 | SomeObject1 := TSomeObject1.Create; 5 | try 6 | SomeObject2 := TSomeObject2.Create; 7 | try 8 | SomeObject3 := TSomeObject3.Create; 9 | try 10 | <...> 11 | finally 12 | SomeObject3.Free; 13 | end; 14 | finally 15 | SomeObject2.Free; 16 | end; 17 | finally 18 | SomeObject1.Free; 19 | end; 20 | ``` 21 | 22 | or slightly more smart but still annoying: 23 | ```delphi 24 | SomeObject1 := nil; 25 | SomeObject2 := nil; 26 | SomeObject3 := nil; 27 | try 28 | SomeObject1 := TSomeObject1.Create; 29 | SomeObject2 := TSomeObject2.Create; 30 | SomeObject3 := TSomeObject3.Create; 31 | <...> 32 | finally 33 | SomeObject3.Free; 34 | SomeObject2.Free; 35 | SomeObject1.Free; 36 | end; 37 | ``` 38 | 39 | Then try AutoScope. With it you can write like this: 40 | ```delphi 41 | uses 42 | AutoScope,<...>; 43 | <...> 44 | procedure SomeProc; 45 | var 46 | Scoped: TScoped; 47 | <...> 48 | begin 49 | SomeObject1 := Scoped[TSomeObject1.Create] as TSomeObject1; 50 | SomeObject2 := Scoped[TSomeObject2.Create] as TSomeObject2; 51 | SomeObject3 := Scoped[TSomeObject3.Create] as TSomeObject3; 52 | <...> 53 | end; 54 | ``` 55 | 56 | That's it! At the `end` an implicit call of `Scoped.Finalize` happens and all of stored objects will freed in reverse order. AutoScope also can handle with raw memory block, allocated by `GetMem`/`FreeMem` functions. (But not with typed `New`/`Dispose` pointers.) 57 | 58 | Compatible with Delphi 2007+ (may be with 2006+) and Free Pascal 2.6.0+. 59 | -------------------------------------------------------------------------------- /tests/AutoScopeTest.dpr: -------------------------------------------------------------------------------- 1 | {********************************************************************** 2 | ● Copyright(c) 2017 Dmitriy Pomerantsev 3 | 4 | See the file COPYING.FPC, included in this distribution, 5 | for details about the copyright. 6 | 7 | This program is distributed in the hope that it will be useful, 8 | but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | **********************************************************************} 12 | program AutoScopeTest; 13 | {$IFDEF FPC} 14 | {$CODEPAGE UTF8} 15 | {$MODE DELPHI}{$H+} 16 | {$IFDEF WINDOWS}{$DEFINE USE_APPTYPE}{$ENDIF} 17 | {$IFDEF MACOS}{$DEFINE USE_APPTYPE}{$ENDIF} 18 | {$IFDEF OS2}{$DEFINE USE_APPTYPE}{$ENDIF} 19 | {$IFDEF AMIGA}{$DEFINE USE_APPTYPE}{$ENDIF} 20 | {$ELSE} 21 | {$IFDEF VER180}{$DEFINE OLD_DELPHI}{$ENDIF} 22 | {$IFDEF VER185}{$DEFINE OLD_DELPHI}{$ENDIF} 23 | {$IFDEF VER190}{$DEFINE OLD_DELPHI}{$ENDIF} 24 | {$DEFINE USE_APPTYPE} 25 | {$ENDIF} 26 | 27 | {$IFDEF CONSOLE_TESTRUNNER} 28 | {$IFDEF USE_APPTYPE}{$APPTYPE CONSOLE}{$ENDIF} 29 | {$ENDIF} 30 | 31 | uses 32 | {$IFDEF FPC} 33 | {$IFDEF UNIX} 34 | cwstring, 35 | {$ENDIF} 36 | {$IFDEF CONSOLE_TESTRUNNER} 37 | Classes, 38 | ConsoleTestRunner, 39 | {$ELSE} 40 | Interfaces, 41 | Forms, 42 | GuiTestRunner, 43 | {$ENDIF} 44 | {$ELSE} 45 | {$IFDEF OLD_DELPHI} 46 | Forms, 47 | TestFramework, 48 | GUITestRunner, 49 | TextTestRunner, 50 | {$ELSE} 51 | DUnitTestRunner, 52 | {$ENDIF} 53 | {$ENDIF} 54 | AutoScope in '..\AutoScope.pas', 55 | TestScoped in 'TestScoped.pas'; 56 | 57 | {$R *.res} 58 | 59 | {$IFDEF CONSOLE_TESTRUNNER} 60 | var 61 | Application: TTestRunner; 62 | {$ENDIF} 63 | 64 | begin 65 | {$IFDEF FPC} 66 | {$IFDEF CONSOLE_TESTRUNNER} 67 | Application := TTestRunner.Create(nil); 68 | {$ENDIF} 69 | Application.Initialize; 70 | Application.Run; 71 | {$IFDEF CONSOLE_TESTRUNNER} 72 | Application.Free; 73 | {$ENDIF} 74 | {$ELSE} 75 | ReportMemoryLeaksOnShutdown := True; 76 | {$IFDEF OLD_DELPHI} 77 | Application.Initialize; 78 | if IsConsole then 79 | TextTestRunner.RunRegisteredTests 80 | else 81 | GUITestRunner.RunRegisteredTests; 82 | {$ELSE} 83 | DUnitTestRunner.RunRegisteredTests; 84 | {$ENDIF} 85 | {$ENDIF} 86 | end. 87 | 88 | -------------------------------------------------------------------------------- /tests/AutoScopeTest.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {A2868934-CFAD-4D46-9332-3661B27D0BD3} 4 | 18.2 5 | None 6 | True 7 | Debug 8 | Win32 9 | 3 10 | Console 11 | AutoScopeTest.dpr 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_1 34 | true 35 | true 36 | 37 | 38 | true 39 | Base 40 | true 41 | 42 | 43 | AutoScopeTest 44 | 1049 45 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 46 | $(BDS)\Source\DUnit\src;$(DCC_UnitSearchPath) 47 | _CONSOLE_TESTRUNNER;$(DCC_Define) 48 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) 49 | .\$(Platform)\$(Config) 50 | .\$(Platform)\$(Config) 51 | false 52 | false 53 | false 54 | false 55 | false 56 | 57 | 58 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 59 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 60 | 1033 61 | Debug 62 | DBXSqliteDriver;RESTComponents;DBXInterBaseDriver;vclactnband;vclFireDAC;tethering;svnui;JvGlobus;FireDACADSDriver;JvPluginSystem;JvMM;vcltouch;JvBands;vcldb;bindcompfmx;svn;JvJans;JvNet;inetdb;JvAppFrm;JvDotNetCtrls;FireDACIBDriver;fmx;fmxdae;JvWizards;dbexpress;IndyCore;vclx;JvPageComps;dsnap;FireDACCommon;JvDB;RESTBackendComponents;VCLRESTComponents;soapserver;JclDeveloperTools;vclie;bindengine;DBXMySQLDriver;CloudService;JvCmp;FireDACMySQLDriver;JvHMI;FireDACCommonODBC;FireDACCommonDriver;inet;IndyIPCommon;bindcompdbx;JvCustom;vcl;IndyIPServer;JvXPCtrls;IndySystem;dsnapcon;FireDACMSAccDriver;fmxFireDAC;vclimg;Jcl;FireDAC;JvCore;JvCrypt;FireDACSqliteDriver;FireDACPgDriver;soaprtl;DbxCommonDriver;JvDlgs;JvRuntimeDesign;JvManagedThreads;xmlrtl;soapmidas;JvTimeFramework;fmxobj;vclwinx;rtl;DbxClientDriver;CustomIPTransport;vcldsnap;JvSystem;JvStdCtrls;bindcomp;appanalytics;IndyIPClient;bindcompvcl;JvDocking;dbxcds;VclSmp;JvPascalInterpreter;adortl;JclVcl;dsnapxml;dbrtl;IndyProtocols;inetdbxpress;JvControls;JvPrintPreview;JclContainers;fmxase;$(DCC_UsePackage) 63 | 64 | 65 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 66 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) 67 | 1033 68 | Debug 69 | DBXSqliteDriver;RESTComponents;DBXInterBaseDriver;vclactnband;vclFireDAC;tethering;FireDACADSDriver;vcltouch;vcldb;bindcompfmx;inetdb;FireDACIBDriver;fmx;fmxdae;dbexpress;IndyCore;vclx;dsnap;FireDACCommon;RESTBackendComponents;VCLRESTComponents;soapserver;vclie;bindengine;DBXMySQLDriver;CloudService;FireDACMySQLDriver;FireDACCommonODBC;FireDACCommonDriver;inet;IndyIPCommon;bindcompdbx;vcl;IndyIPServer;IndySystem;dsnapcon;FireDACMSAccDriver;fmxFireDAC;vclimg;FireDAC;FireDACSqliteDriver;FireDACPgDriver;soaprtl;DbxCommonDriver;xmlrtl;soapmidas;fmxobj;vclwinx;rtl;DbxClientDriver;CustomIPTransport;vcldsnap;bindcomp;appanalytics;IndyIPClient;bindcompvcl;dbxcds;VclSmp;adortl;dsnapxml;dbrtl;IndyProtocols;inetdbxpress;fmxase;$(DCC_UsePackage) 70 | 71 | 72 | DEBUG;$(DCC_Define) 73 | true 74 | false 75 | true 76 | true 77 | true 78 | 79 | 80 | (None) 81 | 1033 82 | false 83 | 84 | 85 | false 86 | RELEASE;$(DCC_Define) 87 | 0 88 | 0 89 | 90 | 91 | 92 | MainSource 93 | 94 | 95 | 96 | 97 | Cfg_2 98 | Base 99 | 100 | 101 | Base 102 | 103 | 104 | Cfg_1 105 | Base 106 | 107 | 108 | 109 | Delphi.Personality.12 110 | Application 111 | 112 | 113 | 114 | AutoScopeTest.dpr 115 | 116 | 117 | Microsoft Office 2000 Sample Automation Server Wrapper Components 118 | Microsoft Office XP Sample Automation Server Wrapper Components 119 | 120 | 121 | 122 | 123 | 124 | true 125 | 126 | 127 | 128 | 129 | true 130 | 131 | 132 | 133 | 134 | true 135 | 136 | 137 | 138 | 139 | true 140 | 141 | 142 | 143 | 144 | AutoScopeTest.exe 145 | true 146 | 147 | 148 | 149 | 150 | 0 151 | .dll;.bpl 152 | 153 | 154 | 1 155 | .dylib 156 | 157 | 158 | Contents\MacOS 159 | 1 160 | .dylib 161 | 162 | 163 | 1 164 | .dylib 165 | 166 | 167 | 1 168 | .dylib 169 | 170 | 171 | 172 | 173 | Contents\Resources 174 | 1 175 | 176 | 177 | 178 | 179 | classes 180 | 1 181 | 182 | 183 | 184 | 185 | Contents\MacOS 186 | 0 187 | 188 | 189 | 1 190 | 191 | 192 | Contents\MacOS 193 | 1 194 | 195 | 196 | 197 | 198 | 1 199 | 200 | 201 | 1 202 | 203 | 204 | 1 205 | 206 | 207 | 208 | 209 | res\drawable-xxhdpi 210 | 1 211 | 212 | 213 | 214 | 215 | library\lib\mips 216 | 1 217 | 218 | 219 | 220 | 221 | 1 222 | 223 | 224 | 1 225 | 226 | 227 | 0 228 | 229 | 230 | 1 231 | 232 | 233 | Contents\MacOS 234 | 1 235 | 236 | 237 | library\lib\armeabi-v7a 238 | 1 239 | 240 | 241 | 1 242 | 243 | 244 | 245 | 246 | 0 247 | 248 | 249 | Contents\MacOS 250 | 1 251 | .framework 252 | 253 | 254 | 255 | 256 | 1 257 | 258 | 259 | 1 260 | 261 | 262 | 263 | 264 | 1 265 | 266 | 267 | 1 268 | 269 | 270 | 1 271 | 272 | 273 | 274 | 275 | 1 276 | 277 | 278 | 1 279 | 280 | 281 | 1 282 | 283 | 284 | 285 | 286 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 287 | 1 288 | 289 | 290 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 291 | 1 292 | 293 | 294 | 295 | 296 | 1 297 | 298 | 299 | 1 300 | 301 | 302 | 1 303 | 304 | 305 | 306 | 307 | 1 308 | 309 | 310 | 1 311 | 312 | 313 | 1 314 | 315 | 316 | 317 | 318 | library\lib\armeabi 319 | 1 320 | 321 | 322 | 323 | 324 | 0 325 | 326 | 327 | 1 328 | 329 | 330 | Contents\MacOS 331 | 1 332 | 333 | 334 | 335 | 336 | 1 337 | 338 | 339 | 1 340 | 341 | 342 | 1 343 | 344 | 345 | 346 | 347 | res\drawable-normal 348 | 1 349 | 350 | 351 | 352 | 353 | res\drawable-xhdpi 354 | 1 355 | 356 | 357 | 358 | 359 | res\drawable-large 360 | 1 361 | 362 | 363 | 364 | 365 | 1 366 | 367 | 368 | 1 369 | 370 | 371 | 1 372 | 373 | 374 | 375 | 376 | Assets 377 | 1 378 | 379 | 380 | Assets 381 | 1 382 | 383 | 384 | 385 | 386 | ..\ 387 | 1 388 | 389 | 390 | ..\ 391 | 1 392 | 393 | 394 | 395 | 396 | res\drawable-hdpi 397 | 1 398 | 399 | 400 | 401 | 402 | library\lib\armeabi-v7a 403 | 1 404 | 405 | 406 | 407 | 408 | Contents 409 | 1 410 | 411 | 412 | 413 | 414 | ..\ 415 | 1 416 | 417 | 418 | 419 | 420 | Assets 421 | 1 422 | 423 | 424 | Assets 425 | 1 426 | 427 | 428 | 429 | 430 | 1 431 | 432 | 433 | 1 434 | 435 | 436 | 1 437 | 438 | 439 | 440 | 441 | res\values 442 | 1 443 | 444 | 445 | 446 | 447 | res\drawable-small 448 | 1 449 | 450 | 451 | 452 | 453 | res\drawable 454 | 1 455 | 456 | 457 | 458 | 459 | 1 460 | 461 | 462 | 1 463 | 464 | 465 | 1 466 | 467 | 468 | 469 | 470 | 1 471 | 472 | 473 | 474 | 475 | res\drawable 476 | 1 477 | 478 | 479 | 480 | 481 | 0 482 | 483 | 484 | 0 485 | 486 | 487 | Contents\Resources\StartUp\ 488 | 0 489 | 490 | 491 | 0 492 | 493 | 494 | 0 495 | 496 | 497 | 0 498 | 499 | 500 | 501 | 502 | library\lib\armeabi-v7a 503 | 1 504 | 505 | 506 | 507 | 508 | 0 509 | .bpl 510 | 511 | 512 | 1 513 | .dylib 514 | 515 | 516 | Contents\MacOS 517 | 1 518 | .dylib 519 | 520 | 521 | 1 522 | .dylib 523 | 524 | 525 | 1 526 | .dylib 527 | 528 | 529 | 530 | 531 | res\drawable-mdpi 532 | 1 533 | 534 | 535 | 536 | 537 | res\drawable-xlarge 538 | 1 539 | 540 | 541 | 542 | 543 | res\drawable-ldpi 544 | 1 545 | 546 | 547 | 548 | 549 | 1 550 | 551 | 552 | 1 553 | 554 | 555 | 556 | 557 | 558 | 559 | 560 | 561 | 562 | 563 | 564 | 565 | True 566 | True 567 | 568 | 569 | DUnit / Delphi Win32 570 | GUI 571 | 572 | 573 | 574 | 575 | 12 576 | 577 | 578 | 579 | 580 | 581 | -------------------------------------------------------------------------------- /tests/AutoScopeTest.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pda0/AutoScope/31433628155265750c18f20265fdb902a93334a4/tests/AutoScopeTest.ico -------------------------------------------------------------------------------- /tests/AutoScopeTest.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | <ResourceType Value="res"/> 11 | <UseXPManifest Value="True"/> 12 | <Icon Value="0"/> 13 | </General> 14 | <i18n> 15 | <EnableI18N LFM="False"/> 16 | </i18n> 17 | <VersionInfo> 18 | <StringTable ProductVersion=""/> 19 | </VersionInfo> 20 | <BuildModes Count="1"> 21 | <Item1 Name="Default" Default="True"/> 22 | </BuildModes> 23 | <PublishOptions> 24 | <Version Value="2"/> 25 | </PublishOptions> 26 | <RunParams> 27 | <local> 28 | <FormatVersion Value="1"/> 29 | <CommandLineParams Value="--all --all --progress --format=plain"/> 30 | </local> 31 | </RunParams> 32 | <RequiredPackages Count="2"> 33 | <Item1> 34 | <PackageName Value="LCL"/> 35 | </Item1> 36 | <Item2> 37 | <PackageName Value="FCL"/> 38 | </Item2> 39 | </RequiredPackages> 40 | <Units Count="3"> 41 | <Unit0> 42 | <Filename Value="AutoScopeTest.dpr"/> 43 | <IsPartOfProject Value="True"/> 44 | </Unit0> 45 | <Unit1> 46 | <Filename Value="..\AutoScope.pas"/> 47 | <IsPartOfProject Value="True"/> 48 | </Unit1> 49 | <Unit2> 50 | <Filename Value="TestScoped.pas"/> 51 | <IsPartOfProject Value="True"/> 52 | </Unit2> 53 | </Units> 54 | </ProjectOptions> 55 | <CompilerOptions> 56 | <Version Value="11"/> 57 | <PathDelim Value="\"/> 58 | <SearchPaths> 59 | <IncludeFiles Value="$(ProjOutDir)"/> 60 | <OtherUnitFiles Value=".."/> 61 | <UnitOutputDirectory Value="$(TargetOS)\Debug"/> 62 | </SearchPaths> 63 | <Linking> 64 | <Debugging> 65 | <UseHeaptrc Value="True"/> 66 | <TrashVariables Value="True"/> 67 | </Debugging> 68 | </Linking> 69 | <Other> 70 | <CustomOptions Value="-dCONSOLE_TESTRUNNER"/> 71 | <OtherDefines Count="1"> 72 | <Define0 Value="CONSOLE_TESTRUNNER"/> 73 | </OtherDefines> 74 | </Other> 75 | </CompilerOptions> 76 | <Debugging> 77 | <Exceptions Count="3"> 78 | <Item1> 79 | <Name Value="EAbort"/> 80 | </Item1> 81 | <Item2> 82 | <Name Value="ECodetoolError"/> 83 | </Item2> 84 | <Item3> 85 | <Name Value="EFOpenError"/> 86 | </Item3> 87 | </Exceptions> 88 | </Debugging> 89 | </CONFIG> 90 | -------------------------------------------------------------------------------- /tests/AutoScopeTest.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pda0/AutoScope/31433628155265750c18f20265fdb902a93334a4/tests/AutoScopeTest.res -------------------------------------------------------------------------------- /tests/AutoScopeTest_2007.dproj: -------------------------------------------------------------------------------- 1 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> 2 | <PropertyGroup> 3 | <ProjectGuid>{b31db51f-4b35-4aef-84a3-45e337c878f1}</ProjectGuid> 4 | <MainSource>AutoScopeTest.dpr</MainSource> 5 | <Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration> 6 | <Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform> 7 | <DCC_DCCCompiler>DCC32</DCC_DCCCompiler> 8 | <DCC_DependencyCheckOutputName>Win32\Debug\AutoScopeTest.exe</DCC_DependencyCheckOutputName> 9 | </PropertyGroup> 10 | <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' "> 11 | <Version>7.0</Version> 12 | <DCC_DebugInformation>False</DCC_DebugInformation> 13 | <DCC_LocalDebugSymbols>False</DCC_LocalDebugSymbols> 14 | <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> 15 | <DCC_Define>RELEASE</DCC_Define> 16 | <DCC_ExeOutput>.\Win32\Release</DCC_ExeOutput> 17 | <DCC_DcuOutput>.\Win32\Release</DCC_DcuOutput> 18 | <DCC_ObjOutput>.\Win32\Release</DCC_ObjOutput> 19 | <DCC_HppOutput>.\Win32\Release</DCC_HppOutput> 20 | </PropertyGroup> 21 | <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' "> 22 | <Version>7.0</Version> 23 | <DCC_Define>DEBUG;_CONSOLE_TESTRUNNER</DCC_Define> 24 | <DCC_UnitSearchPath>;$(BDS)\Source\DUnit\src</DCC_UnitSearchPath> 25 | <DCC_ResourcePath>;$(BDS)\Source\DUnit\src</DCC_ResourcePath> 26 | <DCC_ObjPath>;$(BDS)\Source\DUnit\src</DCC_ObjPath> 27 | <DCC_IncludePath>;$(BDS)\Source\DUnit\src</DCC_IncludePath> 28 | <DCC_ExeOutput>.\Win32\Debug</DCC_ExeOutput> 29 | <DCC_DcuOutput>.\Win32\Debug</DCC_DcuOutput> 30 | <DCC_ObjOutput>.\Win32\Debug</DCC_ObjOutput> 31 | <DCC_HppOutput>.\Win32\Debug</DCC_HppOutput> 32 | </PropertyGroup> 33 | <ProjectExtensions> 34 | <Borland.Personality>Delphi.Personality</Borland.Personality> 35 | <Borland.ProjectType /> 36 | <BorlandProject> 37 | <BorlandProject><Delphi.Personality><Parameters><Parameters Name="UseLauncher">False</Parameters><Parameters Name="LoadAllSymbols">True</Parameters><Parameters Name="LoadUnspecifiedSymbols">False</Parameters></Parameters><VersionInfo><VersionInfo Name="IncludeVerInfo">False</VersionInfo><VersionInfo Name="AutoIncBuild">False</VersionInfo><VersionInfo Name="MajorVer">1</VersionInfo><VersionInfo Name="MinorVer">0</VersionInfo><VersionInfo Name="Release">0</VersionInfo><VersionInfo Name="Build">0</VersionInfo><VersionInfo Name="Debug">False</VersionInfo><VersionInfo Name="PreRelease">False</VersionInfo><VersionInfo Name="Special">False</VersionInfo><VersionInfo Name="Private">False</VersionInfo><VersionInfo Name="DLL">False</VersionInfo><VersionInfo Name="Locale">1049</VersionInfo><VersionInfo Name="CodePage">1251</VersionInfo></VersionInfo><VersionInfoKeys><VersionInfoKeys Name="CompanyName"></VersionInfoKeys><VersionInfoKeys Name="FileDescription"></VersionInfoKeys><VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys><VersionInfoKeys Name="InternalName"></VersionInfoKeys><VersionInfoKeys Name="LegalCopyright"></VersionInfoKeys><VersionInfoKeys Name="LegalTrademarks"></VersionInfoKeys><VersionInfoKeys Name="OriginalFilename"></VersionInfoKeys><VersionInfoKeys Name="ProductName"></VersionInfoKeys><VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys><VersionInfoKeys Name="Comments"></VersionInfoKeys></VersionInfoKeys><Source><Source Name="MainSource">AutoScopeTest.dpr</Source></Source></Delphi.Personality><UnitTesting><TestFramework>DUnit / Delphi Win32</TestFramework><TestRunner>GUI</TestRunner></UnitTesting></BorlandProject></BorlandProject> 38 | </ProjectExtensions> 39 | <Import Project="$(MSBuildBinPath)\Borland.Delphi.Targets" /> 40 | <Import Project="$(MSBuildBinPath)\Borland.Delphi.Targets" /> 41 | <ItemGroup> 42 | <DelphiCompile Include="AutoScopeTest.dpr"> 43 | <MainSource>MainSource</MainSource> 44 | </DelphiCompile> 45 | <DCCReference Include="..\AutoScope.pas" /> 46 | <DCCReference Include="TestScoped.pas" /> 47 | </ItemGroup> 48 | </Project> -------------------------------------------------------------------------------- /tests/TestScoped.pas: -------------------------------------------------------------------------------- 1 | {********************************************************************** 2 | ● Copyright(c) 2017 Dmitriy Pomerantsev <pda2@yandex.ru> 3 | 4 | See the file COPYING.FPC, included in this distribution, 5 | for details about the copyright. 6 | 7 | This program is distributed in the hope that it will be useful, 8 | but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | **********************************************************************} 12 | unit TestScoped; 13 | {$IFDEF FPC} 14 | {$CODEPAGE UTF8} 15 | {$MODE DELPHI}{$H+} 16 | {$ENDIF} 17 | 18 | interface 19 | 20 | uses 21 | {$IFDEF FPC} 22 | fpcunit, testregistry, 23 | {$ELSE} 24 | TestFramework, 25 | {$ENDIF} 26 | AutoScope; 27 | 28 | type 29 | TTestScoped = class(TTestCase) 30 | private 31 | FExObject: TObject; 32 | FExCreated, FExDeleted: Integer; 33 | class function GetMemoryUsed: NativeUInt; static; 34 | procedure MakeException; 35 | procedure MakeConstructorException; 36 | procedure MakeDestructorException; 37 | procedure SolveHanoi; 38 | published 39 | procedure TestEmpty; 40 | procedure TestAddObject; 41 | procedure TestProperty; 42 | procedure TestAddMem; 43 | procedure TestGetMem; 44 | procedure TestFreeMem; 45 | procedure TestReallocMem; 46 | procedure TestMixed; 47 | procedure TestRemoveObject; 48 | procedure TestRemoveMem; 49 | procedure TestException; 50 | procedure TestConstructorException; 51 | procedure TestDestructorException; 52 | procedure TestHanoi; 53 | end; 54 | 55 | implementation 56 | 57 | uses 58 | Classes, SysUtils; 59 | 60 | const 61 | MAX_DISCS = 5; 62 | 63 | type 64 | TTestObject = class 65 | protected 66 | FCreated, FDeleted: PInteger; 67 | public 68 | constructor Create(CreatedPtr, DeletedPtr: PInteger); virtual; 69 | destructor Destroy; override; 70 | procedure Dummy; 71 | end; 72 | 73 | TTestCFailObject = class(TTestObject) 74 | public 75 | constructor Create(CreatedPtr, DeletedPtr: PInteger); override; 76 | end; 77 | 78 | TTestDFailObject = class(TTestObject) 79 | private 80 | FFail: Boolean; 81 | public 82 | constructor Create(CreatedPtr, DeletedPtr: PInteger); override; 83 | destructor Destroy; override; 84 | property Fail: Boolean read FFail write FFail; 85 | end; 86 | 87 | IRenderer = Interface 88 | procedure RenderLine(AnStr: string); 89 | end; 90 | 91 | TPegs = (FirstPeg, SecondPeg, ThirdPeg); 92 | 93 | TPeg = record 94 | Discs: array [0 .. MAX_DISCS - 1] of Integer; 95 | Count: Integer; 96 | procedure MoveTopDisc(var DestPeg: TPeg); 97 | function RenderLine(Line: Integer): string; 98 | end; 99 | 100 | TTowers = record 101 | Pegs: array [TPegs] of TPeg; 102 | procedure Init; 103 | procedure Render(Rendered: IRenderer); 104 | end; 105 | 106 | TRenderer = class(TInterfacedObject, IRenderer) 107 | private 108 | FStrings: TStrings; 109 | public 110 | constructor Create(const Strings: TStrings); 111 | procedure RenderLine(AnStr: string); 112 | end; 113 | 114 | { TTestObject } 115 | 116 | constructor TTestObject.Create(CreatedPtr, DeletedPtr: PInteger); 117 | begin 118 | inherited Create; 119 | FCreated := CreatedPtr; 120 | FDeleted := DeletedPtr; 121 | Inc(FCreated^); 122 | end; 123 | 124 | destructor TTestObject.Destroy; 125 | begin 126 | if Assigned(FDeleted) then 127 | begin 128 | Inc(FDeleted^); 129 | FDeleted := nil; 130 | end; 131 | inherited; 132 | end; 133 | 134 | procedure TTestObject.Dummy; 135 | begin 136 | end; 137 | 138 | { TTestCFailObject } 139 | 140 | constructor TTestCFailObject.Create(CreatedPtr, DeletedPtr: PInteger); 141 | begin 142 | Abort; 143 | inherited; 144 | end; 145 | 146 | { TTestDFailObject } 147 | 148 | constructor TTestDFailObject.Create(CreatedPtr, DeletedPtr: PInteger); 149 | begin 150 | inherited; 151 | FFail := True; 152 | end; 153 | 154 | destructor TTestDFailObject.Destroy; 155 | begin 156 | if FFail then 157 | Abort; 158 | 159 | inherited; 160 | end; 161 | 162 | { TPeg } 163 | 164 | procedure TPeg.MoveTopDisc(var DestPeg: TPeg); 165 | begin 166 | Dec(Count); 167 | DestPeg.Discs[DestPeg.Count] := Discs[Count]; 168 | Discs[Count] := 0; 169 | Inc(DestPeg.Count); 170 | end; 171 | 172 | function TPeg.RenderLine(Line: Integer): string; 173 | var 174 | TowerWidth, RingWidth, Spaces: Integer; 175 | begin 176 | TowerWidth := 3 + 2 * (MAX_DISCS - 1); 177 | 178 | if Line >= MAX_DISCS then 179 | RingWidth := 1 180 | else 181 | RingWidth := 1 + 2 * Discs[Line]; 182 | 183 | Spaces := (TowerWidth - RingWidth) div 2; 184 | 185 | if RingWidth = 1 then 186 | Result := '#' 187 | else 188 | Result := StringOfChar('@', RingWidth); 189 | 190 | Result := StringOfChar(' ', Spaces) + Result + StringOfChar(' ', Spaces); 191 | end; 192 | 193 | { TTowers } 194 | procedure TTowers.Init; 195 | var 196 | i: Integer; 197 | begin 198 | Pegs[FirstPeg].Count := MAX_DISCS; 199 | Pegs[SecondPeg].Count := 0; 200 | Pegs[ThirdPeg].Count := 0; 201 | for i := 0 to MAX_DISCS - 1 do 202 | begin 203 | Pegs[FirstPeg].Discs[i] := MAX_DISCS - i; 204 | Pegs[SecondPeg].Discs[i] := 0; 205 | Pegs[ThirdPeg].Discs[i] := 0; 206 | end; 207 | end; 208 | 209 | { TRenderer } 210 | 211 | constructor TRenderer.Create(const Strings: TStrings); 212 | begin 213 | FStrings := Strings; 214 | end; 215 | 216 | procedure TRenderer.RenderLine(AnStr: string); 217 | begin 218 | FStrings.Append(AnStr); 219 | end; 220 | 221 | procedure TTowers.Render(Rendered: IRenderer); 222 | var 223 | PegLine: string; 224 | Line: Integer; 225 | Peg: TPegs; 226 | begin 227 | Rendered.RenderLine(''); 228 | for Line := MAX_DISCS downto 0 do 229 | begin 230 | PegLine := ''; 231 | for Peg := Low(Pegs) to High(Pegs) do 232 | PegLine := PegLine + Pegs[Peg].RenderLine(Line); 233 | Rendered.RenderLine(PegLine); 234 | end; 235 | end; 236 | 237 | { TTestScoped } 238 | 239 | class function TTestScoped.GetMemoryUsed: NativeUInt; 240 | {$IFNDEF FPC} 241 | var 242 | st: TMemoryManagerState; 243 | i: Integer; 244 | {$ENDIF} 245 | begin 246 | {$IFDEF FPC} 247 | Result := NativeUint(GetHeapStatus.TotalAllocated); 248 | {$ELSE} 249 | GetMemoryManagerState(st); 250 | Result := st.TotalAllocatedMediumBlockSize + st.TotalAllocatedLargeBlockSize; 251 | for i := Low(st.SmallBlockTypeStates) to High(st.SmallBlockTypeStates) do 252 | Result := Result + st.SmallBlockTypeStates[i].UseableBlockSize * 253 | st.SmallBlockTypeStates[i].AllocatedBlockCount; 254 | {$ENDIF} 255 | end; 256 | 257 | {$IFDEF FPC}{$PUSH}{$NOTES OFF}{$ENDIF}{$HINTS OFF} 258 | procedure TTestScoped.TestEmpty; 259 | var 260 | Mem1, Mem2: NativeUInt; 261 | 262 | procedure ScopedTest; 263 | var 264 | Scoped: TScoped; 265 | begin 266 | { Here we have two implicit calls: 267 | @InitializeRecord(Scoped); 268 | @FinalizeRecord(Scoped); } 269 | end; 270 | begin 271 | Mem1 := GetMemoryUsed; 272 | ScopedTest; 273 | Mem2 := GetMemoryUsed; 274 | 275 | CheckEquals(Mem1, Mem2); 276 | end; 277 | {$IFDEF FPC}{$POP}{$ELSE}{$HINTS ON}{$ENDIF} 278 | 279 | procedure TTestScoped.TestAddObject; 280 | var 281 | CreatedCounter, DeletedCounter: Integer; 282 | 283 | procedure ScopedTest; 284 | var 285 | Scoped: TScoped; 286 | T1, T2, T3: TTestObject; 287 | begin 288 | T1 := Scoped.AddObject(TTestObject.Create(@CreatedCounter, @DeletedCounter)) as TTestObject; 289 | T2 := Scoped.AddObject(TTestObject.Create(@CreatedCounter, @DeletedCounter)) as TTestObject; 290 | T3 := Scoped.AddObject(TTestObject.Create(@CreatedCounter, @DeletedCounter)) as TTestObject; 291 | T1.Dummy; 292 | T2.Dummy; 293 | T3.Dummy; 294 | end; 295 | begin 296 | CreatedCounter := 0; 297 | DeletedCounter := 0; 298 | 299 | ScopedTest; 300 | CheckEquals(3, CreatedCounter); 301 | CheckEquals(3, DeletedCounter); 302 | end; 303 | 304 | procedure TTestScoped.TestProperty; 305 | var 306 | CreatedCounter, DeletedCounter: Integer; 307 | 308 | procedure ScopedTest; 309 | var 310 | Scoped: TScoped; 311 | T1, T2, T3: TTestObject; 312 | begin 313 | T1 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 314 | T2 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 315 | T3 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 316 | T1.Dummy; 317 | T2.Dummy; 318 | T3.Dummy; 319 | end; 320 | begin 321 | CreatedCounter := 0; 322 | DeletedCounter := 0; 323 | 324 | ScopedTest; 325 | CheckEquals(3, CreatedCounter); 326 | CheckEquals(3, DeletedCounter); 327 | end; 328 | 329 | procedure TTestScoped.TestAddMem; 330 | var 331 | Mem1, Mem2: NativeUInt; 332 | 333 | procedure ScopedTest; 334 | var 335 | Scoped: TScoped; 336 | P: Pointer; 337 | begin 338 | GetMem(P, 64); 339 | Scoped.AddMem(P); 340 | end; 341 | begin 342 | Mem1 := GetMemoryUsed; 343 | ScopedTest; 344 | Mem2 := GetMemoryUsed; 345 | 346 | CheckEquals(Mem1, Mem2); 347 | end; 348 | 349 | procedure TTestScoped.TestGetMem; 350 | var 351 | Mem1, Mem2: NativeUInt; 352 | 353 | procedure ScopedTest; 354 | var 355 | Scoped: TScoped; 356 | P1, P2, P3: Pointer; 357 | begin 358 | Scoped.GetMem(P1, 64); 359 | Scoped.GetMem(P2, 128); 360 | Scoped.GetMem(P3, 64); 361 | end; 362 | begin 363 | Mem1 := GetMemoryUsed; 364 | ScopedTest; 365 | Mem2 := GetMemoryUsed; 366 | 367 | CheckEquals(Mem1, Mem2); 368 | end; 369 | 370 | procedure TTestScoped.TestFreeMem; 371 | var 372 | Mem1, Mem2: NativeUInt; 373 | 374 | procedure ScopedTest; 375 | var 376 | Scoped: TScoped; 377 | P1, P2, P3: Pointer; 378 | begin 379 | Scoped.GetMem(P1, 64); 380 | Scoped.GetMem(P2, 128); 381 | Scoped.GetMem(P3, 64); 382 | Scoped.FreeMem(P2); 383 | end; 384 | begin 385 | Mem1 := GetMemoryUsed; 386 | ScopedTest; 387 | Mem2 := GetMemoryUsed; 388 | 389 | CheckEquals(Mem1, Mem2); 390 | end; 391 | 392 | procedure TTestScoped.TestReallocMem; 393 | var 394 | Mem1, Mem2: NativeUInt; 395 | 396 | procedure ScopedTest; 397 | var 398 | Scoped: TScoped; 399 | P: Pointer; 400 | begin 401 | Scoped.GetMem(P, 64); 402 | Scoped.ReallocMem(P, 128); 403 | end; 404 | begin 405 | Mem1 := GetMemoryUsed; 406 | ScopedTest; 407 | Mem2 := GetMemoryUsed; 408 | 409 | CheckEquals(Mem1, Mem2); 410 | end; 411 | 412 | procedure TTestScoped.TestMixed; 413 | var 414 | Mem1, Mem2: NativeUInt; 415 | CreatedCounter, DeletedCounter: Integer; 416 | 417 | procedure ScopedTest; 418 | var 419 | Scoped: TScoped; 420 | T1, T2: TTestObject; 421 | P1, P2: Pointer; 422 | begin 423 | T1 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 424 | Scoped.GetMem(P1, 64); 425 | T2 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 426 | Scoped.GetMem(P2, 64); 427 | T1.Dummy; 428 | T2.Dummy; 429 | end; 430 | begin 431 | CreatedCounter := 0; 432 | DeletedCounter := 0; 433 | 434 | Mem1 := GetMemoryUsed; 435 | ScopedTest; 436 | Mem2 := GetMemoryUsed; 437 | 438 | CheckEquals(2, CreatedCounter); 439 | CheckEquals(2, DeletedCounter); 440 | CheckEquals(Mem1, Mem2); 441 | end; 442 | 443 | procedure TTestScoped.TestRemoveObject; 444 | var 445 | CreatedCounter, DeletedCounter: Integer; 446 | T1, T2, T3: TTestObject; 447 | 448 | procedure ScopedTest; 449 | var 450 | Scoped: TScoped; 451 | begin 452 | T1 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 453 | T2 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 454 | T3 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 455 | T1.Dummy; 456 | T2.Dummy; 457 | T3.Dummy; 458 | Scoped.RemoveObject(T2); 459 | end; 460 | begin 461 | CreatedCounter := 0; 462 | DeletedCounter := 0; 463 | T2 := nil; 464 | 465 | ScopedTest; 466 | CheckEquals(3, CreatedCounter); 467 | CheckEquals(2, DeletedCounter); 468 | 469 | T2.Free; 470 | CheckEquals(3, CreatedCounter); 471 | CheckEquals(3, DeletedCounter); 472 | end; 473 | 474 | procedure TTestScoped.TestRemoveMem; 475 | var 476 | Mem1, Mem2: NativeUInt; 477 | P1, P2, P3: Pointer; 478 | 479 | procedure ScopedTest; 480 | var 481 | Scoped: TScoped; 482 | begin 483 | Scoped.GetMem(P1, 64); 484 | Scoped.GetMem(P2, 128); 485 | Scoped.GetMem(P3, 64); 486 | Scoped.RemoveMem(P2); 487 | end; 488 | begin 489 | P2 := nil; 490 | Mem1 := GetMemoryUsed; 491 | ScopedTest; 492 | Mem2 := GetMemoryUsed; 493 | 494 | CheckNotEquals(Mem1, Mem2); 495 | 496 | FreeMem(P2); 497 | Mem2 := GetMemoryUsed; 498 | 499 | CheckEquals(Mem1, Mem2); 500 | end; 501 | 502 | procedure TTestScoped.MakeException; 503 | var 504 | Scoped: TScoped; 505 | T1, T2, T3: TTestObject; 506 | begin 507 | T1 := Scoped[TTestObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 508 | T2 := Scoped[TTestObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 509 | T3 := Scoped[TTestObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 510 | 511 | Abort; 512 | 513 | T1.Dummy; 514 | T2.Dummy; 515 | T3.Dummy; 516 | end; 517 | 518 | procedure TTestScoped.TestException; 519 | begin 520 | FExCreated := 0; 521 | FExDeleted := 0; 522 | 523 | CheckException(MakeException, EAbort); 524 | 525 | CheckEquals(3, FExCreated); 526 | CheckEquals(3, FExDeleted); 527 | end; 528 | 529 | procedure TTestScoped.MakeConstructorException; 530 | var 531 | Scoped: TScoped; 532 | T1, T2: TTestObject; 533 | begin 534 | T1 := Scoped[TTestObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 535 | T2 := Scoped[TTestCFailObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 536 | 537 | T1.Dummy; 538 | T2.Dummy; 539 | end; 540 | 541 | procedure TTestScoped.TestConstructorException; 542 | begin 543 | FExCreated := 0; 544 | FExDeleted := 0; 545 | 546 | CheckException(MakeConstructorException, EAbort); 547 | 548 | CheckEquals(1, FExCreated); 549 | CheckEquals(1, FExDeleted); 550 | end; 551 | 552 | procedure TTestScoped.MakeDestructorException; 553 | var 554 | Scoped: TScoped; 555 | T1, T2, T3: TTestObject; 556 | begin 557 | T1 := Scoped[TTestObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 558 | T2 := Scoped[TTestDFailObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 559 | T3 := Scoped[TTestObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 560 | 561 | FExObject := T2; 562 | 563 | T1.Dummy; 564 | T2.Dummy; 565 | T3.Dummy; 566 | end; 567 | 568 | procedure TTestScoped.TestDestructorException; 569 | begin 570 | FExCreated := 0; 571 | FExDeleted := 0; 572 | 573 | CheckException(MakeDestructorException, EAbort); 574 | 575 | CheckEquals(3, FExCreated); 576 | CheckEquals(2, FExDeleted); 577 | 578 | (FExObject as TTestDFailObject).Fail := False; 579 | FExObject.Free; 580 | 581 | CheckEquals(3, FExDeleted); 582 | end; 583 | 584 | { The solution to the `Tower of Hanoi' puzzle is used to get a large enough and 585 | complex code to make sure that the compiler does not remove Scoped ahead of 586 | time. } 587 | procedure TTestScoped.SolveHanoi; 588 | var 589 | Scoped: TScoped; 590 | Towers: TTowers; 591 | Solution: TStrings; 592 | Renderer: IRenderer; 593 | T: TTestObject; 594 | 595 | procedure MoveStack(Amount: Integer; SrcPeg, DestPeg: TPegs); 596 | var 597 | Scoped: TScoped; 598 | Renderer: IRenderer; 599 | T2: TTestObject; 600 | FreePeg: TPegs; 601 | CreatedCounter, DeletedCounter: Integer; 602 | begin 603 | FreePeg := FirstPeg; 604 | CreatedCounter := 0; 605 | DeletedCounter := 0; 606 | T2 := Scoped[TTestObject.Create(@CreatedCounter, @DeletedCounter)] as TTestObject; 607 | T2.Dummy; 608 | 609 | if Amount > 0 then 610 | begin 611 | Renderer := TRenderer.Create(Solution); 612 | Dec(Amount); 613 | 614 | case SrcPeg of 615 | FirstPeg: 616 | if DestPeg = SecondPeg then 617 | FreePeg := ThirdPeg 618 | else 619 | FreePeg := SecondPeg; 620 | SecondPeg: 621 | if DestPeg = ThirdPeg then 622 | FreePeg := FirstPeg 623 | else 624 | FreePeg := ThirdPeg; 625 | ThirdPeg: 626 | if DestPeg = FirstPeg then 627 | FreePeg := SecondPeg 628 | else 629 | FreePeg := FirstPeg; 630 | end; 631 | 632 | MoveStack(Amount, SrcPeg, FreePeg); 633 | Towers.Pegs[SrcPeg].MoveTopDisc(Towers.Pegs[DestPeg]); 634 | Towers.Render(Renderer); 635 | MoveStack(Amount, FreePeg, DestPeg); 636 | end; 637 | 638 | CheckEquals(1, CreatedCounter); 639 | CheckEquals(0, DeletedCounter); 640 | end; 641 | begin 642 | T := Scoped[TTestObject.Create(@FExCreated, @FExDeleted)] as TTestObject; 643 | Solution := Scoped[TStringList.Create] as TStringList; 644 | T.Dummy; 645 | 646 | Renderer := TRenderer.Create(Solution); 647 | Towers.Init; 648 | Towers.Render(Renderer); 649 | MoveStack(MAX_DISCS, FirstPeg, SecondPeg); 650 | CheckEquals(0, FExDeleted); 651 | end; 652 | 653 | procedure TTestScoped.TestHanoi; 654 | begin 655 | FExCreated := 0; 656 | FExDeleted := 0; 657 | 658 | SolveHanoi; 659 | 660 | CheckEquals(1, FExCreated); 661 | CheckEquals(1, FExDeleted); 662 | end; 663 | 664 | initialization 665 | RegisterTest('AutoScope', TTestScoped.Suite); 666 | 667 | end. 668 | --------------------------------------------------------------------------------