mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-08 07:21:34 +02:00
* Examples: database\sqlite_mushrooms: added Firebird embedded support
git-svn-id: trunk@46033 -
This commit is contained in:
reiniero
parent
7f76272dd0
commit
50ba0b1659
2
.gitattributes
vendored
2
.gitattributes
vendored
@ -4570,6 +4570,8 @@ examples/database/sqlite_mushrooms/images/Small-Conocybe_rugosa.jpg -text svneol
|
||||
examples/database/sqlite_mushrooms/images/Small-Destroying_Angel_02.jpg -text svneol=unset#image/jpeg
|
||||
examples/database/sqlite_mushrooms/images/Small-FalseMorel.JPG -text svneol=unset#image/jpeg
|
||||
examples/database/sqlite_mushrooms/images/Small-Galerina.jpg -text svneol=unset#image/jpeg
|
||||
examples/database/sqlite_mushrooms/imagetest.fbk -text
|
||||
examples/database/sqlite_mushrooms/mushrooms_firebird.sql svneol=native#text/plain
|
||||
examples/database/sqlite_mushrooms/project1.ico -text svneol=unset#image/ico
|
||||
examples/database/sqlite_mushrooms/project1.lpi svneol=native#text/plain
|
||||
examples/database/sqlite_mushrooms/project1.lpr svneol=native#text/pascal
|
||||
|
||||
@ -1,23 +1,38 @@
|
||||
MushRoomsDatabase by Jurassic Pork - January 2014
|
||||
MushRoomsDatabase by Jurassic Pork using SQLite - January 2014
|
||||
Updated for Firebird Embedded - August 2014
|
||||
|
||||
Features:
|
||||
- Use SqlDb and lazreport components.
|
||||
- Sqlite3 database DeadlyMushrooms with 5 mushrooms.
|
||||
- Sqlite3 or Firebird embedded database DeadlyMushrooms with 5 mushrooms.
|
||||
Sqlite3 will be tried first; if no Sqlite library is available, Firebird
|
||||
embedded will be tried.
|
||||
- It demonstrates:
|
||||
- creating a new SQLite3 database with table if the db does not exist
|
||||
- use of TSQLScript to run multiple SQL statements
|
||||
- use of FBAdmin to restore Firebird backup (smaller than the live .fdb file)
|
||||
on first run, useful for keeping your setup file small and compatible with
|
||||
older Firebird versions
|
||||
- The images are stored in blob field without extension at the beginning.
|
||||
With this you can view blob images with database browser editor (ex sqlite2009pro).
|
||||
With this you can view blob images with database browser editor
|
||||
(e.g. sqlite2009pro).
|
||||
- In the database there is also a field with images links (filenames).
|
||||
- You can see the linked images in a Timage.
|
||||
- The linked images are stored in the folder images of the project.
|
||||
- You can change the images in the database :
|
||||
- for Tdbimage double click on the component and choose your image.
|
||||
- for Timage click on the button near the image filename.(you must be in edit mode )
|
||||
- Transaction commit when you click on Tdbnavigator refresh button or on close form.
|
||||
- Small pictures of the mushrooms are in the sqlite3Database. Largest images are in files in the folder images.
|
||||
- You can see the linked images in a Timage.
|
||||
- You can change the images in the database:
|
||||
- for Tdbimage (image in db): double click on the component and choose your
|
||||
image.
|
||||
- for Timage (linked image): click on the button near the image filename
|
||||
(you must be in edit mode).
|
||||
- Transaction commits when you click on Tdbnavigator refresh button or on close
|
||||
form.
|
||||
- Small pictures of the mushrooms are in the sqlite3Database. Largest images are
|
||||
in files in the folder images.
|
||||
- Print button to print all the mushrooms (lazreport).
|
||||
On each page you have:
|
||||
On each page you have:
|
||||
- a title.
|
||||
- the field common_name of the mushroom database.
|
||||
- the field notes of the mushroom database.
|
||||
- the field picture of the mushroom database (picture picture1).
|
||||
- the picture of the field image_link (picture picture2).
|
||||
|
||||
The report name is Mushroom_Report.lrf
|
||||
The report name is Mushroom_Report.lrf
|
||||
|
||||
BIN
examples/database/sqlite_mushrooms/imagetest.fbk
Normal file
BIN
examples/database/sqlite_mushrooms/imagetest.fbk
Normal file
Binary file not shown.
52
examples/database/sqlite_mushrooms/mushrooms_firebird.sql
Normal file
52
examples/database/sqlite_mushrooms/mushrooms_firebird.sql
Normal file
@ -0,0 +1,52 @@
|
||||
|
||||
CREATE GENERATOR GEN_DEADLYMUSHROOMS_ID;
|
||||
|
||||
CREATE TABLE DEADLYMUSHROOMS
|
||||
(
|
||||
ID INTEGER NOT NULL,
|
||||
SCIENTIFIC_NAME VARCHAR(200) NOT NULL,
|
||||
COMMON_NAME VARCHAR(200),
|
||||
"Order" VARCHAR(200),
|
||||
GENUS VARCHAR(200),
|
||||
NOTES BLOB SUB_TYPE 1,
|
||||
PICTURE BLOB SUB_TYPE 0,
|
||||
IMAGE_LINK VARCHAR(1000),
|
||||
CONSTRAINT CPKDM_1 PRIMARY KEY (ID)
|
||||
);
|
||||
|
||||
SET TERM ^ ;
|
||||
CREATE TRIGGER DEADLYMUSHROOMS_BI FOR DEADLYMUSHROOMS ACTIVE
|
||||
BEFORE INSERT POSITION 0
|
||||
AS
|
||||
DECLARE VARIABLE tmp DECIMAL(18,0);
|
||||
BEGIN
|
||||
IF (NEW.ID IS NULL) THEN
|
||||
NEW.ID = GEN_ID(GEN_DEADLYMUSHROOMS_ID, 1);
|
||||
ELSE
|
||||
BEGIN
|
||||
tmp = GEN_ID(GEN_DEADLYMUSHROOMS_ID, 0);
|
||||
if (tmp < new.ID) then
|
||||
tmp = GEN_ID(GEN_DEADLYMUSHROOMS_ID, new.ID-tmp);
|
||||
END
|
||||
END^
|
||||
SET TERM ; ^
|
||||
|
||||
UPDATE RDB$GENERATORS set
|
||||
RDB$DESCRIPTION = 'Generator (sequence) that gives a new unique ID. The trigger for the mushrooms table uses this.'
|
||||
where RDB$GENERATOR_NAME = 'GEN_DEADLYMUSHROOMS_ID';
|
||||
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Unique ID; primary key' where RDB$FIELD_NAME = 'ID' and RDB$RELATION_NAME = 'DEADLYMUSHROOMS';
|
||||
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Scientific name (often Latin) of the mushroom' where RDB$FIELD_NAME = 'SCIENTIFIC_NAME' and RDB$RELATION_NAME = 'DEADLYMUSHROOMS';
|
||||
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Common or garden name for the mushroom' where RDB$FIELD_NAME = 'COMMON_NAME' and RDB$RELATION_NAME = 'DEADLYMUSHROOMS';
|
||||
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Free-form notes about the mushroom' where RDB$FIELD_NAME = 'NOTES' and RDB$RELATION_NAME = 'DEADLYMUSHROOMS';
|
||||
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'BLOB containing picture data' where RDB$FIELD_NAME = 'PICTURE' and RDB$RELATION_NAME = 'DEADLYMUSHROOMS';
|
||||
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Location of image in file system' where RDB$FIELD_NAME = 'IMAGE_LINK' and RDB$RELATION_NAME = 'DEADLYMUSHROOMS';
|
||||
UPDATE RDB$RELATIONS set
|
||||
RDB$DESCRIPTION = 'Table of mushroom names and images'
|
||||
where RDB$RELATION_NAME = 'DEADLYMUSHROOMS';
|
||||
UPDATE RDB$TRIGGERS set
|
||||
RDB$DESCRIPTION = 'Trigger that gives a new unique ID on each insert in the mushroom table if an ID hasn''t been provided in the SQL. Emulates the autonumber/autoincrement functionality of other databases but is more powerful.'
|
||||
where RDB$TRIGGER_NAME = 'DEADLYMUSHROOMS_BI';
|
||||
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
|
||||
ON DEADLYMUSHROOMS TO SYSDBA WITH GRANT OPTION;
|
||||
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
|
||||
ON DEADLYMUSHROOMS TO PUBLIC;
|
||||
@ -48,7 +48,6 @@
|
||||
<Unit0>
|
||||
<Filename Value="project1.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="project1"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="unit1.pas"/>
|
||||
@ -82,12 +81,6 @@
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
<Other>
|
||||
<CompilerMessages>
|
||||
<MsgFileName Value=""/>
|
||||
</CompilerMessages>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
|
||||
@ -206,7 +206,7 @@ object Form1: TForm1
|
||||
end
|
||||
object DBEdit1: TDBEdit
|
||||
Left = 128
|
||||
Height = 23
|
||||
Height = 21
|
||||
Top = 408
|
||||
Width = 166
|
||||
DataField = 'Image_Link'
|
||||
@ -235,32 +235,32 @@ object Form1: TForm1
|
||||
Columns = <
|
||||
item
|
||||
Title.Caption = 'Common Name'
|
||||
Width = 108
|
||||
Width = 86
|
||||
FieldName = 'Common_Name'
|
||||
end
|
||||
item
|
||||
Title.Caption = 'Scientific Name'
|
||||
Width = 110
|
||||
Width = 87
|
||||
FieldName = 'Scientific_Name'
|
||||
end
|
||||
item
|
||||
Title.Caption = 'Order'
|
||||
Width = 49
|
||||
Width = 43
|
||||
FieldName = 'Order'
|
||||
end
|
||||
item
|
||||
Title.Caption = 'Genus'
|
||||
Width = 53
|
||||
Width = 45
|
||||
FieldName = 'Genus'
|
||||
end
|
||||
item
|
||||
Title.Caption = 'ID'
|
||||
Width = 28
|
||||
Width = 26
|
||||
FieldName = 'ID'
|
||||
end
|
||||
item
|
||||
Title.Caption = 'Notes'
|
||||
Width = 49
|
||||
Width = 43
|
||||
FieldName = 'Notes'
|
||||
end>
|
||||
DataSource = Datasource1
|
||||
@ -277,8 +277,8 @@ object Form1: TForm1
|
||||
BevelOuter = bvNone
|
||||
BorderWidth = 2
|
||||
BorderStyle = bsSingle
|
||||
ClientHeight = 326
|
||||
ClientWidth = 320
|
||||
ClientHeight = 324
|
||||
ClientWidth = 318
|
||||
ParentColor = False
|
||||
TabOrder = 6
|
||||
object Image1: TImage
|
||||
@ -303,8 +303,8 @@ object Form1: TForm1
|
||||
BevelOuter = bvNone
|
||||
BorderWidth = 2
|
||||
BorderStyle = bsSingle
|
||||
ClientHeight = 326
|
||||
ClientWidth = 160
|
||||
ClientHeight = 324
|
||||
ClientWidth = 158
|
||||
ParentColor = False
|
||||
TabOrder = 7
|
||||
object DBImage1: TDBImage
|
||||
@ -325,17 +325,17 @@ object Form1: TForm1
|
||||
end
|
||||
object Label1: TLabel
|
||||
Left = 8
|
||||
Height = 15
|
||||
Height = 13
|
||||
Top = 55
|
||||
Width = 25
|
||||
Width = 18
|
||||
Caption = 'Link'
|
||||
ParentColor = False
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 360
|
||||
Height = 15
|
||||
Height = 13
|
||||
Top = 55
|
||||
Width = 26
|
||||
Width = 20
|
||||
Caption = 'Blob'
|
||||
ParentColor = False
|
||||
end
|
||||
@ -350,16 +350,16 @@ object Form1: TForm1
|
||||
end
|
||||
object Label3: TLabel
|
||||
Left = 8
|
||||
Height = 15
|
||||
Height = 13
|
||||
Top = 424
|
||||
Width = 36
|
||||
Width = 30
|
||||
Caption = 'Note :'
|
||||
ParentColor = False
|
||||
end
|
||||
object Datasource1: TDataSource
|
||||
DataSet = SQLQuery1
|
||||
OnDataChange = Datasource1DataChange
|
||||
left = 216
|
||||
left = 232
|
||||
top = 192
|
||||
end
|
||||
object OpenDialog1: TOpenDialog
|
||||
@ -381,7 +381,7 @@ object Form1: TForm1
|
||||
Active = False
|
||||
Action = caCommitRetaining
|
||||
Database = SQLite3Connection1
|
||||
left = 208
|
||||
left = 232
|
||||
top = 120
|
||||
end
|
||||
object SQLite3Connection1: TSQLite3Connection
|
||||
@ -411,4 +411,11 @@ object Form1: TForm1
|
||||
left = 464
|
||||
top = 344
|
||||
end
|
||||
object IBConnection1: TIBConnection
|
||||
Connected = False
|
||||
LoginPrompt = False
|
||||
KeepConnection = False
|
||||
left = 152
|
||||
top = 120
|
||||
end
|
||||
end
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
unit Unit1;
|
||||
// J.P August 2013
|
||||
// J.P. August 2013
|
||||
// Firebird embedded support added 2014
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
@ -7,7 +8,7 @@ interface
|
||||
uses
|
||||
Classes, SysUtils, FileUtil, LR_Class, LR_DBSet, Forms, Controls, Graphics,
|
||||
Dialogs, DbCtrls, Buttons, ExtCtrls, StdCtrls, DBGrids,
|
||||
db, sqldb, sqlite3conn, Grids;
|
||||
db, sqldb, sqlite3conn, ibconnection, fbadmin, Grids;
|
||||
|
||||
type
|
||||
|
||||
@ -26,6 +27,7 @@ type
|
||||
DBText1: TDBText;
|
||||
frDBDataSet1: TfrDBDataSet;
|
||||
frReport1: TfrReport;
|
||||
IBConnection1: TIBConnection;
|
||||
Image1: TImage;
|
||||
Label1: TLabel;
|
||||
Label2: TLabel;
|
||||
@ -49,9 +51,16 @@ type
|
||||
procedure frReport1EnterRect(Memo: TStringList; View: TfrView);
|
||||
private
|
||||
{ private declarations }
|
||||
FUsingFirebird: boolean; //indicates whether we're using Firebird (true) or SQLite3 (false)
|
||||
// Updates linked image field with image named in DBEdit1.Text
|
||||
// Shows image to user
|
||||
procedure UpdateImageLink;
|
||||
// Lets user change image stored in database blob field
|
||||
procedure ChangeImage;
|
||||
// Load image from file into database blob
|
||||
procedure LoadDbImage(aFileName: string);
|
||||
// Recreates mushroom database
|
||||
// for either SQLite3 (empty) or Firebird (filled)
|
||||
function RecreateDB: boolean;
|
||||
public
|
||||
{ public declarations }
|
||||
@ -64,6 +73,11 @@ implementation
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
const
|
||||
FirebirdDB='ImageTest.fdb'; //database file for Firebird
|
||||
SQLiteDB='ImageTest.db3'; //database file for SQLite3
|
||||
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
procedure TForm1.Button1Click(Sender: TObject);
|
||||
@ -106,8 +120,8 @@ procedure TForm1.DBNavigator1BeforeAction(Sender: TObject;
|
||||
begin
|
||||
if Button = nbRefresh then
|
||||
begin
|
||||
SQLQuery1.ApplyUpdates;
|
||||
SQLTransaction1.CommitRetaining;
|
||||
SQLQuery1.ApplyUpdates;
|
||||
SQLTransaction1.CommitRetaining;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -120,36 +134,113 @@ end;
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
SQLQuery1.Close;
|
||||
SQLite3Connection1.DatabaseName:= ExtractFilePath(ParamStr(0)) + 'ImageTest.db3';
|
||||
try
|
||||
SQLQuery1.Active := true;
|
||||
except
|
||||
on E:Exception do begin
|
||||
//WriteLn(E.ClassName,': '+E.Message);
|
||||
if RecreateDb then begin
|
||||
SQLQuery1.Active := true;
|
||||
ShowMessage('The database has been recreated');
|
||||
|
||||
// First try SQLite3 database in application directory
|
||||
// If no sqlite3 driver is found, try Firebird
|
||||
FUsingFirebird := false; //try sqlite first
|
||||
if not(FUsingFirebird) then
|
||||
begin
|
||||
SQLite3Connection1.DatabaseName:=ExtractFilePath(ParamStr(0)) + SQLiteDB;
|
||||
try
|
||||
SQLQuery1.Active := true;
|
||||
except
|
||||
on E:Exception do
|
||||
begin
|
||||
//ShowMessage('Exception: '+E.ClassName+': '+E.Message);
|
||||
if E.ClassNameIs('EInOutError') then
|
||||
// Assume 'Can not load SQLite client library "sqlite3.dll". Check your installation.' => but this text may change
|
||||
begin
|
||||
FUsingFirebird:=true;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if RecreateDb then
|
||||
begin
|
||||
SQLQuery1.Active := true;
|
||||
ShowMessage('The SQLite3 database has been recreated');
|
||||
end
|
||||
else
|
||||
begin
|
||||
ShowMessage('Failure to create SQLite3 databse. Aborting');
|
||||
Application.Terminate;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Caption := Caption + ' (SQLite3)';
|
||||
end;
|
||||
|
||||
if FUsingFirebird then
|
||||
begin
|
||||
// Try Firebird. We'll need to reconnect some components as they were
|
||||
// set up for sqlite
|
||||
// Hostname was already empty in Object Inspector so we use embedded
|
||||
//IBConnection1.HostName:='';
|
||||
IBConnection1.UserName:='SYSDBA'; //for embedded, this should be an existing name
|
||||
IBConnection1.CharSet:='UTF8';
|
||||
IBConnection1.Params.Add('PAGE_SIZE=16384'); //enough space for indexes etc
|
||||
IBConnection1.DatabaseName:=ExtractFilePath(ParamStr(0)) + FirebirdDB;
|
||||
IBConnection1.Transaction:=SQLTransaction1;
|
||||
SQLTransaction1.Database:=IBConnection1;
|
||||
SQLQuery1.DataBase:=IBConnection1;
|
||||
try
|
||||
SQLQuery1.Active:=true;
|
||||
except
|
||||
on I: EIBDatabaseError do
|
||||
begin
|
||||
// Check for database file not found error message
|
||||
if (I.GDSErrorcode=335544344) and (pos('I/O error',i.message)>0) then
|
||||
begin
|
||||
if RecreateDb then
|
||||
begin
|
||||
SQLQuery1.Active := true;
|
||||
ShowMessage('The Firebird database has been recreated');
|
||||
end
|
||||
else
|
||||
begin
|
||||
ShowMessage('Failure to create Firebird databse. Aborting');
|
||||
Application.Terminate;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
ShowMessage('Have tried SQLite3 and Firebird dbs without success. '+LineEnding+
|
||||
'Exception: '+I.ClassName+': '+I.Message+LineEnding+
|
||||
'(Firebird GDS Eror code: '+inttostr(I.GDSErrorCode)+')'+LineEnding+
|
||||
'Aborting.');
|
||||
Application.Terminate;
|
||||
end;
|
||||
end;
|
||||
on E: Exception do
|
||||
begin
|
||||
ShowMessage('Have tried SQLite3 and Firebird dbs without success. '+LineEnding+
|
||||
'Exception: '+E.ClassName+': '+E.Message+LineEnding+
|
||||
'Aborting.');
|
||||
Application.Terminate;
|
||||
end;
|
||||
end;
|
||||
Caption := Caption + ' (Firebird embedded)';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.frReport1EnterRect(Memo: TStringList; View: TfrView);
|
||||
begin
|
||||
if (View.Name = 'Picture2') AND
|
||||
if (View.Name = 'Picture2') AND
|
||||
(frDBDataSet1.DataSet.FieldByName('Image_Link').AsString <> '') then
|
||||
TFrPictureView(View).Picture.LoadFromFile(ExtractFilePath(ParamStr(0)) +
|
||||
'images' + DirectorySeparator + frDBDataSet1.DataSet.FieldByName('Image_Link').AsString);
|
||||
TFrPictureView(View).Picture.LoadFromFile(ExtractFilePath(ParamStr(0)) +
|
||||
'images' + DirectorySeparator + frDBDataSet1.DataSet.FieldByName('Image_Link').AsString);
|
||||
end;
|
||||
|
||||
procedure TForm1.UpdateImageLink;
|
||||
var
|
||||
s: String;
|
||||
begin
|
||||
if DBEdit1.Text <> '' then begin
|
||||
s := ExtractFilePath(ParamStr(0)) + 'images' + DirectorySeparator + DBEdit1.Text;
|
||||
if DBEdit1.Text <> '' then
|
||||
begin
|
||||
s := ExtractFilePath(ParamStr(0)) + 'images' + DirectorySeparator + DBEdit1.Text;
|
||||
Image1.Picture.LoadFromFile(s);
|
||||
end else
|
||||
end
|
||||
else
|
||||
Image1.Picture.Clear;
|
||||
end;
|
||||
|
||||
@ -157,15 +248,18 @@ procedure TForm1.ChangeImage;
|
||||
var
|
||||
WasEditing: Boolean;
|
||||
begin
|
||||
if SQLQuery1.Active then begin
|
||||
if SQLQuery1.Active then
|
||||
begin
|
||||
OpenDialog1.Filter :=
|
||||
'All image files (*.bmp,*.jpg,*.png,*.gif)|*.bmp;*.jpg;*.png;*.gif|' +
|
||||
'BMP files (*.bmp)|*.bmp|' +
|
||||
'JPEG files (*.jpg)|*.jpg|' +
|
||||
'PNG files (*.png)|*.png|' +
|
||||
'GIF files (*.gif)|*.gif';
|
||||
'GIF files (*.gif)|*.gif' +
|
||||
'TIFF files (*.tiff)|*.tiff;*.tif';
|
||||
OpenDialog1.InitialDir := ExtractFilePath(ParamStr(0)) + 'images';
|
||||
if OpenDialog1.Execute then begin
|
||||
if OpenDialog1.Execute then
|
||||
begin
|
||||
WasEditing := (SQLQuery1.State = dsEdit);
|
||||
if not WasEditing then
|
||||
SQLQuery1.Edit;
|
||||
@ -179,27 +273,109 @@ end;
|
||||
|
||||
procedure TForm1.LoadDbImage(aFileName: string);
|
||||
begin
|
||||
// Disabling writeheader means the image is compatible with Delphi TDBImage applications
|
||||
// and other applications that only expect raw jpg data in the database blob.
|
||||
// However, it makes it a bit more difficult to mix various kinds of image types
|
||||
// e.g. jpg and tiff in the same database fields.
|
||||
// Fortunately, Lazarus can deal with that for us.
|
||||
DbImage1.WriteHeader:=false;
|
||||
DbImage1.Picture.LoadFromFile(aFileName);
|
||||
end;
|
||||
|
||||
function TForm1.RecreateDB: boolean;
|
||||
var
|
||||
BackupFile: string;
|
||||
DBFile: string;
|
||||
FBAdmin: TFBAdmin;
|
||||
SQLInstructions: string; //file with sql instructions to create tables etc
|
||||
Scripter: TSQLScript;
|
||||
begin
|
||||
try
|
||||
SQLite3Connection1.ExecuteDirect(
|
||||
'CREATE TABLE DeadlyMushrooms '+LineEnding+
|
||||
'-- This table created by Jurassic Pork '+LineEnding+
|
||||
'-- for Free Pascal Lazarus '+LineEnding+
|
||||
'-- Create date:2013-08-05 23:55:09 '+LineEnding+
|
||||
'( '+LineEnding+
|
||||
' ID INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, '+LineEnding+
|
||||
' Scientific_Name VARCHAR NOT NULL, '+LineEnding+
|
||||
' Common_Name VARCHAR, '+LineEnding+
|
||||
' `Order` VARCHAR, `Genus` VARCHAR, `Notes` TEXT, `Picture` BLOB, `Image_Link` VARCHAR)'
|
||||
);
|
||||
result := true;
|
||||
except
|
||||
result := false;
|
||||
result:=false;
|
||||
if not(FUsingFirebird) then //not using Firebird, so using SQLite3
|
||||
begin
|
||||
try
|
||||
SQLite3Connection1.ExecuteDirect(
|
||||
'CREATE TABLE DeadlyMushrooms '+LineEnding+
|
||||
'-- This table created by Jurassic Pork '+LineEnding+
|
||||
'-- for Free Pascal Lazarus '+LineEnding+
|
||||
'-- Create date:2013-08-05 23:55:09 '+LineEnding+
|
||||
'( '+LineEnding+
|
||||
' ID INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, '+LineEnding+
|
||||
' Scientific_Name VARCHAR NOT NULL, '+LineEnding+
|
||||
' Common_Name VARCHAR, '+LineEnding+
|
||||
' `Order` VARCHAR, `Genus` VARCHAR, `Notes` TEXT, `Picture` BLOB, `Image_Link` VARCHAR)'
|
||||
);
|
||||
result := true;
|
||||
except
|
||||
result := false;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin //Using Firebird
|
||||
try
|
||||
DBFile:=ExtractFilePath(ParamStr(0)) + FirebirdDB;
|
||||
BackupFile:=ChangeFileExt(DBFile,'.fbk');
|
||||
// First try restoring backup file with full content
|
||||
if fileexists(BackupFile) then
|
||||
begin
|
||||
FBAdmin:=TFBAdmin.Create(nil);
|
||||
try
|
||||
try
|
||||
FBAdmin.UseExceptions:=true;
|
||||
FBAdmin.Host:=''; //embedded
|
||||
FBAdmin.Protocol:=IBSPLOCAL;
|
||||
FBAdmin.User:='SYSDBA';
|
||||
FBAdmin.Password:=''; //embedded: doesn't matter which password is used
|
||||
FBAdmin.Connect;
|
||||
// Now run the restore. It will not overwrite an existing file but will
|
||||
// create a new db
|
||||
if FBAdmin.Restore(DBFile,BackupFile,[IBResCreate]) then
|
||||
begin
|
||||
sleep(200); //at least needed on Windows: give the filesystem time to update so we don't get failures connecting
|
||||
exit(true) //we're done; exit the function
|
||||
end
|
||||
else
|
||||
result := false;
|
||||
finally
|
||||
FBAdmin.Free;
|
||||
end;
|
||||
except
|
||||
result := false; //we can continue with the next fallback step
|
||||
end;
|
||||
end;
|
||||
|
||||
// If no backup was found or restore failed,
|
||||
// create an empty .fdb file
|
||||
if (FileExists(DBFile))=false then
|
||||
begin
|
||||
IBConnection1.CreateDB;
|
||||
end;
|
||||
if (FileExists(DBFile)=false) then
|
||||
raise Exception.CreateFmt('Firebird error: failure to create database %s',[DBFile]);
|
||||
// Now create needed tables etc:
|
||||
if not(IBConnection1.Connected) then IBConnection1.Connected := true;
|
||||
Scripter:=TSQLScript.Create(nil);
|
||||
try
|
||||
SQLInstructions := ExtractFilePath(ParamStr(0)) + 'mushrooms_firebird.sql';
|
||||
if not fileexists(SQLInstructions) then
|
||||
raise Exception.CreateFmt('Error creating db: could not load SQL definition file %s',[SQLInstructions]);
|
||||
Scripter.Script.LoadFromFile(SQLInstructions);
|
||||
Scripter.DataBase := IBConnection1;
|
||||
Scripter.Transaction := SQLTransaction1;
|
||||
Scripter.CommentsInSQL := false; //needed to circumvent bugs in TSQLScript
|
||||
Scripter.UseSetTerm := true; //needed because we have SET TERM statements in the SQL file
|
||||
// Now everything is loaded in, run all commands at once:
|
||||
Scripter.Execute;
|
||||
//... and then commit to make them stick and show them to the SQL that comes
|
||||
// after the commit
|
||||
SQLTransaction1.Commit;
|
||||
result := true;
|
||||
finally
|
||||
Scripter.Free;
|
||||
end;
|
||||
except
|
||||
result := false;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user