Problemas con Thread Memoria en Paradox

[goedecke]

Resulta que los TListString solo soportan 150,000 Lineas y yo estoy manejando en ciertos archivos mas de 1 Millon de registros

cambie este TListString a meterlo directamente en el archivo

Código Delphi [-]
 
AssignFile(SQLFile, DEFAULT_ODIR+Table+'.SQL');
ReWrite(SQLFile);
WriteLn(SQLFile,'CREATE DATABASE IF NOT EXISTS `dwh`;');
WriteLn(SQLFile,'USE `dwh`;');
Etc.....

Con esto si se hace un poquito mas lenta la aplicación pero me deja meter archivos muy muy grandes.

Ahora bien me queda el punto del multi-thread

Aqui les dejo el código de como quedo:

Código Delphi [-]
program DB2SQLReport;

{$APPTYPE CONSOLE}

{$R *.res}

uses
   System.SysUtils, System.Classes, Bde.DBTables, Data.DB, TypInfo, StrUtils, ShellApi;


const
  DEFAULT_IDIR = 'C:\Reports\';      // direc. por defecto donde se leeran los archivos
  DEFAULT_ODIR = 'C:\SQL\create\';
  VK_TAB = Chr(9);

 type

    TMiThread = class(TThread)
  protected
    procedure Execute; override;
  public
    constructor Create;
  end;
  {
  TMsgRecord = record
    thread : Integer;
   // msg    : string[30];
    dir : string;
    PdxFile : string;
    fin : Boolean;
  end;
   }


var
//  Path : String;
  WildCard : String;
  Clientes : array of String;
  index : integer;
  errors : TStringList;
  registros : Integer;
  thidnext : Integer = 0;
  thPdxFilses, thdirs :TStringList;


  //ThreadVar         // We must allow each thread its own instances
                  // of the passed record variable
  //msgPtr : ^TMsgRecord;


// -------------------------------------------------------------------------------------
// esta fn. prepara un campo cadena , si es null retorna la palabra null, sin apostrofos
// sino le agrega los apostrofos y ademas si el datos tiene caracteres tales como: \ ' "
// le agrega su respectivo slash
function QuotedField(const field : String) : String;
var
  cadena : String;
begin
  cadena := field;
  if(field = '') {or (field = '')} or (field = 'NULL') then
    cadena := 'null'
  else
    cadena := '''' + cadena + '''';

  Result := cadena;
end;
// -------------------------------------------------------------------------------------
//fils the "list" TStrings with the subdirectories of the "directory" directory
 procedure GetSubDirectories(const directory : string; list : TStrings) ;
 var
   sr : TSearchRec;
 begin
   try
     if FindFirst(IncludeTrailingPathDelimiter(directory) + '*.*', faDirectory, sr) < 0 then
       Exit
     else
     repeat
       if ((sr.Attr and faDirectory <> 0) AND (sr.Name <> '.') AND (sr.Name <> '..')) then
         List.Add(IncludeTrailingPathDelimiter(directory) + sr.Name) ;
     until FindNext(sr) <> 0;
   finally
     FindClose(sr) ;
   end;
 end;
// -------------------------------------------------------------------------------------
procedure FindAll (const Path: String; Attr: Integer; List: TStrings);
var
   Res: TSearchRec;
   EOFound: Boolean;
begin
   EOFound:= False;
   if FindFirst(Path, Attr, Res) < 0 then
     exit
   else
     while not EOFound do begin
       List.Add(Res.Name) ;
       EOFound:= FindNext(Res) <> 0;
     end;
   FindClose(Res) ;
end;



// -------------------------------------------------------------------------------------
// esta fn. agrega slashes a la cadena
function AddSlash(const value : String) : String;
var
  cadena : String;
begin
  cadena := value;
  cadena := StringReplace(cadena, '\', '\\', [rfReplaceAll, rfIgnoreCase]);
  cadena := StringReplace(cadena, #39, '\'+#39, [rfReplaceAll, rfIgnoreCase]);
  Result := cadena;
end;

// -------------------------------------------------------------------------------------
// retorna un arreglo con los numeros de cliente leidos desde un directorio base
procedure getClientesByDir();
var
  i : integer;
  lstFiles : TStringList;

begin

    lstFiles := TStringList.Create;

    GetSubDirectories(DEFAULT_IDIR, lstFiles);
    SetLength(Clientes, lstFiles.Count);
    for i := 0 to lstFiles.Count - 1 Do
    begin
      //Writeln(lstFiles.Strings[i]);
      // agregar el directorio al arreglo
      Clientes[i] :=  ExtractFileName( lstFiles.Strings[i] );
    end;
    lstFiles.Free;
end;

{
// -------------------------------------------------------------------------------------
// retorna una cadena con la creacion de una tabla desde paradox
procedure CreateMysqlScript(const APath: String; const AFile: String );
var
  tblParadox : TTable;
  i, d : integer;
  FieldName : String;
  FieldType : TFieldType;
  FieldSize : integer;
//  Script : String;
  Table : string;
  MySqlType : String;
  Pos : integer;
  coma : string;
  scrInsert : string;
  fecha : TDateTime;
  AFieldValue : AnsiString;
  fieldList:string;
label
  endfunction;

begin

  // se trata de un archivo corrupto
  if(AnsiPos('_', AFile) > 0) then
    Exit;


  try
    tblParadox := TTable.Create(nil);
    tblParadox.DatabaseName := APath;
    tblParadox.TableName := AFile;
    tblParadox.Active := true;
  except
    on E : Exception do
       begin
         errors.Add('Exception class name = '+E.ClassName + ' Exception message = '+E.Message);
       end;
  end;

  // quitarle la extension
  pos := AnsiPos('.', AFile);
  if(pos > 0)
  then Table := AnsiLowerCase(Copy(AFile, 1, pos - 1))
  else Table := AnsiLowerCase(AFile);

  // leer los campos
  script.Add('DROP TABLE IF EXISTS `' + Table + '`;');
  script.Add('CREATE TABLE IF NOT EXISTS `' + Table + '`(');

  for d := 0 to tblParadox.FieldCount - 1 do
  begin
    FieldName := tblParadox.Fields[d].FieldName;
    FieldType := tblParadox.Fields[d].DataType;
    FieldSize := tblParadox.Fields[d].Size;
    case FieldType of
      ftString   : begin
        if(FieldSize > 5) then
          MySqlType := 'VARCHAR'
        else
          MySqlType := 'CHAR';
        MySqlType := MySqlType + '(' + IntToStr(FieldSize) + ')';
      end;
      ftSmallint : MySqlType := 'SMALLINT';
      ftFloat    : MySqlType := 'DECIMAL(11,2)';
      ftDate     : MySqlType := 'DATE';
    end;

    // SOLo para los casos de los campos Client y Branch
    if( AnsiUpperCase(FieldName) = 'CLIENT') OR (AnsiUpperCase(FieldName) = 'BRANCH') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'CONTADOR') OR (AnsiUpperCase(FieldName) = 'VentasNetas') OR (AnsiUpperCase(FieldName) = 'A') then
      MySqlType := 'TINYINT'
    else if( AnsiUpperCase(FieldName) = 'EXISTENCIA') then
      MySqlType := 'INT'
    else if( AnsiUpperCase(FieldName) = 'DIAS') OR (AnsiUpperCase(FieldName) = 'ANO') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'MES') OR (AnsiUpperCase(FieldName) = 'DIA') then
      MySqlType := 'TINYINT UNSIGNED';

    // AGREGAR la comita
    if(d< tblParadox.FieldCount - 1) then coma := ','
    else coma := '';
     // AGREGAR la comita

    fieldList := fieldList + '`' + FieldName + '` ' + coma;
   // script.Add('`' + FieldName + '` ' + MySqlType + coma);


    script.Add('`' + FieldName + '` ' + MySqlType + coma);
  end;
  script.Add(') ENGINE = MyISAM;');
  script.Add('');




  // ------------------------------------------------------------------------------------
  // crear los inserts
  while (NOT tblParadox.Eof) do
  begin
  registros := registros+1;
    scrInsert := 'INSERT INTO `' + Table + '`(' + fieldList + ') VALUES(';
    for i := 0 to tblParadox.FieldCount - 1 do
    begin
      if(i > 0) then scrInsert := scrInsert + ', ';
      FieldName := tblParadox.Fields[i].FieldName;
      // si es una fecha cmbiar el formato a yyyy/mm/dd
      if(tblParadox.Fields[i].DataType = ftDate) then
      begin
        fecha := tblParadox.FieldByName(FieldName).AsDateTime;
        AFieldValue := FormatDateTime('yyyy/mm/dd', fecha);
      end else
        AFieldValue := tblParadox.FieldByName(FieldName).AsAnsiString;

      scrInsert := scrInsert + QuotedField(AddSlash(AFieldValue));
    end; // for fields
    scrInsert := scrInsert + ');';
    script.Add(scrInsert);
    tblParadox.Next;
  end; // while records
  tblParadox.Close;
  tblParadox.Free;
  endfunction:

end; // CreateMysqlScript
}



// -------------------------------------------------------------------------------------
// crea un archivo de texto con el nombre del cliente + .sql
// que contiene la creacion del script
procedure ProcesoCliente(const dir: String; const PdxFile: String);
var
  i : integer;
  tblParadox : TTable;
  a, d : integer;
  FieldName : String;
  FieldType : TFieldType;
  FieldSize : integer;
//  Script : String;
  Table : string;
  MySqlType : String;
  Pos : integer;
  coma : string;
  scrInsert : string;
  fecha : TDateTime;
  AFieldValue : AnsiString;
  fieldList:string;
   SQLFile : TextFile;
label
  endfunction;
begin

  // quitarle la extension
  pos := AnsiPos('.', PdxFile);
  if(pos > 0)
  then Table := AnsiLowerCase(Copy(PdxFile, 1, pos - 1))
  else Table := AnsiLowerCase(PdxFile);

     Writeln(VK_TAB + Table +' -> '+ DEFAULT_ODIR+Table+'.SQL');

//Aqui abro el archivo en el cual voy a meter el texto
 AssignFile(SQLFile, DEFAULT_ODIR+Table+'.SQL');
 ReWrite(SQLFile);

    // guardar el script en el archivo
    // limpiar el script para el siguinte cliente
      if(PdxFile = '') then ;
      Writeln('->'+PdxFile+'<-');
      registros :=0;
       WriteLn(SQLFile,'CREATE DATABASE IF NOT EXISTS `dwh`;');
       WriteLn(SQLFile,'USE `dwh`;');
      //CreateMysqlScript(dir, PdxFile);
      //Pongo aqui el Create SQL con el fin de contruir el Insert en la misma funcion


  // se trata de un archivo corrupto
  if(AnsiPos('_', PdxFile) > 0) then
    Exit;


  try
    tblParadox := TTable.Create(nil);
    tblParadox.DatabaseName := dir;
    tblParadox.TableName := PdxFile;
    tblParadox.Active := true;
  except
    on E : Exception do
       begin
         errors.Add('Exception class name = '+E.ClassName + ' Exception message = '+E.Message);
       end;
  end;


  // leer los campos
  WriteLn(SQLFile,'DROP TABLE IF EXISTS `' + Table + '`;');
  WriteLn(SQLFile,'CREATE TABLE IF NOT EXISTS `' + Table + '`(');

  for d := 0 to tblParadox.FieldCount - 1 do
  begin
    FieldName := tblParadox.Fields[d].FieldName;
    FieldType := tblParadox.Fields[d].DataType;
    FieldSize := tblParadox.Fields[d].Size;
    case FieldType of
      ftString   : begin
        if(FieldSize > 5) then
          MySqlType := 'VARCHAR'
        else
          MySqlType := 'CHAR';
        MySqlType := MySqlType + '(' + IntToStr(FieldSize) + ')';
      end;
      ftSmallint : MySqlType := 'SMALLINT';
      ftFloat    : MySqlType := 'DECIMAL(11,2)';
      ftDate     : MySqlType := 'DATE';
    end;

    // SOLo para los casos de los campos Client y Branch
    if( AnsiUpperCase(FieldName) = 'CLIENT') OR (AnsiUpperCase(FieldName) = 'BRANCH') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'CONTADOR') OR (AnsiUpperCase(FieldName) = 'VentasNetas') OR (AnsiUpperCase(FieldName) = 'A') then
      MySqlType := 'TINYINT'
    else if( AnsiUpperCase(FieldName) = 'EXISTENCIA') then
      MySqlType := 'INT'
    else if( AnsiUpperCase(FieldName) = 'DIAS') OR (AnsiUpperCase(FieldName) = 'ANO') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'MES') OR (AnsiUpperCase(FieldName) = 'DIA') then
      MySqlType := 'TINYINT UNSIGNED';

    // AGREGAR la comita
    if(d< tblParadox.FieldCount - 1) then coma := ','
    else coma := '';
     // AGREGAR la comita

    fieldList := fieldList + '`' + FieldName + '` ' + coma;
   // script.Add('`' + FieldName + '` ' + MySqlType + coma);


    WriteLn(SQLFile,'`' + FieldName + '` ' + MySqlType + coma);
  end;
  WriteLn(SQLFile,') ENGINE = MyISAM;');
  WriteLn(SQLFile,'');




  // ------------------------------------------------------------------------------------
  // crear los inserts
  while (NOT tblParadox.Eof) do
  begin
  registros := registros+1;
    scrInsert := 'INSERT INTO `' + Table + '`(' + fieldList + ') VALUES(';
    for a := 0 to tblParadox.FieldCount - 1 do
    begin
      if(a > 0) then scrInsert := scrInsert + ', ';
      FieldName := tblParadox.Fields[a].FieldName;
      // si es una fecha cmbiar el formato a yyyy/mm/dd
      if(tblParadox.Fields[a].DataType = ftDate) then
      begin
        fecha := tblParadox.FieldByName(FieldName).AsDateTime;
        AFieldValue := FormatDateTime('yyyy/mm/dd', fecha);
      end else
        AFieldValue := tblParadox.FieldByName(FieldName).AsAnsiString;

      scrInsert := scrInsert + QuotedField(AddSlash(AFieldValue));
    end; // for fields
    scrInsert := scrInsert + ');';
    WriteLn(SQLFile,scrInsert);
    tblParadox.Next;
  end; // while records
  tblParadox.Close;
  tblParadox.Free;
  endfunction:
//Termino SQL INSERT


  // Close the file
  CloseFile(SQLFile);

end;

constructor TMiThread.Create;
begin
  inherited Create(FALSE);
  // Aqui le indicamos que cuando la ejecucion del thread termine
  // debe liberar el objeto TMithread
  FreeOnTerminate:= TRUE;
end;

procedure TMiThread.Execute;
var
i:Integer;
begin
  repeat
    Beep;
    Writeln('Entra'+thdirs[thidnext]+thPdxFilses[thidnext]);

   ProcesoCliente(thdirs[thidnext], thPdxFilses[thidnext]);
    // Siempre que tengamos un bucle de este tipo, es conveniente usar algún
    // retardo para no abusar de la CPU. A lo mejor en tu código no es necesario.
   // Sleep(1000);
    thidnext:=thidnext+1;
  until Terminated;
end;
 {
function DoThread(Parameter : Pointer) : Integer;
begin
  // Set up a 0 return value
  Result := 0;

  // Map the pointer to the passed data
  // Note that each thread has a separate copy of msgPtr
  msgPtr := Parameter;

  // crear el thread
  // dormimos el thread por 3 segundos simulando
  // el proceso que tendrias que hacer por debajo del agua
  Writeln('Entra'+msgPtr.dir+msgPtr.PdxFile);

   ProcesoCliente(msgPtr.dir, msgPtr.PdxFile);
  msgPtr.fin := True;
  EndThread(0);
  //Application.ProcessMessages;
end;
}

// -------------------------------------------------------------------------------------
// crea un archivo de texto con el nombre del cliente + .sql
// que contiene la creacion del script
procedure ProcessCliente(const Cliente: String);
var
  ScrFileName : String;
  i : integer;
  APdxFile, PdxFile : String;
  thdir, thpath, lstFiles : TStringList;
  dir : string;
  id1 : LongWord;
  pi, Pos : integer;
  AFile:string;
  Table:string;
  MiThread: TMiThread;
begin
    lstFiles := TStringList.Create;
    thdir := TStringList.Create;
    thpath := TStringList.Create;
    MiThread:= TMiThread.Create;
    // DIR
    // leer todos los archivos de paradox del directorio de este cliente
    dir := DEFAULT_IDIR ;
    FindAll( dir + '*.DB', faAnyFile, lstFiles);
    for i := 0 to lstFiles.Count - 1 Do
    begin
      PdxFile := lstFiles.Strings[i];

      if(PdxFile = '') then Continue;
      Writeln(VK_TAB + PdxFile);
      // ProcesoCliente(dir, PdxFile);         //Remplazado por Thread

             thdir.Add(dir);
             thpath.Add(PdxFile);


    end;
    thdirs := thdir;
    thPdxFilses := thpath;
    MiThread.Execute;
    thdirs.Free;
    thPdxFilses.Free;
    lstFiles.Free;
end;


// -------------------------------------------------------------------------------------
// MAIN
begin

  Writeln('Programa que genera scripts basados en tablas de Paradox a Mysql');
  try
    errors := TStringList.Create;

    { TODO -oUser -cConsole Main : Insert code here }
    // obtner los archivos en el directorio que se pasa como parametro
    if(ParamCount < 1) then
    begin
      // no indico parametros entonces poner valores por defecto.
      // en este caso buscar todos los numeros de clientes, los cuales se obtienen de los
      // directorios de los clientes ubicados en C:\SD\DB
     // getClientesByDir();
    end
    else begin
      SetLength(Clientes, ParamCount);
      for index := 1 to ParamCount do
        Clientes[index-1] := ParamStr(index);
    end;

    // procesar cada cliente

  //    Writeln('Procesando cliente: ' + Clientes[index]);
      ProcessCliente('Clients');

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;

  errors.SaveToFile(DEFAULT_ODIR + 'pdxstruct_errors.log');
  errors.Free;
    //         end;

end.