{ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ}
{Û                                                       Û}
{Û      Virtual Pascal Examples. Version 2.1.            Û}
{Û      Classes demonstration example                    Û}
{Û      ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÛ}
{Û      Copyright (C) 1996-2000 vpascal.com              Û}
{Û                                                       Û}
{ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß}

program ClsDemo;

{&X+,H+,Delphi+,Use32-}

{ 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 or later.                                                }

Uses
  SysUtils, Classes;

{ 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 );
      // ...
      Free;
    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;
  p      : String;
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
      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
      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 );
      Free;                            // Free memory
    end;
  Notify.Free;                         // Free 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.Free;                             // 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( '  Free stream and component' );
    tb.Free;                           // Free the object
    tf.Free;                           // Free 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( '  Free stream and object' );
    tb.Free;                          // Free memory
    tf.Free;
  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.Free;                                   // 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
{$IFDEF LINUX}
    tf2 := TFileStream.Create( '/dev/tty', fmOpenWrite );  // Output to 'tty' = screen
{$ELSE}
    tf2 := TFileStream.Create( 'con', fmOpenWrite );       // Output to 'con' = screen
{$ENDIF}
    try
      ObjectBinaryToText( tf1, tf2 );                      // Convert to text and display
    finally
      tf1.Free;                                            // Free the streams
      tf2.Free;
    end;
  except
    on E:Exception do Writeln( 'Unexpected exception: ',E.Message );
  end;
  key;
end;

begin
  {$IFDEF LINUX}
  FileSystem := fsDos;
  {$ENDIF}

  WriteLn('Virtual Pascal Classes Demo  Version 2.1 Copyright (C) 1996-2000 vpascal.com');
  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.


