a binary tree structure "PersistentTree"
unit StreamAdapter.pas
unit PersistentTree.pas
1 2 //+ Jonas Raoni Soares Silva 3 //@ http://jsfromhell.com 4 5 unit StreamAdapter; 6 7 interface 8 9 uses 10 Classes; 11 12 type 13 IStream = interface( IInterface ) 14 ['{FBEF199A-09BC-4B61-89EA-1EF8B22C93A5}'] 15 function Read(var Buffer; const Count: Longint): Longint; 16 function Write(const Buffer; const Count: Longint): Longint; 17 function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; 18 procedure ReadBuffer(var Buffer; const Count: Longint); 19 procedure WriteBuffer(const Buffer; const Count: Longint); 20 function CopyFrom(Source: TStream; const Count: Int64): Int64; 21 function WriteTo(Dest: TStream; const Count: Int64): Int64; 22 23 procedure SetPosition( const Value: Int64 ); 24 procedure SetSize( const Value: Int64 ); 25 function GetPosition: Int64; 26 function GetSize: Int64; 27 28 property Position: Int64 read GetPosition write SetPosition; 29 property Size: Int64 read GetSize write SetSize; 30 end; 31 32 TStreamAdapter = class( TInterfacedObject, IStream ) 33 private 34 FStream: TStream; 35 procedure SetPosition( const Value: Int64 ); 36 procedure SetSize( const Value: Int64 ); 37 function GetPosition: Int64; 38 function GetSize: Int64; 39 40 public 41 constructor Create( Stream: TStream ); 42 destructor Destroy; override; 43 44 function Read(var Buffer; const Count: Longint): Longint; 45 function Write(const Buffer; const Count: Longint): Longint; 46 47 procedure ReadBuffer(var Buffer; const Count: Longint); 48 procedure WriteBuffer(const Buffer; const Count: Longint); 49 50 function CopyFrom(Source: TStream; const Count: Int64): Int64; 51 function WriteTo(Dest: TStream; const Count: Int64): Int64; 52 53 function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; 54 55 property Position: Int64 read GetPosition write SetPosition; 56 property Size: Int64 read GetSize write SetSize; 57 end; 58 59 implementation 60 61 { TStreamAdapter } 62 63 function TStreamAdapter.CopyFrom(Source: TStream; const Count: Int64): Int64; 64 begin 65 Result := FStream.CopyFrom( Source, Count ); 66 end; 67 68 constructor TStreamAdapter.Create(Stream: TStream); 69 begin 70 FStream := Stream; 71 end; 72 73 destructor TStreamAdapter.Destroy; 74 begin 75 FStream.Free; 76 inherited; 77 end; 78 79 function TStreamAdapter.GetPosition: Int64; 80 begin 81 Result := FStream.Position; 82 end; 83 84 function TStreamAdapter.GetSize: Int64; 85 begin 86 Result := FStream.Size; 87 end; 88 89 function TStreamAdapter.Read(var Buffer; const Count: Integer): Longint; 90 begin 91 Result := FStream.Read( Buffer, Count ); 92 end; 93 94 procedure TStreamAdapter.ReadBuffer(var Buffer; const Count: Integer); 95 begin 96 FStream.ReadBuffer( Buffer, Count ); 97 end; 98 99 function TStreamAdapter.Seek(const Offset: Int64; 100 Origin: TSeekOrigin): Int64; 101 begin 102 Result := FStream.Seek( Offset, Origin ); 103 end; 104 105 procedure TStreamAdapter.SetPosition(const Value: Int64); 106 begin 107 FStream.Position := Value; 108 end; 109 110 procedure TStreamAdapter.SetSize(const Value: Int64); 111 begin 112 FStream.Size := Value; 113 end; 114 115 function TStreamAdapter.Write(const Buffer; const Count: Integer): Longint; 116 begin 117 Result := FStream.Write( Buffer, Count ); 118 end; 119 120 procedure TStreamAdapter.WriteBuffer(const Buffer; const Count: Integer); 121 begin 122 FStream.WriteBuffer( Buffer, Count ); 123 end; 124 125 function TStreamAdapter.WriteTo(Dest: TStream; const Count: Int64): Int64; 126 begin 127 Result := Dest.CopyFrom( FStream, Count ); 128 end; 129 130 end.
unit PersistentTree.pas
1 2 //+ Jonas Raoni Soares Silva 3 //@ http://jsfromhell.com 4 5 unit PersistentTree; 6 7 interface 8 9 uses 10 Windows, Classes, SysUtils, StreamAdapter; 11 12 type 13 EPersistentTree = class( Exception ); 14 15 TPersistentTree = class; 16 17 TPersistentTreeClass = class of TPersistentTree; 18 19 TPersistentTree = class( TStream ) 20 private 21 FStream: IStream; 22 FList: TList; 23 FBaseClass: TPersistentTreeClass; 24 FOwner, FParent: TPersistentTree; 25 FOwnStream: Boolean; 26 FDataFilename, FFilename: string; 27 FLastPosition, FDataBegin, FDataLength: Int64; 28 29 function GetItem(const Index: Integer): TPersistentTree; 30 function GetCount: Integer; 31 function GetStream: TStream; 32 function Import( Item: TPersistentTree ): Boolean; 33 procedure ClearData; 34 procedure RecreateStream( const Pos: Int64; const Deep: Boolean = False ); 35 procedure Synchronize; 36 37 protected 38 //override to provide writing/reading notifications 39 procedure Loaded; virtual; 40 procedure Saving; virtual; 41 42 //derived from TStream 43 function GetSize: Int64; override; 44 procedure SetSize(NewSize: Longint); override; 45 procedure SetSize(const NewSize: Int64); override; 46 47 public 48 constructor Create; virtual; 49 destructor Destroy; override; 50 51 //derived from TStream 52 function Read( var Buffer; Count: Longint ): Longint; override; 53 function Write( const Buffer; Count: Longint ): Longint; override; 54 function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; 55 56 function Truncate: Int64; 57 function ReadString: string; 58 procedure WriteString( const Data: string ); 59 60 procedure Save( const AFilename: string ); overload; 61 procedure Save( Stream: TStream ); overload; 62 procedure Load( const AFilename: string ); overload; 63 procedure Load( Stream: IStream ); overload; 64 procedure Load( Stream: TStream ); overload; 65 66 function Add: TPersistentTree; overload; 67 function Add( Item: TPersistentTree ): Integer; overload; 68 procedure Insert( const Index: Integer; Item: TPersistentTree); 69 function IndexOf( Item: TPersistentTree ): Integer; 70 function Remove( Item: TPersistentTree ): Integer; 71 procedure Delete( const Index: Integer); 72 function Extract( Item: TPersistentTree ): TPersistentTree; 73 procedure Exchange( const IndexA, IndexB: Integer ); 74 procedure Move(const CurIndex, NewIndex: Integer); 75 procedure Clear; 76 77 property Items[ const Index: Integer ]: TPersistentTree read GetItem; default; 78 property Count: Integer read GetCount; 79 property Owner: TPersistentTree read FOwner; 80 property Parent: TPersistentTree read FParent; 81 property Filename: string read FFilename; 82 property BaseClass: TPersistentTreeClass read FBaseClass write FBaseClass; 83 end; 84 85 TPersistentTreeHeader = packed record 86 Sig: array[0..4] of Char; 87 Ver: Word; 88 end; 89 90 const 91 PERSISTENT_TREE_HEADER: TPersistentTreeHeader = ( Sig: 'PTREE'; Ver: 1 ); 92 93 function GetTempFile: string; 94 95 96 implementation 97 98 function GetTempFile: string; 99 var 100 Path: array[0..MAX_PATH-1] of Char; 101 begin 102 GetTempPath( MAX_PATH, Path ); 103 GetTempFileName( Path, 'BUF', 0, Path ); 104 Result := Path; 105 end; 106 107 { TPersistentTree } 108 109 procedure TPersistentTree.Clear; 110 var 111 I: Integer; 112 begin 113 for I := FList.Count - 1 downto 0 do 114 begin 115 TPersistentTree( FList[I] ).Free; 116 FList.Delete( I ); 117 end; 118 end; 119 120 constructor TPersistentTree.Create; 121 begin 122 FBaseClass := TPersistentTreeClass( Self.ClassType ); 123 FList := TList.Create; 124 FStream := TStreamAdapter.Create( GetStream ); 125 FOwnStream := True; 126 end; 127 128 destructor TPersistentTree.Destroy; 129 begin 130 ClearData; 131 FList.Free; 132 inherited; 133 end; 134 135 procedure TPersistentTree.Exchange(const IndexA, IndexB: Integer); 136 begin 137 FList.Exchange( IndexA, IndexB ); 138 end; 139 140 function TPersistentTree.GetCount: Integer; 141 begin 142 Result := FList.Count; 143 end; 144 145 function TPersistentTree.GetItem(const Index: Integer): TPersistentTree; 146 begin 147 Result := FList[ Index ]; 148 end; 149 150 function TPersistentTree.IndexOf( 151 Item: TPersistentTree): Integer; 152 begin 153 Result := FList.IndexOf( Item ); 154 end; 155 156 procedure TPersistentTree.Load(const AFilename: string); 157 var 158 FS: TFileStream; 159 //Header: TPersistentTreeHeader; 160 begin 161 FS := TFileStream.Create( AFilename, fmOpenRead or fmShareDenyWrite ); 162 try 163 //FS.Read( Header, SizeOf( TPersistentTreeHeader ) ); 164 //if not CompareMem( @Header, @PERSISTENT_TREE_HEADER, SizeOf( TPersistentTreeHeader ) ) then 165 // raise EPersistentTree.CreateFmt( '%s.LoadFromFile :: "%s" Not Recognized', [ClassName, AFilename] ); 166 Load( FS ); 167 FFilename := AFilename; 168 except 169 FS.Free; 170 raise; 171 end; 172 end; 173 174 procedure TPersistentTree.Load(Stream: TStream); 175 begin 176 Load( TStreamAdapter.Create( Stream ) ); 177 end; 178 179 function TPersistentTree.Remove(Item: TPersistentTree): Integer; 180 begin 181 Result := FList.Remove( Item ); 182 if Result >= 0 then 183 Item.Free; 184 end; 185 186 procedure TPersistentTree.Save( const AFilename: string ); 187 var 188 FS: TFileStream; 189 begin 190 FS := TFileStream.Create( AFilename, fmCreate or fmShareDenyWrite ); 191 try 192 //FS.Write( PERSISTENT_TREE_HEADER, SizeOf( TPersistentTreeHeader ) ); 193 Save( FS ); 194 finally 195 FS.Free; 196 end; 197 end; 198 199 procedure TPersistentTree.Save(Stream: TStream); 200 var 201 I: LongInt; 202 begin 203 Seek( 0, soBeginning ); 204 Saving; 205 206 FDataLength := Size; 207 Stream.Write( FDataLength, SizeOf( FDataLength ) ); 208 Stream.CopyFrom( Self, 0 ); 209 210 I := FList.Count; 211 Stream.Write( I, SizeOf( I ) ); 212 for I := 0 to FList.Count-1 do 213 Self[I].Save( Stream ); 214 end; 215 216 function TPersistentTree.Write( const Buffer; Count: Longint ): Longint; 217 begin 218 if FOwnStream then 219 Result := FStream.Write( Buffer, Count ) 220 else 221 begin 222 Synchronize; 223 if Position + Count > Size then 224 RecreateStream( Position ); 225 Result := FStream.Write( Buffer, Count ); 226 FLastPosition := FStream.Position; 227 end; 228 229 end; 230 231 function TPersistentTree.Read( var Buffer; Count: Longint): Longint; 232 begin 233 if FOwnStream then 234 Result := FStream.Read( Buffer, Count ) 235 else 236 begin 237 Synchronize; 238 if Count < 0 then 239 Count := 0 240 else if Count > Size - Position then 241 Count := Size - Position; 242 Result := FStream.Read( Buffer, Count ); 243 FLastPosition := FStream.Position; 244 end 245 end; 246 247 function TPersistentTree.Seek(const Offset: Int64; 248 Origin: TSeekOrigin): Int64; 249 begin 250 if FOwnStream then 251 Result := FStream.Seek( Offset, Origin ) 252 else 253 begin 254 Synchronize; 255 case Origin of 256 soBeginning: Result := FDataBegin + Offset; 257 soCurrent: Result := FStream.Position + Offset; 258 soEnd: Result := FDataBegin + Size - Offset; 259 else 260 Result := 0; 261 end; 262 if Result > -1 then 263 if Result <= FDataBegin + Size then 264 Result := FStream.Seek( Result, soBeginning ) - FDataBegin 265 else 266 begin 267 RecreateStream( Size ); 268 Result := FStream.Seek( Result, soBeginning ); 269 end; 270 FLastPosition := FStream.Position; 271 end; 272 end; 273 274 procedure TPersistentTree.SetSize(const NewSize: Int64); 275 begin 276 if FOwnStream then 277 FStream.Size := NewSize 278 else begin 279 if NewSize <= 0 then 280 RecreateStream( 0 ) 281 else if NewSize > Size then 282 RecreateStream( Size ) 283 else 284 begin 285 FDataLength := NewSize; 286 Seek( 0, soEnd ); 287 end; 288 FLastPosition := FStream.Position; 289 end; 290 end; 291 292 procedure TPersistentTree.Synchronize; 293 begin 294 if not FOwnStream and ( ( FStream.Position < FDataBegin ) or ( FStream.Position - FDataBegin > FDataLength ) ) then 295 FStream.Seek( FLastPosition, soBeginning ); 296 end; 297 298 procedure TPersistentTree.Load( Stream: IStream); 299 var 300 I: LongInt; 301 begin 302 ClearData; 303 304 FStream := Stream; 305 FOwnStream := False; 306 307 Stream.Read( FDataLength, SizeOf( FDataLength ) ); 308 FDataBegin := FStream.Position; 309 FLastPosition := FDataBegin; 310 311 Stream.Seek( FDataLength, soCurrent ); 312 313 Stream.Read( I, SizeOf( I ) ); 314 for I := I - 1 downto 0 do 315 Add.Load( FStream ); 316 317 //Seek( 0, soBeginning ); it isnt needed since synchonize will do it anyway 318 Loaded; 319 FStream.Seek( FDataBegin + FDataLength + SizeOf( I ), soBeginning ); 320 end; 321 322 function TPersistentTree.Extract( Item: TPersistentTree): TPersistentTree; 323 begin 324 Result := FList.Extract( Item ); 325 if Assigned( Result ) then begin 326 Result.FParent := nil; 327 Result.FOwner := nil; 328 Result.RecreateStream( Size, True ); 329 end; 330 end; 331 332 333 function TPersistentTree.GetSize: Int64; 334 begin 335 if FOwnStream then 336 Result := FStream.Size 337 else 338 Result := FDataLength; 339 end; 340 341 procedure TPersistentTree.WriteString(const Data: string); 342 var 343 I: LongWord; 344 begin 345 I := Length( Data ); 346 Write( I, SizeOf( I ) ); 347 Write( Pointer( Data )^, I ); 348 end; 349 350 function TPersistentTree.ReadString: string; 351 var 352 I: LongWord; 353 begin 354 Read( I, SizeOf( I ) ); 355 SetLength( Result, I ); 356 Read( Pointer( Result )^, I ); 357 end; 358 359 procedure TPersistentTree.SetSize(NewSize: Integer); 360 begin 361 SetSize( Int64( NewSize ) ); 362 end; 363 364 procedure TPersistentTree.RecreateStream( const Pos: Int64; const Deep: Boolean ); 365 var 366 FS: TStream; 367 I: Integer; 368 begin 369 if not FOwnStream then 370 begin 371 FS := GetStream; 372 if Pos > 0 then 373 begin 374 Seek( 0, soBeginning ); 375 FS.CopyFrom( Self, Pos ); 376 end; 377 FStream := TStreamAdapter.Create( FS ); 378 FOwnStream := True; 379 end; 380 if Deep then 381 for I := 0 to FList.Count - 1 do 382 Self[I].RecreateStream( Self[I].Size, True ); 383 end; 384 385 procedure TPersistentTree.ClearData; 386 begin 387 FStream := nil; 388 if FOwnStream then 389 DeleteFile( FDataFilename ); 390 Clear; 391 end; 392 393 function TPersistentTree.GetStream: TStream; 394 begin 395 FDataFilename := GetTempFile; 396 Result := TFileStream.Create( FDataFilename, fmCreate or fmShareDenyWrite ); 397 end; 398 399 function TPersistentTree.Add: TPersistentTree; 400 begin 401 Result := TPersistentTreeClass( FBaseClass ).Create; 402 Add( Result ); 403 end; 404 405 function TPersistentTree.Add( Item: TPersistentTree): Integer; 406 begin 407 if Import( Item ) then 408 Result := FList.Add( Item ) 409 else 410 Result := FList.IndexOf( Item ); 411 end; 412 413 procedure TPersistentTree.Delete(const Index: Integer); 414 begin 415 TPersistentTree( FList[Index] ).Free; 416 FList.Delete( Index ); 417 end; 418 419 procedure TPersistentTree.Insert(const Index: Integer; Item: TPersistentTree); 420 begin 421 if Import( Item ) then 422 FList.Insert( Index, Item ) 423 else 424 FList.Move( FList.IndexOf( Item ), Index ); 425 end; 426 427 procedure TPersistentTree.Move(const CurIndex, NewIndex: Integer); 428 begin 429 FList.Move( CurIndex, NewIndex ); 430 end; 431 432 function TPersistentTree.Truncate: Int64; 433 begin 434 Result := Position; 435 Size := Result; 436 end; 437 438 function TPersistentTree.Import(Item: TPersistentTree): Boolean; 439 begin 440 Result := not Assigned( Item.FParent ) or ( ( Item.FParent <> Self ) and Assigned( Item.FParent.Extract( Item ) ) ); 441 if Result then 442 begin 443 Item.FParent := Self; 444 if FOwner <> nil then 445 Item.FOwner := FOwner 446 else 447 Item.FOwner := Self; 448 end; 449 end; 450 451 procedure TPersistentTree.Saving; 452 begin 453 //override to provide extra save features 454 end; 455 456 procedure TPersistentTree.Loaded; 457 begin 458 //override to provide extra load features 459 end; 460 461 end. 462
