Explicação:
Você está tentando Showmodal em um form que esta visivel.
o form tem um Visible = True, e é isso que está causando o problema.
Solução:
Altere Visible = True para Visible = False
Pronto. Problema resolvido :-)
Seja livre!
Use lazarus/freepascal
quarta-feira, 30 de junho de 2010
quinta-feira, 24 de junho de 2010
TStringList - Uso da propriedade Values
Nesse post, vou apresentar um exemplo de uso da propriedade Values da classe TStringlist.
É muito comum precisarmos manter uma lista de variaveis totalizando campos numericos. O problema é que toda vez que precisamos de um novo totalizador, temos que criar uma nova variavel no programa.
Uma abordagem mais pratica dessa situação, é utilizar a classe TStringlist.
Nesse caso o TStringlist funcionará como um array, com a vantagem que seus elementos podem ser acessados pelo nome.
A propriedade Values
O TStringlist nos dá a opção de nomear elementos, associando seu respectivo valor, através do metodo Values.
Exemplo:
var
Lista1:TStringlist;
x:integer;
begin
Lista1:=TStringlist.Create;
for x:=1 to 5 do
begin
Lista1.Values['elemento'+inttostr(x)]:=inttostr(x*2);
end;
end;
Resultará em:
elemento1=2
elemento2=4
elemento3=6
elemento4=8
elemento5=10
Para acessar o valor de 'elemento3' basta executar:
Edit1.text:=Lista1.Values['elemento3'];
Que retornará a string '6'.
Pronto! Muito pratico não é mesmo?
Vamos então a um exemplo mais completo.
Para esse caso, criei duas funções:
function GetStringValue(svVar:string):Real;
procedure setStringValue(svVar:string;svValue:Real);
function GetStringValue(svVar:string):Real;
begin
Result:=StrtoFloat(CalcList.Values[svVar]);
end;
procedure setStringValue(svVar:string;svValue:Real);
begin
CalcList.Values[svVar]:=FloatToStr(svValue);
end;
A função GetStringValue retorna um valor convertido no tipo Real, de modo que podemos utilizar como totalizador, ou qualquer uso que desejar.
A função setStringValue cria/atribui um determinado valor a um elemento do Stringlist.
Exemplos:
setStringValue('total1',100); -> cria/atribui valor 100 a um elemento chamado total1
MinhaVariavelFloat:=GetStringValue('total1');-> atribui o 100 a MinhaVariavelFloat;
Agora incrementamos a variavel:
MinhaVariavelFloat:=MinhaVariavelFloat+20;
E atribuimos novamente ao elemento 'total1':
setStringValue('total1',MinhaVariavelFloat);
MinhaVariavelFloat:=GetStringValue('total1'); Resulta em 120
Espero que essas funções sirvam para você leitor, tanto quanto serviu pra mim.
Qualquer duvida, sugestão ou critica, fiquem a vontade para comentar.
Abaixo, o codigo fonte do nosso exemplo:
unit testa_strings_values0;
{$mode objfpc}{$H+}
interface
uses
LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Buttons, StdCtrls, ComCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
calcular: TButton;
box_varlist: TComboBox;
box_operation: TComboBox;
Criar_variavel: TButton;
Edit_calcval: TEdit;
Edit_valor1: TEdit;
Edit_var1: TEdit;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
Label10: TLabel;
Label11: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
ListBox1: TListBox;
Memo1: TMemo;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
procedure calcularClick(Sender: TObject);
procedure Criar_variavelClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
function GetStringValue(svVar:string):Real;
procedure setStringValue(svVar:string;svValue:Real);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
CalcList:TStringlist;
implementation
{$R *.lfm}
procedure TForm1.calcularClick(Sender: TObject);
var
V1,V2,V3:Real;
begin
Memo1.lines.add( 'Valor inicial...:'+CalcList.Values[box_varlist.Text]);
V1:=GetStringValue(box_varlist.Text);
V2:=StrToFloat(Edit_CalcVal.Text);
if box_operation.ItemIndex=0 then
begin
Memo1.lines.add('Valor a somar...:'+Edit_CalcVal.Text);
V3:=V1+V2;
end;
if box_operation.ItemIndex=1 then
begin
Memo1.lines.add('Valor a subtrair:'+Edit_CalcVal.Text);
V3:=V1-V2;
end;
setStringValue(box_varlist.Text,V3);
ListBox1.Items.Values[box_varlist.Text]:=FloatToStr(V3);
V1:=GetStringValue(box_varlist.Text);
Memo1.lines.add(' *-*-* Resultado='+FloatToStr(V1));
Memo1.lines.add(' ');
end;
function TForm1.GetStringValue(svVar:string):Real;
begin
Result:=StrtoFloat(CalcList.Values[svVar]);
end;
procedure TForm1.setStringValue(svVar:string;svValue:Real);
begin
CalcList.Values[svVar]:=FloatToStr(svValue);
end;
procedure TForm1.Criar_variavelClick(Sender: TObject);
begin
CalcList.Values[edit_var1.Text]:=edit_valor1.Text;
box_varlist.Items.Add(edit_var1.Text);
ListBox1.Items.Values[edit_var1.Text]:=edit_valor1.Text;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
CalcList:=TStringlist.Create;
Memo1.lines.Clear;
box_operation.ItemIndex:=-1;
box_varlist.ItemIndex:=-1;
end;
end.
A tela do nosso programinha, deve ficar assim:
Download dos Fontes:
Faça o download dos fontes aqui
Até a próxima.
É muito comum precisarmos manter uma lista de variaveis totalizando campos numericos. O problema é que toda vez que precisamos de um novo totalizador, temos que criar uma nova variavel no programa.
Uma abordagem mais pratica dessa situação, é utilizar a classe TStringlist.
Nesse caso o TStringlist funcionará como um array, com a vantagem que seus elementos podem ser acessados pelo nome.
A propriedade Values
O TStringlist nos dá a opção de nomear elementos, associando seu respectivo valor, através do metodo Values.
Exemplo:
var
Lista1:TStringlist;
x:integer;
begin
Lista1:=TStringlist.Create;
for x:=1 to 5 do
begin
Lista1.Values['elemento'+inttostr(x)]:=inttostr(x*2);
end;
end;
Resultará em:
elemento1=2
elemento2=4
elemento3=6
elemento4=8
elemento5=10
Para acessar o valor de 'elemento3' basta executar:
Edit1.text:=Lista1.Values['elemento3'];
Que retornará a string '6'.
Pronto! Muito pratico não é mesmo?
Vamos então a um exemplo mais completo.
Para esse caso, criei duas funções:
function GetStringValue(svVar:string):Real;
procedure setStringValue(svVar:string;svValue:Real);
function GetStringValue(svVar:string):Real;
begin
Result:=StrtoFloat(CalcList.Values[svVar]);
end;
procedure setStringValue(svVar:string;svValue:Real);
begin
CalcList.Values[svVar]:=FloatToStr(svValue);
end;
A função GetStringValue retorna um valor convertido no tipo Real, de modo que podemos utilizar como totalizador, ou qualquer uso que desejar.
A função setStringValue cria/atribui um determinado valor a um elemento do Stringlist.
Exemplos:
setStringValue('total1',100); -> cria/atribui valor 100 a um elemento chamado total1
MinhaVariavelFloat:=GetStringValue('total1');-> atribui o 100 a MinhaVariavelFloat;
Agora incrementamos a variavel:
MinhaVariavelFloat:=MinhaVariavelFloat+20;
E atribuimos novamente ao elemento 'total1':
setStringValue('total1',MinhaVariavelFloat);
MinhaVariavelFloat:=GetStringValue('total1'); Resulta em 120
Espero que essas funções sirvam para você leitor, tanto quanto serviu pra mim.
Qualquer duvida, sugestão ou critica, fiquem a vontade para comentar.
Abaixo, o codigo fonte do nosso exemplo:
unit testa_strings_values0;
{$mode objfpc}{$H+}
interface
uses
LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Buttons, StdCtrls, ComCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
calcular: TButton;
box_varlist: TComboBox;
box_operation: TComboBox;
Criar_variavel: TButton;
Edit_calcval: TEdit;
Edit_valor1: TEdit;
Edit_var1: TEdit;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
Label10: TLabel;
Label11: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
ListBox1: TListBox;
Memo1: TMemo;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
procedure calcularClick(Sender: TObject);
procedure Criar_variavelClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
function GetStringValue(svVar:string):Real;
procedure setStringValue(svVar:string;svValue:Real);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
CalcList:TStringlist;
implementation
{$R *.lfm}
procedure TForm1.calcularClick(Sender: TObject);
var
V1,V2,V3:Real;
begin
Memo1.lines.add( 'Valor inicial...:'+CalcList.Values[box_varlist.Text]);
V1:=GetStringValue(box_varlist.Text);
V2:=StrToFloat(Edit_CalcVal.Text);
if box_operation.ItemIndex=0 then
begin
Memo1.lines.add('Valor a somar...:'+Edit_CalcVal.Text);
V3:=V1+V2;
end;
if box_operation.ItemIndex=1 then
begin
Memo1.lines.add('Valor a subtrair:'+Edit_CalcVal.Text);
V3:=V1-V2;
end;
setStringValue(box_varlist.Text,V3);
ListBox1.Items.Values[box_varlist.Text]:=FloatToStr(V3);
V1:=GetStringValue(box_varlist.Text);
Memo1.lines.add(' *-*-* Resultado='+FloatToStr(V1));
Memo1.lines.add(' ');
end;
function TForm1.GetStringValue(svVar:string):Real;
begin
Result:=StrtoFloat(CalcList.Values[svVar]);
end;
procedure TForm1.setStringValue(svVar:string;svValue:Real);
begin
CalcList.Values[svVar]:=FloatToStr(svValue);
end;
procedure TForm1.Criar_variavelClick(Sender: TObject);
begin
CalcList.Values[edit_var1.Text]:=edit_valor1.Text;
box_varlist.Items.Add(edit_var1.Text);
ListBox1.Items.Values[edit_var1.Text]:=edit_valor1.Text;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
CalcList:=TStringlist.Create;
Memo1.lines.Clear;
box_operation.ItemIndex:=-1;
box_varlist.ItemIndex:=-1;
end;
end.
A tela do nosso programinha, deve ficar assim:
Download dos Fontes:
Faça o download dos fontes aqui
Até a próxima.
quinta-feira, 10 de junho de 2010
Convertendo aplicações delphi facilmente
Fonte: Parallel Pascal Worlds
Os forms do Lazarus(FPC) estão mais compativeis do que nunca com Delphi.
A nova versão do 2.4.0/2.5.1 do FPC, lazarus e FPC permitem salvar os forms no formato LFM sem a necesidade dos arquivos LRS.
Esta mudança permite migrar facilmente um form Delphi para Lazarus.
Pré requisitos:
Versão trunk do Lazarus.
Versão trunk do FPC. A versão 2.4.0 tambem funcionou
Siga os passos abaixo:
1) Ir a Opcões de Projeto, tab miscelaneos e selecionar recursos FPC (FPC resources).
2) Copiar o arquivo dfm para um com extensão lfm.
3) Abrir o arquivo extensão pas relacionado no lazarus.
4) Procurar a referencia a arquivos dfm e substituir pelo siguinte código:
{$IFDEF LCL}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
5) Procurar a instrução que inclui o arquivo *.lrs na sessão de inicializacão da unit e remove-la.
6) Tecle F12 (para ver o arquivo lfm).
7) É possivel ignorar as advertências sobre propiedades inexistentes, ou não presentes no lazarus. Ista é correto para a maioria dos casos. Como você é un programador sério, revisara cada mensagem para verificar a importancia ou não do mesmo, correto? ;)
Salvar.
8) Compile. (CTRL-F9)
Como sempre, não esqueça de informar as units necessarias na clausula uses. Me refiro a LclType, LResources,etc.
Seja livre.
Use lazarus!
English Version
Lazarus(FPC) forms even more compatible with delphi.
Starting with FPC version 2.5.1 lazarus and FPC allow to save forms in lfm format without the need of LRS files.
This change make even easy migrate code from Delphi to Lazarus.
Prereqs:
Lazarus trunk version.
FPC trunk version (tested with version 2.5.1, don't know which is the minimal version required).
(Edited: minimal version required is FPC Version 2.4.0. Thanks Paul!)
The steps are:
1) Go to project options, tab miscellaneous and select fpc resources.
2) Copy dfm file to lfm file.
3) Open pas file on lazarus.
4) search your dfm reference and replace it for
{$IFDEF LCL}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
5) Search the include for lrs file at inicialization section and remove it.
6) HIT F12 (to see the lfm file).
7) You can safely ignore warnings about properties non presents in lazarus. That is true for the most of cases, but like you are a serious programmer will always read the warning messages to evaluate importance of the message, right? ;)
Save
8) Build. Done!
As always, don't forget to add need uses clauses in header of units ( i mind LclType, LResources,etc).
Enjoy!
Conheça o Elevatedb, banco de dados para Windows Mobile
.
Os forms do Lazarus(FPC) estão mais compativeis do que nunca com Delphi.
A nova versão do 2.4.0/2.5.1 do FPC, lazarus e FPC permitem salvar os forms no formato LFM sem a necesidade dos arquivos LRS.
Esta mudança permite migrar facilmente um form Delphi para Lazarus.
Pré requisitos:
Versão trunk do Lazarus.
Versão trunk do FPC. A versão 2.4.0 tambem funcionou
Siga os passos abaixo:
1) Ir a Opcões de Projeto, tab miscelaneos e selecionar recursos FPC (FPC resources).
2) Copiar o arquivo dfm para um com extensão lfm.
3) Abrir o arquivo extensão pas relacionado no lazarus.
4) Procurar a referencia a arquivos dfm e substituir pelo siguinte código:
{$IFDEF LCL}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
5) Procurar a instrução que inclui o arquivo *.lrs na sessão de inicializacão da unit e remove-la.
6) Tecle F12 (para ver o arquivo lfm).
7) É possivel ignorar as advertências sobre propiedades inexistentes, ou não presentes no lazarus. Ista é correto para a maioria dos casos. Como você é un programador sério, revisara cada mensagem para verificar a importancia ou não do mesmo, correto? ;)
Salvar.
8) Compile. (CTRL-F9)
Como sempre, não esqueça de informar as units necessarias na clausula uses. Me refiro a LclType, LResources,etc.
Seja livre.
Use lazarus!
English Version
Lazarus(FPC) forms even more compatible with delphi.
Starting with FPC version 2.5.1 lazarus and FPC allow to save forms in lfm format without the need of LRS files.
This change make even easy migrate code from Delphi to Lazarus.
Prereqs:
Lazarus trunk version.
FPC trunk version (tested with version 2.5.1, don't know which is the minimal version required).
(Edited: minimal version required is FPC Version 2.4.0. Thanks Paul!)
The steps are:
1) Go to project options, tab miscellaneous and select fpc resources.
2) Copy dfm file to lfm file.
3) Open pas file on lazarus.
4) search your dfm reference and replace it for
{$IFDEF LCL}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
5) Search the include for lrs file at inicialization section and remove it.
6) HIT F12 (to see the lfm file).
7) You can safely ignore warnings about properties non presents in lazarus. That is true for the most of cases, but like you are a serious programmer will always read the warning messages to evaluate importance of the message, right? ;)
Save
8) Build. Done!
As always, don't forget to add need uses clauses in header of units ( i mind LclType, LResources,etc).
Enjoy!
Conheça o Elevatedb, banco de dados para Windows Mobile
.
quarta-feira, 9 de junho de 2010
Advantage TDataset Descendent for Lazarus
O Advantage TDataSet Descendant é uma ferramenta de desenvolvimento onde se pode programar usando componentes similares aos TTable, TQuery, TDatabase and TStoredProc com metodos e propriedades semelhantes. O Advantage TDataSet Descendant combinado com o Advantage Database Server, forma uma robusta solução cliente/servidor para adicionar performance, estabilidade and escalabilidade para aplicações multi-usuario.
O Advantage TDataSet Descendant prove acesso local aos dados com o driver Advantage Local Server, é royalty-free, adequado para desenvolvimento em tabelas locais e ideal para clientes que mais tarde queiram melhorar a performance e segurança de seus dados adquirindo então a versão Cliente/Servidor, o Advantage Database Server.
Caracteristicas
* Multiplataforma - Funciona em WIndows, Linux e Windows Mobile.
* Facil desenvolvimento e distribuição.
* Caso deseja mudar de acesso local para ambiente cliente/servidor não é necessaria nenhuma alteração nos fontes.
* Caracteristicas nativa dos componentes semelhantes aos conhecidos TTable, TQuery, TDatabase e TStoredProc
* Compatibilidade com outros componentes de banco de dados de terceiros
* Prove accesso para avançadas funcionalidades não encontrada em componentes de banco de dados nativos
* Facil conversão de dados de arquivos Paradox, InterBase, Access e SQL Server usando o Advantage Data Architect
* Facil migração para client/server, Internet, thin-client e aplicações moveis
* Baixa manutenção
Para saber mais acesse http://devzone.advantagedatabase.com/
Lá encontrará farta documentação sobre o banco de dados e os varios componentes de acesso, incluindo driver pra ODBC, PHP, .Net, e outros.
Atenção:
No modo local, você pode usar sem limitação, desde que os arquivos sejam acessados diretamente.
Qualquer acesso indireto no modo local, é violação da licença do AdvantageDatabase, atualmente mantido pela Sybase Anywhere.
A versão Cliente/Servidor é paga, mas pode ser testada gratuitamente durante 30 dias.
Versão for lazarus
Estou disponibilizando o TDataset Descendent for lazarus.
Codigo Fonte
Componente TAdsQuery em tempo de desing
Paleta de componentes Advantage
Estão portados os seguintes componentes:
TAdsTable
TAdsQuery
TAdsConnection
TAdsSettings
TAdsStoreProc
TAdsDictionary
TAdsBatchMove (Somente windows)
É um trabalho em andamento, portanto deve ser testado antes de usar em ambiente de produção.
Os componentes são multiplataforma, funcionam no windows e no linux.
Nos testes realizados com a versão de servidor local, funcionou perfeitamente.
Não testado em modo cliente/servidor.
Aproveite para testar agora!
Leia a licença de uso do Advantage.
Esses componentes não são LGLP, eles estão sob uma licença proprietária da Sybase Anywhere.
Para usar os componentes, é necessário instalar pelo menos o Advantage Client Engine.
Postem suas criticas e sugestões.
Espero que esse trabalho seja util pra você, desenvolvedor.
Até a proxima.
Bug
Versão: Advantage 9.10.0.9 for linux
Para quem instalou as libs do Advantage com o aceapi-9.10.0.9.tar.gz ou com o adsodbc-9.10.0.9.tar.gz, os usuarios linux terão que fazer o link simbolico a seguir:
#cd /usr/lib
#ln -s libace.so.9.10.0.9 libace.so.9.90
Se não fizer, ao tentar conectar dá erro de axServerConnection.
Observações da versão for lazarus
Não estão disponiveis os seguintes tipos de campos:
AdsStringField-> Será usado o tipo TStringField.
AIntegerField-> Será usado o tipo TLongintField.
Downloads
Versão 8.10
Componentes de acesso for lazarus
Advantage Client Engine 8.10.0.38 for Windows
Advantage Client Engine 8.10.0.38 for Linux
Versão 9.10
Componentes de acesso for lazarus
Advantage Client Engine 9.10.0.9 for Windows
Advantage Client Engine 9.10.0.9 for Linux
.
O Advantage TDataSet Descendant prove acesso local aos dados com o driver Advantage Local Server, é royalty-free, adequado para desenvolvimento em tabelas locais e ideal para clientes que mais tarde queiram melhorar a performance e segurança de seus dados adquirindo então a versão Cliente/Servidor, o Advantage Database Server.
Caracteristicas
* Multiplataforma - Funciona em WIndows, Linux e Windows Mobile.
* Facil desenvolvimento e distribuição.
* Caso deseja mudar de acesso local para ambiente cliente/servidor não é necessaria nenhuma alteração nos fontes.
* Caracteristicas nativa dos componentes semelhantes aos conhecidos TTable, TQuery, TDatabase e TStoredProc
* Compatibilidade com outros componentes de banco de dados de terceiros
* Prove accesso para avançadas funcionalidades não encontrada em componentes de banco de dados nativos
* Facil conversão de dados de arquivos Paradox, InterBase, Access e SQL Server usando o Advantage Data Architect
* Facil migração para client/server, Internet, thin-client e aplicações moveis
* Baixa manutenção
Para saber mais acesse http://devzone.advantagedatabase.com/
Lá encontrará farta documentação sobre o banco de dados e os varios componentes de acesso, incluindo driver pra ODBC, PHP, .Net, e outros.
Atenção:
No modo local, você pode usar sem limitação, desde que os arquivos sejam acessados diretamente.
Qualquer acesso indireto no modo local, é violação da licença do AdvantageDatabase, atualmente mantido pela Sybase Anywhere.
A versão Cliente/Servidor é paga, mas pode ser testada gratuitamente durante 30 dias.
Versão for lazarus
Estou disponibilizando o TDataset Descendent for lazarus.
Codigo Fonte
Componente TAdsQuery em tempo de desing
Paleta de componentes AdvantageEstão portados os seguintes componentes:
TAdsTable
TAdsQuery
TAdsConnection
TAdsSettings
TAdsStoreProc
TAdsDictionary
TAdsBatchMove (Somente windows)
É um trabalho em andamento, portanto deve ser testado antes de usar em ambiente de produção.
Os componentes são multiplataforma, funcionam no windows e no linux.
Nos testes realizados com a versão de servidor local, funcionou perfeitamente.
Não testado em modo cliente/servidor.
Aproveite para testar agora!
Leia a licença de uso do Advantage.
Esses componentes não são LGLP, eles estão sob uma licença proprietária da Sybase Anywhere.
Para usar os componentes, é necessário instalar pelo menos o Advantage Client Engine.
Postem suas criticas e sugestões.
Espero que esse trabalho seja util pra você, desenvolvedor.
Até a proxima.
Bug
Versão: Advantage 9.10.0.9 for linux
Para quem instalou as libs do Advantage com o aceapi-9.10.0.9.tar.gz ou com o adsodbc-9.10.0.9.tar.gz, os usuarios linux terão que fazer o link simbolico a seguir:
#cd /usr/lib
#ln -s libace.so.9.10.0.9 libace.so.9.90
Se não fizer, ao tentar conectar dá erro de axServerConnection.
Observações da versão for lazarus
Não estão disponiveis os seguintes tipos de campos:
AdsStringField-> Será usado o tipo TStringField.
AIntegerField-> Será usado o tipo TLongintField.
Downloads
Versão 8.10
Componentes de acesso for lazarus
Advantage Client Engine 8.10.0.38 for Windows
Advantage Client Engine 8.10.0.38 for Linux
Versão 9.10
Componentes de acesso for lazarus
Advantage Client Engine 9.10.0.9 for Windows
Advantage Client Engine 9.10.0.9 for Linux
.
quarta-feira, 2 de junho de 2010
Synapse - Exemplo com sockets
Os componentes de socket mais famosos sem duvida são o IdTcpServer e IdTcpClient, da paleta Indy.
Eu não sei quanto aos outros desenvolvedores, mas acho o Indy muito complexo, pesado, e no caso do lazarus, com varios bugs, pelo menos até a versão 0.9.27 do lazarus, quando eu portei um projeto em delphi/kylix3 pro lazarus.
Resolvi estudar outros componentes de socket para portar o meu projeto pro lazarus.
Os componentes que eu analisei foram:
.Synapse (Ararat Synapse)
.LNet (Lightweight networking library)
Aqui nesse post vou apresentar um projeto de teste do synapse composto de 3 modulos:
.Modulo Cliente
.Modulo Servidor
.Modulo Configura/Dispara Clientes
Como funciona
Modulo Servidor
Primeiro, carregue o modulo servidor (server_synapse1.exe).
Antes de ativar, marque a opção "Em caso de erro parar comunicação"
Clique em Ativar Servidor
Pronto, o nosso servidor está no ativo, esperando conexões.
Tela do servidor
Modulo Cliente
Agora, vamos carregar o(s) modulo(s) clientes do nosso projeto.
Execute o clientesynapse1.exe
Veja a tela do nosso cliente abaixo:
Observe que temos algumas configurações disponiveis pro nosso cliente, pra possibilitar a nossa maratona de testes.
Estas opções são:
Numero de sends
Numero de vezes que o cliente repetira o teste escolhido
Disparo por arquivo externo
Informa ao cliente que deve procurar pelo arquivo "disparo.dat" pra iniciar o teste
Finaliza automatico
Informa ao cliente pra auto-finalizar assim que o teste for executado
Parar em caso de erro
Em caso de problemas, para e mostra a mensagem de erro
Modulo Cliente Control
Esse modulo permite configurar o comportamento dos modulos clientes que serão carregados.
Tela do modulo control
Do lado esquerdo temos as configurações que serão carregadas pelos clientes.
Marque as opções desejadas e clique em "Gerar cconfig"
Do lado esquerdo temos 4 botões:
Engatilhar
Apos o primeiro "disparo", clique nesse botao pra colocar o modulo cliente em estado de espera pelo "disparo"
Disparar clientes
Ao clicar nesse botão, sera gerado o arquivo "disparo.dat" que será lido pelos clientes, e apos se iniciará o processamento desejado
Fechar clientes
Clicando nesse botão, será gerado o arquivo "closecli.dat" que fará com que todos os modulos clientes fechem automaticamente.
Reset
Ao receber o click, apaga os arquivos de controle (dispara.dat,closecli.dat)
Outros comandos
dispara10 e dispara100
Comandos para carregar 10 ou 100 modulos clientes de uma vez. Eu carreguei 100 modulos de uma vez no meu archlinux e funcionou beleza.
Download dos fontes aqui.
Boa diversão :-)
Modulo Servidor
unit server_synapse1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, blcksock, synsock;
type
TTCPEchoDaemon = class(TThread)
private
Daemon_Memo1:TMemo;
SSocket:TTCPBlockSocket;
public
Constructor Create (hMemo:TMemo);
Destructor Destroy; override;
procedure Execute; override;
end;
TTCPEchoThrd = class(TThread)
private
Sock:TTCPBlockSocket;
loClientSock:TTCPBlockSocket;
EchoMemo:TMemo;
CSock: TSocket;
Memo1Text:string;
procedure UpdateMemo1;
public
Constructor Create (hsock:tSocket;hMemo:TMemo);
procedure Execute; override;
end;
{ TForm1 }
TForm1 = class(TForm)
servidor_modo_thread: TButton;
cancela_button: TButton;
box_error: TCheckBox;
modo_verbose: TCheckBox;
Memo1: TMemo;
procedure cancela_buttonClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure servidor_modo_threadClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
SSocket: TTCPBlockSocket;
loClientSock: TTCPBlockSocket;
cancelar:Boolean;
implementation
{$R *.lfm}
Constructor TTCPEchoDaemon.Create(hMemo:TMemo);
begin
inherited create(false);
Daemon_Memo1:=hMemo;
Ssocket:=TTCPBlockSocket.create;
FreeOnTerminate:=true;
end;
Destructor TTCPEchoDaemon.Destroy;
begin
SSocket.free;
end;
procedure TTCPEchoDaemon.Execute;
var
echo1:TTCPEchoThrd;
ClientSock:TSocket;
begin
SSocket.CreateSocket;
SSocket.Bind('127.0.0.1','7000');
SSocket.Listen;
cancelar:=False;
if SSocket.LastError = 0 then
begin
while true do
begin
if terminated then break;
Application.ProcessMessages;
if SSocket.CanRead(10000)
then begin
ClientSock := SSocket.Accept;
if SSocket.LastError = 0
then begin
echo1:=TTCPEchoThrd.create(ClientSock,Daemon_memo1);
echo1.Resume;
end ;
end ;
end ;
end
else
begin
Daemon_memo1.Lines.add('Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx);
end;
Daemon_memo1.Lines.Add('Finalizou');
SSocket.CloseSocket;
SSocket.Purge;
end;
Constructor TTCPEchoThrd.Create(Hsock:TSocket;hMemo:TMemo);
begin
inherited create(true);
Csock := Hsock;
EchoMemo:=hMemo;
FreeOnTerminate:=true;
end;
procedure TTCPEchoThrd.UpdateMemo1;
begin
Form1.Memo1.Lines.Add(Memo1Text);
Application.ProcessMessages;
end;
procedure TTCPEchoThrd.Execute;
var
clienteID,s1:string;
r,r1,r2,x,x1:integer;
begin
loClientSock:=TTCPBlockSocket.create;
try
loClientSock.socket:=CSock;
s1:=loClientSock.RecvString(10000);
if s1='**teste1' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
loClientSock.SendString('** resp server '+clienteID+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
end;
end;
if s1='**teste2' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
s1:=loClientSock.RecvString(10000);
x1:=strtoint(s1);
for x:=1 to x1 do
begin
s1:=loClientSock.RecvString(10000);
loClientSock.SendString('** resp server clienteID='+clienteID+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
break;
end;
end;
end;
if s1='**teste3' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
s1:=loClientSock.RecvString(10000);
x1:=strtoint(s1);
for x:=1 to x1 do
begin
s1:=loClientSock.RecvString(10000);
if s1<>'**soma_inicio' then
begin
Memo1Text:='ID '+clienteID+' nao recebi **somainicio';
Synchronize(@UpdateMemo1);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' RecvString - Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
end;
break;
end;
s1:=loClientSock.RecvString(10000);
r:=strtoint(s1);
r2:=0;
for r1:=1 to r do
begin
s1:=loClientSock.RecvString(10000);
r2:=r2+strtoint(s1);
end;
loClientSock.SendString(inttostr(r2)+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString - Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
break;
end;
end;
end;
finally
loClientSock.CloseSocket ;
loClientSock.Free;
end;
end;
{ TForm1 }
procedure TForm1.cancela_buttonClick(Sender: TObject);
begin
cancelar:=True;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
SSocket.CloseSocket;
SSocket.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SSocket := TTCPBlockSocket.Create;
end;
procedure TForm1.servidor_modo_threadClick(Sender: TObject);
var
loSock : TSocket;
clienteID,s1:string;
r,r1,r2,x,x1:integer;
Daemon1:TTCPEchoDaemon;
begin
Memo1.Lines.Add('Modo Thread Ativado');
Application.ProcessMessages;
cancelar:=False;
Daemon1:=TTCPEchoDaemon.Create(memo1);
Daemon1.Resume;
end;
end.
Modulo Cliente
unit clientesynapse1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls, blcksock, DateUtils;
type
{ TForm1 }
TForm1 = class(TForm)
box_error: TCheckBox;
envia3: TButton;
finalizaauto: TCheckBox;
disparo1: TCheckBox;
Edit2: TEdit;
envia2: TButton;
envia: TButton;
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Memo1: TMemo;
Timer1: TTimer;
Timer2: TTimer;
procedure envia3Click(Sender: TObject);
procedure enviamodo1;
procedure enviamodo2;
procedure enviamodo3;
procedure envia2Click(Sender: TObject);
procedure enviaClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
SClient: TTCPBlockSocket;
formID:string;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.enviamodo1;
var
S1:string;
x,x1:integer;
begin
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
x1:=strtoint(edit2.Text);
for x:=1 to x1 do
begin
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.Add('Conexao de teste '+inttostr(x));
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(100) then
begin
SClient.SendString('**teste1'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(Edit1.Text+' '+inttostr(x)+CRLF);
S1:=SClient.RecvString(10000);
memo1.Lines.Add(S1);
end;
SClient.CloseSocket;
end;
memo1.Lines.add('**teste1 finalizado');
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.envia3Click(Sender: TObject);
begin
enviamodo3;
end;
procedure TForm1.enviamodo2;
var
S1:string;
x,x1:integer;
begin
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(1000) then
begin
SClient.SendString('**teste2'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(edit2.text+CRLF);
x1:=strtoint(edit2.Text);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
end;
for x:=1 to x1 do
begin
SClient.SendString(Edit1.Text+' '+inttostr(x)+CRLF);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 2 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
if box_error.Checked then break;
end;
S1:=SClient.RecvString(10000);
if SClient.LastError<>0 then
begin
memo1.Lines.add('RecvString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
if box_error.Checked then break;
end;
memo1.Lines.Add(S1);
end;
end;
memo1.Lines.add('**teste2 finalizado');
SClient.CloseSocket;
SClient.Purge;
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.enviamodo3;
var
S1:string;
r,r1,r2,x,x1,x2:integer;
TS1:TStringlist;
begin
randomize;
TS1:=TStringlist.Create;
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(1000) then
begin
SClient.SendString('**teste3'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(edit2.text+CRLF);
x1:=strtoint(edit2.Text);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
end;
for x:=1 to x1 do
begin
r:=10+trunc(random()*50);
TS1.Clear;
r2:=0;
for x2:=1 to r do
begin
r1:=trunc(random()*100);
r2:=r2+r1;
TS1.Add(inttostr(r1));
end;
SClient.SendString('**soma_inicio'+CRLF);
SClient.SendString(inttostr(TS1.Count)+CRLF);
for x2:=0 to TS1.Count-1 do
begin
SClient.SendString(TS1[x2]+CRLF);
end;
S1:=SClient.RecvString(10000);
if strtoint(S1)<>r2 then memo1.Lines.add('Erro de soma');
end;
memo1.Lines.add('**teste3 finalizado');
end;
SClient.CloseSocket;
SClient.Purge;
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.enviaClick(Sender: TObject);
begin
enviamodo1;
end;
procedure TForm1.envia2Click(Sender: TObject);
begin
enviamodo2;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
SClient.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
s1:string;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
SClient := TTCPBlockSocket.Create;
s1:=inttostr(DateUtils.MilliSecondOfTheHour(Time()));
formID:=s1;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
label2.Caption:=formID;
timer1.Enabled:=True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
ts1:TStringlist;
x:integer;
begin
timer1.Enabled:=False;
if fileexists('cconfig.dat') then
begin
ts1:=TStringlist.Create;
ts1.LoadFromFile('cconfig.dat');
for x:=0 to ts1.Count-1 do
begin
if ts1[x]='disparo' then
begin
disparo1.Checked:=True;
memo1.Lines.Clear;
memo1.Lines.Add('Aguardando disparo');
end;
if ts1[x]='boxerro' then box_error.Checked:=True;
if ts1[x]='finaliza' then finalizaauto.Checked:=True;
if copy(ts1[x],1,1)='0' then edit2.Text:=ts1[x];
end;
Application.ProcessMessages;
for x:=0 to ts1.Count-1 do
begin
if ts1[x]='envia1' then enviamodo1;
if ts1[x]='envia2' then enviamodo2;
if ts1[x]='envia3' then enviamodo3;
end;
end;
Application.ProcessMessages;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
if fileexists('closecli.dat') then close;
if fileexists('redisparo.dat') then
begin
memo1.Lines.Clear;
memo1.Lines.Add('Aguardando disparo');
Application.ProcessMessages;
timer1.Enabled:=True;
end;
end;
end.
Modulo Controle dos Clientes
unit clientesynapse_control1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
box_error: TCheckBox;
Engatilhar: TButton;
n_sends: TEdit;
Label2: TLabel;
nenhum_evento: TRadioButton;
reset1: TButton;
gravar: TButton;
disparo1: TCheckBox;
fechar_processos: TButton;
disparo: TButton;
finalizaauto: TCheckBox;
GroupBox1: TGroupBox;
Label1: TLabel;
modo1: TRadioButton;
modo2: TRadioButton;
modo3: TRadioButton;
procedure disparoClick(Sender: TObject);
procedure EngatilharClick(Sender: TObject);
procedure fechar_processosClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure gravarClick(Sender: TObject);
procedure reset1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
end;
procedure TForm1.disparoClick(Sender: TObject);
var
s1:TStringlist;
begin
s1:=TStringlist.Create;
s1.add('start');
s1.SaveToFile('disparo.dat');
end;
procedure TForm1.EngatilharClick(Sender: TObject);
var
s1:TStringlist;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
s1:=TStringlist.Create;
s1.add('start');
s1.SaveToFile('redisparo.dat');
end;
procedure TForm1.fechar_processosClick(Sender: TObject);
var
s1:TStringlist;
x:integer;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
s1:=TStringlist.Create;
s1.add('close');
s1.SaveToFile('closecli.dat');
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
end;
procedure TForm1.gravarClick(Sender: TObject);
var
s1:TStringlist;
begin
s1:=TStringlist.Create;
if strtointdef(n_sends.Text,0)>0 then s1.Add('0'+n_sends.Text);
if disparo1.Checked then s1.Add('disparo');
if finalizaauto.Checked then s1.Add('finaliza');
if box_error.Checked then s1.Add('boxerro');
if modo1.Checked then s1.Add('envia1');
if modo2.Checked then s1.Add('envia2');
if modo3.Checked then s1.Add('envia3');
s1.SaveToFile('cconfig.dat');
end;
procedure TForm1.reset1Click(Sender: TObject);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
end;
end.
Eu não sei quanto aos outros desenvolvedores, mas acho o Indy muito complexo, pesado, e no caso do lazarus, com varios bugs, pelo menos até a versão 0.9.27 do lazarus, quando eu portei um projeto em delphi/kylix3 pro lazarus.
Resolvi estudar outros componentes de socket para portar o meu projeto pro lazarus.
Os componentes que eu analisei foram:
.Synapse (Ararat Synapse)
.LNet (Lightweight networking library)
Aqui nesse post vou apresentar um projeto de teste do synapse composto de 3 modulos:
.Modulo Cliente
.Modulo Servidor
.Modulo Configura/Dispara Clientes
Como funciona
Modulo Servidor
Primeiro, carregue o modulo servidor (server_synapse1.exe).
Antes de ativar, marque a opção "Em caso de erro parar comunicação"
Clique em Ativar Servidor
Pronto, o nosso servidor está no ativo, esperando conexões.
Tela do servidorModulo Cliente
Agora, vamos carregar o(s) modulo(s) clientes do nosso projeto.
Execute o clientesynapse1.exe
Veja a tela do nosso cliente abaixo:
Observe que temos algumas configurações disponiveis pro nosso cliente, pra possibilitar a nossa maratona de testes.
Estas opções são:
Numero de sends
Numero de vezes que o cliente repetira o teste escolhido
Disparo por arquivo externo
Informa ao cliente que deve procurar pelo arquivo "disparo.dat" pra iniciar o teste
Finaliza automatico
Informa ao cliente pra auto-finalizar assim que o teste for executado
Parar em caso de erro
Em caso de problemas, para e mostra a mensagem de erro
Modulo Cliente Control
Esse modulo permite configurar o comportamento dos modulos clientes que serão carregados.
Tela do modulo controlDo lado esquerdo temos as configurações que serão carregadas pelos clientes.
Marque as opções desejadas e clique em "Gerar cconfig"
Do lado esquerdo temos 4 botões:
Engatilhar
Apos o primeiro "disparo", clique nesse botao pra colocar o modulo cliente em estado de espera pelo "disparo"
Disparar clientes
Ao clicar nesse botão, sera gerado o arquivo "disparo.dat" que será lido pelos clientes, e apos se iniciará o processamento desejado
Fechar clientes
Clicando nesse botão, será gerado o arquivo "closecli.dat" que fará com que todos os modulos clientes fechem automaticamente.
Reset
Ao receber o click, apaga os arquivos de controle (dispara.dat,closecli.dat)
Outros comandos
dispara10 e dispara100
Comandos para carregar 10 ou 100 modulos clientes de uma vez. Eu carreguei 100 modulos de uma vez no meu archlinux e funcionou beleza.
Download dos fontes aqui.
Boa diversão :-)
Modulo Servidor
unit server_synapse1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, blcksock, synsock;
type
TTCPEchoDaemon = class(TThread)
private
Daemon_Memo1:TMemo;
SSocket:TTCPBlockSocket;
public
Constructor Create (hMemo:TMemo);
Destructor Destroy; override;
procedure Execute; override;
end;
TTCPEchoThrd = class(TThread)
private
Sock:TTCPBlockSocket;
loClientSock:TTCPBlockSocket;
EchoMemo:TMemo;
CSock: TSocket;
Memo1Text:string;
procedure UpdateMemo1;
public
Constructor Create (hsock:tSocket;hMemo:TMemo);
procedure Execute; override;
end;
{ TForm1 }
TForm1 = class(TForm)
servidor_modo_thread: TButton;
cancela_button: TButton;
box_error: TCheckBox;
modo_verbose: TCheckBox;
Memo1: TMemo;
procedure cancela_buttonClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure servidor_modo_threadClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
SSocket: TTCPBlockSocket;
loClientSock: TTCPBlockSocket;
cancelar:Boolean;
implementation
{$R *.lfm}
Constructor TTCPEchoDaemon.Create(hMemo:TMemo);
begin
inherited create(false);
Daemon_Memo1:=hMemo;
Ssocket:=TTCPBlockSocket.create;
FreeOnTerminate:=true;
end;
Destructor TTCPEchoDaemon.Destroy;
begin
SSocket.free;
end;
procedure TTCPEchoDaemon.Execute;
var
echo1:TTCPEchoThrd;
ClientSock:TSocket;
begin
SSocket.CreateSocket;
SSocket.Bind('127.0.0.1','7000');
SSocket.Listen;
cancelar:=False;
if SSocket.LastError = 0 then
begin
while true do
begin
if terminated then break;
Application.ProcessMessages;
if SSocket.CanRead(10000)
then begin
ClientSock := SSocket.Accept;
if SSocket.LastError = 0
then begin
echo1:=TTCPEchoThrd.create(ClientSock,Daemon_memo1);
echo1.Resume;
end ;
end ;
end ;
end
else
begin
Daemon_memo1.Lines.add('Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx);
end;
Daemon_memo1.Lines.Add('Finalizou');
SSocket.CloseSocket;
SSocket.Purge;
end;
Constructor TTCPEchoThrd.Create(Hsock:TSocket;hMemo:TMemo);
begin
inherited create(true);
Csock := Hsock;
EchoMemo:=hMemo;
FreeOnTerminate:=true;
end;
procedure TTCPEchoThrd.UpdateMemo1;
begin
Form1.Memo1.Lines.Add(Memo1Text);
Application.ProcessMessages;
end;
procedure TTCPEchoThrd.Execute;
var
clienteID,s1:string;
r,r1,r2,x,x1:integer;
begin
loClientSock:=TTCPBlockSocket.create;
try
loClientSock.socket:=CSock;
s1:=loClientSock.RecvString(10000);
if s1='**teste1' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
loClientSock.SendString('** resp server '+clienteID+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
end;
end;
if s1='**teste2' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
s1:=loClientSock.RecvString(10000);
x1:=strtoint(s1);
for x:=1 to x1 do
begin
s1:=loClientSock.RecvString(10000);
loClientSock.SendString('** resp server clienteID='+clienteID+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
break;
end;
end;
end;
if s1='**teste3' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
s1:=loClientSock.RecvString(10000);
x1:=strtoint(s1);
for x:=1 to x1 do
begin
s1:=loClientSock.RecvString(10000);
if s1<>'**soma_inicio' then
begin
Memo1Text:='ID '+clienteID+' nao recebi **somainicio';
Synchronize(@UpdateMemo1);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' RecvString - Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
end;
break;
end;
s1:=loClientSock.RecvString(10000);
r:=strtoint(s1);
r2:=0;
for r1:=1 to r do
begin
s1:=loClientSock.RecvString(10000);
r2:=r2+strtoint(s1);
end;
loClientSock.SendString(inttostr(r2)+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString - Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
break;
end;
end;
end;
finally
loClientSock.CloseSocket ;
loClientSock.Free;
end;
end;
{ TForm1 }
procedure TForm1.cancela_buttonClick(Sender: TObject);
begin
cancelar:=True;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
SSocket.CloseSocket;
SSocket.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SSocket := TTCPBlockSocket.Create;
end;
procedure TForm1.servidor_modo_threadClick(Sender: TObject);
var
loSock : TSocket;
clienteID,s1:string;
r,r1,r2,x,x1:integer;
Daemon1:TTCPEchoDaemon;
begin
Memo1.Lines.Add('Modo Thread Ativado');
Application.ProcessMessages;
cancelar:=False;
Daemon1:=TTCPEchoDaemon.Create(memo1);
Daemon1.Resume;
end;
end.
Modulo Cliente
unit clientesynapse1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls, blcksock, DateUtils;
type
{ TForm1 }
TForm1 = class(TForm)
box_error: TCheckBox;
envia3: TButton;
finalizaauto: TCheckBox;
disparo1: TCheckBox;
Edit2: TEdit;
envia2: TButton;
envia: TButton;
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Memo1: TMemo;
Timer1: TTimer;
Timer2: TTimer;
procedure envia3Click(Sender: TObject);
procedure enviamodo1;
procedure enviamodo2;
procedure enviamodo3;
procedure envia2Click(Sender: TObject);
procedure enviaClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
SClient: TTCPBlockSocket;
formID:string;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.enviamodo1;
var
S1:string;
x,x1:integer;
begin
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
x1:=strtoint(edit2.Text);
for x:=1 to x1 do
begin
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.Add('Conexao de teste '+inttostr(x));
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(100) then
begin
SClient.SendString('**teste1'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(Edit1.Text+' '+inttostr(x)+CRLF);
S1:=SClient.RecvString(10000);
memo1.Lines.Add(S1);
end;
SClient.CloseSocket;
end;
memo1.Lines.add('**teste1 finalizado');
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.envia3Click(Sender: TObject);
begin
enviamodo3;
end;
procedure TForm1.enviamodo2;
var
S1:string;
x,x1:integer;
begin
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(1000) then
begin
SClient.SendString('**teste2'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(edit2.text+CRLF);
x1:=strtoint(edit2.Text);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
end;
for x:=1 to x1 do
begin
SClient.SendString(Edit1.Text+' '+inttostr(x)+CRLF);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 2 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
if box_error.Checked then break;
end;
S1:=SClient.RecvString(10000);
if SClient.LastError<>0 then
begin
memo1.Lines.add('RecvString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
if box_error.Checked then break;
end;
memo1.Lines.Add(S1);
end;
end;
memo1.Lines.add('**teste2 finalizado');
SClient.CloseSocket;
SClient.Purge;
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.enviamodo3;
var
S1:string;
r,r1,r2,x,x1,x2:integer;
TS1:TStringlist;
begin
randomize;
TS1:=TStringlist.Create;
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(1000) then
begin
SClient.SendString('**teste3'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(edit2.text+CRLF);
x1:=strtoint(edit2.Text);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
end;
for x:=1 to x1 do
begin
r:=10+trunc(random()*50);
TS1.Clear;
r2:=0;
for x2:=1 to r do
begin
r1:=trunc(random()*100);
r2:=r2+r1;
TS1.Add(inttostr(r1));
end;
SClient.SendString('**soma_inicio'+CRLF);
SClient.SendString(inttostr(TS1.Count)+CRLF);
for x2:=0 to TS1.Count-1 do
begin
SClient.SendString(TS1[x2]+CRLF);
end;
S1:=SClient.RecvString(10000);
if strtoint(S1)<>r2 then memo1.Lines.add('Erro de soma');
end;
memo1.Lines.add('**teste3 finalizado');
end;
SClient.CloseSocket;
SClient.Purge;
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.enviaClick(Sender: TObject);
begin
enviamodo1;
end;
procedure TForm1.envia2Click(Sender: TObject);
begin
enviamodo2;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
SClient.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
s1:string;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
SClient := TTCPBlockSocket.Create;
s1:=inttostr(DateUtils.MilliSecondOfTheHour(Time()));
formID:=s1;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
label2.Caption:=formID;
timer1.Enabled:=True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
ts1:TStringlist;
x:integer;
begin
timer1.Enabled:=False;
if fileexists('cconfig.dat') then
begin
ts1:=TStringlist.Create;
ts1.LoadFromFile('cconfig.dat');
for x:=0 to ts1.Count-1 do
begin
if ts1[x]='disparo' then
begin
disparo1.Checked:=True;
memo1.Lines.Clear;
memo1.Lines.Add('Aguardando disparo');
end;
if ts1[x]='boxerro' then box_error.Checked:=True;
if ts1[x]='finaliza' then finalizaauto.Checked:=True;
if copy(ts1[x],1,1)='0' then edit2.Text:=ts1[x];
end;
Application.ProcessMessages;
for x:=0 to ts1.Count-1 do
begin
if ts1[x]='envia1' then enviamodo1;
if ts1[x]='envia2' then enviamodo2;
if ts1[x]='envia3' then enviamodo3;
end;
end;
Application.ProcessMessages;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
if fileexists('closecli.dat') then close;
if fileexists('redisparo.dat') then
begin
memo1.Lines.Clear;
memo1.Lines.Add('Aguardando disparo');
Application.ProcessMessages;
timer1.Enabled:=True;
end;
end;
end.
Modulo Controle dos Clientes
unit clientesynapse_control1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
box_error: TCheckBox;
Engatilhar: TButton;
n_sends: TEdit;
Label2: TLabel;
nenhum_evento: TRadioButton;
reset1: TButton;
gravar: TButton;
disparo1: TCheckBox;
fechar_processos: TButton;
disparo: TButton;
finalizaauto: TCheckBox;
GroupBox1: TGroupBox;
Label1: TLabel;
modo1: TRadioButton;
modo2: TRadioButton;
modo3: TRadioButton;
procedure disparoClick(Sender: TObject);
procedure EngatilharClick(Sender: TObject);
procedure fechar_processosClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure gravarClick(Sender: TObject);
procedure reset1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
end;
procedure TForm1.disparoClick(Sender: TObject);
var
s1:TStringlist;
begin
s1:=TStringlist.Create;
s1.add('start');
s1.SaveToFile('disparo.dat');
end;
procedure TForm1.EngatilharClick(Sender: TObject);
var
s1:TStringlist;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
s1:=TStringlist.Create;
s1.add('start');
s1.SaveToFile('redisparo.dat');
end;
procedure TForm1.fechar_processosClick(Sender: TObject);
var
s1:TStringlist;
x:integer;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
s1:=TStringlist.Create;
s1.add('close');
s1.SaveToFile('closecli.dat');
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
end;
procedure TForm1.gravarClick(Sender: TObject);
var
s1:TStringlist;
begin
s1:=TStringlist.Create;
if strtointdef(n_sends.Text,0)>0 then s1.Add('0'+n_sends.Text);
if disparo1.Checked then s1.Add('disparo');
if finalizaauto.Checked then s1.Add('finaliza');
if box_error.Checked then s1.Add('boxerro');
if modo1.Checked then s1.Add('envia1');
if modo2.Checked then s1.Add('envia2');
if modo3.Checked then s1.Add('envia3');
s1.SaveToFile('cconfig.dat');
end;
procedure TForm1.reset1Click(Sender: TObject);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
end;
end.
terça-feira, 1 de junho de 2010
Indy Socket Error 98
Se ao tentar ativar o IdTcpServer componente indy der o segunite erro:
socket error # 98
address already in use
Basta fazer a seguinte configuração:
O Id_IPv4 força o IdTCPServer a trabalhar no padrão Id_IPV4.
O problema está resolvido.
socket error # 98
address already in use
Basta fazer a seguinte configuração:
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Add.IPVersion := Id_IPv4;
IdTCPServer1.Active := True;
O Id_IPv4 força o IdTCPServer a trabalhar no padrão Id_IPV4.
O problema está resolvido.
Problemas com SVN
A alguns dias tentei baixar a ultima versão do fortes4lazarus com o svn e não consegui, pois deu erro.
Executei o comando abaixo:
$svn co https://fortes4lazarus.svn.sourceforge.net/svnroot/fortes4lazarus/trunk fortes4lazarus
Deu o seguinte erro:
SSL negotiation failed: SSL disabled due to library version mismatch
Como eu ainda sou inexperiente com svn, achei que estava fazendo alguma coisa errada.
Mas não era. Na verdade era o pacote neon que estava desatualizado.
No meu caso,uso archlinux, executei:
#pacman -S openssl, neon
Pra usuarios do Ubuntu, digite:
#apt-get install openssl, neon
E pronto. Feito isso, o svn funcionou normalmente.
Espero ter colaborado.
Executei o comando abaixo:
$svn co https://fortes4lazarus.svn.sourceforge.net/svnroot/fortes4lazarus/trunk fortes4lazarus
Deu o seguinte erro:
SSL negotiation failed: SSL disabled due to library version mismatch
Como eu ainda sou inexperiente com svn, achei que estava fazendo alguma coisa errada.
Mas não era. Na verdade era o pacote neon que estava desatualizado.
No meu caso,uso archlinux, executei:
#pacman -S openssl, neon
Pra usuarios do Ubuntu, digite:
#apt-get install openssl, neon
E pronto. Feito isso, o svn funcionou normalmente.
Espero ter colaborado.
Assinar:
Postagens (Atom)