arrays/2Darray/Unit1.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DbCtrls, db,
  IBArrayGrid, IBDatabase, IBQuery, IBCustomDataSet, IB;

{$DEFINE LOCALDATABASE}

const
  sDatabaseName = '2Dtest.fdb'; {If LOCALDATABASE defined then prepended with
                               path to temp folder}

  {If you want to explicitly define the test database location then undefine
  LOCALDATABASE and set explicit path e.g.

  sDatabaseName = 'myserver:/databases/test.fdb';
  }

type

  { TForm1 }

  TForm1 = class(TForm)
    DataSource1: TDataSource;
    DBEdit1: TDBEdit;
    DBNavigator1: TDBNavigator;
    IBArrayGrid1: TIBArrayGrid;
    IBDatabase1: TIBDatabase;
    IBDataSet1: TIBDataSet;
    IBTransaction1: TIBTransaction;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1AfterConnect(Sender: TObject);
    procedure IBDatabase1CreateDatabase(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormShow(Sender: TObject);
begin
  repeat
    try
      IBDatabase1.Connected := true;
    except
     on E:EIBClientError do
      begin
        Close;
        Exit
      end;
    On E:Exception do
     MessageDlg(E.Message,mtError,[mbOK],0);
    end;
  until IBDatabase1.Connected;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  {$IFDEF LOCALDATABASE}
  IBDatabase1.DatabaseName := GetTempDir + sDatabaseName
  {$else}
  IBDatabase1.DatabaseName := sDatabaseName
  {$ENDIF}
end;

procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
begin
  IBDataSet1.Active := true;
end;

const
  sqlCreateTable =
    'Create Table TestData ('+
    'RowID Integer not null,'+
    'Title VarChar(32) Character Set UTF8,'+
    'MyArray VarChar(16) [0:16, -1:7] Character Set UTF8,'+
    'Primary Key(RowID)'+
    ')';

  sqlCreateGenerator = 'Create Generator ROWNUMBER';
  sqlSetGenerator = 'Set Generator ROWNUMBER to ';

  sqlInsert = 'Insert into TestData(RowID,Title) Values(:RowID,:Title)';

  sqlUpdate = 'Update TestData Set MyArray = ? Where RowID = ?';

procedure TForm1.IBDatabase1CreateDatabase(Sender: TObject);
var Transaction: ITransaction;
    Statement: IStatement;
    ResultSet: IResultSet;
    row, i,j,k : integer;
    ar: IArray;
    c: char;
begin
  with IBDatabase1.Attachment do
  begin
    ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable); {Create the table}
    ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateGenerator); {Create the table}
    {Now Populate it}
    Transaction := StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
    Statement := Prepare(Transaction,'Select * from TestData');
    for row := 1 to 3 do
    begin
      Statement := PrepareWithNamedParameters(Transaction,sqlInsert);
      with Statement.GetSQLParams do
      begin
        ByName('rowid').AsInteger := row;
        ByName('title').AsString := 'Row ' + IntToStr(row);
      end;
      Statement.Execute;

      Statement := Prepare(Transaction,sqlUpdate);
      if row > 2 then continue;
      ar := CreateArray(Transaction,'TestData','MyArray');
      if ar <> nil then
      begin
        k := 0;
        c := chr(ord('A') + row - 1);
        for i := 0 to 16 do
          for j := -1 to 7 do
          begin
            ar.SetAsString([i,j],c + IntToStr(k));
            Inc(k);
          end;
        Statement.SQLParams[0].AsArray := ar;
        Statement.SQLParams[1].AsInteger := row;
        Statement.Execute;
      end;
    end;
    ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlSetGenerator + '4'); {update the generator}
  end;
end;

end.

Revision:	45
Committed:	Tue Dec 6 10:33:46 2016 UTC (7 years, 11 months ago) by tony
Content type:	text/x-pascal
File size:	4658 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	User	Rev	Content
1	tony	45	(*
2			* IBX For Lazarus (Firebird Express)
3			*
4			* The contents of this file are subject to the Initial Developer's
5			* Public License Version 1.0 (the "License"); you may not use this
6			* file except in compliance with the License. You may obtain a copy
7			* of the License here:
8			*
9			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10			*
11			* Software distributed under the License is distributed on an "AS
12			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13			* implied. See the License for the specific language governing rights
14			* and limitations under the License.
15			*
16			* The Initial Developer of the Original Code is Tony Whyman.
17			*
18			* The Original Code is (C) 2015 Tony Whyman, MWA Software
19			* (http://www.mwasoftware.co.uk).
20			*
21			* All Rights Reserved.
22			*
23			* Contributor(s): ______________________________________.
24			*
25			*)
26
27			unit Unit1;
28
29			{$mode objfpc}{$H+}
30
31			interface
32
33			uses
34			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DbCtrls, db,
35			IBArrayGrid, IBDatabase, IBQuery, IBCustomDataSet, IB;
36
37			{$DEFINE LOCALDATABASE}
38
39			const
40			sDatabaseName = '2Dtest.fdb'; {If LOCALDATABASE defined then prepended with
41			path to temp folder}
42
43			{If you want to explicitly define the test database location then undefine
44			LOCALDATABASE and set explicit path e.g.
45
46			sDatabaseName = 'myserver:/databases/test.fdb';
47			}
48
49			type
50
51			{ TForm1 }
52
53			TForm1 = class(TForm)
54			DataSource1: TDataSource;
55			DBEdit1: TDBEdit;
56			DBNavigator1: TDBNavigator;
57			IBArrayGrid1: TIBArrayGrid;
58			IBDatabase1: TIBDatabase;
59			IBDataSet1: TIBDataSet;
60			IBTransaction1: TIBTransaction;
61			procedure FormCreate(Sender: TObject);
62			procedure FormShow(Sender: TObject);
63			procedure IBDatabase1AfterConnect(Sender: TObject);
64			procedure IBDatabase1CreateDatabase(Sender: TObject);
65			private
66			{ private declarations }
67			public
68			{ public declarations }
69			end;
70
71			var
72			Form1: TForm1;
73
74			implementation
75
76			{$R *.lfm}
77
78			{ TForm1 }
79
80			procedure TForm1.FormShow(Sender: TObject);
81			begin
82			repeat
83			try
84			IBDatabase1.Connected := true;
85			except
86			on E:EIBClientError do
87			begin
88			Close;
89			Exit
90			end;
91			On E:Exception do
92			MessageDlg(E.Message,mtError,[mbOK],0);
93			end;
94			until IBDatabase1.Connected;
95			end;
96
97			procedure TForm1.FormCreate(Sender: TObject);
98			begin
99			{$IFDEF LOCALDATABASE}
100			IBDatabase1.DatabaseName := GetTempDir + sDatabaseName
101			{$else}
102			IBDatabase1.DatabaseName := sDatabaseName
103			{$ENDIF}
104			end;
105
106			procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
107			begin
108			IBDataSet1.Active := true;
109			end;
110
111			const
112			sqlCreateTable =
113			'Create Table TestData ('+
114			'RowID Integer not null,'+
115			'Title VarChar(32) Character Set UTF8,'+
116			'MyArray VarChar(16) [0:16, -1:7] Character Set UTF8,'+
117			'Primary Key(RowID)'+
118			')';
119
120			sqlCreateGenerator = 'Create Generator ROWNUMBER';
121			sqlSetGenerator = 'Set Generator ROWNUMBER to ';
122
123			sqlInsert = 'Insert into TestData(RowID,Title) Values(:RowID,:Title)';
124
125			sqlUpdate = 'Update TestData Set MyArray = ? Where RowID = ?';
126
127			procedure TForm1.IBDatabase1CreateDatabase(Sender: TObject);
128			var Transaction: ITransaction;
129			Statement: IStatement;
130			ResultSet: IResultSet;
131			row, i,j,k : integer;
132			ar: IArray;
133			c: char;
134			begin
135			with IBDatabase1.Attachment do
136			begin
137			ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable); {Create the table}
138			ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateGenerator); {Create the table}
139			{Now Populate it}
140			Transaction := StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
141			Statement := Prepare(Transaction,'Select * from TestData');
142			for row := 1 to 3 do
143			begin
144			Statement := PrepareWithNamedParameters(Transaction,sqlInsert);
145			with Statement.GetSQLParams do
146			begin
147			ByName('rowid').AsInteger := row;
148			ByName('title').AsString := 'Row ' + IntToStr(row);
149			end;
150			Statement.Execute;
151
152			Statement := Prepare(Transaction,sqlUpdate);
153			if row > 2 then continue;
154			ar := CreateArray(Transaction,'TestData','MyArray');
155			if ar <> nil then
156			begin
157			k := 0;
158			c := chr(ord('A') + row - 1);
159			for i := 0 to 16 do
160			for j := -1 to 7 do
161			begin
162			ar.SetAsString([i,j],c + IntToStr(k));
163			Inc(k);
164			end;
165			Statement.SQLParams[0].AsArray := ar;
166			Statement.SQLParams[1].AsInteger := row;
167			Statement.Execute;
168			end;
169			end;
170			ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlSetGenerator + '4'); {update the generator}
171			end;
172			end;
173
174			end.
175