* * *

Recent Posts

Pages: [1] 2 3 ... 10
1
Databases / Re: Tool ZeosDB for Firebird and MySQL
« Last post by jaky2551 on Today at 08:01:20 am »
Change function TDataUtil.FieldIsType to bellow .-

Code: Pascal  [Select]
  1. function TDataUtil.FieldIsType(aTB, aFD: string): TFieldType;
  2. var
  3.   s: string;
  4. begin
  5.   Result := ftUnknown;
  6.  
  7.   if IsFirebird then
  8.     FQuery.SQL.Text := 'SELECT r.RDB$RELATION_NAME, r.RDB$FIELD_NAME, ' +
  9.                        'r.RDB$FIELD_SOURCE, ' +
  10.                        'f.RDB$FIELD_TYPE AS FDType_INT, ' +
  11.                        'f.RDB$FIELD_SUB_TYPE AS FDSubType ' +
  12.                        'FROM RDB$RELATION_FIELDS r ' +
  13.                        'LEFT JOIN RDB$FIELDS f ' +
  14.                        'ON r.RDB$FIELD_SOURCE=f.RDB$FIELD_NAME ' +
  15.                        'WHERE r.RDB$RELATION_NAME=' + QuotedStr(aTB) +
  16.                        ' AND r.RDB$FIELD_NAME=' + QuotedStr(aFD)
  17.   else
  18.     FQuery.SQL.Text := 'SELECT TABLE_SCHEMA, TABLE_NAME, COLUMN_NAME, DATA_TYPE ' +
  19.                        'FROM information_schema.COLUMNS WHERE TABLE_NAME=' +
  20.                        QuotedStr(aTB) + ' AND TABLE_SCHEMA=' +
  21.                        QuotedStr(Database) + ' AND COLUMN_NAME=' +
  22.                        QuotedStr(aFD);
  23.   FQuery.Open;
  24.   if FQuery.RecordCount <> 0 then
  25.   begin
  26.     if IsFirebird then
  27.     begin
  28.       case FQuery.FieldByName('FDType_INT').AsInteger of
  29.         7           : s := 'SMALLINT';
  30.         8           : s := 'INTEGER';
  31.         9           : s := 'QUAD';
  32.         10          : s := 'FLOAT';
  33.         11          : s := 'FLOAT';        // D_FLOAT
  34.         12          : s := 'DATE';
  35.         13          : s := 'TIME';
  36.         14          : s := 'CHAR';
  37.         16          : s := 'BIGINT';
  38.         27          : s := 'DOUBLE';
  39.         35          : s := 'TIMESTAMP';
  40.         37          : s := 'VARCHAR';
  41.         40          : s := 'CSTRING';
  42.         261         : s := 'BLOB';
  43.       else
  44.         s := 'UNKNOWN';
  45.       end;
  46.       if FQuery.FieldByName('FDType_INT').AsInteger in [7, 8, 16] then
  47.       begin
  48.         case FQuery.FieldByName('FDSubType').AsInteger of
  49.           1     : s := 'NUMERIC';
  50.           2     : s := 'DECIMAL';
  51.         end;
  52.       end;
  53.     end
  54.     else
  55.       s := UpperCase(FQuery.FieldByName('DATA_TYPE').AsString);
  56.     if (s = 'VARCHAR') or (s = 'CHAR') or (s = 'TEXT') or (s = 'TINYTEXT') or
  57.        (s = 'MEDIUMTEXT') or (s = 'LONGTEXT') or (s = 'SET') or (s = 'ENUM') or
  58.        (s = 'NCHAR') then
  59.       Result := ftString
  60.     else if (s = 'INT') or (s = 'BIGINT') or (s = 'INTEGER') or (s = 'TINYINT') or
  61.        (s = 'SMALLINT') or (s = 'MEDIUMINT') or (s = 'YEAR') then
  62.       Result := ftInteger
  63.     else if (s = 'DECIMAL') or (s = 'NUMERIC') then
  64.       Result := ftCurrency
  65.     else if (s = 'FLOAT') or (s = 'REAL') or (s = 'DOUBLE') then
  66.       Result := ftFloat
  67.     else if (s = 'DATE') then
  68.       Result := ftDate
  69.     else if (s = 'TIME') then
  70.       Result := ftTime
  71.     else if (s = 'DATETIME') then
  72.       Result := ftDateTime
  73.     else if (s = 'TIMESTAMP') then
  74.       Result := ftTimeStamp
  75.     else if (s = 'BINARY') or (s = 'VARBINARY') or (s = 'TINYBLOB') or
  76.             (s = 'BLOB') or (s = 'MEDIUMBLOB') or (s = 'LONGBLOB') then
  77.       Result := ftBlob
  78.     else
  79.       Result := ftUnknown;
  80.   end;
  81.   FQuery.Close;
  82. end;
  83.  
2
FPC development / Re: AVX and SSE support question
« Last post by dicepd on Today at 06:32:19 am »
I stand corrected on one thing... the System V ABI does support unaligned vectors, unlike vectorcall.  I'll see if I can correct that and hence fix your library!

??? nothing in our library uses unaligned vectors. At least in 64bit it does not, we have been quite strict in making sure that all accesses are aligned for performance reasons. Only 32bit uses unaligned assembler variants, and to be honest 32bit is not the  priority as it is much slower because of the fewer registers available and the fact we are forced to use unaligned assembler calls.

32 bit is a limitation of the fpc pascal calling convention, it should be possible to make vectorcall work for all 32bit intel platforms as the calling convention in 32 bit is a pascal defined calling convention if I remember correctly.
3
Databases / Re: Tool ZeosDB for Firebird and MySQL
« Last post by jaky2551 on Today at 04:37:29 am »
Code: Pascal  [Select]
  1. // Field
  2.  
  3. function TDataUtil.HasField(aTB, aFD: string): Boolean;
  4. var
  5.   i: Integer;
  6. begin
  7.   aFD := UpperCase(aFD);
  8.   Result := False;
  9.   if IsFirebird then
  10.     FQuery.SQL.Text := 'SELECT FIRST 1 * FROM ' + aTB
  11.   else
  12.     FQuery.SQL.Text := 'SELECT * FROM ' + aTB + ' LIMIT 0, 1';
  13.   FQuery.Open;
  14.   for i := 0 to FQuery.Fields.Count - 1 do
  15.     if UpperCase(FQuery.Fields[i].FieldName) = aFD then
  16.     begin
  17.       Result := True;
  18.       Break;
  19.     end;
  20.   FQuery.Close;
  21. end;
  22.  
  23. procedure TDataUtil.InsertField(aTB, aFD, aTY, After: string);
  24. var
  25.   i, n: Integer;
  26.   s: string;
  27. begin
  28.   if Connected then
  29.   begin
  30.     After := UpperCase(After);
  31.     s := 'ALTER TABLE ' + aTB + ' ADD ' + aFD + ' ';
  32.     if IsFirebird then
  33.     begin
  34.       s := s + aTY;
  35.       n := -1;
  36.       if After <> '' then
  37.       begin
  38.         FQuery.SQL.Text := 'SELECT FIRST 1 * FROM ' + aTB;
  39.         FQuery.Open;
  40.         for i := 0 to FQuery.Fields.Count - 1 do
  41.           if After = UpperCase(FQuery.Fields[i].FieldName) then
  42.           begin
  43.             n := i + 1;
  44.             Break;
  45.           end;
  46.       end;
  47.       if (n <> -1) then
  48.         s := s + ' POSITION ' + IntToStr(n);
  49.     end
  50.     else
  51.     begin
  52.       s := s + MySQLField(aTY);
  53.       if After <> '' then
  54.         s := s + ' AFTER ' + After;
  55.     end;
  56.     QueryExecSQL(s);
  57.   end;
  58. end;
  59.  
  60. procedure TDataUtil.DeleteField(aTB, aFD: string);
  61. begin
  62.   QueryExecSQL('ALTER TABLE ' + UpperCase(aTB) + ' DROP ' + UpperCase(aFD));
  63. end;
  64.  
  65. function TDataUtil.FieldIsType(aTB, aFD: string): TFieldType;
  66. var
  67.   s: string;
  68. begin
  69.   Result := ftUnknown;
  70.  
  71.   FQuery.SQL.Text := 'SELECT TABLE_SCHEMA, TABLE_NAME, COLUMN_NAME, DATA_TYPE ' +
  72.                      'FROM information_schema.COLUMNS WHERE TABLE_NAME=' +
  73.                      QuotedStr(aTB) + ' AND TABLE_SCHEMA=' +
  74.                      QuotedStr(Database) + ' AND COLUMN_NAME=' +
  75.                      QuotedStr(aFD);
  76. {
  77.   if IsFirebird then
  78.     FQuery.SQL.Text := 'SELECT FIRST 1 FROM ' + aTB
  79.   else
  80.     FQuery.SQL.Text := 'SELECT * FROM ' + aTB + ' LIMIT 0,1';
  81. }
  82.  
  83.   FQuery.Open;
  84.   if FQuery.RecordCount <> 0 then
  85.   begin
  86.     s := UpperCase(FQuery.FieldByName('DATA_TYPE').AsString);
  87.     if (s = 'VARCHAR') or (s = 'CHAR') or (s = 'TEXT') or (s = 'TINYTEXT') or
  88.        (s = 'MEDIUMTEXT') or (s = 'LONGTEXT') or (s = 'SET') or (s = 'ENUM') or
  89.        (s = 'NCHAR') then
  90.       Result := ftString
  91.     else if (s = 'INT') or (s = 'BIGINT') or (s = 'INTEGER') or (s = 'TINYINT') or
  92.        (s = 'SMALLINT') or (s = 'MEDIUMINT') or (s = 'YEAR') then
  93.       Result := ftInteger
  94.     else if (s = 'DECIMAL') or (s = 'NUMERIC') then
  95.       Result := ftCurrency
  96.     else if (s = 'FLOAT') or (s = 'REAL') or (s = 'DOUBLE') then
  97.       Result := ftFloat
  98.     else if (s = 'DATE') then
  99.       Result := ftDate
  100.     else if (s = 'TIME') then
  101.       Result := ftTime
  102.     else if (s = 'DATETIME') then
  103.       Result := ftDateTime
  104.     else if (s = 'TIMESTAMP') then
  105.       Result := ftTimeStamp
  106.     else if (s = 'BINARY') or (s = 'VARBINARY') or (s = 'TINYBLOB') or
  107.             (s = 'BLOB') or (s = 'MEDIUMBLOB') or (s = 'LONGBLOB') then
  108.       Result := ftBlob
  109.     else
  110.       Result := ftUnknown;
  111.   end;
  112.   FQuery.Close;
  113. end;
  114.  
  115. // Something
  116.  
  117. procedure TDataUtil.QueryExecSQL(aSQL: string);
  118. begin
  119.   {$IFDEF DEBUGQUERY}
  120.     ShowMessage(aSQL);
  121.   {$ENDIF}
  122.   FQuery.SQL.Text := aSQL;
  123.   FQuery.ExecSQL;
  124. end;
  125.  
  126. procedure TDataUtil.QuerySQL(var rField: string; var rValue: string; const aField, aValue: string); overload;
  127. begin
  128.   if aValue <> '' then
  129.   begin
  130.     rField := AddComma(rField) + aField;
  131.     rValue := AddComma(rValue) + aValue;
  132.   end;
  133. end;
  134.  
  135. procedure TDataUtil.QuerySQL(var rField: string; const aField, aValue: string); overload;
  136. begin
  137.   if aValue <> '' then
  138.     rField := AddComma(rField) + aField + '=' + aValue;
  139. end;
  140.  
  141. procedure TDataUtil.OpenQuery(aQuery: TZQuery; aSQL: string = ''; aID: Integer = -1);
  142. begin
  143.   if (aQuery.SQL.Text = '') and (aSQL = '') then
  144.     raise Exception.Create('SQL Query not assign!');
  145.   if aQuery.Active then
  146.     aQuery.Close;
  147.   if aSQL <> '' then
  148.     aQuery.SQL.Text := aSQL;
  149.   aQuery.Open;
  150.   if aID <> -1 then
  151.     aQuery.Locate('ID', aID, []);
  152. end;
  153.  
  154. procedure TDataUtil.Delete4ID(aQuery: TZQuery; aTB: string; aID: Integer);
  155. begin
  156.   aQuery.Close;
  157.   QueryExecSQL('DELETE FROM ' + aTB + ' WHERE ID=' + IntToStr(aID));
  158.   OpenQuery(aQuery);
  159. end;
  160.  
  161. procedure TDataUtil.Search(aQuery: TZQuery; FromTable, InField, ByText: string;
  162.                  tso: TSearchOrder = tsoBefore);
  163. var
  164.   sso, qry: string;
  165. begin
  166.   if Connected then
  167.   begin
  168.     aQuery.Close;
  169.     qry := 'SELECT * FROM ' + FromTable + ' WHERE ';
  170.     if IsFirebird then
  171.       qry := qry + ' POSITION(' + QuotedStr(UpperCase(ByText)) +
  172.                    ' IN UPPER(' + InField + '))>0'
  173.     else
  174.     begin
  175.       case tso of
  176.         tsoBefore    : sso := '%' + ByText;
  177.         tsoAfter     : sso := ByText + '%';
  178.       else
  179.         sso := '%' + ByText + '%';
  180.       end;
  181.       qry := qry + InField + ' LIKE ' + QuotedStr(sso);
  182.     end;
  183.     aQuery.SQL.Text := qry + ' ORDER BY ' + InField + ' ASC';
  184.     aQuery.Open;
  185.   end;
  186. end;
  187.  
  188. function TDataUtil.CanEditOrDelete(aQuery: TZQuery): Boolean;
  189. begin
  190.   Result := aQuery.Active and (aQuery.RecordCount <> 0);
  191. end;
  192.  
  193. function TDataUtil.GetHostName: string;
  194. begin
  195.   Result := FConfig.HostName;
  196. end;
  197.  
  198. function TDataUtil.GetUserName: string;
  199. begin
  200.   Result := FConfig.UserName;
  201. end;
  202.  
  203. function TDataUtil.GetPassword: string;
  204. begin
  205.   Result := FConfig.Password;
  206. end;
  207.  
  208. function TDataUtil.GetPort: Word;
  209. begin
  210.   Result := FConfig.Port;
  211. end;
  212.  
  213. function TDataUtil.GetDatabase: string;
  214. begin
  215.   Result := FConfig.Database;
  216. end;
  217.  
  218. function TDataUtil.GetDataType: TDataType;
  219. begin
  220.   Result := FConfig.DataType;
  221. end;
  222.  
  223. procedure TDataUtil.SetHostName(aHost: string);
  224. begin
  225.   FConfig.HostName := aHost;
  226. end;
  227.  
  228. procedure TDataUtil.SetUserName(aUser: string);
  229. begin
  230.   FConfig.UserName := aUser;
  231. end;
  232.  
  233. procedure TDataUtil.SetPassword(aPass: string);
  234. begin
  235.   FConfig.Password := aPass;
  236. end;
  237.  
  238. procedure TDataUtil.SetDatabase(aData: string);
  239. begin
  240.   FConfig.Database := aData;
  241. end;
  242.  
  243. procedure TDataUtil.SetDataType(aData: TDataType);
  244. begin
  245.   FConfig.DataType := aData;
  246. end;
  247.  
  248. procedure TDataUtil.SetPath(aPath: string);
  249. begin
  250.   if Copy(aPath, Length(aPath), 1) <> '\' then
  251.     aPath := aPath + '\';
  252.   FPath := aPath;
  253. end;
  254.  
  255. function TDataUtil.GetCodePage(aTB: string): string;
  256. begin
  257.   Result := 'utf8';
  258.   if not IsFirebird then
  259.   begin
  260.     FQuery.SQL.Text := 'SELECT TABLE_COLLATION FROM information_schema.TABLES where TABLE_SCHEMA=' +
  261.             QuotedStr(Database) + ' AND TABLE_NAME=' +
  262.             QuotedStr(aTB);
  263.     FQuery.Open;
  264.     if FQuery.RecordCount <> 0 then
  265.       Result := Trim(FQuery.Fields[0].AsString);
  266.     FQuery.Close;
  267.   end;
  268. end;
  269.  
  270. procedure TDataUtil.Backup2File(Filename: string);
  271. var
  272.   ts: TStringList;
  273.   tb: TStringList;
  274.   i, j: Integer;
  275.   s: string;
  276.   CStream: TCompressionStream;
  277.   FStream: TFileStream;
  278.   MStream, DStream: TMemoryStream;
  279. begin
  280.   tb := TStringList.Create;
  281.   try
  282.     TableList(tb);
  283.     if tb.Count <> 0 then
  284.     begin
  285.       ts := TStringList.Create;
  286.       try
  287.         if FProgress then
  288.         begin
  289.           ProFrm := TProFrm.Create(nil);
  290.           ProFrm.MessStr := 'Restoring...';
  291.           ProFrm.MaxValue := tb.Count;
  292.           ProFrm.Show;
  293.         end;
  294.         for i := 0 to tb.Count - 1 do
  295.         begin
  296.           if FProgress then
  297.             ProFrm.Next;
  298.  
  299.           FQuery.SQL.Text := 'SELECT * FROM ' + tb.Strings[i] + ' ORDER BY ID ASC';
  300.           FQuery.Open;
  301.           if FQuery.RecordCount <> 0 then
  302.           begin
  303.             ts.Add('#N' + tb.Strings[i]);
  304.             s := '#F';
  305.             for j := 0 to FQuery.Fields.Count - 1 do
  306.               s := s + '|' + UpperCase(FQuery.Fields[j].FieldName);
  307.             ts.Add(s);
  308.             s := '#T';
  309.             for j := 0 to FQuery.Fields.Count - 1 do
  310.             begin
  311.               s := s + '|';
  312.               case FQuery.Fields[j].DataType of
  313.                 ftInteger   : s := s + 'I';
  314.                 ftFloat,
  315.                 ftCurrency  : s := s + 'F';
  316.               else
  317.                 s := s + 'S';
  318.               end;
  319.             end;
  320.             ts.Add(s);
  321.             FQuery.First;
  322.             while not FQuery.Eof do
  323.             begin
  324.               s := '#D';
  325.               for j := 0 to FQuery.Fields.Count - 1 do
  326.               begin
  327.                 s := s + '|';
  328.                 case FQuery.Fields[j].DataType of
  329.                   ftInteger   : s := s + IntToStr(FQuery.Fields[j].AsInteger);
  330.                   ftFloat,
  331.                   ftCurrency  : s := s + FloatToStr(FQuery.Fields[j].AsFloat);
  332.                 else
  333.                   s := s + UTF8ToAnsi(Trim(FQuery.Fields[j].AsString));
  334.                 end;
  335.               end;
  336.               ts.Add(s);
  337.               FQuery.Next;
  338.             end;
  339.             FQuery.Close;
  340.             j := 0;
  341.             if IsFirebird then
  342.               j := GetAutoInc(tb.Strings[i])
  343.             else
  344.               j := NextAutoInc(tb.Strings[i]);
  345.             ts.Add('#E|' + IntToStr(j));
  346.           end;
  347.         end;
  348.         if FBackupCompress then
  349.         begin
  350.           FStream := TFileStream.Create(UTF8ToAnsi(Filename), fmOpenReadWrite or fmCreate);
  351.           try
  352.             DStream := TMemoryStream.Create;
  353.             MStream := TMemoryStream.Create;
  354.             try
  355.               ts.SaveToStream(MStream);
  356.               MStream.Position := 0;
  357.  
  358.               CStream := TCompressionStream.Create(clMax, DStream);
  359.               try
  360.                 CStream.CopyFrom(MStream, MStream.Size);
  361.               finally
  362.                 FreeAndNil(CStream);
  363.               end;
  364.               DStream.Position := 0;
  365.               FStream.CopyFrom(DStream, DStream.Size);
  366.             finally
  367.               FreeAndNil(MStream);
  368.             end;
  369.           finally
  370.             FreeAndNil(FStream);
  371.             FreeAndNil(DStream);
  372.           end;
  373.         end
  374.         else
  375.           ts.SaveToFile(UTF8ToAnsi(Filename));
  376.  
  377.         if FProgress then
  378.           FreeAndNil(ProFrm);
  379.       finally
  380.         ts.Clear;
  381.         FreeAndNil(ts);
  382.       end;
  383.     end;
  384.   finally
  385.     tb.Clear;
  386.     FreeAndNil(tb);
  387.   end;
  388.   if Assigned(FOnBackup) then
  389.     FOnBackup(Self);
  390. end;
  391.  
  392. procedure TDataUtil.Restore4File(Filename: string);
  393. const
  394.   BufSize = 10240;
  395. var
  396.   ts: TStringList;
  397.   s1, s2, s3, nm, ty, tb: string;
  398.   i, a: Integer;
  399.   Buffer: array[0..BufSize - 1] of Byte;
  400.   FStream: TFileStream;
  401.   MStream: TMemoryStream;
  402.   DStream: TDecompressionStream;
  403. begin
  404.   ts := TStringList.Create;
  405.   try
  406.     if BackupCompress then
  407.     begin
  408.       FStream := TFileStream.Create(UTF8ToAnsi(Filename), fmOpenRead);
  409.       try
  410.         FStream.Position := 0;
  411.         MStream := TMemoryStream.Create;
  412.         try
  413.           DStream := TDecompressionStream.Create(FStream);
  414.           try
  415.             while True do
  416.             begin
  417.               a := DStream.Read(Buffer, BufSize);
  418.               if a <> 0 then
  419.                 MStream.WriteBuffer(Buffer, a)
  420.               else
  421.                 Break;
  422.             end;
  423.           finally
  424.             FreeAndNil(DStream);
  425.           end;
  426.           MStream.Position := 0;
  427.           ts.LoadFromStream(MStream);
  428.         finally
  429.           FreeAndNil(MStream);
  430.         end;
  431.       finally
  432.         FreeAndNil(FStream);
  433.       end;
  434.     end
  435.     else
  436.       ts.LoadFromFile(UTF8ToAnsi(Filename));
  437.  
  438.     if FProgress then
  439.     begin
  440.       ProFrm := TProFrm.Create(nil);
  441.       ProFrm.MessStr := 'Restoring...';
  442.       ProFrm.MaxValue := ts.Count;
  443.       ProFrm.Show;
  444.     end;
  445.  
  446.     for i := 0 to ts.Count - 1 do
  447.     begin
  448.       if FProgress then
  449.         ProFrm.Next;
  450.  
  451.       s1 := ts.Strings[i];
  452.       if Copy(s1, 1, 2) = '#N' then
  453.       begin
  454.         Delete(s1, 1, 2);
  455.         tb := s1;
  456.         QueryExecSQL('DELETE FROM ' + tb);
  457.       end
  458.       else if Copy(s1, 1, 2) = '#E' then
  459.       begin
  460.         Delete(s1, 1, 3);
  461.         a := StrToInt(s1);
  462.       end
  463.       else if Copy(s1, 1, 2) = '#F' then
  464.       begin
  465.         Delete(s1, 1, 3);
  466.         nm := '';
  467.         while s1 <> '' do
  468.         begin
  469.           if nm <> '' then
  470.             nm := nm + ', ';
  471.           nm := nm + GetToken(s1, '|');
  472.         end;
  473.       end
  474.       else if Copy(s1, 1, 2) = '#T' then
  475.       begin
  476.         Delete(s1, 1, 3);
  477.         ty := s1;
  478.       end
  479.       else if Copy(s1, 1, 2) = '#D' then
  480.       begin
  481.         Delete(s1, 1, 3);
  482.         s2 := ty;
  483.         s3 := '';
  484.         while s1 <> '' do
  485.         begin
  486.           if s3 <> '' then
  487.             s3 := s3 + ', ';
  488.           if Pos('|', s1) <> 0 then
  489.           begin
  490.             if Copy(s2, 1, Pos('|', s2) - 1) = 'S' then
  491.               s3 := s3 + QuotedStr(AnsiToUTF8(Copy(s1, 1, Pos('|', s1) - 1)))
  492.             else
  493.               s3 := s3 + Copy(s1, 1, Pos('|', s1) - 1);
  494.             Delete(s1, 1, Pos('|', s1));
  495.           end
  496.           else
  497.           begin
  498.             if Copy(s2, 1, Pos('|', s2) - 1) = 'S' then
  499.               s3 := s3 + QuotedStr(AnsiToUTF8(s1))
  500.             else
  501.               s3 := s3 + s1;
  502.             s1 := '';
  503.           end;
  504.           Delete(s2, 1, Pos('|', s2));
  505.         end;
  506.         QueryExecSQL('INSERT INTO ' + tb + ' (' + nm + ') VALUES (' + s3 + ')');
  507.       end;
  508.       if (a <> 0) then
  509.         SetAutoInc(tb, a);
  510.     end;
  511.     if FProgress then
  512.       FreeAndNil(ProFrm);
  513.   finally
  514.     ts.Clear;
  515.     FreeAndNil(ts);
  516.   end;
  517.   if Assigned(FOnRestore) then
  518.     FOnRestore(Self);
  519. end;
  520.  
  521. procedure TDataUtil.LoadConfig(aFile: string);
  522. var
  523.   fl: file;
  524.   r: Integer;
  525. begin
  526.   if not FileExists(UTF8ToAnsi(aFile)) then
  527.   begin
  528.     FConfig.HostName := '';
  529.     FConfig.UserName := 'SYSDBA';
  530.     FConfig.Password := 'masterkey';
  531.     FConfig.Database := '';
  532.     FConfig.Protocol := 'firebird-2.5';
  533.     FConfig.Port := 0;
  534.     FConfig.DataType := tdtEmbed;
  535.   end
  536.   else
  537.   begin
  538.     AssignFile(fl, aFile);
  539.     Reset(fl, 1);
  540.     BlockRead(fl, FConfig, SizeOf(TConfig), r);
  541.     CloseFile(fl);
  542.   end;
  543. end;
  544.  
  545. procedure TDataUtil.SaveConfig(aFile: string);
  546. var
  547.   fl: file;
  548.   w: Integer;
  549. begin
  550.   AssignFile(fl, aFile);
  551.   Rewrite(fl, 1);
  552.   BlockWrite(fl, FConfig, SizeOf(TConfig), w);
  553.   CloseFile(fl);
  554. end;
  555.  
  556. function TDataUtil.GetDBEmbed(aDB: string): string;
  557. begin
  558.   if ExtractFilePath(aDB) = '' then
  559.     aDB := Path + aDB;
  560.   if Pos('.FDB', aDB) = 0 then
  561.     aDB := aDB + '.FDB';
  562.   Result := aDB;
  563. end;
  564.  
  565. function TDataUtil.IsFirebird: Boolean;
  566. begin
  567.   Result := (DataType = tdtEmbed) or (DataType = tdtFirebird);
  568. end;
  569.  
  570. procedure TDataUtil.LoadFromStream(aQuery: TZQuery; aFD: string; aMemo: TMemo);
  571. var
  572.   aStream: TStream;
  573. begin
  574.   if aQuery.Active then
  575.   begin
  576.     aMemo.Lines.Clear;
  577.     try
  578.       aStream := aQuery.CreateBlobStream(aQuery.FieldByName(UpperCase(aFD)), bmRead);
  579.       aStream.Position := 0;
  580.       if aStream.Size <> 0 then
  581.         aMemo.Lines.LoadFromStream(aStream);
  582.     finally
  583.       aStream.Free;
  584.     end;
  585.   end;
  586. end;
  587.  
  588. procedure TDataUtil.LoadFromBlob(aQuery: TZQuery; aFD: string; aImg: TImage);
  589. var
  590.   aStream: TStream;
  591. begin
  592.   if aQuery.Active then
  593.   begin
  594.     if aQuery.FieldByName(aFD).DataType <> ftBlob then
  595.       raise Exception.Create('Field "' + aFD + '" is not BLOB Field!');
  596.     if aQuery.FieldByName(aFD).IsNull then
  597.       with aImg.Canvas do
  598.       begin
  599.         Brush.Color := clWhite;
  600.         Brush.Style := bsSolid;
  601.         FillRect(0, 0, aImg.Width, aImg.Height);
  602.       end
  603.     else
  604.       try
  605.         aStream := aQuery.CreateBlobStream(aQuery.FieldByName(UpperCase(aFD)), bmRead);
  606.         aStream.Position := 0;
  607.         if aStream.Size <> 0 then
  608.           aImg.Picture.LoadFromStream(aStream);
  609.       finally
  610.         aStream.Free;
  611.       end;
  612.   end;
  613. end;
  614.  
  615. procedure TDataUtil.SaveToBlob(aQuery: TZQuery; aFD: string; aStream: TStream);
  616. begin
  617.   if aQuery.Active then
  618.     if aQuery.FieldByName(aFD).DataType <> ftBlob then
  619.       raise Exception.Create('Field "' + aFD + '" is not BLOB Field!')
  620.     else
  621.       TBlobField(aQuery.FieldByName(UpperCase(aFD))).LoadFromStream(aStream);
  622. end;
  623.  
  624. end.
  625.  
4
Databases / Re: Tool ZeosDB for Firebird and MySQL
« Last post by jaky2551 on Today at 04:37:00 am »
Code: Pascal  [Select]
  1.  
  2. // Table
  3.  
  4. function TDataUtil.HasTable(aTB: string): Boolean;
  5. begin
  6.   aTB := UpperCase(aTB);
  7.   Result := False;
  8.   if IsFirebird then
  9.   begin
  10.     FQuery.SQL.Text := 'SELECT 1 FROM RDB$RELATIONS WHERE RDB$RELATION_NAME=' +
  11.                        QuotedStr(aTB);
  12.     FQuery.Open;
  13.     Result := (FQuery.RecordCount <> 0);
  14.     FQuery.Close;
  15.   end
  16.   else
  17.   begin
  18.     FQuery.SQL.Text := 'SHOW TABLES';
  19.     FQuery.Open;
  20.     while not FQuery.Eof do
  21.       if UpperCase(FQuery.Fields[0].AsString) = aTB then
  22.       begin
  23.         Result := True;
  24.         Break;
  25.       end
  26.       else
  27.         FQuery.Next;
  28.     FQuery.Close;
  29.   end;
  30. end;
  31.  
  32. procedure TDataUtil.TableList(TBList: TStringList);
  33. var
  34.   tb: TStringList;
  35.   tx: string;
  36.   i: Integer;
  37. begin
  38.   if not Assigned(TBList) then
  39.     TBList := TStringList.Create;
  40.  
  41.   TBList.Clear;
  42.   if IsFirebird then
  43.   begin
  44.     tb := TStringList.Create;
  45.     try
  46.       FConnect.GetTableNames('', tb);
  47.       for i := 0 to tb.Count - 1 do
  48.       begin
  49.         tx := UpperCase(tb.Strings[i]);
  50.         if (Copy(tx, 1, 3) <> 'RDB') and (Copy(tx, 1, 3) <> 'MON') then
  51.           TBList.Add(tx);
  52.       end;
  53.     finally
  54.       tb.Clear;
  55.       FreeAndNil(tb);
  56.     end;
  57.   end
  58.   else
  59.   begin
  60.     FQuery.SQL.Text := 'SHOW TABLES';
  61.     FQuery.Open;
  62.     while not FQuery.Eof do
  63.     begin
  64.       TBList.Add(UpperCase(FQuery.Fields[0].AsString));
  65.       FQuery.Next;
  66.     end;
  67.     FQuery.Close;
  68.   end;
  69. end;
  70.  
  71. procedure TDataUtil.CreateTable(TBList: TStringList);
  72.   procedure FBTrigger(aTB: string);
  73.   begin
  74.     with FConnect do
  75.     begin
  76.       ExecuteDirect('CREATE GENERATOR GEN_' + aTB + '_ID;');
  77.       ExecuteDirect('SET GENERATOR GEN_' + aTB + '_ID TO 0;');
  78.       ExecuteDirect('CREATE TRIGGER TR_' + Copy(aTB, 1, 5) + ' FOR ' + aTB +
  79.                     ' ACTIVE BEFORE INSERT POSITION 0' +
  80.                     ' AS BEGIN if (NEW.ID is NULL) then NEW.ID = GEN_ID(GEN_' +
  81.                     aTB + '_ID, 1); END;');
  82.     end;
  83.   end;
  84.  
  85. var
  86.   i: Integer;
  87.   aSQL, tb, ss, fd: string;
  88. begin
  89.   if FProgress then
  90.   begin
  91.     ProFrm := TProFrm.Create(nil);
  92.     ProFrm.MessStr := 'Restoring...';
  93.     ProFrm.MaxValue := TBList.Count;
  94.     ProFrm.Show;
  95.   end;
  96.  
  97.   aSQL := '';
  98.   for i := 0 to TBList.Count - 1 do
  99.   begin
  100.     if FProgress then
  101.       ProFrm.Next;
  102.  
  103.     ss := UpperCase(Trim(TrimLeft(TBList.Strings[i])));
  104.     if Pos('//', ss) <> 0 then
  105.       ss := Trim(Copy(ss, 1, Pos('//', ss) - 1));
  106.     if (ss <> '') and (ss <> '//') then
  107.       if Copy(ss, 1, 2) = '#N' then
  108.       begin
  109.         Delete(ss, 1, 2);
  110.         tb := ss;
  111.       end
  112.       else
  113.         if Copy(ss, 1, 2) = '#E' then
  114.         begin
  115.           if tb <> '' then
  116.           begin
  117.             if not HasTable(tb) then
  118.             begin
  119.               if IsFirebird then
  120.               begin
  121.                 FConnect.ExecuteDirect('CREATE TABLE ' + tb +
  122.                      ' (ID INTEGER NOT NULL PRIMARY KEY, ' + aSQL + ')');
  123.                 FBTrigger(tb);
  124.               end
  125.               else
  126.                 QueryExecSQL('CREATE TABLE IF NOT EXISTS ' + tb +
  127.                            ' (ID INT(11) NOT NULL AUTO_INCREMENT PRIMARY KEY , ' +
  128.                            aSQL + ') ENGINE=MYISAM');
  129.             end;
  130.           end;
  131.           aSQL := '';
  132.           tb := '';
  133.         end
  134.         else
  135.         begin
  136.           aSQL := AddComma(aSQL);
  137.           if IsFirebird then
  138.             aSQL := aSQL + ss
  139.           else
  140.           begin
  141.             fd := Copy(ss, 1, Pos(' ', ss) - 1);
  142.             Delete(ss, 1, Pos(' ', ss));
  143.             aSQL := aSQL + fd + ' ' + MySQLField(ss) + ' NOT NULL';
  144.           end;
  145.         end;
  146.   end;
  147.   if FProgress then
  148.     FreeAndNil(ProFrm);
  149. end;
  150.  
  151. procedure TDataUtil.DeleteTable(aTB: string);
  152. begin
  153.   QueryExecSQL('DROP TABLE ' + UpperCase(aTB));
  154. end;
  155.  
  156. procedure TDataUtil.SetAutoInc(aTB: string; Def: Integer = 0);
  157. begin
  158.   aTB := UpperCase(aTB);
  159.   if Copy(aTB, 1, 3) = 'TB_' then
  160.     Delete(aTB, 1, 3);
  161.   if IsFirebird then
  162.     QueryExecSQL('SET GENERATOR GEN_' + aTB + '_ID TO ' + IntToStr(Def))
  163.   else
  164.     QueryExecSQL('ALTER TABLE ' + aTB + ' AUTO_INCREMENT=' + IntToStr(Def));
  165. end;
  166.  
  167. function TDataUtil.GetAutoInc(aTB: string): Integer;
  168. begin
  169.   if IsFirebird then
  170.   begin
  171.     if Copy(aTB, 1, 3) = 'TB_' then
  172.       Delete(aTB, 1, 3);
  173.     FQuery.SQL.Text := 'SELECT RDB$GENERATOR_NAME FROM RDB$GENERATORS ' +
  174.               'WHERE RDB$SYSTEM_FLAG=0 AND RDB$GENERATOR_NAME=' +
  175.               QuotedStr('GEN_' + UpperCase(aTB) + '_ID');
  176.     FQuery.Open;
  177.     if FQuery.RecordCount = 0 then
  178.       Result := -1
  179.     else
  180.     begin
  181.       FQuery.Close;
  182.       FQuery.SQL.Text := 'SELECT GEN_ID(GEN_' + UpperCase(aTB) +
  183.                          '_ID, 0) FROM RDB$DATABASE';
  184.       FQuery.Open;
  185.       Result := FQuery.FieldByName('GEN_ID').AsInteger;
  186.     end;
  187.   end
  188.   else
  189.   begin
  190.     FQuery.SQL.Text := 'SELECT LAST_INSERT_ID() AS ID FROM ' + aTB;
  191.     FQuery.Open;
  192.     Result := FQuery.Fields[0].AsInteger;
  193.   end;
  194.   FQuery.Close;
  195. end;
  196.  
  197. function TDataUtil.NextAutoInc(aTB: string): Integer;
  198. begin
  199.   if IsFirebird then
  200.     Result := GetAutoInc(aTB) + 1
  201.   else
  202.   begin
  203.     FQuery.SQL.Text := 'SELECT AUTO_INCREMENT FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_SCHEMA=' +
  204.             QuotedStr(FConnect.Database) + ' AND TABLE_NAME = ' + QuotedStr(aTB);
  205.     FQuery.Open;
  206.     Result := FQuery.Fields[0].AsInteger;
  207.     FQuery.Close;
  208.   end;
  209. end;
  210.  
  211.  
5
Databases / Re: Tool ZeosDB for Firebird and MySQL
« Last post by jaky2551 on Today at 04:36:01 am »
Code: Pascal  [Select]
  1. constructor TDataUtil.Create;
  2. begin
  3.   inherited;
  4.   FConnect := TZConnection.Create(nil);
  5.  
  6.   FQuery := TZQuery.Create(nil);
  7.   FQuery.Connection := FConnect;
  8.  
  9.   Path := ExtractFilePath(Application.ExeName);
  10.   DataType := tdtEmbed;
  11.   FConfig.Database := '';
  12.  
  13.   FProgress := False;
  14.  
  15.   FBackupCompress := False;
  16. end;
  17.  
  18. destructor TDataUtil.Destroy;
  19. begin
  20.   if FQuery.Active then
  21.     FQuery.Close;
  22.   FreeAndNil(FQuery);
  23.  
  24.   if FConnect.Connected then
  25.     FConnect.Disconnect;
  26.   FreeAndNil(FConnect);
  27.  
  28.   inherited;
  29. end;
  30.  
  31. procedure TDataUtil.PrepareConnect;
  32. begin
  33.   if FConnect.Connected then
  34.     FConnect.Disconnect;
  35.   FConnect.User := UserName;
  36.   FConnect.Password := Password;
  37.   FConnect.HostName := HostName;
  38.   FConnect.Protocol := FConfig.Protocol;
  39.   FConnect.Port := Port;
  40.   case FConfig.DataType of
  41.     tdtEmbed       : FConnect.LibraryLocation := Path + 'fbembed.dll';
  42.     tdtFirebird    : FConnect.LibraryLocation := Path + 'fbclient.dll';
  43.     tdtWinMySQL    : FConnect.LibraryLocation := Path + 'libmysql.dll';
  44.     tdtLXMySQL     : FConnect.LibraryLocation := Path + 'libmysqld.dll';
  45.   end;
  46. end;
  47.  
  48. function TDataUtil.ConnectDB: Boolean;
  49. var
  50.   db: string;
  51. begin
  52.   Result := False;
  53.   if FConnect.Connected then
  54.     DisconnectDB;
  55.   if FConfig.DataType = tdtEmbed then
  56.   begin
  57.     db := GetDBEmbed(Database);
  58.     if not FileExists(UTF8ToAnsi(db)) then
  59.       raise Exception.Create('Database "' + db + '" not found!');
  60.     FConnect.Database := db;
  61.   end
  62.   else
  63.     FConnect.Database := Database;
  64.   if (FConnect.Database = '') and (not IsFirebird) then
  65.     FConnect.Database := 'mysql';
  66.  
  67.   PrepareConnect;
  68.   FConnect.Connect;
  69.   if Assigned(FOnConnect) then
  70.     FOnConnect(Self, FConnect.Connected);
  71.   Result := FConnect.Connected;
  72. end;
  73.  
  74. procedure TDataUtil.DisconnectDB;
  75. begin
  76.   FQuery.Close;
  77.   if FConnect.Connected then
  78.     FConnect.Disconnect;
  79. end;
  80.  
  81. function TDataUtil.Connected: Boolean;
  82. begin
  83.   Result := FConnect.Connected;
  84. end;
  85.  
  86. // Database
  87.  
  88. function TDataUtil.HasDatabase(aDB: string): Boolean;
  89. var
  90.   Flg: Boolean;
  91. begin
  92.   if DataType = tdtEmbed then
  93.   begin
  94.     aDB := GetDBEmbed(aDB);
  95.     Result := FileExists(UTF8ToAnsi(aDB));
  96.   end
  97.   else
  98.   begin
  99.     Flg := Connected;
  100.     Result := False;
  101.     aDB := UpperCase(aDB);
  102.     DisconnectDB;
  103.     FConnect.Database := 'mysql';
  104.     PrepareConnect;
  105.     FConnect.Connect;
  106.     if Connected then
  107.     begin
  108.       FQuery.SQL.Text := 'SHOW DATABASES';
  109.       FQuery.Open;
  110.       while not FQuery.Eof do
  111.         if UpperCase(FQuery.Fields[0].AsString) = aDB then
  112.         begin
  113.           Result := True;
  114.           Break;
  115.         end
  116.         else
  117.           FQuery.Next;
  118.       FQuery.Close;
  119.     end;
  120.     if Flg and (not IsFirebird) then
  121.     begin
  122.       FConnect.Database := Database;
  123.       ConnectDB;
  124.     end;
  125.   end;
  126. end;
  127.  
  128. procedure TDataUtil.DatabaseList(DBList: TStringList);
  129. begin
  130.   if not Assigned(DBList) then
  131.     DBList := TStringList.Create;
  132.  
  133.   DBList.Clear;
  134.   if DataType <> tdtEmbed then
  135.   begin
  136.     FQuery.SQL.Text := 'SHOW DATABASES';
  137.     FQuery.Open;
  138.     while not FQuery.Eof do
  139.     begin
  140.       DBList.Add(UpperCase(FQuery.Fields[0].AsString));
  141.       FQuery.Next;
  142.     end;
  143.     FQuery.Close;
  144.   end;
  145. end;
  146.  
  147. procedure TDataUtil.CreateDatabase(aDB: string);
  148. begin
  149.   aDB := UpperCase(aDB);
  150.   if DataType = tdtEmbed then
  151.   begin
  152.     if not FileExists(Path + 'MSGLIVE.FD_') then
  153.       raise Exception.Create('File database dummy is not found!');
  154.     aDB := GetDBEmbed(aDB);
  155.     CopyFile(PChar(Path + 'MSGLIVE.FD_'), PChar(aDB), True);
  156.   end
  157.   else
  158.     if not IsFirebird then
  159.     begin
  160.       if not FConnect.Connected then
  161.       begin
  162.         FConnect.Database := 'mysql';
  163.         FConnect.Connect;
  164.       end;
  165.       QueryExecSQL('CREATE DATABASE IF NOT EXISTS ' + aDB +
  166.                    ' DEFAULT CHARACTER SET utf8 COLLATE utf8_bin');
  167.       if FConnect.Connected then
  168.         FConnect.Disconnect;
  169.     end;
  170. end;
  171.  
  172. procedure TDataUtil.DeleteDatabase(aDB: string);
  173. begin
  174.   if DataType = tdtEmbed then
  175.   begin
  176.     aDB := GetDBEmbed(aDB);
  177.     if FileExists(UTF8ToAnsi(aDB)) then
  178.     begin
  179.       DisconnectDB;
  180.       DeleteFile(PChar(aDB));
  181.     end;
  182.   end
  183.   else
  184.     QueryExecSQL('DROP DATABASE ' + aDB);
  185. end;
  186.  
  187. function TDataUtil.OpenDatabase(aDB, aTB: string; Created: Boolean = True): Boolean;
  188. var
  189.   ts: TStringList;
  190. begin
  191.   Result := False;
  192.   Database := aDB;
  193.   if not HasDatabase(Database) then
  194.   begin
  195.     if not Created then
  196.       Exit;
  197.     CreateDatabase(Database);
  198.     if not Connected then
  199.       ConnectDB;
  200.     if Connected then
  201.     begin
  202.       ts := TStringList.Create;
  203.       try
  204.         ts.LoadFromFile(UTF8ToAnsi(aTB));
  205.         CreateTable(ts);
  206.       finally
  207.         ts.Clear;
  208.         FreeAndNil(ts);
  209.       end;
  210.       DisconnectDB;
  211.     end;
  212.   end;
  213.   Result := ConnectDB;
  214. end;
  215.  
  216.  
6
Databases / Tool ZeosDB for Firebird and MySQL
« Last post by jaky2551 on Today at 04:34:44 am »
I have an active tool for Firebird and MySQL which is run on ZeosDB.
Code: Pascal  [Select]
  1. unit DataUtils;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. // {$DEFINE DEBUGQUERY}
  6.  
  7. interface
  8.  
  9. uses
  10.   Classes, SysUtils, FileUtil, Forms, Graphics, StdCtrls, ExtCtrls, DB,
  11.   ZConnection, ZDataSet, ZStream, Dialogs;
  12.  
  13. type
  14.   TDataType = (tdtEmbed, tdtFirebird, tdtWinMySQL, tdtLXMySQL);
  15.   TSearchOrder = (tsoBefore, tsoAfter, tsoAny);
  16.  
  17.   TOnConnect = procedure(Sender: TObject; Connected: Boolean) of object;
  18.  
  19.   TConfig = record
  20.     HostName: string[50];
  21.     UserName: string[40];
  22.     Password: string[40];
  23.     Database: string[150];
  24.     Protocol: string[40];
  25.     Port: Word;
  26.     DataType: TDataType;
  27.   end;
  28.  
  29.   TDataUtil = class(TObject)
  30.   private
  31.     FConnect: TZConnection;
  32.     FQuery: TZQuery;
  33.     FConfig: TConfig;
  34.     FPath: string;
  35. //    FLibrary: string;
  36.     FBackupCompress: Boolean;
  37.     FProgress: Boolean;
  38.  
  39.     FOnConnect: TOnConnect;
  40.     FOnBackup: TNotifyEvent;
  41.     FOnRestore: TNotifyEvent;
  42.  
  43.     function GetHostName: string;
  44.     function GetUserName: string;
  45.     function GetPassword: string;
  46.     function GetPort: Word;
  47.     function GetDatabase: string;
  48.     function GetDataType: TDataType;
  49.     procedure SetHostName(aHost: string);
  50.     procedure SetUserName(aUser: string);
  51.     procedure SetPassword(aPass: string);
  52.     procedure SetDatabase(aData: string);
  53.     procedure SetDataType(aData: TDataType);
  54.  
  55.     procedure SetPath(aPath: string);
  56.   protected
  57.     procedure PrepareConnect;
  58.   public
  59.     constructor Create;
  60.     destructor Destroy; override;
  61.  
  62.     function ConnectDB: Boolean;
  63.     procedure DisconnectDB;
  64.     function Connected: Boolean;
  65.  
  66.     function HasDatabase(aDB: string): Boolean;
  67.     procedure DatabaseList(DBList: TStringList);
  68.     procedure CreateDatabase(aDB: string);
  69.     procedure DeleteDatabase(aDB: string);
  70.     function OpenDatabase(aDB, aTB: string; Created: Boolean = True): Boolean;
  71.  
  72.     function HasTable(aTB: string): Boolean;
  73.     procedure TableList(TBList: TStringList);
  74.     procedure CreateTable(TBList: TStringList);
  75.     procedure DeleteTable(aTB: string);
  76.  
  77.     function HasField(aTB, aFD: string): Boolean;
  78.     procedure InsertField(aTB, aFD, aTY, After: string);
  79.     procedure DeleteField(aTB, aFD: string);
  80.     function FieldIsType(aTB, aFD: string): TFieldType;
  81.  
  82.     procedure SetAutoInc(aTB: string; Def: Integer = 0);
  83.     function GetAutoInc(aTB: string): Integer;
  84.     function NextAutoInc(aTB: string): Integer;
  85.     function GetCodePage(aTB: string): string;
  86.  
  87.     procedure Backup2File(Filename: string);
  88.     procedure Restore4File(Filename: string);
  89.     procedure LoadConfig(aFile: string);
  90.     procedure SaveConfig(aFile: string);
  91.     function GetDBEmbed(aDB: string): string;
  92.     function IsFirebird: Boolean;
  93.  
  94.     procedure LoadFromStream(aQuery: TZQuery; aFD: string; aMemo: TMemo);
  95.     procedure LoadFromBlob(aQuery: TZQuery; aFD: string; aImg: TImage);
  96.     procedure SaveToBlob(aQuery: TZQuery; aFD: string; aStream: TStream);
  97.  
  98.     procedure QueryExecSQL(aSQL: string);
  99.     procedure QuerySQL(var rField: string; var rValue: string; const aField, aValue: string); overload;
  100.     procedure QuerySQL(var rField: string; const aField, aValue: string); overload;
  101.     procedure OpenQuery(aQuery: TZQuery; aSQL: string = ''; aID: Integer = -1);
  102.     procedure Delete4ID(aQuery: TZQuery; aTB: string; aID: Integer);
  103.     procedure Search(aQuery: TZQuery; FromTable, InField, ByText: string;
  104.                      tso: TSearchOrder = tsoBefore);
  105.     function CanEditOrDelete(aQuery: TZQuery): Boolean;
  106.   published
  107.     property Connection: TZConnection read FConnect;
  108.     property Query: TZQuery read FQuery;
  109.     property Progress: Boolean read FProgress write FProgress;
  110.  
  111.     property HostName: string read GetHostName write SetHostName;
  112.     property UserName: string read GetUserName write SetUserName;
  113.     property Password: string read GetPassword write SetPassword;
  114.     property Database: string read GetDatabase write SetDatabase;
  115.     property Port: Word read GetPort;
  116.     property DataType: TDataType read GetDataType write SetDataType default tdtEmbed;
  117.  
  118.     property Path: string read FPath write SetPath;
  119.     property BackupCompress: Boolean read FBackupCompress write FBackupCompress default False;
  120.  
  121.     property OnConnect: TOnConnect read FOnConnect write FOnConnect;
  122.     property OnBackup: TNotifyEvent read FOnBackup write FOnBackup;
  123.     property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
  124.   end;
  125.  
  126. implementation
  127.  
  128. uses
  129.   ProUnt;
  130.  
  131. function AddComma(aText: string): string;
  132. begin
  133.   Result := Trim(aText);
  134.   if Result <> '' then
  135.     Result := Result + ', ';
  136. end;
  137.  
  138. function GetToken(var ss: string; dl: Char): string;
  139. begin
  140.   if Pos(dl, ss) <> 0 then
  141.   begin
  142.     Result := Copy(ss, 1, Pos(dl, ss) - 1);
  143.     Delete(ss, 1, Pos(dl, ss));
  144.   end
  145.   else
  146.   begin
  147.     Result := ss;
  148.     ss := '';
  149.   end;
  150. end;
  151.  
  152. function MySQLField(fd: string): string;
  153. var
  154.   qr: string;
  155. begin
  156.   qr := UpperCase(Copy(fd, 1, 3));
  157.   if (qr = 'VAR') or (qr = 'CHA') then
  158.     Result := fd // + ' CHARACTER SET utf8 COLLATE utf8_bin'
  159.   else if qr = 'DAT' then
  160.     Result := 'DATETIME DEFAULT ''0000-00-00 00:00:00'''
  161.   else if qr = 'DEC' then
  162.     Result := 'DECIMAL(10,2)'
  163.   else if qr = 'INT' then
  164.     Result := 'INT(11)'
  165.   else if qr = 'DOU' then
  166.     Result := 'DOUBLE(10,2)'
  167.   else if qr = 'BLO' then
  168.     Result := 'MEDIUMBLOB'
  169.   else
  170.     Result := fd;
  171. end;
  172.  
  173.  
7
General / Re: Quick, INCREDIBLY stupid stringgrid, column title question
« Last post by taazz on Today at 03:47:52 am »
Okay taazz, you've helped me before and this is no exception.  Perfect.

Please feel free to laugh yourself into unconsciousness. 

Thanks again.
Being stuck is not a matter of laugh. we all need a push from time to time sometimes you have people around you that can help some times you do not.
8
General / Re: Fast Screen Updating program
« Last post by molly on Today at 03:31:59 am »
... Lazarus and added the starred lines below to the section of Unit1.pas file (and added Crt to "Uses" clause):
Mixing GUi with crt is a bad idea. Just remove that unit from your uses clause.

Code: [Select]
  *Delay(1);
use sleep instead.

But even then, why would you want to do that if your aim is to be as fast as possible ?

I don't seem to remember ever having to use memo.refresh manually. beginupdate/write loads of stuff/endupdate usually does the trick.

You add lines while the ticker you showed in the video (just) changes existing lines. Of course they should be added first, but once present you update the existing/present entries.

PS: a small riddle for you: how much of those 'changes in gui updates' are possible to notice by a human eye ?
9
General / Re: Fast Screen Updating program
« Last post by JL69 on Today at 03:24:24 am »
Lazarus version is 1.8, FPC version is 3.0.4.  Not sure where to find widget set version.  But I installed the most current Lazarus/FPC versions about a week ago.

All I did was open the example file dropfiles.lpi which was installed with Lazarus and added the starred lines below to the section of Unit1.pas file (and added Crt to "Uses" clause):

Actually, now that I look at this again, this may be ok.  When I drop 10 files on the form, the code below tells me it is taking 176 ms to write those 10 files to Memo1 (I know the timer functions I am using below may not be the most accurate), which would be 17 ms each line.  Is there anyway to improve this updating time?

procedure TForm1.ApplicationProperties1DropFiles(Sender: TObject;
  const FileNames: array of String);
var
  I: Integer;
begin
  Start := Now;
  Memo1.Lines.Add(TimeToStr(Now));
  Memo1.Lines.Add(IntToStr(Length(FileNames)) + ' file(s) dropped on Application:');
  for I := 0 to High(FileNames) do
    begin
    Memo1.Lines.Add(FileNames);
 
  *Memo1.Refresh;
  *Delay(1);
 
  *end;
  *Stop := Now;
  *Memo1.Lines.Add(TimeToStr(Stop));
  *Memo1.Lines.Add(IntToStr(MilliSecondsBetween(Stop,Start)));
end;                 
10
General / Re: Fast Screen Updating program
« Last post by Handoko on Today at 02:53:50 am »
...  This works as expected except that when I use Memo1.Refresh between each line added (each trade), the delay of the refresh command itself slows the speed of the program dramatically.

What is your OS, Lazarus version and widgetset?

Can you please write a demo showing that issue, compress them (exclude: binary, *.bak and lib folder) and send it to the forum?
Pages: [1] 2 3 ... 10

Recent

Get Lazarus at SourceForge.net. Fast, secure and Free Open Source software downloads Open Hub project report for Lazarus