{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█ █}
{█ Virtual Pascal Examples. Version 1.10 █}
{█ Classes demonstration example █}
{█ ─────────────────────────────────────────────────█}
{█ Copyright (C) 1996 fPrint UK Ltd █}
{█ █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
program ClsDemo;
{&X+,Delphi+}
{ This example, demonstrating various aspects of the new class model }
{ and the Classes unit, can be compiled using the command-line compiler }
{ of Delphi v2.0. }
{ Write DCC32.EXE CLSDEMO /CC to compile with Delphi v2.0. }
Uses
{$IFDEF OS2}
Os2Base,
{$ENDIF}
SysUtils, Classes;
{$IFDEF VPDEMO}
{&Dynamic VP11Demo.Lib}
{$ENDIF}
{ Display helper functions }
type
str5 = String[5];
Const
IndentLvl = 40;
BoolStr : Array[Boolean] of Str5 = ( 'False', 'True' );
StreamName = 'Test.Str';
procedure Key;
begin
Write( ' Press Enter ---> ' );
Readln;
end;
Function Indent( const s : String ) : String;
begin
Result := Copy( ' ' + s + ' .....................................', 1, IndentLvl ) + ' ';
end;
Procedure ShowS( s1 : String; Const s2 : String );
begin
Writeln( Indent( s1 ), s2 );
end;
Procedure ShowL( s1 : String; i : LongInt );
begin
Writeln( Indent( s1 ), i );
end;
{ }
{ Simple demonstration of the use of Is and As }
{ }
procedure TestIsAs;
var
t : tObject;
begin
Writeln( ' Demonstrate Is and As' );
t := tCollection.Create( tCollectionItem );
ShowS( 't is tObject?', BoolStr[t is tObject] );
ShowS( 't is tCollection?', BoolStr[t is tCollection] );
ShowS( 't is tReader?', BoolStr[t is tReader] );
With t as tCollection do
begin
// Code using t as a collection
ShowS( 'ClassName', ClassName );
// ...
Destroy;
end;
Key;
end;
{ }
{ Simple demo of TStringList class, which implements a collection of }
{ text strings. }
{ }
type
tNotify = class(tObject)
public
procedure Change(Sender: tObject);
end;
procedure tNotify.Change(Sender: tObject);
begin
If Sender is tStrings then
With Sender as tStrings do
ShowL( 'Notify: Count is now ', Count );
end;
procedure TestTStringList;
var
ts : tStringList;
Index : Integer;
Notify : tNotify;
{$IFDEF OS2}
p : pChar;
{$ELSE}
p : String;
{$ENDIF}
begin
Writeln;
Writeln( 'TStringList class demonstration:' );
ts := tStringList.Create; // Create string list
Notify := tNotify.Create; // Create notify object
With ts do
begin
Add( ' Vitaly Miryanov' ); // Add items to list
Add( ' Allan Mertner' );
Add( ' Dave Gomm' );
OnChange := Notify.Change; // Install notify handler
Add( ' John Hargreaves' );
Add( ' Linden Roth' );
Writeln( ' String List as text:' );
p := Text;
Writeln( p ); // Output stringlist as text
{$IFDEF OS2} StrDispose( p ); // Dispose of pChar
{$ENDIF}
SaveToFile( 'Strings.Txt' ); // Save strings to text file
ShowL( 'Strings', Count );
ShowL( 'IndexOf Allan', IndexOf( ' Allan Mertner' ));
Sorted := True; // Set Sorted property
OnChange := nil; // Remove notify handler
Writeln( ' Sorted String List as text:' );
p := Text;
Writeln( p ); // Output stringlist as text
{$IFDEF OS2} StrDispose( p ); // Dispose of pChar
{$ENDIF}
ShowS( 'Find Allan', BoolStr[Find( ' Allan Mertner', Index )] );
ShowS( 'Find Rob', BoolStr[Find( 'Rob', Index )] );
ShowL( 'IndexOf Allan', IndexOf( ' Allan Mertner' ));
Clear; // Clear list
Sorted := false; // Set Sorted property
LoadFromFile( 'Strings.txt' ); // Load strings from file
ShowL( 'Loaded from file, Count', Count );
Destroy; // Free memory
end;
Notify.Destroy; // Destroy notify handler
Key;
end;
{ }
{ Simple demo of the TBits class, which implements a dynamic array of }
{ Booleans, where each value takes up only 1 bit. }
{ }
procedure TestTBits;
Var
tb : TBits;
i : Integer;
begin
Writeln;
Writeln( 'TBits class demonstration:' );
tb := TBits.Create; // Create Bit array
For i := 1 to 1000 do
tb[i] := odd( i ); // True if i is Odd
// Assignment uses Default property
ShowL( 'OpenBit', tb.OpenBit ); // Number of bits set initially
tb[0] := True; // Set bit 0
ShowL( 'OpenBit', tb.OpenBit ); // Display beginning bits again
ShowS( 'GetBit 500', BoolStr[tb[500]] ); // Display values
ShowS( 'GetBit 501', BoolStr[tb[501]] );
ShowL( 'Size', tb.Size ); // Display size of Bit-array
tb.Destroy; // Free memory
Key;
end;
{ }
{ Demonstration of the TFileStream class. }
{ Writes and then reads a TTestComponent class instance from the stream. }
{ }
type
TTestComponent = class(TComponent)
private
fIntField : Longint;
fStrField : String;
fIntField2 : Longint;
fStrField2 : String;
fIntField3 : Longint;
fStrField3 : String;
fFloat : Extended;
protected
function GetLongInt: Longint;
procedure SetLongInt(x: Longint);
function GetString: String;
procedure SetString(x: String);
function GetLongInt3: Longint; virtual;
procedure SetLongInt3(x: Longint); virtual;
function GetString3: String; virtual;
procedure SetString3(x: String); virtual;
published
property IntField1: Longint read fIntField write fIntField; // field access methods
property StrField1: String read fStrField write fStrField;
property FloatField1: Extended read fFloat write fFloat;
property IntField2: Longint read GetLongint write SetLongint; // static access methods
property StrField2: String read GetString write SetString;
property IntField3: Longint read GetLongint3 write SetLongint3; // virtual access methods
property StrField3: String read GetString3 write SetString3;
property roField: String read fStrField; // read-only property
property woField: String write fStrField stored false; // write-only property
end;
function TTestComponent.GetLongInt: Longint;
begin
GetLongint := fIntField2;
end;
procedure TTestComponent.SetLongInt(x: Longint);
begin
fIntField2 := x;
end;
function TTestComponent.GetString: String;
begin
GetString := fStrField2;
end;
procedure TTestComponent.SetString(x: String);
begin
fStrField2 := x;
end;
function TTestComponent.GetLongInt3: Longint;
begin
GetLongint3 := fIntField3;
end;
procedure TTestComponent.SetLongInt3(x: Longint);
begin
fIntField3 := x;
end;
function TTestComponent.GetString3: String;
begin
GetString3 := fStrField3;
end;
procedure TTestComponent.SetString3(x: String);
begin
fStrField3 := x;
end;
procedure TestTFileStream;
var
tf : TFileStream;
tb : TComponent;
i : integer;
st : String;
begin
Writeln;
Writeln( 'TFileStream class demonstration:' );
RegisterClass( TTestComponent ); // Register TTestComponent
Writeln( 'Create stream' );
try
tf := TFileStream.Create( StreamName, fmCreate );
tb := TTestComponent.Create( nil );// Create a component to store on stream
Writeln( ' Write TComponent to stream' );
With tb as TTestComponent do // Fill in some values
begin
Name := 'My_test_component';
IntField1 := 3;
StrField1 := 'This is a String Field';
IntField2 := -100;
StrField2 := 'Another String...';
IntField3 := 12031;
StrField3 := 'Dynamic property access!';
FloatField1 := -100.3;
end; // Write the component to stream
tf.WriteComponent( tb );
With tb as TTestComponent do // Show the values on screen
begin
ShowL( 'IntField1', IntField1 );
ShowS( 'StrField1', StrField1 );
ShowL( 'IntField2', IntField2 );
ShowS( 'StrField2', StrField2 );
ShowL( 'IntField3', IntField3 );
ShowS( 'StrField3', StrField3 );
ShowS( 'FloatField1', Format( '%n', [FloatField1] ) );
ShowS( 'Read Only Field', roField );
end;
Writeln( ' Destroy stream and component' );
tb.Destroy; // Destroy the object
tf.Destroy; // Destroy the stream
except
on E:Exception do Writeln( 'Unexpected exception: ',E.Message );
end;
Writeln;
Writeln( 'Open stream for reading' );
try
tf := TFileStream.Create( StreamName, fmOpenRead );
Writeln( ' Read class instance from stream' );
tb := tf.ReadComponent( nil ); // Read the component from the stream
ShowS( 'ClassName', tb.ClassName );
ShowS( 'Component Name', tb.Name );
If tb is TTestComponent then // Display it again
With tb as TTestComponent do
begin
ShowL( 'IntField1', IntField1 );
ShowS( 'StrField1', StrField1 );
ShowL( 'IntField2', IntField2 );
ShowS( 'StrField2', StrField2 );
ShowL( 'IntField3', IntField3 );
ShowS( 'StrField3', StrField3 );
ShowS( 'FloatField1', Format( '%n', [FloatField1] ) );
ShowS( 'Read Only Field', roField );
end;
Writeln( ' Destroy stream and object' );
tb.Destroy; // Free memory
tf.Destroy;
except
on E:Exception do Writeln( 'Unexpected exception: ',E.Message );
end;
Key;
end;
{ }
{ Demonstration of TCollections. A TCollection can be considered as a }
{ dynamic array of objects of various types with a common ancestor type. }
{ This example creates two new classes, TPerson and TFriend, and stores }
{ a few of them in a collection. }
{ }
type
TPerson = class( TCollectionItem )
private
fFirstName : String;
fLastName : String;
fAddress : String;
fPhone : String;
protected
function GetName: String;
procedure SetName(s: String); virtual;
public
constructor Create(Collection: TCollection; _Name : String ); virtual;
property Name: String read GetName write SetName;
property Address: String read fAddress write fAddress;
property Phone: String read fPhone write fPhone;
end;
TFriend = class( TPerson )
private
fAge : Integer;
public
constructor Create(Collection: TCollection; _Name: String; _Age: Integer ); virtual;
property Age: Integer read fAge write fAge;
end;
constructor TPerson.Create; // Simple constructor method
begin
Inherited Create(Collection);
Name := _Name;
Address := '';
Phone := '';
end;
procedure TPerson.SetName(s: String);
var
x : Integer;
begin
x := Pos( ' ', s );
if x <> 0 then
begin
fFirstName := Copy( s, 1, x-1 );
Delete( s, 1, x );
end;
fLastName := s;
end;
function TPerson.GetName: String;
begin
If fFirstName = '' then
GetName := fLastName
else
GetName := fFirstName + ' ' + fLastName;
end;
constructor TFriend.Create; // Even simpler constructor
begin
inherited create(Collection, _Name);
Age := _Age;
end;
procedure TestTCollection;
var
tc : TCollection;
tp : TPerson;
i : integer;
begin
Writeln;
Writeln( 'TCollection class demonstration:' );
tc := TCollection.Create( TPerson ); // Create a collection of TPersons
try
with tc do
begin
Add; // Add an empty TPerson item
tp := TPerson.Create( tc, 'John Doe' ); // Create a TPerson in the collection
ShowL( 'Index', tp.Index ); // Show index of John Doe
tp := TFriend.Create( tc, 'Allan', 29 ); // Add a TFriend to the collection
ShowL( 'Item Count', Count ); // Show number of items
for i := 0 to Count-1 do // Show all items
begin
{ First display the class name of the item }
ShowS( Format( 'Type of item #%d', [i] ), Items[i].ClassName );
{ Then display the content by using guarded typechecking with "is" }
If Items[i] is TFriend then // If TFriend...
With Items[i] as TFriend do // Display TFriend Info
ShowS( Format( 'Item #%d', [i] ),
Format( 'Name: "%s"; Age: %2d', [ Name, Age ] ) )
else
If Items[i] is TPerson then // If TPerson...
With Items[i] as TPerson do // Display TPerson Info
ShowS( Format( 'Item #%d', [i] ),
Format( 'Name: "%s"', [ Name ] ) )
else
Writeln( ' Item of unknown type' );
{ Re-display information using exceptions to determine type }
try
With Items[i] as TFriend do // try to display as TFriend
ShowS( Format( 'Item #%d', [i] ),
Format( 'Name: "%s"; Age: %2d', [ Name, Age ] ) );
except
on EInvalidCast do // If invalid typecast...
try // try as TPerson
With Items[i] as TPerson do
ShowS( Format( 'Item #%d', [i] ),
Format( 'Name: "%s"', [ Name ] ) );
except // Display error message
on E:Exception do
Writeln( 'Unexpected exception: ',E.Message );
end;
on E:Exception do // Display error message
writeln( 'Unexpected exception: ',E.message);
end;
end; { for i }
end; { with tc }
finally
tc.Destroy; // Free memory used by collection and items
end;
key;
end;
{ }
{ Very simple demo of the TParser class. The TParser is used to convert }
{ data from binary to textual form and vice versa. As a demo, the }
{ stream output in TestTFileStream is read and displayed as text. }
{ }
procedure TestTParser;
var
tf1 : TFileStream;
tf2 : TFileStream;
begin
Writeln;
Writeln( 'TParser class demonstration:' );
try
tf1 := TFileStream.Create( StreamName, fmOpenRead ); // The input data
tf2 := TFileStream.Create( 'con', fmOpenWrite ); // Output to 'con' = screen
try
ObjectBinaryToText( tf1, tf2 ); // Convert to text and display
finally
tf1.Destroy; // Destroy the streams
tf2.Destroy;
end;
except
on E:Exception do Writeln( 'Unexpected exception: ',E.Message );
end;
key;
end;
begin
WriteLn('Virtual Pascal Classes Demo Version 1.10 Copyright (C) 1996 fPrint UK Ltd');
{$IFDEF OS2}
PopupErrors := False; // Disable pop-up exception messages
{$ENDIF}
try // Catch any exception raised in demo
TestIsAs;
TestTStringList;
TestTBits;
TestTCollection;
TestTFileStream;
TestTParser;
except // If an exception occurs...
on E:Exception do // Exit gracefully
begin
Writeln( 'The Classes Demo terminated due to an exception:' );
Writeln( '"',E.Message,'"' );
end;
end;
end.
