quarta-feira, 30 de junho de 2010

TCustomForm.ShowModal impossible

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

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.

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

.

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


.

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.

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:

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.