home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 May / CMCD0505.ISO / Software / Shareware / Programare / pgedri / Source / Demos / FishFact / D2005 / FFACTWIN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2005-04-01  |  9.1 KB  |  319 lines
  1. unit Ffactwin;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, Windows, Messages, Classes, Graphics, Controls,
  7.   Forms, StdCtrls, DBCtrls, DBGrids, DB, DBTables, Buttons, Grids, ExtCtrls,
  8.   ComCtrls, FMTBcd, DBXpress, SqlExpr, Provider, DBClient;
  9.  
  10. const
  11.   strTableName = 'biolife';
  12.  
  13. type
  14.   TForm1 = class(TForm)
  15.     Label1: TLabel;
  16.     DataSource1: TDataSource;
  17.     Table1: TTable;
  18.     Table1Common_Name: TStringField;
  19.     Table1Graphic: TBlobField;
  20.     DBGrid1: TDBGrid;
  21.     BitBtn1: TBitBtn;
  22.     Table1Category: TStringField;
  23.     Table1SpeciesName: TStringField;
  24.     Table1Lengthcm: TFloatField;
  25.     Table1Length_In: TFloatField;
  26.     Table1Notes: TMemoField;
  27.     StatusBar1: TStatusBar;
  28.     SQLConnection1: TSQLConnection;
  29.     Panel5: TPanel;
  30.     SQLDataSet1: TSQLDataSet;
  31.     ClientDataSet1: TClientDataSet;
  32.     DataSetProvider1: TDataSetProvider;
  33.     btnConvert: TBitBtn;
  34.     btnDrop: TBitBtn;
  35.     RadioGroup1: TRadioGroup;
  36.     DBNavigator1: TDBNavigator;
  37.     Panel1: TPanel;
  38.     Panel6: TPanel;
  39.     DBLabel1: TDBText;
  40.     DBImage1: TDBImage;
  41.     Panel3: TPanel;
  42.     DBMemo1: TDBMemo;
  43.     btnApplyChanges: TBitBtn;
  44.     btnCancel: TBitBtn;
  45.     procedure Table1AfterOpen(DataSet: TDataSet);
  46.     procedure btnConvertClick(Sender: TObject);
  47.     procedure btnDropClick(Sender: TObject);
  48.     procedure RadioGroup1Click(Sender: TObject);
  49.     procedure btnApplyChangesClick(Sender: TObject);
  50.     procedure btnCancelClick(Sender: TObject);
  51.   private
  52.     { Private declarations }
  53.   public
  54.     procedure DropBiolife;
  55.     { Public declarations }
  56.   end;
  57.  
  58. var
  59.   Form1: TForm1;
  60.  
  61. implementation
  62. uses
  63.   Types, StrUtils;
  64.  
  65. {$R *.dfm}
  66.  
  67. const
  68.   strPGVersion = 'PGVersion';
  69.  
  70.   {$IF RtlVersion < 16}
  71.     // On Delphi 8, the SQL_SUCCESS constant got renamed to 'DBXERR_NONE
  72.     DBXERR_NONE = SQL_SUCCESS;
  73.   {$IFEND}
  74.  
  75. // The following functions are from the PGEDriverUtils unit:
  76. //
  77. procedure Check(Value: Word; Connection: TSQLConnection);
  78. var
  79.   S: AnsiString;
  80.   Len: SmallInt;
  81. begin
  82.   if Value <> SQL_SUCCESS then
  83.   begin
  84.     Len := Connection.SQLConnection.getErrorMessageLen(Len);
  85.     SetLength(S, Len);
  86.     Connection.SQLConnection.getErrorMessage(PChar(S));
  87.     DatabaseError(S);
  88.   end;
  89. end;
  90.  
  91. // Retrieves the PosthgreSQL version number. D7+ Only.
  92. function GetVersion(Connection: TSQLconnection): Extended;
  93. const
  94.   BufSize: Byte = 50;
  95. var
  96.   Len: SmallInt;
  97.   Buffer: TByteDynArray;
  98. begin
  99.   SetLength(Buffer, BufSize);
  100.   try
  101.     StrCopy(@Buffer[0], strPGVersion);
  102.     Check(Connection.SQLConnection.GetOption(eConnCustomInfo, @Buffer[0], Length(Buffer), Len), Connection);
  103.     Result := PExtended(Buffer)^;
  104.   except
  105.     Result := -1;
  106.   end;
  107. end;
  108.  
  109. function GetTableName(S: AnsiString): AnsiString;
  110. var
  111.   P: PChar;
  112. begin
  113.   P := StrRScan(PChar(S), '.');
  114.   if P <> nil then
  115.     Result := StrPas(P+1)
  116.   else
  117.     Result := S;  
  118. end;
  119.  
  120. procedure TForm1.Table1AfterOpen(DataSet: TDataSet);
  121. begin
  122.   StatusBar1.Panels[0].Text := 'Using DBDEMOS Dataset';
  123.   Application.ProcessMessages;
  124. end;
  125.  
  126. procedure TForm1.DropBiolife;
  127. begin
  128.   StatusBar1.Panels[0].Text := 'Table '+ strTableName + ' is being dropped...';
  129.   Application.ProcessMessages;
  130.   SQLConnection1.ExecuteDirect('drop table '+ strTableName);
  131.   StatusBar1.Panels[0].Text := 'Table dropped successfully.';
  132.   SQLDataset1.Close;
  133.   ClientDataset1.Close;
  134. end;
  135.  
  136. procedure TForm1.btnConvertClick(Sender: TObject);
  137. var
  138.   List: TStringList;
  139.   TempDataset: TSQLDataset;
  140.   Version: Extended;
  141.   I, J: Integer;
  142. begin
  143.   StatusBar1.Panels[0].Text := 'Converting from DBDEMOS to PostgreSQL...';
  144.   Application.ProcessMessages;
  145.   List := TStringlist.Create;
  146.   TempDataset := TSQLDataset.Create(Self);
  147.   TempDataset.SQLConnection := SQLConnection1;
  148.  
  149.   SQLConnection1.Open;
  150.   Version := GetVersion(SQLConnection1);
  151.   if Version < 7.2 then
  152.     DatabaseError('This demo needs PostgreSQL 7.2 or above.');
  153.   try
  154.     // Checking if table already exists. If it does, drop it.
  155.     StatusBar1.Panels[0].Text := 'Converting from DBDEMOS to PostgreSQL...';
  156.     Application.ProcessMessages;
  157.     Sleep(500);
  158.  
  159.     // Checking if "lo" type already exists...
  160.     with TempDataset do
  161.     begin
  162.       StatusBar1.Panels[0].Text := 'Checking for ''lo'' type...';
  163.       Application.ProcessMessages;
  164.       CommandText := 'select typname from pg_type where typname=''lo''';
  165.       Open;
  166.       // If type does not exist, create it
  167.       if TempDataset.Eof then
  168.       begin
  169.         StatusBar1.Panels[0].Text := 'The ''lo'' type does not exist; creating it...';
  170.         Application.ProcessMessages;
  171.         // This is for PostgreSQL 7.3
  172.         if Version >= 7.3 then
  173.           SQLConnection1.ExecuteDirect(
  174.             'CREATE FUNCTION lo_in(cstring) '
  175.             + 'RETURNS lo'
  176.             + '   AS ''int4in'' '
  177.             + '   LANGUAGE ''internal'' WITH (ISCACHABLE, ISSTRICT); '
  178.             + 'CREATE FUNCTION lo_out(lo) '
  179.             + '   RETURNS cstring '
  180.             + '   AS ''int4out'' '
  181.             + '   LANGUAGE ''internal'' WITH (ISCACHABLE, ISSTRICT); '
  182.             + 'CREATE TYPE lo ( '
  183.             + '   internallength = 4, '
  184.             + '   externallength=10, '
  185.             + '   input = lo_in, '
  186.             + '   output = lo_out, '
  187.             + '   alignment = int4, '
  188.             + '   default = '', '
  189.             + '   passedbyvalue '
  190.             + '); '
  191.             + 'CREATE CAST (lo AS oid) WITHOUT FUNCTION;')
  192.         else
  193.         SQLConnection1.ExecuteDirect('create type lo(internallength=4, externallength=10, input=oidin, output=oidout,'
  194.           + 'default='''', passedbyvalue);')
  195.       end;
  196.     end;
  197.  
  198.     StatusBar1.Panels[0].Text := 'Checking for ' + strTableName + ' table...';
  199.     Application.ProcessMessages;
  200.     SQLConnection1.GetTableNames(List);
  201.     for I := 0 to List.Count - 1 do
  202.     begin
  203.       if GetTableName(List[I]) = strTableName then
  204.       begin
  205.         DropBioLife;
  206.         Break;
  207.       end;
  208.     end;
  209.     List.Clear;
  210.     StatusBar1.Panels[0].Text := 'Table exists.';
  211.     Sleep(500);
  212.  
  213.     // Creating table
  214.     StatusBar1.Panels[0].Text := 'Creating table' + strTableName + '...';
  215.     Application.ProcessMessages;
  216.     SQLConnection1.ExecuteDirect('create table biolife("Category" varchar(15), "Species Name" varchar(40), '
  217.      + '"Length (cm)" float, "Length_In" float, "Common_Name" varchar(30), "Notes" text, "Graphic" lo)');
  218.  
  219.     // Creating trigger and function that will void orphan Large Objects.
  220.     // Please check the pgExpress documentation.
  221.     StatusBar1.Panels[0].Text := 'Creating trigger & function for avoiding orphan blobs...';
  222.     Application.ProcessMessages;
  223.  
  224.  
  225.     SQLConnection1.ExecuteDirect('create or replace function ' + strTableName + '_lo_clean() returns '
  226.       + IfThen(Version >= 7.3, 'trigger', 'opaque') +' as '''
  227.       + '  declare '
  228.       + '    lo_oid oid; '
  229.       + '  begin '
  230.       + '    -- If it is an update action but the BLOB (lo) field was not changed, dont do anything '#13
  231.       + '    if (TG_OP = ''''UPDATE'''') then '
  232.       + '      if (old."Graphic" = new."Graphic") or (old."Graphic" is null) then '
  233.       + '        return new; '
  234.       + '      end if; '
  235.       + '    end if; '
  236.       + '    select into lo_oid loid from pg_largeobject where lo_oid = oid(old."Graphic"); '
  237.       + '    if found then '
  238.       + '      perform lo_unlink(lo_oid); '
  239.       + '    end if; '
  240.       + '    return new; '
  241.       + '  end'' '
  242.       + 'language plpgsql');
  243.  
  244.     SQLConnection1.ExecuteDirect('create trigger ' + strTableName + '_lo_cleanup '
  245.       + 'after delete or update on '+ strTableName + ' '
  246.       + 'for each row execute procedure ' + strTableName + '_lo_clean();');
  247.  
  248.     StatusBar1.Panels[0].Text := 'Populating table' + strTableName + '...';
  249.     Application.ProcessMessages;
  250.     try
  251.       Table1.DisableControls;
  252.       Table1.Open;
  253.       Table1.First;
  254.       ClientDataset1.Open;
  255.       while not Table1.Eof do
  256.       begin
  257.         ClientDataset1.Insert;
  258.         for J := 0 to Table1.Fields.Count - 1 do
  259.         begin
  260.           ClientDataset1.Fields[J].Value := Table1.Fields[J].Value;
  261.         end;
  262.         Table1.Next;
  263.         ClientDataset1.Next;
  264.       end;
  265.       // Applying updates to the database...
  266.       ClientDataset1.ApplyUpdates(-1);
  267.     finally
  268.       Table1.EnableControls;
  269.     end;
  270.     StatusBar1.Panels[0].Text := 'Conversion done.';
  271.     Application.ProcessMessages;
  272.   finally
  273.     List.Free;
  274.     TempDataset.Free;
  275.   end;
  276.   Sleep(2000);
  277. end;
  278.  
  279. procedure TForm1.btnDropClick(Sender: TObject);
  280. begin
  281.   DropBiolife;
  282. end;
  283.  
  284. procedure TForm1.RadioGroup1Click(Sender: TObject);
  285. begin
  286.   case RadioGroup1.ItemIndex of
  287.     0:
  288.     begin
  289.       Table1.Open;
  290.       DataSource1.DataSet := Table1;
  291.     end;
  292.     1:
  293.     begin
  294.       try
  295.         ClientDataset1.Open;
  296.         DataSource1.DataSet := ClientDataset1;
  297.       except
  298.         on E: Exception do
  299.         begin
  300.           RadioGroup1.ItemIndex := 0;
  301.           raise;
  302.         end;
  303.       end;
  304.     end;
  305.   end;
  306. end;
  307.  
  308. procedure TForm1.btnApplyChangesClick(Sender: TObject);
  309. begin
  310.   Clientdataset1.ApplyUpdates(-1);
  311. end;
  312.  
  313. procedure TForm1.btnCancelClick(Sender: TObject);
  314. begin
  315.    ClientDataset1.CancelUpdates;
  316. end;
  317.  
  318. end.
  319.