Skip to content

S
StarUML Evológica Plugin
Commit 29d6d4f7 authored by Sandro Camata Santana's avatar Sandro Camata Santana
Browse files
Options

Merge branch '11-criar-filtros-no-explore-do-editor-do-oql' into EVOUMLPlugin

parents 52c1c2f4 8c82944b
Show whitespace changes
Inline Side-by-side
Showing with 9569 additions and 580 deletions
EvoUMLPlugin/src/CurioAddIn.lpi
View file @ 29d6d4f7
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<CONFIG> <CONFIG>
<ProjectOptions> <ProjectOptions>
<Version Value="12"/> <Version Value="11"/>
<PathDelim Value="\"/> <PathDelim Value="\"/>
<General> <General>
<Flags> <Flags>
...@@ -9,9 +9,9 @@ ...@@ -9,9 +9,9 @@
<MainUnitHasCreateFormStatements Value="False"/> <MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/> <MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/> <MainUnitHasScaledStatement Value="False"/>
<CompatibilityMode Value="True"/>
</Flags> </Flags>
<SessionStorage Value="InProjectDir"/> <SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="CurioAddIn"/> <Title Value="CurioAddIn"/>
<UseAppBundle Value="False"/> <UseAppBundle Value="False"/>
<ResourceType Value="res"/> <ResourceType Value="res"/>
...@@ -138,11 +138,11 @@ ...@@ -138,11 +138,11 @@
<VerifyObjMethodCallValidity Value="True"/> <VerifyObjMethodCallValidity Value="True"/>
<TargetCPU Value="x86_64"/> <TargetCPU Value="x86_64"/>
<TargetOS Value="win64"/> <TargetOS Value="win64"/>
<Optimizations>
<OptimizationLevel Value="0"/>
</Optimizations>
</CodeGeneration> </CodeGeneration>
<Linking> <Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
</Debugging>
<Options> <Options>
<Win32> <Win32>
<GraphicApplication Value="True"/> <GraphicApplication Value="True"/>
...@@ -412,6 +412,9 @@ ...@@ -412,6 +412,9 @@
<VerifyObjMethodCallValidity Value="True"/> <VerifyObjMethodCallValidity Value="True"/>
<TargetCPU Value="x86_64"/> <TargetCPU Value="x86_64"/>
<TargetOS Value="linux"/> <TargetOS Value="linux"/>
<Optimizations>
<OptimizationLevel Value="0"/>
</Optimizations>
</CodeGeneration> </CodeGeneration>
<Linking> <Linking>
<Debugging> <Debugging>
...@@ -429,9 +432,6 @@ ...@@ -429,9 +432,6 @@
<ShowAll Value="True"/> <ShowAll Value="True"/>
</Verbosity> </Verbosity>
<CustomOptions Value="-dUseCThreads"/> <CustomOptions Value="-dUseCThreads"/>
<OtherDefines Count="1">
<Define0 Value="FullDebugMode"/>
</OtherDefines>
</Other> </Other>
</CompilerOptions> </CompilerOptions>
<Debugging> <Debugging>
......
EvoUMLPlugin/src/IntegracaoDelphiSUML.pas
View file @ 29d6d4f7
...@@ -1720,7 +1720,8 @@ begin ...@@ -1720,7 +1720,8 @@ begin
end; end;
end; end;
function TUtil.AlimentarMetamodelRegisterMapping(poClasseRaiz: IUMLClass; poMetaModel: acMetaModel; piMetaModelOptions: TMetaModelGenerationOptions; piProgress: TFShowProgress): string; function TUtil.AlimentarMetamodelRegisterMapping(poClasseRaiz: IUMLClass; poMetaModel: acMetaModel;
piMetaModelOptions: TMetaModelGenerationOptions; piProgress: TFShowProgress): string;
var index, index2, lFixSize, lVarSize: integer; var index, index2, lFixSize, lVarSize: integer;
lbMandatory: boolean; lbMandatory: boolean;
lClassChild: IUMLClass; lClassChild: IUMLClass;
......
EvoUMLPlugin/src/SynFacilBasic.pas 0 → 100644
View file @ 29d6d4f7
{ SynFacilBasic
Unidad con rutinas básicas de SynFacilSyn.
Incluye la definición de la clase base: TSynFacilSynBase, que es la clase padre
de TSYnFacilSyn.
Además icnluye la definición del tipo "tFaTokContent" y el procesamiento de
expresiones regulares que son usadas por TSynFacilSyn.
Por Tito Hinostroza 02/12/2014 - Lima Perú
}
unit SynFacilBasic;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, SynEditHighlighter, strutils, Graphics, DOM, LCLIntf,
LCLProc, SynEditHighlighterFoldBase, SynEditTypes;
type
///////// Definiciones para manejo de tokens por contenido ///////////
//Tipo de expresión regular soportada. Las exp. regulares soportadas son
//simples. Solo incluyen literales de cadena o listas.
tFaRegExpType = (
tregString, //Literal de cadena: "casa"
tregChars, //Lista de caracteres: [A-Z]
tregChars01, //Lista de caracteres: [A-Z]?
tregChars0_, //Lista de caracteres: [A-Z]*
tregChars1_ //Lista de caracteres: [A-Z]+
);
//Acciones a ejecutar en las comparaciones
tFaActionOnMatch = (
aomNext, //pasa a la siguiente instrucción
aomExit, //termina la exploración
aomMovePar, //Se mueve a una posición específica
aomExitpar //termina la exploración retomando una posición específica.
);
//Estructura para almacenar una instrucción de token por contenido
tFaTokContentInst = record
Chars : array[#0..#255] of ByteBool; //caracteres
Text : string; //cadena válida
expTyp : tFaRegExpType; //tipo de expresión
aMatch : integer; //atributo asignado en caso TRUE
aFail : integer; //atributo asignado en caso TRUE
//Campos para ejecutar instrucciones, cuando No cumple
actionFail : tFaActionOnMatch;
destOnFail : integer; //posición destino
//Campos para ejecutar instrucciones, cuando cumple
actionMatch: tFaActionOnMatch;
destOnMatch: integer; //posición destino
posFin : integer; //para guardar posición
end;
ESynFacilSyn = class(Exception); //excepción del resaltador
{ tFaTokContent }
//Estructura para almacenar la descripción de los token por contenido
tFaTokContent = class
TokTyp : integer; //tipo de token por contenido
CaseSensitive: boolean; //Usado para comparación de literales de cadena
Instrucs : array of tFaTokContentInst; //Instrucciones del token por contenido
nInstruc : integer; //Cantidad de instrucciones
procedure Clear;
procedure AddInstruct(exp: string; ifTrue: string = ''; ifFalse: string = '';
atMatch: integer = - 1; atFail: integer = - 1);
procedure AddRegEx(exp: string; Complete: boolean=false);
private
function AddItem(expTyp: tFaRegExpType; ifMatch, ifFail: string): integer;
procedure AddOneInstruct(var exp: string; ifTrue: string; ifFalse: string;
atMatch: integer = -1; atFail: integer = -1);
end;
///////// Definiciones básicas para el resaltador ///////////
//Identifica si un token es el delimitador inicial
TFaTypeDelim =(tdNull, //no es delimitado
tdUniLin, //es delimitador inicial de token delimitado de una línea
tdMulLin, //es delimitador inicial de token delimitado multilínea
tdConten1, //es delimitador inicial de token por contenido 1
tdConten2, //es delimitador inicial de token por contenido 2
tdConten3, //es delimitador inicial de token por contenido 3
tdConten4); //es delimitador inicial de token por contenido 4
//Tipos de coloreado de bloques
TFaColBlock = (cbNull, //sin coloreado
cbLevel, //colorea bloques por nivel
cbBlock); //colorea bloques usando el color definido para cada bloque
TFaProcMetTable = procedure of object; //Tipo de procedimiento para procesar el token de
//acuerdo al caracter inicial.
TFaProcRange = procedure of object; //Procedimiento para procesar en medio de un rango.
TFaSynBlock = class; //definición adelantada
//Descripción de tokens especiales (identificador o símbolo)
TTokSpec = record
txt : string; //palabra clave (puede cambiar la caja y no incluir el primer caracter)
orig : string; //palabra clave tal cual se indica
TokPos: integer; //posición del token dentro de la línea
tTok : integer; //tipo de token
typDel: TFaTypeDelim; {indica si el token especial actual, es en realidad, el
delimitador inicial de un token delimitado o por contenido}
dEnd : string; //delimitador final (en caso de que sea delimitador)
pRange: TFaProcRange; //procedimiento para procesar el token o rango(si es multilinea)
folTok: boolean; //indica si el token delimitado, tiene plegado
chrEsc: char; //Caracter de escape de token delimitado. Si no se usa, contiene #0.
//propiedades para manejo de bloques y plegado de código
openBlk : boolean; //indica si el token es inicio de bloque de plegado
BlksToOpen: array of TFaSynBlock; //lista de referencias a los bloques que abre
closeBlk : boolean; //indica si el token es fin de bloque de plegado
BlksToClose: array of TFaSynBlock; //lista de referencias a los bloques que cierra
OpenSec : boolean; //indica si el token es inicio de sección de bloque
SecsToOpen: array of TFaSynBlock; //lista de bloques de los que es inicio de sección
firstSec : TFaSynBlock; //sección que se debe abrir al abrir el bloque
end;
TEvBlockOnOpen = procedure(blk: TFaSynBlock; var Cancel: boolean) of object;
TArrayTokSpec = array of TTokSpec;
//clase para manejar la definición de bloques de sintaxis
TFaSynBlock = class
name : string; //nombre del bloque
index : integer; //indica su posición dentro de TFaListBlocks
showFold : boolean; //indica si se mostrará la marca de plegado
parentBlk : TFaSynBlock; //bloque padre (donde es válido el bloque)
BackCol : TColor; //color de fondo de un bloque
IsSection : boolean; //indica si es un bloque de tipo sección
UniqSec : boolean; //índica que es sección única
CloseParent : boolean; //indica que debe cerrar al blqoue padre al cerrarse
OnBeforeOpen : TEvBlockOnOpen; //evento de apertura de bloque
OnBeforeClose : TEvBlockOnOpen; //evento de cierre de bloque
end;
TPtrATokEspec = ^TArrayTokSpec; //puntero a tabla
TPtrTokEspec = ^TTokSpec; //puntero a tabla
//Guarda información sobre un atributo de un nodo XML
TFaXMLatrib = record //atributo XML
hay: boolean; //bandera de existencia
val: string; //valor en cadena
n : integer; //valor numérico
bol: boolean; //valor booleando (si aplica)
col: TColor; //valor de color (si aplica)
end;
{ TSynFacilSynBase }
//Clase con métodos básicos para el resaltador
TSynFacilSynBase = class(TSynCustomFoldHighlighter)
protected
fLine : PChar; //Puntero a línea de trabajo
tamLin : integer; //Tamaño de línea actual
fProcTable : array[#0..#255] of TFaProcMetTable; //tabla de métodos
fAtriTable : array[#0..#255] of integer; //tabla de atributos de tokens
posIni : Integer; //índice a inicio de token
posFin : Integer; //índice a siguiente token
fStringLen : Integer; //Tamaño del token actual
fToIdent : PChar; //Puntero a identificador
fTokenID : integer; //Id del token actual
charIni : char; //caracter al que apunta fLine[posFin]
posTok : integer; //para identificar el ordinal del token en una línea
CaseSensitive: boolean; //Para ignorar mayúscula/minúscula
charsIniIden: Set of char; //caracteres iniciales de identificador
lisTmp : TStringList; //lista temporal
fSampleSource: string; //código de muestra
function GetSampleSource: String; override;
protected //identificadores especiales
CharsIdentif: array[#0..#255] of ByteBool; //caracteres válidos para identificadores
tc1, tc2, tc3, tc4: tFaTokContent;
//Tablas para identificadores especiales
mA, mB, mC, mD, mE, mF, mG, mH, mI, mJ,
mK, mL, mM, mN, mO, mP, mQ, mR, mS, mT,
mU, mV, mW, mX, mY, mZ: TArrayTokSpec; //para mayúsculas
mA_,mB_,mC_,mD_,mE_,mF_,mG_,mH_,mI_,mJ_,
mK_,mL_,mM_,mN_,mO_,mP_,mQ_,mR_,mS_,mT_,
mU_,mV_,mW_,mX_,mY_,mZ_: TArrayTokSpec; //para minúsculas
m_, mDol, mArr, mPer, mAmp, mC3 : TArrayTokSpec;
mSym : TArrayTokSpec; //tabla de símbolos especiales
mSym0 : TArrayTokSpec; //tabla temporal para símbolos especiales.
TabMayusc : array[#0..#255] of Char; //Tabla para conversiones rápidas a mayúscula
protected //funciones básicas
function BuscTokEspec(var mat: TArrayTokSpec; cad: string; out n: integer;
TokPos: integer = 0): boolean;
function ToListRegex(list: TFaXMLatrib): string;
function dStartRegex(tStart, tCharsStart: TFaXMLatrib): string;
procedure VerifDelim(delim: string);
procedure ValidAsigDelim(delAct, delNue: TFaTypeDelim; delim: string);
procedure ValidateParamStart(Start: string; var ListElem: TStringList);
function KeyComp(var r: TTokSpec): Boolean;
function CreaBuscTokEspec(var mat: TArrayTokSpec; cad: string; out i: integer;
TokPos: integer = 0): boolean;
//procesamiento de XML
procedure CheckXMLParams(n: TDOMNode; listAtrib: string);
function ReadXMLParam(n: TDOMNode; nomb: string): TFaXMLatrib;
protected //Métodos para tokens por contenido
procedure metTokCont(const tc: tFaTokContent); //inline;
procedure metTokCont1;
procedure metTokCont2;
procedure metTokCont3;
procedure metTokCont4;
protected //Procesamiento de otros elementos
procedure metIdent;
procedure metIdentUTF8;
procedure metNull;
procedure metSpace;
procedure metSymbol;
public //Funciones públicas
procedure DefTokIdentif(dStart, Content: string );
public //Atributos y sus propiedades de acceso
//Atributos predefinidos
tkEol : TSynHighlighterAttributes;
tkSymbol : TSynHighlighterAttributes;
tkSpace : TSynHighlighterAttributes;
tkIdentif : TSynHighlighterAttributes;
tkNumber : TSynHighlighterAttributes;
tkKeyword : TSynHighlighterAttributes;
tkString : TSynHighlighterAttributes;
tkComment : TSynHighlighterAttributes;
//ID para los tokens
tnEol : integer; //id para los tokens salto de línea
tnSymbol : integer; //id para los símbolos
tnSpace : integer; //id para los espacios
tnIdentif : integer; //id para los identificadores
tnNumber : integer; //id para los números
tnKeyword : integer; //id para las palabras claves
tnString : integer; //id para las cadenas
tnComment : integer; //id para los comentarios
{Se crea el contenedor adicional Attrib[], para los atributos, porque aunque ya se
tiene Attribute[] en TSynCustomHighlighter, este está ordenado pro defecto y no
ayuda en ubicar a los attributos por su índice}
Attrib: array of TSynHighlighterAttributes;
function NewTokAttrib(TypeName: string; out TokID: integer
): TSynHighlighterAttributes;
function NewTokType(TypeName: string; out TokAttrib: TSynHighlighterAttributes
): integer;
function NewTokType(TypeName: string): integer;
procedure CreateAttributes; //limpia todos loa atributos
function GetAttribByName(txt: string): TSynHighlighterAttributes;
function GetAttribIDByName(txt: string): integer;
function IsAttributeName(txt: string): boolean;
protected
function ProcXMLattribute(nodo: TDOMNode): boolean;
public //Inicializacoón
constructor Create(AOwner: TComponent); override;
end;
function ExtractRegExp(var exp: string; var str: string; var listChars: string): tFaRegExpType;
function ExtractRegExpN(var exp: string; out RegexTyp: tFaRegExpType ): string;
function ReplaceEscape(str: string): string;
function ColorFromStr(cad: string): TColor;
implementation
const
//Mensajes de error generales
// ERR_START_NO_EMPTY = 'Parámetro "Start" No puede ser nulo';
// ERR_EXP_MUST_BE_BR = 'Expresión debe ser de tipo [lista de caracteres]';
// ERR_TOK_DELIM_NULL = 'Delimitador de token no puede ser nulo';
// ERR_NOT_USE_START = 'No se puede usar "Start" y "CharsStart" simultáneamente.';
// ERR_PAR_START_CHARS = 'Se debe definir el parámetro "Start" o "CharsStart".';
// ERR_TOK_DEL_IDE_ERR = 'Delimitador de token erróneo: %s (debe ser identificador)';
// ERR_IDEN_ALREA_DEL = 'Identificador "%s" ya es delimitador inicial.';
// ERR_INVAL_ATTR_LAB = 'Atributo "%s" no válido para etiqueta <%s>';
// ERR_BAD_PAR_STR_IDEN = 'Parámetro "Start" debe ser de la forma: "[A-Z]", en identificadores';
// ERR_BAD_PAR_CON_IDEN = 'Parámetro "Content" debe ser de la forma: "[A-Z]*", en identificadores';
ERR_START_NO_EMPTY = 'Parameter "Start" can not be null';
ERR_EXP_MUST_BE_BR = 'Expression must be like: [list of chars]';
ERR_TOK_DELIM_NULL = 'Token delimiter can not be null';
ERR_NOT_USE_START = 'Cannot use "Start" and "CharsStart" simultaneously.';
ERR_PAR_START_CHARS = 'It must be defined "Start" or "CharsStart" parameter.';
ERR_TOK_DEL_IDE_ERR = 'Bad Token delimiter: %s (must be identifier)';
ERR_IDEN_ALREA_DEL = 'Identifier "%s" is already a Start delimiter.';
ERR_INVAL_ATTR_LAB = 'Invalid attribute "%s" for label <%s>';
ERR_BAD_PAR_STR_IDEN = 'Parameter "Start" must be like: "[A-Z]", in identifiers';
ERR_BAD_PAR_CON_IDEN = 'Parameter "Content" must be like: "[A-Z]*", in identifiers';
//Mensajes de tokens por contenido
// ERR_EMPTY_INTERVAL = 'Error: Intervalo vacío.';
// ERR_EMPTY_EXPRES = 'Expresión vacía.';
// ERR_EXPECTED_BRACK = 'Se esperaba "]".';
// ERR_UNSUPPOR_EXP_ = 'Expresión no soportada.';
// ERR_INC_ESCAPE_SEQ = 'Secuencia de escape incompleta.';
// ERR_SYN_PAR_IFFAIL_ = 'Error de sintaxis en parámetro "IfFail": ';
// ERR_SYN_PAR_IFMATCH_ = 'Error de sintaxis en parámetro "IfMarch": ';
ERR_EMPTY_INTERVAL = 'Error: Empty Interval.';
ERR_EMPTY_EXPRES = 'Empty expression.';
ERR_EXPECTED_BRACK = 'Expected "]".';
ERR_UNSUPPOR_EXP_ = 'Unsupported expression: ';
ERR_INC_ESCAPE_SEQ = 'Incomplete Escape sequence';
ERR_SYN_PAR_IFFAIL_ = 'Syntax error on Parameter "IfFail": ';
ERR_SYN_PAR_IFMATCH_ = 'Syntax error on Parameter "IfMarch": ';
var
bajos: string[128];
altos: string[128];
function copyEx(txt: string; p: integer): string;
//Versión sobrecargada de copy con 2 parámetros
begin
Result := copy(txt, p, length(txt));
end;
//Funciones para el manejo de expresiones regulares
function ExtractChar(var txt: string; out escaped: boolean; convert: boolean): string;
//Extrae un caracter de una expresión regular. Si el caracter es escapado, devuelve
//TRUE en "escaped"
//Si covert = TRUE, reemplaza el caracter compuesto por uno solo.
var
c: byte;
begin
escaped := false;
Result := ''; //valor por defecto
if txt = '' then exit;
if txt[1] = '\' then begin //caracter escapado
escaped := true;
if length(txt) = 1 then //verificación
raise ESynFacilSyn.Create(ERR_INC_ESCAPE_SEQ);
if txt[2] in ['x','X'] then begin
//caracter en hexadecimal
if length(txt) < 4 then //verificación
raise ESynFacilSyn.Create(ERR_INC_ESCAPE_SEQ);
if convert then begin //toma caracter hexdecimal
c := StrToInt('$'+copy(txt,3,2));
Result := Chr(c);
end else begin //no tranforma
Result := copy(txt, 1,4);
end;
txt := copyEx(txt,5);
end else begin //se supone que es de tipo \A
//secuencia normal de dos caracteres
if convert then begin //hay que convertirlo
Result := txt[2];
end else begin //lo toma tal cual
Result := copy(txt,1,2);
end;
txt := copyEx(txt,3);
end;
end else begin //caracter normal
Result := txt[1];
txt := copyEx(txt,2);
end;
end;
function ExtractChar(var txt: string): char;
//Versión simplificada de ExtractChar(). Extrae un caracter ya convertido. Si no hay
//más caracteres, devuelve #0
var
escaped: boolean;
tmp: String;
begin
if txt = '' then Result := #0
else begin
tmp := ExtractChar(txt, escaped, true);
Result := tmp[1]; //se supone que siempre será de un solo caracter
end;
end;
function ExtractCharN(var txt: string): string;
//Versión simplificada de ExtractChar(). Extrae un caracter sin convertir.
var
escaped: boolean;
begin
Result := ExtractChar(txt, escaped, false);
end;
function ReplaceEscape(str: string): string;
{Reemplaza las secuencias de escape por su caracter real. Las secuencias de
escape recnocidas son:
* Secuencia de 2 caracteres: "\#", donde # es un caracter cualquiera, excepto"x".
Esta secuencia equivale al caracter "#".
* Secuencia de 4 caracteres: "\xHH" o "\XHH", donde "HH" es un número hexadecimnal.
Esta secuencia representa a un caracter ASCII.
Dentro de las expresiones regulares de esta librería, los caracteres: "[", "*", "?",
"*", y "\", tienen significado especial, por eso deben "escaparse".
"\\" -> "\"
"\[" -> "["
"\*" -> "*"
"\?" -> "?"
"\+" -> "+"
"\x$$" -> caracter ASCII $$
}
begin
Result := '';
while str<>'' do
Result += ExtractChar(str);
end;
function EscapeText(str: string): string;
//Comvierte los caracteres que pueden tener significado especial en secuencias de
//escape para que se procesen como caracteres normales.
begin
str := StringReplace(str, '\', '\\',[rfReplaceAll]); //debe hacerse primero
str := StringReplace(str, '[', '\[',[rfReplaceAll]);
str := StringReplace(str, '*', '\*',[rfReplaceAll]);
str := StringReplace(str, '?', '\?',[rfReplaceAll]);
str := StringReplace(str, '+', '\+',[rfReplaceAll]);
Result := str;
end;
function PosChar(ch: char; txt: string): integer;
//Similar a Pos(). Devuelve la posición de un caracter que no este "escapado"
var
f: SizeInt;
begin
f := Pos(ch,txt);
if f=1 then exit(1); //no hay ningún caracter antes.
while (f>0) and (txt[f-1]='\') do begin
f := PosEx(ch, txt, f+1);
end;
Result := f;
end;
function ExtractRegExp(var exp: string; var str: string; var listChars: string): tFaRegExpType;
{Extrae parte de una expresión regular y devuelve el tipo. Esta función se basa en
que toda expresión regular se puede reducir a literales de cadenas o listas (con o
sin cuantificador).
En los casos de listas de caracteres, expande los intervalos de tipo: A..Z, reemplaza
las secuencias de escape y devuelve la lista en "listChars".
En el caso de que sea un literal de cadena, reemplaza las secuencias de escape y
devuelve la cadena en "str".
Soporta todas las formas definidas en "tFaRegExpType".
Si encuentra error, genera una excepción.}
procedure ValidateInterval(var cars: string);
{Valida un conjunto de caracteres, expandiendo los intervalos de tipo "A-Z", y
remplazando las secuencias de escape como: "\[", "\\", "\-", ...
El caracter "-", se considera como indicador de intervalo, a menos que se encuentre
en el primer o ùltimo caracter de la cadena, o esté escapado.
Si hay error genera una excepción.}
var
c, car1, car2: char;
car: string;
tmp: String;
Invert: Boolean;
carsSet: set of char;
begin
//reemplaza intervalos
if cars = '' then
raise ESynFacilSyn.Create(ERR_EMPTY_INTERVAL);
//Verifica si es lista invertida
Invert := false;
if cars[1] = '^' then begin
Invert := true; //marca
cars := copyEx(cars,2); //quita "^"
end;
//Procesa contenido, reemplazando los caracteres escapados.
//Si el primer caracter es "-". lo toma literal, sin asumir error.
car1 := ExtractChar(cars); //Extrae caracter convertido. Se asume que es inicio de intervalo.
tmp := car1; //inicia cadena para acumular.
car := ExtractCharN(cars); //Eextrae siguiente. Sin convertir porque puede ser "\-"
while car<>'' do begin
if car = '-' then begin
//es intervalo
car2 := ExtractChar(cars); //caracter final
if car2 = #0 then begin
//Es intervalo incompleto, podría genera error, pero mejor asumimos que es el caracter "-"
tmp += '-';
break; //sale por que se supone que ya no hay más caracteres
end;
//se tiene un intervalo que hay que reemplazar
for c := Chr(Ord(car1)+1) to car2 do //No se incluye "car1", porque ya se agregó
tmp += c;
end else begin //simplemente acumula
car1 := ExtractChar(car); //Se asume que es inicio de intervalo. No importa perder "car"
tmp += car1; //Es necesario, porque puede estar escapado
end;
car := ExtractCharN(cars); //extrae siguiente
end;
cars := StringReplace(tmp, '%HIGH%', altos,[rfReplaceAll]);
cars := StringReplace(cars, '%ALL%', bajos+altos,[rfReplaceAll]);
//Verifica si debe invertir lista
if Invert then begin
//Convierte a conjunto
carsSet := [];
for c in cars do carsSet += [c];
//Agrega caracteres
cars := '';
for c := #1 to #255 do //no considera #0
if not (c in carsSet) then cars += c;
end;
end;
var
tmp: string;
lastAd: String;
begin
if exp= '' then
raise ESynFacilSyn.Create(ERR_EMPTY_EXPRES);
//Reemplaza secuencias conocidas que equivalen a listas.
if copy(exp,1,2) = '\d' then begin
exp := '[0-9]' + copyEx(exp,3);
end else if copy(exp,1,2) = '\D' then begin
exp := '[^0-9]' + copyEx(exp,3);
end else if copy(exp,1,2) = '\a' then begin
exp := '[A-Za-z]' + copyEx(exp,3);
end else if copy(exp,1,2) = '\w' then begin
exp := '[A-Za-z0-9_]' + copyEx(exp,3);
end else if copy(exp,1,2) = '\W' then begin
exp := '[^A-Za-z0-9_]' + copyEx(exp,3);
end else if copy(exp,1,2) = '\s' then begin
exp := ' ' + copyEx(exp,3);
end else if copy(exp,1,2) = '\S' then begin
exp := '[^ ]' + copyEx(exp,3);
end else if copy(exp,1,2) = '\t' then begin
exp := '\x09' + copyEx(exp,3);
end else if copy(exp,1,1) = '.' then begin
exp := '[\x01-\xFF]' + copyEx(exp,2);
end;
//analiza la secuencia
if (exp[1] = '[') and (length(exp)>1) then begin //Es lista de caracteres
//Captura interior del intervalo.
exp := CopyEx(exp,2);
listChars := '';
tmp := ExtractCharN(exp); //No convierte para no confundir "\]"
while (exp<>'') and (tmp<>']') do begin
listChars += tmp;
tmp := ExtractCharN(exp); //No convierte para no confundir "\]"
end;
if (tmp<>']') then //no se encontró ']'
raise ESynFacilSyn.Create(ERR_EXPECTED_BRACK);
//la norma es tener aquí, el contenido de la lista, pero manteniendo los caracteres escapados
ValidateInterval(listChars); //puede simplificar "listChars". También puede generar excepción
if exp = '' then begin //Lista de tipo "[ ... ]"
Result := tregChars;
end else if exp[1] = '*' then begin //Lista de tipo "[ ... ]* ... "
exp := copyEx(exp,2); //extrae parte procesada
Result := tregChars0_
end else if exp[1] = '?' then begin //Lista de tipo "[ ... ]? ... "
exp := copyEx(exp,2); //extrae parte procesada
Result := tregChars01
end else if exp[1] = '+' then begin //Lista de tipo "[ ... ]+ ... "
exp := copyEx(exp,2); //extrae parte procesada
Result := tregChars1_
end else begin
//No sigue ningún cuantificador, podrías er algún literal
Result := tregChars; //Lista de tipo "[ ... ] ... "
end;
end else if (length(exp)=1) and (exp[1] in ['*','?','+','[']) then begin
//Caso especial, no se usa escape, pero no es lista, ni cuantificador. Se asume
//caracter único
listChars := exp; //'['+exp+']'
exp := ''; //ya no quedan caracteres
Result := tregChars;
exit;
end else begin
//No inicia con lista. Se puede suponer que inicia con literal cadena.
{Pueden ser los casos:
Caso 0) "abc" (solo literal cadena, se extraerá la cadena "abc")
Caso 1) "abc[ ... " (válido, se extraerá la cadena "abc")
Caso 2) "a\[bc[ ... " (válido, se extraerá la cadena "a[bc")
Caso 3) "abc* ... " (válido, pero se debe procesar primero "ab")
Caso 4) "ab\\+ ... " (válido, pero se debe procesar primero "ab")
Caso 5) "a? ... " (válido, pero debe transformarse en lista)
Caso 6) "\[* ... " (válido, pero debe transformarse en lista)
}
str := ''; //para acumular
tmp := ExtractCharN(exp);
lastAd := ''; //solo por seguridad
while tmp<>'' do begin
if tmp = '[' then begin
//Empieza una lista. Caso 1 o 2
exp:= '[' + exp; //devuelve el caracter
str := ReplaceEscape(str);
{ if length(str) = 1 then begin //verifica si tiene un caracter
listChars := str; //'['+str+']'
Result := tregChars; //devuelve como lista de un caracter
exit;
end;}
Result := tregString; //es literal cadena
exit; //sale con lo acumulado en "str"
end else if (tmp = '*') or (tmp = '?') or (tmp = '+') then begin
str := copy(str, 1, length(str)-length(lastAd)); //no considera el último caracter
if str <> '' then begin
//Hay literal cadena, antes de caracter y cuantificador. Caso 3 o 4
exp:= lastAd + tmp + exp; //devuelve el último caracter agregado y el cuantificador
str := ReplaceEscape(str);
if length(str) = 1 then begin //verifica si tiene un caracter
listChars := str; //'['+str+']'
Result := tregChars; //devuelve como lista de un caracter
exit;
end;
Result := tregString; //es literal cadena
exit;
end else begin
//Hay caracter y cuantificador. . Caso 5 o 6
listChars := ReplaceEscape(lastAd); //'['+lastAd+']'
//de "exp" ya se quitó: <caracter><cuantificador>
if tmp = '*' then begin //Lista de tipo "[a]* ... "
Result := tregChars0_
end else if tmp = '?' then begin //Lista de tipo "[a]? ... "
Result := tregChars01
end else if tmp = '+' then begin //Lista de tipo "[a]+ ... "
Result := tregChars1_
end; //no hay otra opción
exit;
end;
end;
str += tmp; //agrega caracter
lastAd := tmp; //guarda el último caracter agregado
tmp := ExtractCharN(exp); //siguiente caracter
end;
//Si llega aquí es porque no encontró cuantificador ni lista (Caso 0)
str := ReplaceEscape(str);
{ if length(str) = 1 then begin //verifica si tiene un caracter
listChars := str; //'['+str+']'
Result := tregChars; //devuelve como lista de un caracter
exit;
end;}
Result := tregString;
end;
end;
function ExtractRegExpN(var exp: string; out RegexTyp: tFaRegExpType): string;
{Extrae parte de una expresión regular y la devuelve como cadena . Actualiza el
tipo de expresión obtenida en "RegexTyp".
No Reemplaza las secuencias de excape ni los intervalos, devuelve el texto tal cual}
var
listChars, str: string;
exp0: String;
tam: Integer;
begin
exp0 := exp; //guarda expresión tal cual
RegexTyp := ExtractRegExp(exp, str, listChars);
tam := length(exp0) - length(exp); //ve diferencia de tamaño
Result := copy(exp0, 1, tam)
end;
function ColorFromStr(cad: string): TColor;
//Convierte una cadena a Color
function EsHexa(txt: string; out num: integer): boolean;
//Convierte un texto en un número entero. Si es numérico devuelve TRUE
var i: integer;
begin
Result := true; //valor por defecto
num := 0; //valor por defecto
for i:=1 to length(txt) do begin
if not (txt[i] in ['0'..'9','a'..'f','A'..'F']) then exit(false); //no era
end;
//todos los dígitos son numéricos
num := StrToInt('$'+txt);
end;
var
r, g, b: integer;
begin
if (cad<>'') and (cad[1] = '#') and (length(cad)=7) then begin
//es código de color. Lo lee de la mejor forma
EsHexa(copy(cad,2,2),r);
EsHexa(copy(cad,4,2),g);
EsHexa(copy(cad,6,2),b);
Result:=RGB(r,g,b);
end else begin //constantes de color
case UpCase(cad) of
'WHITE' : Result :=rgb($FF,$FF,$FF);
'SILVER' : Result :=rgb($C0,$C0,$C0);
'GRAY' : Result :=rgb($80,$80,$80);
'BLACK' : Result :=rgb($00,$00,$00);
'RED' : Result :=rgb($FF,$00,$00);
'MAROON' : Result :=rgb($80,$00,$00);
'YELLOW' : Result :=rgb($FF,$FF,$00);
'OLIVE' : Result :=rgb($80,$80,$00);
'LIME' : Result :=rgb($00,$FF,$00);
'GREEN' : Result :=rgb($00,$80,$00);
'AQUA' : Result :=rgb($00,$FF,$FF);
'TEAL' : Result :=rgb($00,$80,$80);
'BLUE' : Result :=rgb($00,$00,$FF);
'NAVY' : Result :=rgb($00,$00,$80);
'FUCHSIA' : Result :=rgb($FF,$00,$FF);
'PURPLE' : Result :=rgb($80,$00,$80);
'MAGENTA' : Result :=rgb($FF,$00,$FF);
'CYAN' : Result :=rgb($00,$FF,$FF);
'BLUE VIOLET': Result :=rgb($8A,$2B,$E2);
'GOLD' : Result :=rgb($FF,$D7,$00);
'BROWN' : Result :=rgb($A5,$2A,$2A);
'CORAL' : Result :=rgb($FF,$7F,$50);
'VIOLET' : Result :=rgb($EE,$82,$EE);
end;
end;
end;
{ tFaTokContent }
procedure tFaTokContent.Clear;
begin
CaseSensitive := false; //por defecto
nInstruc := 0;
setLength(Instrucs,0);
end;
function tFaTokContent.AddItem(expTyp: tFaRegExpType; ifMatch, ifFail: string): integer;
//Agrega un ítem a la lista Instrucs[]. Devuelve el número de ítems.
//Configura el comportamiento de la instrucción usando "ifMatch".
var
ifMatch0, ifFail0: string;
function extractIns(var txt: string): string;
//Extrae una instrucción (identificador)
var
p: Integer;
begin
txt := trim(txt);
if txt = '' then exit('');
p := 1;
while (p<=length(txt)) and (txt[p] in ['A'..'Z']) do inc(p);
Result := copy(txt,1,p-1);
txt := copyEx(txt, p);
// Result := copy(txt,1,p);
// txt := copyEx(txt, p+1);
end;
function extractPar(var txt: string; errMsg: string): integer;
//Extrae un valor numérico
var
p, p0: Integer;
sign: Integer;
begin
txt := trim(txt);
if txt = '' then exit(0);
if txt[1] = '(' then begin
//caso esperado
p := 2; //explora
if not (txt[2] in ['+','-','0'..'9']) then //validación
raise ESynFacilSyn.Create(errMsg + ifFail0);
sign := 1; //signo por defecto
if txt[2] = '+' then begin
p := 3; //siguiente caracter
sign := 1;
if not (txt[3] in ['0'..'9']) then
raise ESynFacilSyn.Create(errMsg + ifFail0);
end;
if txt[2] = '-' then begin
p := 3; //siguiente caracter
sign := -1;
if not (txt[3] in ['0'..'9']) then
raise ESynFacilSyn.Create(errMsg + ifFail0);
end;
//Aquí se sabe que en txt[p], viene un númaro
p0 := p; //guarda posición de inicio
while (p<=length(txt)) and (txt[p] in ['0'..'9']) do inc(p);
Result := StrToInt(copy(txt,p0,p-p0)) * Sign; //lee como número
if txt[p]<>')' then raise ESynFacilSyn.Create(errMsg + ifFail0);
inc(p);
txt := copyEx(txt, p+1);
end else begin
raise ESynFacilSyn.Create(errMsg + ifFail0);
end;
end;
function HavePar(var txt: string): boolean;
//Verifica si la cadena empieza con "("
begin
Result := false;
txt := trim(txt);
if txt = '' then exit;
if txt[1] = '(' then begin //caso esperado
Result := true;
end;
end;
var
inst: String;
n: Integer;
begin
ifMatch0 := ifMatch; //guarda valor original
ifFail0 := ifFail; //guarda valor original
inc(nInstruc);
n := nInstruc-1; //último índice
setlength(Instrucs, nInstruc);
Instrucs[n].expTyp := expTyp; //tipo
Instrucs[n].actionMatch := aomNext; //valor por defecto
Instrucs[n].actionFail := aomExit; //valor por defecto
Instrucs[n].destOnMatch:=0; //valor por defecto
Instrucs[n].destOnFail:= 0; //valor por defecto
Result := nInstruc;
//Configura comportamiento
if ifMatch<>'' then begin
ifMatch := UpCase(ifMatch);
while ifMatch<>'' do begin
inst := extractIns(ifMatch);
if inst = 'NEXT' then begin //se pide avanzar al siguiente
Instrucs[n].actionMatch := aomNext;
end else if inst = 'EXIT' then begin //se pide salir
if HavePar(ifMatch) then begin //EXIT con parámetro
Instrucs[n].actionMatch := aomExitpar;
Instrucs[n].destOnMatch := n + extractPar(ifMatch, ERR_SYN_PAR_IFMATCH_);
end else begin //EXIT sin parámetros
Instrucs[n].actionMatch := aomExit;
end;
end else if inst = 'MOVE' then begin
Instrucs[n].actionMatch := aomMovePar; //Mover a una posición
Instrucs[n].destOnMatch := n + extractPar(ifMatch, ERR_SYN_PAR_IFMATCH_);
end else begin
raise ESynFacilSyn.Create(ERR_SYN_PAR_IFMATCH_ + ifMatch0);
end;
ifMatch := Trim(ifMatch);
if (ifMatch<>'') and (ifMatch[1] = ';') then //quita delimitador
ifMatch := copyEx(ifMatch,2);
end;
end;
if ifFail<>'' then begin
ifFail := UpCase(ifFail);
while ifFail<>'' do begin
inst := extractIns(ifFail);
if inst = 'NEXT' then begin //se pide avanzar al siguiente
Instrucs[n].actionFail := aomNext;
end else if inst = 'EXIT' then begin //se pide salir
if HavePar(ifFail) then begin //EXIT con parámetro
Instrucs[n].actionFail := aomExitpar;
Instrucs[n].destOnFail := n + extractPar(ifFail, ERR_SYN_PAR_IFFAIL_);
end else begin //EXIT sin parámetros
Instrucs[n].actionFail := aomExit;
end;
end else if inst = 'MOVE' then begin
Instrucs[n].actionFail := aomMovePar; //Mover a una posición
Instrucs[n].destOnFail := n + extractPar(ifFail, ERR_SYN_PAR_IFFAIL_);
end else begin
raise ESynFacilSyn.Create(ERR_SYN_PAR_IFFAIL_ + ifFail0);
end;
ifFail := Trim(ifFail);
if (ifFail<>'') and (ifFail[1] = ';') then //quita delimitador
ifFail := copyEx(ifFail,2);
end;
end;
end;
procedure tFaTokContent.AddOneInstruct(var exp: string; ifTrue: string; ifFalse: string;
atMatch: integer=-1; atFail: integer=-1);
{Agrega una y solo instrucción al token por contenido. Si encuentra más de una
instrucción, genera una excepción. Si se pone ifTrue en blnnco, se asumirá 'next',
si se pone "ifFalse" en blanco, se se asumirá 'exit'.
Este es el punto de entrada único para agregar una instrucción de Regex a
tFaTokContent}
var
list: String;
str: string;
n: Integer;
c: Char;
expr: string;
t: tFaRegExpType;
begin
if exp='' then exit;
//analiza
expr := exp; //guarda, porque se va a trozar
t := ExtractRegExp(exp, str, list);
case t of
tregChars, //Es de tipo lista de caracteres [...]
tregChars01, //Es de tipo lista de caracteres [...]?
tregChars0_, //Es de tipo lista de caracteres [...]*
tregChars1_: //Es de tipo lista de caracteres [...]+
begin
n := AddItem(t, ifTrue, ifFalse)-1; //agrega
if atMatch=-1 then Instrucs[n].aMatch :=TokTyp //toma atributo de la clase
else Instrucs[n].aMatch:= atMatch;
if atFail=-1 then Instrucs[n].aFail := TokTyp //toma atributo de la clase
else Instrucs[n].aFail:= atFail;
//Configura caracteres de contenido
for c := #0 to #255 do Instrucs[n].Chars[c] := False;
for c in list do Instrucs[n].Chars[c] := True;
end;
tregString: begin //Es de tipo texto literal
n := AddItem(t, ifTrue, ifFalse)-1; //agrega
if atMatch=-1 then Instrucs[n].aMatch :=TokTyp //toma atributo de la clase
else Instrucs[n].aMatch:= atMatch;
if atFail=-1 then Instrucs[n].aFail := TokTyp //toma atributo de la clase
else Instrucs[n].aFail:= atFail;
//configura cadena
if CaseSensitive then Instrucs[n].Text := str
else Instrucs[n].Text := UpCase(str); //ignora caja
end;
else
raise ESynFacilSyn.Create(ERR_UNSUPPOR_EXP_ + expr);
end;
end;
procedure tFaTokContent.AddInstruct(exp: string; ifTrue: string=''; ifFalse: string='';
atMatch: integer=-1; atFail: integer=-1);
//Agrega una instrucción para el procesamiento del token por contenido.
//Solo se debe indicar una instrucción, de otra forma se generará un error.
var
expr: String;
begin
expr := exp; //guarda, porque se va a trozar
AddOneInstruct(exp, ifTrue, ifFalse, atMatch, atFail); //si hay error genera excepción
//Si llegó aquí es porque se obtuvo una expresión válida, pero la
//expresión continua.
if exp<>'' then begin
raise ESynFacilSyn.Create(ERR_UNSUPPOR_EXP_ + expr);
end;
end;
procedure tFaTokContent.AddRegEx(exp: string; Complete: boolean = false);
{Agrega una expresión regular (un conjunto de instrucciones sin opciones de control), al
token por contenido. Las expresiones regulares deben ser solo las soportadas.
Ejemplos son: "[0..9]*[\.][0..9]", "[A..Za..z]*"
Las expresiones se evalúan parte por parte. Si un token no coincide completamente con la
expresión regular, se considera al token, solamente hasta el punto en que coincide.
Si se produce algún error se generará una excepción.}
var
dToStart: Integer;
begin
if Complete then begin
//Cuando no coincide completamente, retrocede hasta el demimitador incial
dToStart := 0; //distamcia al inicio
while exp<>'' do begin
AddOneInstruct(exp,'','exit(-'+ IntToStr(dToStart) + ')');
Inc(dToStart);
end;
end else begin
//La coinicidencia puede ser parcial
while exp<>'' do begin
AddOneInstruct(exp,'',''); //en principio, siempre debe coger una expresión
end;
end;
end;
{ TSynFacilSynBase }
function TSynFacilSynBase.GetSampleSource: String;
begin
Result := fSampleSource;
end;
//funciones básicas
function TSynFacilSynBase.BuscTokEspec(var mat: TArrayTokSpec; cad: string;
out n: integer; TokPos: integer = 0): boolean;
//Busca una cadena en una matriz TArrayTokSpec. Si la ubica devuelve el índice en "n".
var i : integer;
begin
Result := false;
if TokPos = 0 then begin //búsqueda normal
for i := 0 to High(mat) do begin
if mat[i].txt = cad then begin
n:= i;
exit(true);
end;
end;
end else begin //búsqueda con TokPos
for i := 0 to High(mat) do begin
if (mat[i].txt = cad) and (TokPos = mat[i].TokPos) then begin
n:= i;
exit(true);
end;
end;
end;
end;
function TSynFacilSynBase.ToListRegex(list: TFaXMLatrib): string;
//Reemplaza el contenido de una lista en foramto XML (p.ej. "A..Z") al formato de
//listas de expresiones regulares; "[A-Z]"
//Los caracteres "..", cambian a "-" y el caracter "-", cambia a "\-"
var
tmp: String;
begin
tmp := StringReplace(list.val, '-', '\-',[rfReplaceAll]);
tmp := StringReplace(tmp, '..', '-',[rfReplaceAll]);
Result := '[' + tmp + ']'; //completa con llaves
end;
function TSynFacilSynBase.dStartRegex(tStart, tCharsStart: TFaXMLatrib): string;
//Lee los parámetros XML "Start" y "CharsStart"; y extrae el delimitador inicial
//a usar en formato de Expresión Regular.
begin
//validaciones
if tStart.hay and tCharsStart.hay then begin
//No es un caso válido que se den los dos parámetros
raise ESynFacilSyn.Create(ERR_NOT_USE_START);
end;
if not tStart.hay and not tCharsStart.hay then begin
//Tampoco es un caso válido que no se de ninguno.
raise ESynFacilSyn.Create(ERR_PAR_START_CHARS);
end;
//Hay uno u otro parámetro definido
if tStart.hay then begin
Result := EscapeText(tStart.val); //protege a los caracteres especiales
end else if tCharsStart.hay then begin
Result := ToListRegex(tCharsStart); //convierte a expresión regular como [a..z]
end;
end;
procedure TSynFacilSynBase.VerifDelim(delim: string);
//Verifica la validez de un delimitador para un token delimitado.
//Si hay error genera una excepción.
var c:char;
tmp: string;
begin
//verifica contenido
if delim = '' then
raise ESynFacilSyn.Create(ERR_TOK_DELIM_NULL);
//verifica si inicia con caracter de identificador.
if delim[1] in charsIniIden then begin
//Empieza como identificador. Hay que verificar que todos los demás caracteres
//sean también de identificador, de otra forma no se podrá reconocer el token.
tmp := copy(delim, 2, length(delim) );
for c in tmp do
if not CharsIdentif[c] then begin
raise ESynFacilSyn.Create(format(ERR_TOK_DEL_IDE_ERR,[delim]));
end;
end;
end;
procedure TSynFacilSynBase.ValidateParamStart(Start: string; var ListElem: TStringList);
{Valida si la expresión del parámetro es de tipo <literal> o [<lista de cars>], de
otra forma generará una excepción.
Si es de tipo <literal>, valida que sea un delimitador válido.
Devuelve en "ListElem" una lista con con los caracteres (En el caso de [<lista de cars>])
o un solo elemento con una cadena (En el caso de <literal>). Por ejemplo:
Si Start = 'cadena', entonces se tendrá: ListElem = [ 'cadena' ]
Si Start = '[1..5]', entonces se tendrá: ListElem = ['0','1','2','3','4','5']
Si encuentra error, genera excepción.}
var
t: tFaRegExpType;
listChars: string;
str: string;
c: Char;
begin
if Start= '' then raise ESynFacilSyn.Create(ERR_START_NO_EMPTY);
t := ExtractRegExp(Start, str, listChars);
ListElem.Clear;
if Start<>'' then //la expresión es más compleja
raise ESynFacilSyn.Create(ERR_EXP_MUST_BE_BR);
if t = tregChars then begin
for c in listChars do begin
ListElem.Add(c);
end;
end else if t = tregString then begin //lista simple o literal cadena
VerifDelim(str); //valida reglas
lisTmp.Add(str);
end else //expresión de otro tipo
raise ESynFacilSyn.Create(ERR_EXP_MUST_BE_BR);
end;
procedure TSynFacilSynBase.ValidAsigDelim(delAct, delNue: TFaTypeDelim; delim: string);
//Verifica si la asignación de delimitadores es válida. Si no lo es devuelve error.
begin
if delAct = tdNull then exit; //No estaba inicializado, es totalente factible
//valida asignación de delimitador
if (delAct in [tdUniLin, tdMulLin]) and
(delNue in [tdUniLin, tdMulLin]) then begin
raise ESynFacilSyn.Create(Format(ERR_IDEN_ALREA_DEL,[delim]));
end;
end;
function TSynFacilSynBase.KeyComp(var r: TTokSpec): Boolean; inline;
{Compara rápidamente una cadena con el token actual, apuntado por "fToIden".
El tamaño del token debe estar en "fStringLen"}
var
i: Integer;
Temp: PChar;
begin
Temp := fToIdent;
if Length(r.txt) = fStringLen then begin //primera comparación
if (r.TokPos <> 0) and (r.TokPos<>posTok) then exit(false); //no coincide
Result := True; //valor por defecto
for i := 1 to fStringLen do begin
if TabMayusc[Temp^] <> r.txt[i] then exit(false);
inc(Temp);
end;
end else //definitívamente es diferente
Result := False;
end;
function TSynFacilSynBase.CreaBuscTokEspec(var mat: TArrayTokSpec; cad: string;
out i:integer; TokPos: integer = 0): boolean;
{Busca o crea el token especial indicado en "cad". Si ya existe, devuelve TRUE y
actualiza "i" con su posición. Si no existe. Crea el token especial y devuelve la
referencia en "i". Se le debe indicar la tabla a buscar en "mat"}
var
r:TTokSpec;
begin
if not CaseSensitive then cad:= UpCase(cad); //cambia caja si es necesario
if BuscTokEspec(mat, cad, i, TokPos) then exit(true); //ya existe, devuelve en "i"
//no existe, hay que crearlo. Aquí se definen las propiedades por defecto
r.txt:=cad; //se asigna el nombre
r.TokPos:=TokPos; //se asigna ordinal del token
r.tTok:=-1; //sin tipo asignado
r.typDel:=tdNull; //no es delimitador
r.dEnd:=''; //sin delimitador final
r.pRange:=nil; //sin función de rango
r.folTok:=false; //sin plegado de token
r.chrEsc := #0; //sin caracter de escape
r.openBlk:=false; //sin plegado de bloque
r.closeBlk:=false; //sin plegado de bloque
r.OpenSec:=false; //no es sección de bloque
r.firstSec:=nil; //inicialmente no abre ningún bloque
i := High(mat)+1; //siguiente posición
SetLength(mat,i+1); //hace espacio
mat[i] := r; //copia todo el registro
//sale indicando que se ha creado
Result := false;
end;
//procesamiento de XML
function TSynFacilSynBase.ReadXMLParam(n: TDOMNode; nomb:string): TFaXMLatrib;
//Explora un nodo para ver si existe un atributo, y leerlo. Ignora la caja.
var
i: integer;
cad: string;
atri: TDOMNode;
function EsEntero(txt: string; out num: integer): boolean;
//convierte un texto en un número entero. Si es numérico devuelve TRUE
var i: integer;
begin
Result := true; //valor por defecto
num := 0; //valor por defecto
for i:=1 to length(txt) do begin
if not (txt[i] in ['0'..'9']) then exit(false); //no era
end;
//todos los dígitos son numéricos
num := StrToInt(txt);
end;
begin
Result.hay := false; //Se asume que no existe
Result.val:=''; //si no encuentra devuelve vacío
Result.bol:=false; //si no encuentra devuelve Falso
Result.n:=0; //si no encuentra devuelve 0
for i:= 0 to n.Attributes.Length-1 do begin
atri := n.Attributes.Item[i];
if UpCase(AnsiString(atri.NodeName)) = UpCase(nomb) then begin
Result.hay := true; //marca bandera
Result.val := AnsiString(atri.NodeValue); //lee valor
Result.bol := UpCase(atri.NodeValue) = 'TRUE'; //lee valor booleano
cad := trim(AnsiString(atri.NodeValue)); //valor sin espacios
//lee número
if (cad<>'') and (cad[1] in ['0'..'9']) then //puede ser número
EsEntero(cad,Result.n); //convierte
//Lee color
Result.col := ColorFromStr(cad);
end;
end;
end;
procedure TSynFacilSynBase.CheckXMLParams(n: TDOMNode; listAtrib: string);
//Valida la existencia completa de los nodos indicados. Si encuentra alguno más
//genera excepción. Los nodos deben estar separados por espacios.
var i,j : integer;
atri : TDOMNode;
nombre, tmp : string;
hay : boolean;
begin
//Carga lista de atributos
lisTmp.Clear; //usa lista temproal
lisTmp.Delimiter := ' ';
//StringReplace(listSym, #13#10, ' ',[rfReplaceAll]);
lisTmp.DelimitedText := listAtrib;
//Realiza la verificación
for i:= 0 to n.Attributes.Length-1 do begin
atri := n.Attributes.Item[i];
nombre := UpCase(AnsiString(atri.NodeName));
//verifica existencia
hay := false;
for j:= 0 to lisTmp.Count -1 do begin
tmp := trim(lisTmp[j]);
if nombre = UpCase(tmp) then begin
hay := true; break;
end;
end;
//verifica si no existe
if not hay then begin //Este atributo está demás
raise ESynFacilSyn.Create(format(ERR_INVAL_ATTR_LAB,[atri.NodeName, n.NodeName]));
end;
end;
end;
////Métodos para tokens por contenido
procedure TSynFacilSynBase.metTokCont(const tc: tFaTokContent); //inline;
//Procesa tokens por contenido
var
n,i : Integer;
posFin0: Integer;
nf : Integer;
tam1: Integer;
begin
fTokenID := tc.TokTyp; //No debería ser necesario ya que se asignará después.
inc(posFin); //para pasar al siguiente caracter
n := 0;
while n<tc.nInstruc do begin
tc.Instrucs[n].posFin := posFin; //guarda posición al iniciar
case tc.Instrucs[n].expTyp of
tregString: begin //texo literal
//Rutina de comparación de cadenas
posFin0 := posFin; //para poder restaurar
i := 1;
tam1 := length(tc.Instrucs[n].Text)+1; //tamaño +1
if CaseSensitive then begin //sensible a caja
while (i<tam1) and (tc.Instrucs[n].Text[i] = fLine[posFin]) do begin
inc(posFin);
inc(i);
end;
end else begin //Ignora mayúcula/minúscula
while (i<tam1) and (tc.Instrucs[n].Text[i] = TabMayusc[fLine[posFin]]) do begin
inc(posFin);
inc(i);
end;
end;
//verifica la coincidencia
if i = tam1 then begin //cumple
fTokenID := tc.Instrucs[n].aMatch; //pone atributo
case tc.Instrucs[n].actionMatch of
aomNext:; //no hace nada, pasa al siguiente elemento
aomExit: break; //simplemente sale
aomExitpar: begin //sale con parámetro
nf := tc.Instrucs[n].destOnMatch; //lee posición final
posFin := tc.Instrucs[nf].posFin; //Debe moverse antes de salir
break;
end;
aomMovePar: begin //se mueve a una posición
n := tc.Instrucs[n].destOnMatch; //ubica posición
continue;
end;
end;
end else begin //no cumple
fTokenID := tc.Instrucs[n].aFail; //pone atributo
posFin := posFin0; //restaura posición
case tc.Instrucs[n].actionFail of
aomNext:; //no hace nada, pasa al siguiente elemento
aomExit: break; //simplemente sale
aomExitpar: begin //sale con parámetro
nf := tc.Instrucs[n].destOnFail; //lee posición final
posFin := tc.Instrucs[nf].posFin; //Debe moverse antes de salir
break;
end;
aomMovePar: begin //se mueve a una posición
n := tc.Instrucs[n].destOnFail; //ubica posición
continue;
end;
end;
end;
end;
tregChars: begin //conjunto de caracteres: [ ... ]
//debe existir solo una vez
if tc.Instrucs[n].Chars[fLine[posFin]] then begin
//cumple el caracter
fTokenID := tc.Instrucs[n].aMatch; //pone atributo
inc(posFin); //pasa a la siguiente instrucción
//Cumple el caracter
case tc.Instrucs[n].actionMatch of
aomNext:; //no hace nada, pasa al siguiente elemento
aomExit: break; //simplemente sale
aomExitpar: begin //sale con parámetro
nf := tc.Instrucs[n].destOnMatch; //lee posición final
posFin := tc.Instrucs[nf].posFin; //Debe moverse antes de salir
break;
end;
aomMovePar: begin //se mueve a una posición
n := tc.Instrucs[n].destOnMatch; //ubica posición
continue;
end;
end;
end else begin
//no se encuentra ningún caracter de la lista
fTokenID := tc.Instrucs[n].aFail; //pone atributo
case tc.Instrucs[n].actionFail of
aomNext:; //no hace nada, pasa al siguiente elemento
aomExit: break; //simplemente sale
aomExitpar: begin //sale con parámetro
nf := tc.Instrucs[n].destOnFail; //lee posición final
posFin := tc.Instrucs[nf].posFin; //Debe moverse antes de salir
break;
end;
aomMovePar: begin //se mueve a una posición
n := tc.Instrucs[n].destOnFail; //ubica posición
continue;
end;
end;
end;
end;
tregChars01: begin //conjunto de caracteres: [ ... ]?
//debe existir cero o una vez
if tc.Instrucs[n].Chars[fLine[posFin]] then begin
inc(posFin); //pasa a la siguiente instrucción
end;
//siempre cumplirá este tipo, no hay nada que verificar
fTokenID := tc.Instrucs[n].aMatch; //pone atributo
case tc.Instrucs[n].actionMatch of
aomNext:; //no hace nada, pasa al siguiente elemento
aomExit: break; //simplemente sale
aomExitpar: begin //sale con parámetro
nf := tc.Instrucs[n].destOnMatch; //lee posición final
posFin := tc.Instrucs[nf].posFin; //Debe moverse antes de salir
break;
end;
aomMovePar: begin //se mueve a una posición
n := tc.Instrucs[n].destOnMatch; //ubica posición
continue;
end;
end;
end;
tregChars0_: begin //conjunto de caracteres: [ ... ]*
//debe exitir 0 o más veces
while tc.Instrucs[n].Chars[fLine[posFin]] do begin
inc(posFin);
end;
//siempre cumplirá este tipo, no hay nada que verificar
fTokenID := tc.Instrucs[n].aMatch; //pone atributo
//¿No debería haber código aquí también?
end;
tregChars1_: begin //conjunto de caracteres: [ ... ]+
//debe existir una o más veces
posFin0 := posFin; //para poder comparar
while tc.Instrucs[n].Chars[fLine[posFin]] do begin
inc(posFin);
end;
if posFin>posFin0 then begin //Cumple el caracter
fTokenID := tc.Instrucs[n].aMatch; //pone atributo
case tc.Instrucs[n].actionMatch of
aomNext:; //no hace nada, pasa al siguiente elemento
aomExit: break; //simplemente sale
aomExitpar: begin //sale con parámetro
nf := tc.Instrucs[n].destOnMatch; //lee posición final
posFin := tc.Instrucs[nf].posFin; //Debe moverse antes de salir
break;
end;
aomMovePar: begin //se mueve a una posición
n := tc.Instrucs[n].destOnMatch; //ubica posición
continue;
end;
end;
end else begin //No cumple
fTokenID := tc.Instrucs[n].aFail; //pone atributo
case tc.Instrucs[n].actionFail of
aomNext:; //no hace nada, pasa al siguiente elemento
aomExit: break; //simplemente sale
aomExitpar: begin //sale con parámetro
nf := tc.Instrucs[n].destOnFail; //lee posición final
posFin := tc.Instrucs[nf].posFin; //Debe moverse antes de salir
break;
end;
aomMovePar: begin //se mueve a una posición
n := tc.Instrucs[n].destOnFail; //ubica posición
continue;
end;
end;
end;
end;
end;
inc(n);
end;
end;
procedure TSynFacilSynBase.metTokCont1; //Procesa tokens por contenido 1
begin
metTokCont(tc1);
end;
procedure TSynFacilSynBase.metTokCont2; //Procesa tokens por contenido 2
begin
metTokCont(tc2);
end;
procedure TSynFacilSynBase.metTokCont3; //Procesa tokens por contenido 3
begin
metTokCont(tc3);
end;
procedure TSynFacilSynBase.metTokCont4; //Procesa tokens por contenido 3
begin
metTokCont(tc4);
end;
//Procesamiento de otros elementos
procedure TSynFacilSynBase.metIdent;
//Procesa el identificador actual
begin
inc(posFin); {debe incrementarse, para pasar a comparar los caracteres siguientes,
o de otra forma puede quedarse en un lazo infinito}
while CharsIdentif[fLine[posFin]] do inc(posFin);
fTokenID := tnIdentif; //identificador común
end;
procedure TSynFacilSynBase.metIdentUTF8;
//Procesa el identificador actual. considerando que empieza con un caracter UTF8 (dos bytes)
begin
inc(posFin); {es UTF8, solo filtra por el primer caracter (se asume que el segundo
es siempre válido}
inc(posFin); {debe incrementarse, para pasar a comparar los caracteres siguientes,
o de otra forma puede quedarse en un lazo infinito}
while CharsIdentif[fLine[posFin]] do inc(posFin);
fTokenID := tnIdentif; //identificador común
end;
procedure TSynFacilSynBase.metNull;
//Procesa la ocurrencia del cacracter #0
begin
fTokenID := tnEol; //Solo necesita esto para indicar que se llegó al final de la línae
end;
procedure TSynFacilSynBase.metSpace;
//Procesa caracter que es inicio de espacio
begin
fTokenID := tnSpace;
repeat //captura todos los que sean espacios
Inc(posFin);
until (fLine[posFin] > #32) or (posFin = tamLin);
end;
procedure TSynFacilSynBase.metSymbol;
begin
inc(posFin);
while (fProcTable[fLine[posFin]] = @metSymbol)
do inc(posFin);
fTokenID := tnSymbol;
end;
//Funciones públicas
procedure TSynFacilSynBase.DefTokIdentif(dStart, Content: string );
{Define token para identificadores. Los parámetros deben ser intervalos.
El parámetro "dStart" deben ser de la forma: "[A..Za..z]"
El parámetro "charsCont" deben ser de la forma: "[A..Za..z]*"
Si los parámetros no cumplen con el formato se generará una excepción.
Se debe haber limpiado previamente con "ClearMethodTables"}
var
c : char;
t : tFaRegExpType;
listChars: string;
str: string;
begin
/////// Configura caracteres de inicio
if dStart = '' then exit; //protección
t := ExtractRegExp(dStart, str, listChars);
if (t <> tregChars) or (dStart<>'') then //solo se permite el formato [ ... ]
raise ESynFacilSyn.Create(ERR_BAD_PAR_STR_IDEN);
//Agrega evento manejador en caracteres iniciales
charsIniIden := []; //inicia
for c in listChars do begin //permite cualquier caracter inicial
if c<#128 then begin //caracter normal
fProcTable[c] := @metIdent;
charsIniIden += [c]; //agrega
end else begin //caracter UTF-8
fProcTable[c] := @metIdentUTF8;
charsIniIden += [c]; //agrega
end;
end;
/////// Configura caracteres de contenido
t := ExtractRegExp(Content, str, listChars);
if (t <> tregChars0_) or (Content<>'') then //solo se permite el formato [ ... ]*
raise ESynFacilSyn.Create(ERR_BAD_PAR_CON_IDEN);
//limpia matriz
for c := #0 to #255 do begin
CharsIdentif[c] := False;
//aprovecha para crear la tabla de mayúsculas para comparaciones
if CaseSensitive then
TabMayusc[c] := c
else begin //pasamos todo a mayúscula
TabMayusc[c] := UpCase(c);
end;
end;
//marca las posiciones apropiadas
for c in listChars do CharsIdentif[c] := True;
end;
//Manejo de atributos
function TSynFacilSynBase.NewTokAttrib(TypeName: string; out TokID: integer
): TSynHighlighterAttributes;
{Crea un nuevo atributo y lo agrega al resaltador. Este debe ser el único punto de
entrada, para crear atributos en SynFacilSyn. En tokID, se devuelve el ID del nuevo tipo.
No hay funciones para eliminar atributs creados.}
var
n: Integer;
begin
Result := TSynHighlighterAttributes.Create(TypeName);
n := High(Attrib)+1; //tamaño
setlength(Attrib, n + 1); //incrementa tamaño
Attrib[n] := Result; //guarda la referencia
tokID := n; //devuelve ID
AddAttribute(Result); //lo registra en el resaltador
end;
function TSynFacilSynBase.NewTokType(TypeName: string; out
TokAttrib: TSynHighlighterAttributes): integer;
{Crea un nuevo tipo de token, y devuelve la referencia al atributo en "TokAttrib".}
begin
TokAttrib := NewTokAttrib(TypeName, Result);
end;
function TSynFacilSynBase.NewTokType(TypeName: string): integer;
{Versión simplificada de NewTokType, que devuelve directamente el ID del token}
begin
NewTokAttrib(TypeName, Result);
end;
procedure TSynFacilSynBase.CreateAttributes;
//CRea los atributos por defecto
begin
//Elimina todos los atributos creados, los fijos y los del usuario.
FreeHighlighterAttributes;
setlength(Attrib, 0); //limpia
{ Crea los atributos que siempre existirán. }
tkEol := NewTokAttrib('Eol', tnEol); //atributo de nulos
tkSymbol := NewTokAttrib('Symbol', tnSymbol); //atributo de símbolos
tkSpace := NewTokAttrib('Space', tnSpace); //atributo de espacios.
tkIdentif := NewTokAttrib('Identifier', tnIdentif); //Atributo para identificadores.
tkNumber := NewTokAttrib('Number', tnNumber); //atributo de números
tkNumber.Foreground := clFuchsia;
tkKeyword := NewTokAttrib('Keyword',tnKeyword); //atribuuto de palabras claves
tkKeyword.Foreground:=clGreen;
tkString := NewTokAttrib('String', tnString); //atributo de cadenas
tkString.Foreground := clBlue;
tkComment := NewTokAttrib('Comment', tnComment); //atributo de comentarios
tkComment.Style := [fsItalic];
tkComment.Foreground := clGray;
end;
function TSynFacilSynBase.GetAttribByName(txt: string): TSynHighlighterAttributes;
{Devuelve la referencia de un atributo, recibiendo su nombre. Si no lo encuentra
devuelve NIL.}
var
i: Integer;
begin
txt := UpCase(txt); //ignora la caja
//También lo puede buscar en Attrib[]
for i:=0 to AttrCount-1 do begin
if Upcase(Attribute[i].Name) = txt then begin
Result := Attribute[i]; //devuelve índice
exit;
end;
end;
//No se encontró
exit(nil);
end;
function TSynFacilSynBase.GetAttribIDByName(txt: string): integer;
{Devuelve el identificador de un atributo, recibiendo su nombre. Si no lo encuentra
devuelve -1.}
var
i: Integer;
begin
txt := UpCase(txt); //ignora la caja
//Se tiene que buscar en Attrib[], proque allí están con los índices cprrectos
for i:=0 to AttrCount-1 do begin
if Upcase(Attrib[i].Name) = txt then begin
Result := i; //devuelve índice
exit;
end;
end;
//No se encontró
exit(-1);
end;
function TSynFacilSynBase.IsAttributeName(txt: string): boolean;
//Verifica si una cadena corresponde al nombre de un atributo.
begin
//primera comparación
if GetAttribByName(txt) <> nil then exit(true);
//puede que haya sido "NULL"
if UpCase(txt) = 'NULL' then exit(true);
//definitivamente no es
Result := False;
end;
function TSynFacilSynBase.ProcXMLattribute(nodo: TDOMNode): boolean;
//Verifica si el nodo tiene la etiqueta <ATTRIBUTTE>. De ser así, devuelve TRUE y lo
//procesa. Si encuentra error, genera una excepción.
var
tName: TFaXMLatrib;
tBackCol: TFaXMLatrib;
tForeCol: TFaXMLatrib;
tFrameCol: TFaXMLatrib;
tFrameEdg: TFaXMLatrib;
tFrameSty: TFaXMLatrib;
tStyBold: TFaXMLatrib;
tStyItal: TFaXMLatrib;
tStyUnder: TFaXMLatrib;
tStyStrike: TFaXMLatrib;
tStyle: TFaXMLatrib;
tipTok: TSynHighlighterAttributes;
Atrib: TSynHighlighterAttributes;
tokId: integer;
begin
if UpCase(nodo.NodeName) <> 'ATTRIBUTE' then exit(false);
Result := true; //encontró
////////// Lee parámetros //////////
tName := ReadXMLParam(nodo,'Name');
tBackCol := ReadXMLParam(nodo,'BackCol');
tForeCol := ReadXMLParam(nodo,'ForeCol');
tFrameCol:= ReadXMLParam(nodo,'FrameCol');
tFrameEdg:= ReadXMLParam(nodo,'FrameEdg');
tFrameSty:= ReadXMLParam(nodo,'FrameSty');
tStyBold := ReadXMLParam(nodo,'Bold');
tStyItal := ReadXMLParam(nodo,'Italic');
tStyUnder:= ReadXMLParam(nodo,'Underline');
tStyStrike:=ReadXMLParam(nodo,'StrikeOut');
tStyle := ReadXMLParam(nodo,'Style');
CheckXMLParams(nodo, 'Name BackCol ForeCol FrameCol FrameEdg FrameSty '+
'Bold Italic Underline StrikeOut Style');
////////// cambia atributo //////////
if IsAttributeName(tName.val) then begin
tipTok := GetAttribByName(tName.val); //tipo de atributo
end else begin
//No existe, se crea.
tipTok := NewTokAttrib(tName.val, tokId);
end;
//obtiene referencia
Atrib := tipTok;
//asigna la configuración del atributo
if Atrib <> nil then begin
if tBackCol.hay then Atrib.Background:=tBackCol.col;
if tForeCol.hay then Atrib.Foreground:=tForeCol.col;
if tFrameCol.hay then Atrib.FrameColor:=tFrameCol.col;
if tFrameEdg.hay then begin
case UpCase(tFrameEdg.val) of
'AROUND':Atrib.FrameEdges:=sfeAround;
'BOTTOM':Atrib.FrameEdges:=sfeBottom;
'LEFT': Atrib.FrameEdges:=sfeLeft;
'NONE': Atrib.FrameEdges:=sfeNone;
end;
end;
if tFrameSty.hay then begin
case UpCase(tFrameSty.val) of
'SOLID': Atrib.FrameStyle:=slsSolid;
'DASHED':Atrib.FrameStyle:=slsDashed;
'DOTTED':Atrib.FrameStyle:=slsDotted;
'WAVED': Atrib.FrameStyle:=slsWaved;
end;
end;
if tStyBold.hay then begin //negrita
if tStyBold.bol then Atrib.Style:=Atrib.Style+[fsBold]
else Atrib.Style:=Atrib.Style-[fsBold];
end;
if tStyItal.hay then begin //cursiva
if tStyItal.bol then Atrib.Style:=Atrib.Style+[fsItalic]
else Atrib.Style:=Atrib.Style-[fsItalic];
end;
if tStyUnder.hay then begin //subrayado
if tStyUnder.bol then Atrib.Style:=Atrib.Style+[fsUnderline]
else Atrib.Style:=Atrib.Style-[fsUnderline];
end;
if tStyStrike.hay then begin //tachado
if tStyStrike.bol then Atrib.Style:=Atrib.Style+[fsStrikeOut]
else Atrib.Style:=Atrib.Style-[fsStrikeOut];
end;
if tStyle.hay then begin //forma alternativa
Atrib.Style:=Atrib.Style-[fsBold]-[fsItalic]-[fsUnderline]-[fsStrikeOut];
if Pos('b', tStyle.val)<>0 then Atrib.Style:=Atrib.Style+[fsBold];
if Pos('i', tStyle.val)<>0 then Atrib.Style:=Atrib.Style+[fsItalic];
if Pos('u', tStyle.val)<>0 then Atrib.Style:=Atrib.Style+[fsUnderline];
if Pos('s', tStyle.val)<>0 then Atrib.Style:=Atrib.Style+[fsStrikeOut];
end;
end;
end;
constructor TSynFacilSynBase.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
setlength(Attrib, 0);
end;
var
i: integer;
initialization
//prepara definición de comodines
bajos[0] := #127;
for i:=1 to 127 do bajos[i] := chr(i); //todo menos #0
altos[0] := #128;
for i:=1 to 128 do altos[i] := chr(i+127);
end.
EvoUMLPlugin/src/SynFacilCompletion.pas 0 → 100644
View file @ 29d6d4f7
{
SynFacilCompletion
==================
Por Tito Hinostroza
Pendientes:
* Incluir una forma simplficada de la forma <OpenOn AfterIdentif="Alter">, para simplificar
la definición clásica.
* Ver el trabajo de la librería con caracteres UTF-8 de dos bytes.
* Optimizar el método LookAround(), evitando tener que leer dos veces la línea actual
y de ser posible creando una rutina personalizada, en lugar de usar ExploreLine().
* Incluir el manejo de las ventanas de tipo "Tip", como ayuda para los parámetros de las
funciones.
* Hacer que la ventana de completado haga seguimiento del cursor, cuando este retrocede
mucho en un identificador.
* Realizar dos pasadas en la etiqueta <completion>, para que se puedan definir las listas
en cualquier parte.
}
{Descripción
============
Unidad que expande al resaltador TSynFacilSyn, para que pueda soportar configuraciones
de autocompletado de texto.
Se usa de forma similar a SynFacilSyn. Se debe crear un resaltador, pero ahora de la
clase TSynFacilComplet:
uses ... , SynFacilCompletion;
procedure TForm1.FormShow(Sender: TObject);
begin
//configure highlighter
hlt := TSynFacilComplet.Create(self); //my highlighter
SynEdit1.Highlighter := hlt; //optional if we are going to use SelectEditor()
hlt.LoadFromFile('./languages/ObjectPascal.xml'); //load syntax
hlt.SelectEditor(SynEdit1); //assign to editor
end;
Luego se debe interceptar los evento KeyUp y UTF8KeyPress, del SynEdit:
procedure TForm1.SynEdit1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
hlt.KeyUp(Sender, Key, Shift);
end;
procedure TForm1.SynEdit1UTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
begin
hlt.UTF8KeyPress(Sender, UTF8Key);
end;
Y se debe terminar correctamente:
procedure TForm1.FormDestroy(Sender: TObject);
begin
hlt.UnSelectEditor; //release editor (only necessary if we are to call to SelectEditor(), again)
hlt.Free; //destroy the highlighter
end;
Cuando se desea desaparecer la ventana de ayuda contextual por algún evento, se debe
llamar a CloseCompletionWindow().
}
unit SynFacilCompletion;
{$mode objfpc}{$H+}
//{$define Verbose}
interface
uses
Classes, SysUtils, fgl, Dialogs, XMLRead, DOM, LCLType, Graphics, Controls,
SynEdit, SynEditHighlighter, SynEditTypes, SynEditKeyCmds, Lazlogger,
SynFacilHighlighter, SynFacilBasic, SynCompletion;
type
TFaTokInfoPtr = ^TFaTokInfo;
{ TFaCompletItem }
TFaCompletItem = class
private
fCaption: string; //etiqueta a mostrar en el menú
Replac : string; //contenido a reemplazar
Descrip: string; //descripción del campo
idxIcon: integer; //índice al ícono
function ExtractField(var str: string): string;
procedure SetCaption(AValue: string);
public
property Caption: string read FCaption write SetCaption;
function StartWith(const c: char): boolean; inline;
function StartWithU(const c: char): boolean; inline;
end;
//TFaCompletItemPtr = ^TFaCompletItem;
TFaCompletItems = specialize TFPGObjectList<TFaCompletItem>;
//Filtros que se pueden aplicar a la lista mostrada
TFaFilterList = (
fil_None, //Sin filtro. Muestra todos
fil_LastTok, //por el tokem -1
fil_LastTokPart, //por el token -1, hasta donde está el cursor
fil_LastIdent, //por el identificador anterior (usa su propia rutina para identifificadores)
fil_LastIdentPart //similar pero toma hasta el cursor
);
//Objeto lista para completado
{ TFaCompletionList }
TFaCompletionList = class
Name : string;
Items: TFaCompletItems; //lista de las palabras disponibles
procedure AddItems(list: string; idxIcon: integer);
public
constructor Create;
destructor Destroy; override;
end;
//Colección de listas
TFaCompletionLists = specialize TFPGObjectList<TFaCompletionList>;
//Tipo de Elemento del patrón
TFaTPatternElementKind = (
pak_none, //tipo no definido
pak_String, //es literal cadena
pak_Identif, //es token identificador (tkKeyword, tkIndetifier, ...)
pak_NoIdentif, //no es token identificador
pak_TokTyp, //es un tipo específico de token
pak_NoTokTyp //no es un tipo específico de token
);
//Elemento del patrón
TFaPatternElement = record
patKind: TFaTPatternElementKind;
str : string; //valor, cuando es del tipo pak_String
toktyp : integer; //valor cuando es de tipo pak_TokTyp o pak_NoTokTyp
end;
TFaPatternElementPtr = ^TFaPatternElement;
{Tipos de secuencias de escape que se puede indicar para el reemplazo de texto.
No son todas las secuencias de escape, sino solo las que necesitan procesarse
independientemente para ejecutar correctamente la acción de reemplazo.}
TFaCompletSeqType = (
csqNone, //no es secuencia de escape
csqCurPos, //secuencia que indica posición del cursor
csqTabSpa //tabulación al nivel del primer caracter de línea anterior
);
//Entorno del cursor
{ TFaCursorEnviron }
TFaCursorEnviron = class
private
hlt: TSynFacilSyn; //referencia al resaltador que lo contiene
tokens : TATokInfo; //lista de tokens actuales
StartIdentif : integer; //inicio de identificador
function ExtractStaticText(var ReplaceSeq: string; out seq: TFaCompletSeqType
): string;
procedure InsertSequence(ed: TSynEdit; Pos1, Pos2: TPoint; ReplaceSeq: string);
procedure UpdateStartIdentif;
public
inMidTok : boolean; //indica si el cursor está en medio de un token
tok0 : TFaTokInfoPtr; //referencia al token actual.
tok_1 : TFaTokInfoPtr; //referencia al token anterior.
tok_2 : TFaTokInfoPtr; //referencia al token anterior a tok_1.
tok_3 : TFaTokInfoPtr; //referencia al token anterior a tok_2.
CurX : Integer; //posición actual del cursor
CurY : Integer; //posición actual del cursor
curLine : string; //línea actual de exploración
curBlock : TFaSynBlock; //referencia al bloque actual
caseSen : boolean; //indica el estado de caja actual
procedure LookAround(ed: TSynEdit; CaseSen0: boolean);
//Las siguientes funciones, deben llaamrse después de lamar a LookAround()
function HaveLastTok: boolean;
function LastTok: string;
function LastTokPart: string;
function HaveLastIdent: boolean;
function LastIdent: string;
function LastIdentPart: string;
//Estas funciones implementan las acciones
procedure ReplaceLastTok(ed: TSynEdit; ReplaceSeq: string);
procedure ReplaceLastIden(ed: TSynEdit; ReplaceSeq: string);
procedure Insert(ed: TSynEdit; ReplaceSeq: string);
public
constructor Create(hlt0: TSynFacilSyn);
end;
TFaOpenEvent = class;
TFaOnLoadItems = procedure(opEve: TFaOpenEvent; curEnv: TFaCursorEnviron;
out Cancel: boolean) of object;
//Acciones válidas que se realizarán al seleccionar un ítem
TFAPatAction = (
pac_None, //no se realiza ninguna acción
pac_Default, //acción pro defecto
pac_Insert, //se inserta el texto seleccionado en la posición del cursor
pac_Rep_LastTok //se reemplaza el token anterior
);
//Objeto evento de apertura
{ TFaOpenEvent }
TFaOpenEvent = class
private
hlt: TSynFacilSyn; //referencia al resaltador que lo contiene
{Los índices de elem[] representan posiciones relativas de tokens
[0] -> Token que está justo después del cursor (token actual)
[-1] -> Token que está antes del token actual
[-2] -> Token que está antes del token [-1]
[-3] -> Token que está antes del token [-2] }
elem : array[-3..0] of TFaPatternElement;
nBef : integer; //número de elementos válidos haste el ítem 0 (puede ser 0,1,2 o 3)
nAft : integer; //número de elementos válidos depués del ítem 0 (puede ser 0 o 1)
procedure ExtractElementIn(var befPat: string;
patEle: TFaPatternElementPtr; var ErrStr: string);
function MatchPatternElement(nPe: integer; tokX: TFaTokInfoPtr;
CaseSens: boolean): boolean;
function MatchPatternBefore(const curEnv: TFaCursorEnviron): boolean;
function MatchPatternAfter(const curEnv: TFaCursorEnviron): boolean;
function MatchPattern(const curEnv: TFaCursorEnviron): boolean;
procedure ShiftBeforePattern;
public
name : string; //nombre del evento de apertura
startX: integer; //posición inicial del token o identificador de trabajo
filter: TFaFilterList;
block : TFaSynBlock; //bloque donde es válido
Action: TFAPatAction; //Acción al seleccionar lista
OnLoadItems: TFaOnLoadItems; //Se llama antes de cargar los ítems.
procedure FilterByChar(curEnv: TFaCursorEnviron; const c: char);
procedure DoAction(ed: TSynEdit; env: TFaCursorEnviron; ReplaceSeq: string);
procedure FillFilteredIn(const env: TFaCursorEnviron; lst: TStrings); //Llena Items en una lista
//manejo patrones
procedure ClearBeforePatt; //limpia el patron anterior
procedure ClearAfterPatt; //limpia el patron anterior
procedure AddBeforeElement(var befPat: string; out ErrStr: string);
procedure AddAfterElement(var aftPat: string; var ErrStr: string);
public //Manejo de ítems
Items : TFaCompletItems; //Lista de las palabras disponibles para el completado
Lists : TFaCompletionLists; //Referencias a listas
Avails: TFaCompletItems; //Ítems a cargar cuando se active el patrón.
procedure ClearItems;
procedure LoadItems(curEnv: TFaCursorEnviron);
procedure AddItem(txt: string; idxIcon: integer);
procedure AddItems(lst: TStringList; idxIcon: integer);
procedure AddItems(list: string; idxIcon: integer);
procedure AddList(Alist: TFaCompletionList; OnlyRef: boolean);
procedure ClearAvails;
procedure AddAvail(txt: string); //Rutina simple para agregar cadena a Avails
procedure Clear;
public
constructor Create(hlt0: TSynFacilSyn);
destructor Destroy; override;
end;
//Lista de patrones
TFaOpenEvents = specialize TFPGObjectList<TFaOpenEvent>;
type
{ TSynCompletionF }
{Clase personalizada de "TSynCompletion" usada para el completado con "TSynFacilComplet"}
TSynCompletionF = class(TSynCompletion)
function OnSynCompletionPaintItem(const {%H-}AKey: string; ACanvas: TCanvas; X,
Y: integer; {%H-}IsSelected: boolean; Index: integer): boolean;
public
IconList: TImageList; //lista de íconos
procedure Refresh;
constructor Create(AOwner: TComponent); override;
end;
{ TSynFacilComplet }
//clase principal
TSynFacilComplet = class(TSynFacilSyn)
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure OnCodeCompletion(var Value: string; SourceValue: string;
var SourceStart, SourceEnd: TPoint; KeyChar: TUTF8Char; Shift: TShiftState);
procedure FormUTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
protected
ed : TSynEdit; //referencia interna al editor
MenuComplet: TSynCompletionF;//menú contextual
curEnv : TFaCursorEnviron; //entorno del cursor
UtfKey : TUTF8Char; //tecla pulsada
SpecIdentifiers: TArrayTokSpec;
SearchOnKeyUp : boolean; //bandera de control
procedure MenuComplet_OnExecute(Sender: TObject); virtual;
function CheckForClose: boolean;
procedure FillCompletMenuFiltered;
procedure ProcCompletionLabel(nodo: TDOMNode);
procedure ReadSpecialIdentif;
private //Manejo de patrones de apertura
CompletLists: TFaCompletionLists; //colección de listas de compleatdo
function FindOpenEventMatching: TFaOpenEvent;
function GetIconList: TImageList;
procedure ProcXMLOpenOn(nodo: TDOMNode);
procedure SetIconList(AValue: TImageList);
public //Manejo de patrones de apertura
OpenEvents : TFaOpenEvents; //lista de eventos de apertura
CurOpenEve : TFaOpenEvent; //evento de apertura que se aplica en el momento
function FindOpenEvent(oeName: string): TFaOpenEvent; //Busca un evento de apertura
public
CompletionOn: boolean; //activa o desactiva el auto-completado
SelectOnEnter: boolean; //habilita la selección con enter
CaseSensComp: boolean; //Uso de caja, en autocompletado
OpenOnKeyUp: boolean; //habilita que se abra automáticamente al soltar una tecla
property IconList: TImageList read GetIconList write SetIconList;
function AddOpenEvent(AfterPattern, BeforePattern: string;
filter: TFaFilterList): TFaOpenEvent;
function AddComplList(lstName: string): TFaCompletionList;
function GetListByName(lstName: string): TFaCompletionList;
procedure LoadFromFile(const Filename: string); override;
function LoadSyntaxFromPath(SourceFile: string; path: string;
CaseSens: boolean=false): string;
procedure SelectEditor(ed0: TSynEdit); //inicia la ayuda contextual
procedure UnSelectEditor; //termina la ayuda contextual con el editor
procedure UTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
procedure KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure OpenCompletionWindow(vKey: word; vShift: TShiftState; vUtfKey: TUTF8Char
);
procedure CloseCompletionWindow;
public //Constructor y Destructor
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
//utilidades
function ReadExtenFromXML(XMLfile: string): string;
function XMLFileHaveExten(XMLfile: string; exten: string;
CaseSens: boolean = false): boolean;
implementation
uses SynEditMiscProcs;
const
// ERR_ATTRIB_NO_EXIST = 'Atributo %s no existe. (etiqueta <COMPLETION ...>)';
// ERR_FILTER_NO_EXIST = 'Filtro %s no existe. (etiqueta <OpenOn ...>)';
// ERR_INVAL_LAB_COMP = 'Etiqueta %s no válida para etiqueta <COMPLETION ...>';
// ERR_INVAL_BLK_NAME = 'Nombre de bloque inválido.';
// ERROR_LOADING_ = 'Error loading: ';
// ERR_PAT_EXP_ENDSTR = 'Se esperaba fin de cadena';
// ERR_PAT_INVALID_ = 'Invalido: %s';
// ERR_PAT_SYNTAX_ERR = 'Error de sintaxis.';
// ERR_PAT_TOO_MAN_EL = 'Demasiados elementos.';
// ERR_PAR_AFT_PATT = 'Error en "BeforePattern"';
// ERR_PAR_BEF_PATT = 'Error en "AfterPattern"';
ERR_ATTRIB_NO_EXIST = 'Attribute %s doesn''t exist. (label <OpenOn ...>)';
ERR_LIST_NO_EXIST = 'List "%s" doesn''t exist. (label <OpenOn ...>)';
ERR_FILTER_NO_EXIST = 'Filter %s doesn''t exist. (label <OpenOn ...>)';
ERR_ACTION_NO_EXIST = 'Action %s doesn''t exist. (label <OpenOn ...>)';
ERR_INVAL_LAB_OPNON = 'Invalid label %s for <OpenOn ...>';
ERR_INVAL_LAB_COMP = 'Invalid label %s for <COMPLETION ...>';
ERR_INVAL_BLK_NAME = 'Invalid block name.';
ERROR_LOADING_ = 'Error loading: ';
ERR_PAT_EXP_ENDSTR = 'Expected end of string';
ERR_PAT_INVALID_ = 'Invalid: %s';
ERR_PAT_SYNTAX_ERR = 'Syntax error.';
ERR_PAT_TOO_MAN_EL = 'Too many elements.';
ERR_PAR_AFT_PATT = 'Error in "AfterPattern"';
ERR_PAR_BEF_PATT = 'Error in "BeforePattern"';
//Constantes para manejar parámetros de <OpenOn>
WORD_CHARS = ['a'..'z','0'..'9','A'..'Z','_'];
STR_DELIM = ['''','"'];
ALL_IDENTIF = 'AllIdentifiers';
//Para el reconocimiento de identificadores, cuando se usa "fil_LastIdent" y "fil_LastIdentPart"
CHAR_STRT_IDEN = ['a'..'z','A'..'Z','_'];
CHAR_BODY_IDEN = CHAR_STRT_IDEN + ['0'..'9'];
function ReadExtenFromXML(XMLfile: string): string;
//Lee las extensiones que tiene definidas un archivo de sintaxis.
var doc: TXMLDocument;
atri: TDOMNode;
i: Integer;
begin
try
Result := ''; //por defecto
ReadXMLFile(doc, XMLfile); //carga archivo
//busca el parámetro "ext"
for i:= 0 to doc.DocumentElement.Attributes.Length-1 do begin
atri := doc.DocumentElement.Attributes.Item[i];
if UpCase(atri.NodeName) = 'EXT' then begin
Result := trim(AnsiString(atri.NodeValue)); //valor sin espacios
end;
end;
doc.Free; //libera
except
on E: Exception do begin
ShowMessage(ERROR_LOADING_ + XMLfile + #13#10 + e.Message);
doc.Free;
end;
end;
end;
function XMLFileHaveExten(XMLfile: string; exten: string;
CaseSens: boolean = false): boolean;
//Indica si un archivo XML de sintaxis, tiene definida la extensión que se indica
//La comparación se puede hacer con o sin diferecnia de caja
var
lext: TStringList;
s: String;
tmp: String;
begin
Result := false; //por defecto
lext:= TStringList.Create; //crea lista
tmp := ReadExtenFromXML(XMLfile); //lee archivo
lext.DelimitedText:=' ';
lext.Text:=tmp; //divide
//busca de acuerdo a la caja
if CaseSens then begin
for s in lext do begin
if s = exten then begin
//encontró
Result := true;
lext.Free;
exit;
end;
end;
end else begin
for s in lext do begin
if Upcase(s) = Upcase(exten) then begin
//encontró
Result := true;
lext.Free;
exit;
end;
end;
end;
//No enecontró
lext.Free;
end;
{ TFaCompletItem }
function TFaCompletItem.ExtractField(var str: string): string;
{Extrae un campo de la cadena. Los campos deben estar delimitado con "|" sin caracter
de escape}
function EscapeBefore(i: integer): boolean; inline;
begin
if i<1 then exit(false);
if str[i-1] = '\' then exit(true) else exit(false);
end;
var
psep: SizeInt;
begin
psep := pos('|', str);
if (psep = 0) or EscapeBefore(psep) then begin
//no hay separador de campos, es un caso simple
Result := str;
str := '';
end else begin
//hay separador
Result:=copy(str,1,psep-1);
str := copy(str, psep+1, length(str));
end;
end;
procedure TFaCompletItem.SetCaption(AValue: string);
{Asigna el valor a Caption, separando los campos si es que vinieran codificados}
{Recibe una cadena que representa a un ítem y de el extrae los campos, si es que vinieran
codificados. El formato de la codificiacón es:
<texto a mostrar> | <texto a reemplazar> | <descripción>
}
function ExecEscape(const s: string): string;
{Reemplaza las secuencias de escape para mostrarlas en el menú de completado.
Tal vez convenga hacer este reemplazo, en la rutina que muestra los ítems, por un
tema de velocidad.}
begin
Result := StringReplace(s, '\n', ' ', [rfReplaceAll]);
Result := StringReplace(Result, '\t', ' ', [rfReplaceAll]);
Result := StringReplace(Result, '\u', ' ', [rfReplaceAll]);
Result := StringReplace(Result, '\\', '\', [rfReplaceAll]);
Result := StringReplace(Result, '\|', '|', [rfReplaceAll]);
Result := StringReplace(Result, '\_', '', [rfReplaceAll]);
end;
var
txt1, txt2: String;
begin
if fCaption=AValue then Exit;
txt1 := ExtractField(AValue);
if AValue='' then begin
//solo hay un campo
fCaption :=ExecEscape(txt1);
Replac :=txt1; //los caracteres de escape se expandirán al reemplazar
Descrip :='';
end else begin
//hay al menos otro campo
txt2 := ExtractField(AValue);
if AValue = '' then begin
//hay solo dos campos
fCaption :=ExecEscape(txt1);
Replac := txt2; //los caracteres de escape se expandirán al reemplazar
Descrip :='';
end else begin
//has 3 o más campos
fCaption :=ExecEscape(txt1);
Replac := txt2; //los caracteres de escape se expandirán al reemplazar
Descrip := ExecEscape(AValue);
end;
end;
end;
function TFaCompletItem.StartWith(const c: char): boolean;
begin
Result := (fCaption<>'') and (fCaption[1] = c);
end;
function TFaCompletItem.StartWithU(const c: char): boolean;
begin
Result := (fCaption<>'') and (UpCase(fCaption[1]) = c);
end;
{ TFaCompletionList }
procedure TFaCompletionList.AddItems(list: string; idxIcon: integer);
//Agrega una lista de ítems, separados por espacios, a la lista de completado
var
lst: TStringList;
i: Integer;
it: TFaCompletItem;
begin
//divide
lst := TStringList.Create;
lst.Delimiter := ' ';
lst.DelimitedText := list;
//agrega
for i:= 0 to lst.Count-1 do begin
it := TFaCompletItem.Create;
it.Caption := lst[i];
it.idxIcon:=idxIcon;
Items.Add(it);
end;
lst.Destroy;
end;
constructor TFaCompletionList.Create;
begin
Items:= TFaCompletItems.Create(true); //lista con administración
end;
destructor TFaCompletionList.Destroy;
begin
Items.Destroy;
inherited Destroy;
end;
{ TFaCursorEnviron }
constructor TFaCursorEnviron.Create(hlt0: TSynFacilSyn);
begin
hlt := hlt0;
end;
procedure TFaCursorEnviron.LookAround(ed: TSynEdit; CaseSen0: boolean);
{Analiza el estado del cursor en el editor. Se supone que se debe llamar, después de
actualizar el editor. Actualiza: PosiCursor, curBlock, tok0, tok_1, tok_2
y tok_3. Utiliza punteros, para evitar perder tiempo creando copias.}
var
iTok0 : integer; //índice al token actual
begin
caseSen:=CaseSen0; //actualiza estado
//valores por defecto
curBlock := nil;
//explora la línea con el resaltador
hlt.ExploreLine(ed.CaretXY, tokens, iTok0);
curLine := ed.Lines[ed.CaretY-1]; //Se gaurda porque se va a necesitar
if iTok0=-1 then exit; //no ubica al token actual
tok0 := @tokens[iTok0]; //lee token actual token[0]
CurX := ed.LogicalCaretXY.x; //usa posición física para comparar
CurY := ed.LogicalCaretXY.y;
inMidTok := tokens[iTok0].posIni+1 <> CurX; //actualiza bandera
//actualiza tok_1
if inMidTok then begin
tok_1 := @tokens[iTok0];
if iTok0>0 then tok_2 := @tokens[iTok0-1]
else tok_2 := nil;
if iTok0>1 then tok_3 := @tokens[iTok0-2]
else tok_3 := nil;
end else begin
if iTok0>0 then tok_1 := @tokens[iTok0-1]
else tok_1 := nil;
if iTok0>1 then tok_2 := @tokens[iTok0-2]
else tok_2 := nil;
if iTok0>2 then tok_3 := @tokens[iTok0-3]
else tok_3 := nil;
end;
//captura "curBlock"
curBlock := tok0^.curBlk; //devuelve bloque
{$IFDEF Verbose}
DbgOut(' LookAround:(');
if tok_3<>nil then DbgOut(hlt.Attrib[tok_3^.TokTyp].Name+',');
if tok_2<>nil then DbgOut(hlt.Attrib[tok_2^.TokTyp].Name+',');
if tok_1<>nil then DbgOut(hlt.Attrib[tok_1^.TokTyp].Name+',');
if tok0<>nil then DbgOut(hlt.Attrib[tok0^.TokTyp].Name);
debugln(')');
{$ENDIF}
end;
{Las siguientes funciones, deben llamarse después de lamar a LookAround(). Deben ser de
ejecución rápida}
function TFaCursorEnviron.HaveLastTok: boolean; inline;
begin
Result := (tok_1 <> nil);
end;
function TFaCursorEnviron.LastTok: string; inline;
{Devuelve el último token}
begin
Result := tok_1^.txt;
end;
function TFaCursorEnviron.LastTokPart: string; inline;
{Devuelve el último token, truncado a la posición del cursor}
begin
// Result := copy(tok0^.txt,1,CurX-tok0^.posIni-1);
Result := copy(tok_1^.txt, 1, CurX-tok_1^.posIni-1);
end;
procedure TFaCursorEnviron.UpdateStartIdentif;
{Actualiza el índice al inicio del identificador anterior, a la posición actual del cursor.
Este es un algoritmo, un poco especial, porque los identificadores no se
definen para explorarlos hacia atrás.}
var
i: Integer;
begin
StartIdentif := -1; //valor por defecto
if CurX<=1 then exit; //está al inicio
i:= CurX-1; //caracter anterior al cursor
{Se asume que el cursor, está después de un identificador y retrocede por los
caracteres hasta encontrar un caracter que pueda ser inicio de identificador}
while (i>0) and (curLine[i] in CHAR_BODY_IDEN) do begin
if curLine[i] in CHAR_STRT_IDEN then begin
StartIdentif := i; //guarda una posible posición de inicio
end;
dec(i);
end;
end;
function TFaCursorEnviron.HaveLastIdent: boolean;
{Indica si hay un identificador antes del cursor. Debe llamarse siempre antes de
usar LastIdent().}
begin
UpdateStartIdentif;
Result := (StartIdentif <> -1);
end;
function TFaCursorEnviron.LastIdent: string;
{Devuelve el identificador anterior al cursor. Debe llamarse siempre despues de llamar
a HaveLastIdent}
var
i: Integer;
begin
{Ya sabemos que hay identificador hasta antes del cursor, ahora debemos ver, hasta
dónde se extiende}
i := CurX;
while curLine[i] in CHAR_BODY_IDEN do //no debería ser necesario verificar el final
inc(i);
Result := copy(curLine, StartIdentif, i-StartIdentif+1);
end;
function TFaCursorEnviron.LastIdentPart: string;
{Devuelve el identificador anterior al cursor. Debe llamarse siempre despues de llamar
a HaveLastIdent}
begin
Result := copy(curLine, StartIdentif, CurX-StartIdentif);
end;
{Estas funciones implementan las acciones. Procesan las secuencias de escape}
function TFaCursorEnviron.ExtractStaticText(var ReplaceSeq: string;
out seq: TFaCompletSeqType): string;
{Extrae un fragmento de texto de "ReplaceSeq", que puede insertarse directamente en el editor,
sin necesidad de hacer cálculos de posición, o que no contengan comandos de posicionamiento
del cursor. La idea es que el texto que se devuelva aquí, se pueda insertar directamente
en el editor con una simple operación "Insert". El tipo de secuencia que produjo la ruptura,
se devuelve en "seq"}
function ReplaceEscape(const s: string): string;
begin
Result := StringReplace(s, '\n', LineEnding, [rfReplaceAll]);
Result := StringReplace(Result, '\t', #9, [rfReplaceAll]);
Result := StringReplace(Result, '\|', '|', [rfReplaceAll]);
Result := StringReplace(Result, '\\', '\', [rfReplaceAll]);
end;
function FirstPos(substrs: array of string; str: string; out found: string): integer;
{Busca la ocurrencia de cualquiera de las cadenas dadas en "substrs". Devuelve el índice
a la primera encontrada. Si no enceuntra ninguna, devuelve 0.}
var
i, p: Integer;
limit: Integer;
lin: string;
begin
Result := 0; //valor inicial
found := '';
limit := length(str);
for i:=0 to high(substrs) do begin
lin := copy(str, 1, limit);
p := Pos(substrs[i], lin);
if p<>0 then begin
//encontró uno, compara
if p<limit then begin
limit := p; //restringe límite para la siguiente búsqueda
found := substrs[i]; //lo que enontró
Result := p;
end;
end;
end;
end;
var
p: Integer;
hay: string;
begin
//Detcta las secuencias de posición de cursor, o tabulación '\u'.
p := FirstPos(['\_','\u'], ReplaceSeq, hay); //tabulación al primer caracter no blanco de la línea superior no blanca
if hay = '' then begin
//No hay secuecnia especial
Result := ReplaceEscape(ReplaceSeq);
seq := csqNone; //no se ecnontró secuencia de ruptura
ReplaceSeq := '';
end else if hay = '\_' then begin
//primero está la secuencia de cursor
Result := ReplaceEscape(copy(ReplaceSeq,1,p-1));
seq := csqCurPos; //Indica secuencia de posicionamiento de cursor
ReplaceSeq := copy(ReplaceSeq, p+2, length(ReplaceSeq));
end else if hay = '\u' then begin
//primero está la secuencia de tabulación
Result := ReplaceEscape(copy(ReplaceSeq,1,p-1));
seq := csqTabSpa; //Indica secuencia
ReplaceSeq := copy(ReplaceSeq, p+2, length(ReplaceSeq));
end;
end;
procedure TFaCursorEnviron.InsertSequence(ed: TSynEdit; Pos1, Pos2: TPoint; ReplaceSeq: string);
{Inserta una secuencia de reemplazo en el bloque definido por P1 y P2}
function FindNoWhiteLineUp(ed: TSynEdit): string;
{Busca hacia arriba, una línea con caracteres diferentes de espacio y que ocupen una posición
más a la derecha de la posición actual del cursor. La búsqueda se hace a partir de la
posición actual del cursor. Si no encuentra, devuelve línea en blanco.}
var
x,y: Integer;
lin: String;
begin
y := ed.CaretY-1; //desde la línea anterior
x := ed.CaretX;
while y>0 do begin
lin := ed.Lines[y-1];
if trim(copy(lin,x, length(lin)))<>'' then
exit(lin);
dec(y);
end;
//no encontró
exit('');
end;
var
toRepl: String;
cursorPos: TPoint;
seq: TFaCompletSeqType;
linNoWhite, curLin: String;
i, dif: Integer;
begin
ed.BeginUndoBlock;
ed.TextBetweenPointsEx[Pos1,Pos2, scamEnd] := ''; //elimina el contenido y deja cursor al final
cursorPos.x := -1; //marca bandera
while ReplaceSeq<>'' do begin
toRepl := ExtractStaticText(ReplaceSeq, seq);
case seq of
csqNone: begin
//no hay ruptura, es un texto sencillo
//reemplaza y deja cursor al final
Pos1 := ed.CaretXY;
ed.TextBetweenPointsEx[Pos1,Pos1, scamEnd] := toRepl;
//se suepone que esta es la última secuencia
end;
csqCurPos: begin
//hay comando de posicionamiento de cursor
//reemplaza, deja cursor al final y guarda posición
Pos1 := ed.CaretXY;
ed.TextBetweenPointsEx[Pos1,Pos1, scamEnd] := toRepl;
cursorPos := ed.CaretXY;
end;
csqTabSpa: begin
//hay comando de tabulación inteligente
Pos1 := ed.CaretXY;
//inserta fragmento
ed.TextBetweenPointsEx[Pos1,Pos1, scamEnd] := toRepl;
//calcula espaciado
linNoWhite := FindNoWhiteLineUp(ed);
if linNoWhite<>'' then begin
//hay línea sin blancos, busca posición de caracter no blanco
for i:=ed.CaretX to length(linNoWhite) do begin
//La definición de blanco #1..#32, corresponde al resaltador
if not (linNoWhite[i] in [#1..#32]) then begin
//Encontró. Ahora hay que posicionar el cursor en "i".
curLin := ed.LineText; //línea actual
if length(curLin)<i then begin
//No hay caracteres, en donde se quiere colocar el cursor.
dif := i - length(curLin); //esto es lo que falta
ed.CaretX := length(curLin)+1; //pone cursor al final
ed.InsertTextAtCaret(Space(dif)); {Completa con espacios. Usa InsertTextAtCaret,
para poder deshacer.}
ed.CaretX:=i; //ahora sí se puede posicionar el cursor.
end else begin
//Se puede posicionar directamente
ed.CaretX:=i;
end;
break; //sale del FOR
end;
end;
{Si llega aquí sin encontrar el caracter buscado, indicaria que el
algoritmo de búsqueda de FindNoWhiteLineUp() no es consistente con este código.}
end;
end;
end;
end;
if cursorPos.x<>-1 then begin
//ha habido posicionamiento de cursor
ed.CaretXY := cursorPos;
end;
ed.EndUndoBlock;
end;
procedure TFaCursorEnviron.ReplaceLastTok(ed: TSynEdit; ReplaceSeq: string);
{Reemplaza el último token}
var
Pos1, Pos2: TPoint;
begin
if not HaveLastTok then exit;
Pos1 := Point(tok_1^.posIni + 1, CurY);
Pos2 := Point(tok_1^.posIni + tok_1^.length+1, CurY);
//Realiza el reemplazo del texto, con procesamiento
InsertSequence(ed, Pos1, Pos2, ReplaceSeq);
end;
procedure TFaCursorEnviron.ReplaceLastIden(ed: TSynEdit; ReplaceSeq: string);
{Reemplaza el último identificador}
var
Pos1, Pos2: TPoint;
i: Integer;
begin
if not HaveLastIdent then exit;
Pos1 := Point(StartIdentif, CurY);
i := CurX;
while (i<=length(curLine)) and (curLine[i] in CHAR_BODY_IDEN) do
inc(i);
Pos2 := Point(i, CurY);
InsertSequence(ed, Pos1, Pos2, ReplaceSeq);
end;
procedure TFaCursorEnviron.Insert(ed: TSynEdit; ReplaceSeq: string);
{Reemplaza un texto en la posición actual del cursor}
var
Pos1: TPoint;
begin
Pos1 := Point(CurX, CurY);
InsertSequence(ed, Pos1, Pos1, ReplaceSeq);
end;
{ TFaOpenEvent }
procedure TFaOpenEvent.DoAction(ed: TSynEdit; env: TFaCursorEnviron;
ReplaceSeq: string);
{Ejecuta la acción que se tenga definido para el evento de apertura}
begin
case Action of
pac_None:; //no ahce nada
pac_Default: //acción por defecto
case Filter of
fil_None: ; //no hay elemento de selcción
fil_LastTok,
fil_LastTokPart: //trabaja con el último token
env.ReplaceLastTok(ed, ReplaceSeq);
fil_LastIdent,
fil_LastIdentPart: //trabaja con el úmtimo identificador
env.ReplaceLastIden(ed, ReplaceSeq);
end;
pac_Insert: //inserta
env.Insert(ed, ReplaceSeq);
pac_Rep_LastTok:
env.ReplaceLastTok(ed, ReplaceSeq);
{Se pueden completar más acciones}
else
env.ReplaceLastTok(ed, ReplaceSeq);
end;
end;
procedure TFaOpenEvent.FillFilteredIn(const env: TFaCursorEnviron; lst: TStrings);
{Filtra los ítems que contiene (usando "env") y los pone en la lista indicada}
procedure FilterBy(const str: string);
//Llena el menú de completado a partir de "Avails", filtrando solo las
//palabras que coincidan con "str"
var
l: Integer;
it: TFaCompletItem;
str2: String;
begin
l := length(str);
//Genera la lista que coincide
if env.caseSen then begin
for it in Avails do begin
//esta no es la forma más eficiente de comparar, pero sirve por ahora.
if str = copy(it.fCaption,1,l) then
// lst.Add(Avails[i]^.text);
lst.AddObject(it.fCaption, it);
end;
end else begin //ignora la caja
str2 := UpCase(str);
for it in Avails do begin
if str2 = upcase(copy(it.fCaption,1,l)) then begin
// lst.Add(Avails[i]^.text);
lst.AddObject(it.fCaption, it);
end;
end;
end;
end;
var
it: TFaCompletItem;
begin
case Filter of
fil_None: begin //agrega todos
for it in Avails do begin //agrega sus ítems
lst.AddObject(it.fCaption, it);
end;
end;
fil_LastTok: begin //último token
if env.HaveLastTok then
FilterBy(env.LastTok);
end;
fil_LastTokPart: begin //último token hasta el cursor
if env.HaveLastTok then
FilterBy(env.LastTokPart);
end;
fil_LastIdent: begin //último token
if env.HaveLastIdent then
FilterBy(env.LastIdent);
end;
fil_LastIdentPart: begin //último token hasta el cursor
if env.HaveLastIdent then
FilterBy(env.LastIdentPart);
end;
end;
end;
//manejo de elementos de patrones
procedure TFaOpenEvent.ClearBeforePatt;
begin
elem[-3].patKind := pak_none;
elem[-2].patKind := pak_none;
elem[-1].patKind := pak_none;
nBef:=0; //no hay elementos válidos
end;
procedure TFaOpenEvent.ClearAfterPatt;
begin
elem[0].patKind := pak_none;
nAft:=0; //no hay
end;
procedure TFaOpenEvent.ExtractElementIn(var befPat: string; patEle:TFaPatternElementPtr;
var ErrStr: string);
{Extrae un elemento de un patrón de tokens que viene en cadena y lo almacena en "patEle".
La cadena puede ser algo así como "Identifier,'.',AllIdentifiers".
Si encuentra error, devuelve el mensaje en "ErrStr".}
function ExtractIdentifier(var befPat: string): string;
{Extrae un identificador de la cadena "befPat"}
var
i: Integer;
begin
i := 1;
while (i<=length(befPat)) and (befPat[i] in WORD_CHARS) do begin
inc(i);
end;
Result := copy(befPat, 1,i-1); //extrae cadena
befPat := copy(befPat, i, length(befPat)); //recorta
end;
function ExtractString(var befPat: string; var ErrStr: string): string;
{Extrae una cadena de "befPat". Si hay error devuelve mensaje en "ErrStr"}
var
i: Integer;
ci: Char;
begin
ci := befPat[1]; //caracter inicial
i := 2;
while (i<=length(befPat)) and (befPat[i] <> ci) do begin
inc(i);
end;
if i>length(befPat) then begin
ErrStr := ERR_PAT_EXP_ENDSTR;
exit;
end;
Result := copy(befPat, 1,i); //extrae cadena
befPat := copy(befPat, i+1, length(befPat)); //recorta
end;
procedure ExtractChar(var befPat: string);
begin
befPat := copy(befPat, 2, length(befPat));
end;
procedure ExtractComma(var befPat: string);
begin
befPat := TrimLeft(befPat); //quita espacios
//quita posible coma final
if (befPat<>'') and (befPat[1] = ',') then
befPat := copy(befPat, 2, length(befPat));
end;
var
strElem: String;
begin
if befPat[1] in WORD_CHARS then begin
//Es un identificador: tipo de token o la cadena especial "AllIdentifiers"
strElem := ExtractIdentifier(befPat);
if upcase(strElem) = upcase(ALL_IDENTIF) then begin
//es de tipo "Todos los identificadores"
patEle^.patKind := pak_Identif;
end else if hlt.IsAttributeName(strElem) then begin //es
//Es nombre de tipo de token
patEle^.patKind := pak_TokTyp;
patEle^.toktyp := hlt.GetAttribIDByName(strElem); //tipo de atributo
end else begin //no es, debe haber algún error
ErrStr := Format(ERR_PAT_INVALID_,[strElem]);
exit;
end;
ExtractComma(befpat);
end else if befPat[1] = '!' then begin
//debe ser de tipo "No es ..."
ExtractChar(befPat);
strElem := ExtractIdentifier(befPat);
if upcase(strElem) = upcase(ALL_IDENTIF) then begin
//es de tipo "Todos los identificadores"
patEle^.patKind := pak_NoIdentif;
end else if hlt.IsAttributeName(strElem) then begin
//Es nombre de tipo de token
patEle^.patKind := pak_NoTokTyp;
patEle^.toktyp := hlt.GetAttribIDByName(strElem); //tipo de atributo
end else begin //no es, debe haber algún error
ErrStr := Format(ERR_PAT_INVALID_,[strElem]);
exit;
end;
ExtractComma(befpat);
end else if befPat[1] in STR_DELIM then begin
//es un literal cadena
strElem := ExtractString(befPat, ErrStr);
if ErrStr<>'' then exit;
patEle^.patKind := pak_String;
patEle^.str:= copy(strElem, 2, length(strElem)-2);
ExtractComma(befpat);
end else begin
ErrStr := ERR_PAT_SYNTAX_ERR;
exit;
end;
end;
procedure TFaOpenEvent.AddBeforeElement(var befPat: string; out ErrStr: string);
{Agrega un elemento al patrón anterior. Si encuentra error devuelve el mensaje en ErrStr}
var
patEle: ^TFaPatternElement;
begin
ErrStr := '';
befPat := TrimLeft(befPat); //quita espacios
if befPat='' then exit; //no hay elementos
//Hay algo que agregar
if nBef=3 then begin //validación
ErrStr := ERR_PAT_TOO_MAN_EL; //no hay espacio
exit;
end;
ShiftBeforePattern; //hace espacio
patEle := @elem[-1]; //fija puntero
ExtractElementIn(befPat, patEle, ErrStr);
//puede salir con mensaje de error en "ErrStr"
end;
procedure TFaOpenEvent.AddAfterElement(var aftPat: string; var ErrStr: string);
{Agrega un elemento al patrón siguiente. Si encuentra error devuelve el mensaje en ErrStr}
var
patEle: ^TFaPatternElement;
begin
ErrStr := '';
aftPat := TrimLeft(aftPat); //quita espacios
if aftPat='' then exit; //no hay elementos
//Hay algo que agregar
if nAft=1 then begin //validación
ErrStr := ERR_PAT_TOO_MAN_EL; //no hay espacio
exit;
end;
inc(nAft); //lleva la cuenta
patEle := @elem[0]; //fija puntero
ExtractElementIn(aftPat, patEle, ErrStr);
//puede salir con mensaje de error en "ErrStr"
end;
procedure TFaOpenEvent.ShiftBeforePattern;
{Desplaza los elementos del patrón anterior, a la izquierda, dejando el de la derecha
libre para usarlo. No toca al patrón siguiente}
begin
elem[-3] := elem[-2];
elem[-2] := elem[-1];
elem[-1].patKind := pak_none;
Inc(nBef); //actualiza elementos anteriores válidos
end;
procedure TFaOpenEvent.AddAvail(txt: string);
{Agrega un ítem a la lista Avails[]}
var
it: TFaCompletItem;
begin
it := TFaCompletItem.Create;
it.Caption:=txt;
it.Replac:=txt;
it.idxIcon:=-1;
Avails.Add(it);
end;
procedure TFaOpenEvent.Clear;
begin
ClearAvails;
ClearItems;
end;
//manejo de ítems
procedure TFaOpenEvent.FilterByChar(curEnv: TFaCursorEnviron; const c: char);
{Filtra la lista Items[], usando un caracter. Se define como público, para poder usarla
como utilidad, si es que se necesita.}
var
it: TFaCompletItem;
lst: TFaCompletionList;
cu: Char;
begin
Avails.Clear;
if curEnv.caseSen then begin
for it in Items do begin
if it.StartWith(c) then Avails.Add(it); //copia las referencias
end;
//copia ítens de las listas
for lst in Lists do begin
for it in lst.Items do begin
if it.StartWith(c) then Avails.Add(it); //copia las referencias
end;
end;
end else begin
cu := UpCase(c);
for it in Items do begin
if it.StartWithU(cu) then Avails.Add(it); //copia las referencias
end;
//copia ítens de las listas
for lst in Lists do begin
for it in lst.Items do begin
if it.StartWithU(cu) then Avails.Add(it); //copia las referencias
end;
end;
end;
end;
procedure TFaOpenEvent.LoadItems(curEnv: TFaCursorEnviron);
{Carga todos los ítems con los que se va a trabajar en Avails[]. Los que se usarán para
posteriormente filtrarse y cargarse al menú de completado.}
var
it: TFaCompletItem;
lst: TFaCompletionList;
Cancel: boolean;
begin
if OnLoadItems<>nil then begin
//Hay evento configruado para llenar dinámciamente los ítems
OnLoadItems(self, curEnv, Cancel);
{$IFDEF Verbose}
debugln(' LLenado dinámico de ítems con %d elem.', [items.Count]);
{$ENDIF}
if Cancel then exit;
end;
case filter of
fil_None: begin //no hay filtro
Avails.Assign(Items); //copia todas las referencias
//Agrega, también las referencias de las listas que pueda contener.
for lst in Lists do begin
for it in lst.Items do begin
Avails.Add(it); //copia las referencias
end;
end;
startX := curEnv.CurX; //como no hay palabra de trabajo
end;
fil_LastTok,
fil_LastTokPart: begin //se usará el último token
if curEnv.HaveLastTok then begin
//hay un token anterior
startX := curEnv.tok_1^.posIni; //inicio del token
FilterByChar(curEnv, curEnv.LastTok[1]); //primer caracter como filtro (peor caso)
end;
end;
fil_LastIdent,
fil_LastIdentPart: begin //se usará el último identif.
if curEnv.HaveLastIdent then begin
//hay un token anterior
startX := curEnv.StartIdentif; //es fácil sacar el inicio del identificador
FilterByChar(curEnv, curEnv.LastIdentPart[1]); //primer caracter como filtro (peor caso)
end;
end;
else //no debería pasar
Avails.Clear;
startX := curEnv.CurX;
end;
{$IFDEF Verbose}
debugln(' Cargados en Avail: '+IntToStr(Avails.Count)+ ' ítems.')
{$ENDIF}
end;
function TFaOpenEvent.MatchPatternElement(nPe: integer; tokX: TFaTokInfoPtr;
CaseSens: boolean): boolean;
{Verifica el elemento de un patrón, coincide con un token de tokens[]. }
var
pe: TFaPatternElement;
begin
Result := false; //por defecto
pe := elem[nPe]; //no hay validación. Por velocidad, podría ser mejor un puntero.
if tokX = nil then exit(false); //no existe este token
case pe.patKind of
pak_none: //*** No definido.
exit(true); //No debería llegar aquí.
pak_String: begin //*** Es una cadena
if CaseSens then begin //comparación con caja
if tokX^.txt = pe.str then exit(true)
else exit(false);
end else begin //comparación sin caja
if UpCase(tokX^.txt) = UpCase(pe.str) then exit(true)
else exit(false);
end;
end;
pak_Identif: begin //*** Es identificador
Result := tokX^.IsIDentif;
end;
pak_NoIdentif: begin
Result := not tokX^.IsIDentif;
end;
pak_TokTyp: begin //*** Es un tipo específico de token
Result := pe.toktyp = tokX^.TokTyp;
end;
pak_NoTokTyp: begin //*** Es un tipo específico de token
Result := not (pe.toktyp = tokX^.TokTyp);
end;
end;
end;
function TFaOpenEvent.MatchPatternBefore(const curEnv: TFaCursorEnviron
): boolean;
{Verifica si el patrón indicado, cumple con las condiciones actuales (before)}
begin
Result := false; //por defecto
case nBef of
0: begin //no hay elementos, siempre cumple |
exit(true);
end;
1: begin //hay elem[-1]
Result := MatchPatternElement(-1, curEnv.tok_1, curEnv.caseSen);
end;
2: begin //hay elem[-2],elem[-1]
Result := MatchPatternElement(-1, curEnv.tok_1, curEnv.caseSen) and
MatchPatternElement(-2, curEnv.tok_2, curEnv.caseSen);
end;
3: begin //hay elem[-3],elem[-2],elem[-1]
Result := MatchPatternElement(-1, curEnv.tok_1, curEnv.caseSen) and
MatchPatternElement(-2, curEnv.tok_2, curEnv.caseSen) and
MatchPatternElement(-3, curEnv.tok_3, curEnv.caseSen);
end;
end;
end;
function TFaOpenEvent.MatchPatternAfter(const curEnv: TFaCursorEnviron
): boolean;
{Verifica si el patrón indicado, cumple con las condiciones actuales (after)}
begin
Result := false; //por defecto
case nAft of
0: begin //no hay elementos, siempre cumple
exit(true);
end;
1: begin //hay elem[0]
//es independiente de "inMidTok"
Result := MatchPatternElement(0, curEnv.tok0, curEnv.caseSen);
end;
end;
end;
function TFaOpenEvent.MatchPattern(const curEnv: TFaCursorEnviron): boolean;
function ItemInBlock: boolean; inline;
begin
Result := (block = nil) or //es válido para todos los bloques
(block = curEnv.curBlock);
end;
begin
Result := MatchPatternBefore(curEnv) and
MatchPatternAfter(curEnv) and ItemInBlock;
{$IFDEF Verbose}
if Result then debugln(' -> Aplicable Pat: %s con %d elem.', [name, items.Count]);
{$ENDIF}
end;
procedure TFaOpenEvent.AddItem(txt: string; idxIcon: integer);
{Agrega un ítem al evento de apertura. Versión simplificada}
var
it: TFaCompletItem;
begin
it := TFaCompletItem.Create;
it.Caption := txt;
it.idxIcon:=idxIcon;
Items.Add(it);
end;
procedure TFaOpenEvent.AddItems(lst: TStringList; idxIcon: integer);
{Agrega una lista de ítems al evento de apertura, desde un TStringList}
var
it: TFaCompletItem;
i: Integer;
begin
for i:= 0 to lst.Count-1 do begin
it := TFaCompletItem.Create;
it.Caption := lst[i];
it.idxIcon:=idxIcon;
Items.Add(it);
end;
end;
procedure TFaOpenEvent.AddItems(list: string; idxIcon: integer);
{Agrega una lista de ítems al evento de apertura, desde una cadena }
var
lst: TStringList;
begin
lst := TStringList.Create;
//troza
lst.Delimiter := ' ';
lst.DelimitedText := list;
//agrega
AddItems(lst, idxIcon);
lst.Destroy;
end;
procedure TFaOpenEvent.AddList(Alist: TFaCompletionList; OnlyRef: boolean);
{Agrega los datos de una lista o la referencia.}
begin
if OnlyRef then begin
Lists.Add(Alist); //solo guarda la referencia
end else begin
//No implementado. Es problemático incluir referencias de objetos no administrados.
//Lo mejor sería usar una lista adicional, sin administración de objetos.
// for it in Alist.Items do begin
// Items.Add(it);
// end;
end;
end;
procedure TFaOpenEvent.ClearAvails;
begin
Avails.Clear;
end;
procedure TFaOpenEvent.ClearItems;
begin
Items.Clear;
end;
constructor TFaOpenEvent.Create(hlt0: TSynFacilSyn);
begin
Items:= TFaCompletItems.Create(true); //Lista con administración
Avails:= TFaCompletItems.Create(false); //referecnias sin administración
Lists := TFaCompletionLists.Create(false);
hlt := hlt0;
end;
destructor TFaOpenEvent.Destroy;
begin
Lists.Destroy;
Avails.Destroy;
Items.Destroy;
inherited Destroy;
end;
{ TSynCompletionF }
function TSynCompletionF.OnSynCompletionPaintItem(const AKey: string;
ACanvas: TCanvas; X, Y: integer; IsSelected: boolean; Index: integer): boolean;
var
// MaxX: Integer;
// hl: TSynCustomHighlighter;
Capt: String;
idIcon: Integer;
obj: TObject;
begin
{
ACanvas.Font.Style:=[];
if not IsSelected then
ACanvas.Font.Color := FActiveEditDefaultFGColor
else
ACanvas.Font.Color := FActiveEditSelectedFGColor;
MaxX:=TheForm.ClientWidth;}
{ hl := nil;
if Editor <> nil then
hl := Editor.Highlighter;}
Capt := ItemList[Index];
if IconList<>nil then begin
obj := ItemList.Objects[Index];
if obj=nil then begin
//Puede pasar cuando no se ha asignado un objeto, sino solo texto
idIcon := -1
end else begin
idIcon := TFaCompletItem(obj).idxIcon;
end;
IconList.Draw(ACanvas, X+2, Y, idIcon);
ACanvas.TextOut(X+20, Y, Capt);
end else begin
ACanvas.TextOut(X+2, Y, Capt);
// PaintCompletionItem(AKey, ACanvas, X, Y, MaxX, IsSelected, Index, self);
end;
Result:=true; //para indicar que lo intercepta
end;
procedure TSynCompletionF.Refresh;
begin
if ItemList.Count = 0 then begin
//cierra por no tener elementos
Deactivate;
end else begin
//hay elementos
Position:=0; //selecciona el primero
end;
TheForm.Invalidate; //para que se actualice
end;
constructor TSynCompletionF.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
TheForm.ShowSizeDrag := True;
//intercepta este evento
OnPaintItem:=@OnSynCompletionPaintItem;
end;
{ TSynFacilComplet }
procedure TSynFacilComplet.ReadSpecialIdentif;
//Hace una exploración para leer todos los identificadores especiales en la tabla
//SpecIdentifiers[].
var
met: TFaProcMetTable;
p: TPtrATokEspec;
c: Char;
i: Integer;
n: Integer;
begin
setlength(SpecIdentifiers,0);
if CaseSensitive then begin
for c in ['A'..'Z','a'..'z'] do begin
TableIdent(c, p, met);
if p<> nil then begin
for i:= 0 to high(p^) do begin
n := high(SpecIdentifiers)+1; //tamaño de matriz
setlength(SpecIdentifiers,n+1);
SpecIdentifiers[n] := p^[i];
end;
end;
end;
end else begin //no es sensible a la caja
for c in ['A'..'Z'] do begin
TableIdent(c, p, met);
if p<> nil then begin
for i:= 0 to high(p^) do begin
n := high(SpecIdentifiers)+1; //tamaño de matriz
setlength(SpecIdentifiers,n+1);
SpecIdentifiers[n] := p^[i];
end;
end;
end;
end;
end;
function TSynFacilComplet.LoadSyntaxFromPath(SourceFile: string; path: string;
CaseSens: boolean = false): string;
//Carga un archivo de sintaxis, buscando el resaltador apropiado en un directorio.
//Si encuentra el archivo de sintaxis apropiado, devuelve el nombre del archivo usado
//(sin incluir la ruta), de otra forma, devuelve una cadena vacía.
var
ext: String;
Hay: Boolean;
SR : TSearchRec;
rut: String;
begin
Result := '';
ext := ExtractFileExt(SourceFile);
if ext<>'' then ext := copy(ext, 2, 10); //quita el punto
//explora los lenguajes para encontrar alguno que soporte la extensión dada
Hay := FindFirst(path + '\*.xml',faAnyFile - faDirectory, SR) = 0;
while Hay do begin
//encontró archivo, lee sus extensiones
rut := path + '\' + SR.name;
if XMLFileHaveExten(rut, ext, CaseSens) then begin //encontró
LoadFromFile(rut); //carga sintaxis
Result := SR.name;
exit;
end;
//no encontró extensión, busca siguiente archivo
Hay := FindNext(SR) = 0;
end;
//no encontró
end;
procedure TSynFacilComplet.SetIconList(AValue: TImageList);
begin
// if FIconList=AValue then Exit;
MenuComplet.IconList := AValue;
end;
function TSynFacilComplet.FindOpenEvent(oeName: string): TFaOpenEvent;
var
eve: TFaOpenEvent;
begin
for eve in OpenEvents do begin
if eve.name = oeName then exit(eve);
end;
exit(nil);
end;
procedure TSynFacilComplet.ProcXMLOpenOn(nodo: TDOMNode);
{Procesa el bloque <OpenOn ... >}
procedure GetItemsFromNode(nodo: TDOMNode; opEve: TFaOpenEvent; idxIcon: integer);
var
listIden: DOMString;
i,j : Integer;
nodo2: TDOMNode;
lst: TFaCompletionList;
tIncAttr, tIncList: TFaXMLatrib;
tipTok: integer;
tIncIcnI: TFaXMLatrib;
IncIcnI: Integer;
begin
listIden := nodo.TextContent;
if listIden<>'' then begin
//Se ha especificado lista de palabras. Los carga
opEve.AddItems(AnsiString(listIden), idxIcon);
end;
//explora nodos
for i := 0 to nodo.ChildNodes.Count-1 do begin
nodo2 := nodo.ChildNodes[i];
if UpCAse(nodo2.NodeName)='INCLUDE' then begin //incluye lista de palabras por atributo
//lee parámetros
tIncAttr := ReadXMLParam(nodo2,'Attribute');
tIncList := ReadXMLParam(nodo2,'List');
tIncIcnI := ReadXMLParam(nodo2,'IconIndex');
CheckXMLParams(nodo2, 'Attribute List IconIndex'); //puede generar excepción
if tIncAttr.hay then begin
//se pide agregar la lista de identificadores de un atributo en especial
if IsAttributeName(tIncAttr.val) then begin
tipTok := GetAttribIDByName(tIncAttr.val); //tipo de atributo
if tIncIcnI.hay then IncIcnI := tIncIcnI.n else IncIcnI:=-1;
//busca los identificadores para agregarlos
for j:= 0 to high(SpecIdentifiers) do begin
if SpecIdentifiers[j].tTok = tipTok then begin
opEve.AddItem(SpecIdentifiers[j].orig, IncIcnI); {Agrega a lista por defecto.}
end;
end;
end else begin //atributo no existe
raise ESynFacilSyn.Create(Format(ERR_ATTRIB_NO_EXIST,[nodo2.NodeValue]));
end;
end;
if tIncList.hay then begin
//se pide agregar los ítems de una lista
lst := GetListByName(tIncList.val);
if lst<>nil then begin
opEve.AddList(lst, true);
end else begin
raise ESynFacilSyn.Create(Format(ERR_LIST_NO_EXIST,[tIncList.val]));
end;
end;
end else if nodo2.NodeName='#text' then begin
//éste nodo aparece siempre que haya espacios, saltos o tabulaciones
end else if LowerCase(nodo2.NodeName) = '#comment' then begin
//solo para evitar que de mensaje de error
end else begin
raise ESynFacilSyn.Create(Format(ERR_INVAL_LAB_OPNON,[nodo2.NodeName]));
end;
end;
end;
var
tNamPatt, tBefPatt, tAftPatt: TFaXMLatrib;
filt: TFaFilterList;
tFilPatt, tBlkPatt: TFaXMLatrib;
opEve: TFaOpenEvent;
blk: TFaSynBlock;
success: boolean;
tActPatt: TFaXMLatrib;
tIcnPatt: TFaXMLatrib;
idxIcon: Integer;
begin
tNamPatt := ReadXMLParam(nodo,'Name');
tBefPatt := ReadXMLParam(nodo,'BeforePattern');
tAftPatt := ReadXMLParam(nodo,'AfterPattern');
tFilPatt := ReadXMLParam(nodo,'FilterBy');
tBlkPatt := ReadXMLParam(nodo,'Block');
tActPatt := ReadXMLParam(nodo,'Action');
tIcnPatt := ReadXMLParam(nodo,'IconIndex');
CheckXMLParams(nodo, 'Name BeforePattern AfterPattern FilterBy Block Action IconIndex'); //puede generar excepción
if tFilPatt.hay then begin
case UpCase(tFilPatt.val) of
'NONE' : filt := fil_None;
'LASTTOK' : filt := fil_LastTok;
'LASTTOKPART' : filt := fil_LastTokPart;
'LASTIDENT' : filt := fil_LastIdent;
'LASTIDENTPART': filt := fil_LastIdentPart;
else
raise ESynFacilSyn.Create(Format(ERR_FILTER_NO_EXIST,[tFilPatt.val]));
end;
end else begin
filt := fil_LastTokPart; //valro por defecto
end;
if not tAftPatt.hay then begin
tAftPatt.val:='Identifier';
end;
//agrega patrón
opEve := AddOpenEvent(tAftPatt.val, tBefPatt.val, filt);
//configrua nombre
if tNamPatt.hay then begin //se especificó nombre
opEve.name := tNamPatt.val;
end else begin //se asuem un ombre por defecto
opEve.name := '#Pat' + IntToStr(OpenEvents.Count);
end;
//configura bloque
if tBlkPatt.hay then begin
blk := SearchBlock(tBlkPatt.val, success);
if not success then begin
raise ESynFacilSyn.Create(ERR_INVAL_BLK_NAME);
end;
opEve.block := blk;
end else begin
opEve.block := nil;
end;
//configura acción
if tActPatt.hay then begin
case UpCAse(tActPatt.val) of
'NONE' : opEve.Action := pac_None;
'DEFAULT': opEve.Action := pac_Default;
'INSERT' : opEve.Action := pac_Insert;
'REPLASTTOK': opEve.Action := pac_Rep_LastTok;
else
raise ESynFacilSyn.Create(Format(ERR_ACTION_NO_EXIST,[tActPatt.val]));
end;
end else begin
opEve.Action := pac_Default;
end;
//configura ícono
if tIcnPatt.hay then idxIcon := tIcnPatt.n else idxIcon:=-1;
//verifica contenido
GetItemsFromNode(nodo, opEve, idxIcon);
end;
procedure TSynFacilComplet.ProcCompletionLabel(nodo: TDOMNode);
//Procesa la etiqueta <Completion>, que es el bloque que define todo el sistema de
//completado de código.
var
listIden: string;
i,j : Integer;
nodo2 : TDOMNode;
tipTok : integer;
hayOpen : Boolean;
tIncAttr: TFaXMLatrib;
tLstName, tLstIcnI: TFaXMLatrib;
defPat : TFaOpenEvent;
cmpList : TFaCompletionList;
idxIcon : integer;
tIncIcnI: TFaXMLatrib;
IncIcnI : Integer;
begin
hayOpen := false; //inicia bandera
//crea evento de apertura por defecto
defPat := AddOpenEvent('Identifier', '', fil_LastTokPart);
defpat.name:='#Def';
////////// explora nodos hijos //////////
for i := 0 to nodo.ChildNodes.Count-1 do begin
nodo2 := nodo.ChildNodes[i];
if UpCAse(nodo2.NodeName)='INCLUDE' then begin //incluye lista de palabras por atributo
//lee parámetros
tIncAttr := ReadXMLParam(nodo2,'Attribute');
tIncIcnI := ReadXMLParam(nodo2,'IconIndex');
CheckXMLParams(nodo2, 'Attribute IconIndex'); //puede generar excepción
if tIncAttr.hay then begin
//se pide agregar la lista de identificadores de un atributo en especial
if IsAttributeName(tIncAttr.val) then begin
tipTok := GetAttribIDByName(tIncAttr.val); //tipo de atributo
if tIncIcnI.hay then IncIcnI := tIncIcnI.n else IncIcnI:=-1;
//busca los identificadores para agregarlos
for j:= 0 to high(SpecIdentifiers) do begin
if SpecIdentifiers[j].tTok = tipTok then begin
defPat.AddItem(SpecIdentifiers[j].orig, IncIcnI); {Agrega a lista por defecto.}
end;
end;
end else begin //atributo no existe
raise ESynFacilSyn.Create(Format(ERR_ATTRIB_NO_EXIST,[nodo2.NodeValue]));
end;
end;
end else if UpCAse(nodo2.NodeName)='OPENON' then begin //evento de apertura
//lee parámetros
hayOpen :=true; //marca para indicar que hay lista
ProcXMLOpenOn(nodo2); //puede generar excepción.
end else if UpCAse(nodo2.NodeName)='LIST' then begin //forma alternativa para lista de palabras
//Esta forma de declaración permite definir un orden en la carga de listas
//lee parámetros
tLstName := ReadXMLParam(nodo2,'Name');
tLstIcnI := ReadXMLParam(nodo2,'IconIndex');
CheckXMLParams(nodo2, 'Name IconIndex'); //puede generar excepción
if not tLstName.hay then begin
tLstName.val:='#list'+IntToStr(CompletLists.Count);
end;
cmpList := AddComplList(tLstName.val);
//Ve si tiene contenido
listIden := AnsiString(nodo2.TextContent);
if listIden<>'' then begin
if tLstIcnI.hay then idxIcon := tLstIcnI.n else idxIcon := -1;
cmpList.AddItems(listIden, idxIcon);
{Agrega los ítems de la lista en este patrón, por si se llegase a utilizar. Se
hace aquí mismo para mantener el orden, si es que se mezcla con etiquetas <INCLUDE>
o listas de palabras indicadas directamente en <COMPLETION> ... </COMPLETION>}
defPat.AddItems(listIden, idxIcon);
end;
end else if nodo2.NodeName='#text' then begin
//Este nodo aparece siempre que haya espacios, saltos o tabulaciones
//Puede ser la lista de palabras incluidas directamente en <COMPLETION> </COMPLETION>
defPat.AddItems(AnsiString(nodo2.NodeValue), -1);
end else if LowerCase(nodo2.NodeName) = '#comment' then begin
//solo para evitar que de mensaje de error
end else begin
raise ESynFacilSyn.Create(Format(ERR_INVAL_LAB_COMP,[nodo2.NodeName]));
end;
end;
//verifica las opciones por defecto
if hayOpen then begin
//Se ha especificado patrones de apretura.
OpenEvents.Remove(defPat); //elimina el evento por defecto, porque no se va a usar
end else begin
//No se ha especificado ningún evento de apertura
//mantiene el evento por defecto
end;
end;
procedure TSynFacilComplet.LoadFromFile(const Filename: string);
var
doc: TXMLDocument;
i: Integer;
nodo: TDOMNode;
nombre: WideString;
tCasSen: TFaXMLatrib;
tOpenKUp: TFaXMLatrib;
tSelOEnt: TFaXMLatrib;
begin
inherited LoadFromFile(Filename); {Puede disparar excepción. El mesnajes de error generado
incluye el nombre del archivo}
OpenOnKeyUp := true; //por defecto
ReadSpecialIdentif; //carga los identificadores especiales
OpenEvents.Clear; //limpia patrones de apertura
CompletLists.Clear;
try
ReadXMLFile(doc, Filename); //carga archivo
//procede a la carga de la etiqueta <COMPLETION>
for i:= 0 to doc.DocumentElement.ChildNodes.Count - 1 do begin
// Lee un Nodo o Registro
nodo := doc.DocumentElement.ChildNodes[i];
nombre := UpCase(nodo.NodeName);
if nombre = 'COMPLETION' then begin
//carga los parámetros
tCasSen :=ReadXMLParam(nodo, 'CaseSensitive');
tOpenKUp:=ReadXMLParam(nodo, 'OpenOnKeyUp');
tSelOEnt:=ReadXMLParam(nodo, 'SelectOnEnter');
//carga atributos leidos
if tCasSen.hay then //si se especifica
CaseSensComp := tCasSen.bol //se lee
else //si no
CaseSensComp := CaseSensitive; //toma el del resaltador
if tOpenKUp.hay then OpenOnKeyUp:=tOpenKUp.bol;
if tSelOEnt.hay then SelectOnEnter:=tSelOEnt.bol;
ProcCompletionLabel(nodo); //Puede generar error
end;
end;
doc.Free; //libera
except
on e: Exception do begin
//Completa el mensaje con nombre de archivo, porque esta parte del código
//no lo incluye.
e.Message:=ERROR_LOADING_ + Filename + #13#10 + e.Message;
doc.Free;
raise //genera de nuevo
end;
end;
end;
procedure TSynFacilComplet.SelectEditor(ed0: TSynEdit);
//Inicia el motor de ayuda contextual, en el editor indicado
begin
ed := ed0; //guarda referencia
if ed = nil then begin
showmessage('ERROR: Se requiere un editor para el autocompletado.');
ed := nil; //para indicar que no es válido
exit;
end;
//asigna por si acaso no se había hecho
ed.Highlighter := self;
MenuComplet:=TSynCompletionF.Create(ed.Owner); //crea menú contextual en el formulario
MenuComplet.Editor:=ed; //asigna editor
MenuComplet.Width:=200; //ancho inicial
MenuComplet.OnExecute:=@MenuComplet_OnExecute;
MenuComplet.OnCodeCompletion:=@OnCodeCompletion;
//Para evitar que reemplace automáticamente, cuando se abre con un solo elemento en la lista
MenuComplet.AutoUseSingleIdent := false;
//iintercepta eventos de teclado, para cambiar comportamiento
MenuComplet.OnKeyDown:=@FormKeyDown;
MenuComplet.OnUTF8KeyPress:=@FormUTF8KeyPress; //eventos del teclado de la ventana de completado
end;
procedure TSynFacilComplet.UnSelectEditor;
//Método que quita la ayuda contextual al formulario indicado y al editor.
//Se debería llamar siempre si se ha llamado a SelectEditor().
begin
if MenuComplet = nil then exit; //nunca se creó
MenuComplet.Destroy;
MenuComplet := nil; //lo marca como liberado
end;
function TSynFacilComplet.CheckForClose: boolean;
{Verifica si se dan las condiciones como para cerrar la ventana de completado, y si se da
el caso, la cierra y devuelve TRUE.}
var
opEve: TFaOpenEvent;
begin
curEnv.LookAround(ed, CaseSensComp); //para actualizar el nuevo estado
opEve := FindOpenEventMatching; //Busca evento de apertura que aplica
if opEve = nil then begin
MenuComplet.Deactivate;
CurOpenEve := nil; //como se cierra ya no hay evento activo
exit(true); //ninguno aplica
end;
//hay un aptrón que aplica
if opEve=CurOpenEve then begin
//Es el mismo
exit(false);
end else begin
//Es uno nuevo
{Aquí se puede decidir cerrar la ventana, porque aplica otro patrón, pero yo prefiero
el comportamiento en el que se aplica direcatamente el nuevo patrón, sin necesidad de
esperar a pulsar otra tecla.}
CurOpenEve := opEve; //actualiza referencia
CurOpenEve.LoadItems(curEnv); //carga ítems
exit(false);
end;
end;
function TSynFacilComplet.AddOpenEvent(AfterPattern, BeforePattern: string;
filter: TFaFilterList): TFaOpenEvent;
{Permite agregar un evento de apertura. Devuelve una referencia al evento agregado.}
var
opEve: TFaOpenEvent;
errStr: string;
begin
opEve := TFaOpenEvent.Create(self);
///////analiza AfterPattern
opEve.ClearBeforePatt;
while AfterPattern<>'' do begin
opEve.AddBeforeElement(AfterPattern, errStr);
if errStr<>'' then begin
opEve.Destroy; //destruye proque no lo va a agregar
raise ESynFacilSyn.Create(ERR_PAR_AFT_PATT + ':' + errStr);
end;
end;
///////analiza BeforePattern
opEve.ClearAfterPatt;
while BeforePattern<>'' do begin
opEve.AddAfterElement(BeforePattern, errStr);
if errStr<>'' then begin
opEve.Destroy; //destruye proque no lo va a agregar
raise ESynFacilSyn.Create(ERR_PAR_BEF_PATT + ':' + errStr);
end;
end;
//Hay propiedades que no se inician aquí como el nombre
opEve.filter := filter; //fija filtro
opEve.block := nil;
opEve.Action := pac_Default; //acción por defecto
OpenEvents.Add(opEve); //agrega
Result := opEve; //devuelve referencia
end;
function TSynFacilComplet.AddComplList(lstName: string): TFaCompletionList;
var
lst: TFaCompletionList;
begin
lst := TFaCompletionList.Create;
lst.Name:= lstName;
CompletLists.Add(lst);
Result := lst;
end;
function TSynFacilComplet.GetListByName(lstName: string): TFaCompletionList;
{Devuelve la referencia a una lista, usando su nombre. Si no enecuentra devuelve NIL}
var
l: TFaCompletionList;
UlstName: String;
begin
UlstName := upcase(lstName);
for l in CompletLists do begin
if Upcase(l.Name) = UlstName then
exit(l);
end;
exit(nil);
end;
procedure TSynFacilComplet.OnCodeCompletion(var Value: string;
SourceValue: string; var SourceStart, SourceEnd: TPoint; KeyChar: TUTF8Char;
Shift: TShiftState);
//Se genera antes de hacer el reemplazo del texto. "Value", es la cadena que se usará
//para reemplazar la palabra en el editor.
begin
//Se puede usar "MenuComplet.Position" para saber el elemento seleccionado de la lista
// value := 'hola';
// showmessage(value);
end;
function TSynFacilComplet.FindOpenEventMatching: TFaOpenEvent;
{Devuelve el priumer evento que coincide con el entorno actual "curEnv". Si ninguno coincide,
devuelve NIL.}
var
opEve: TFaOpenEvent;
begin
for opEve in OpenEvents do begin
if opEve.MatchPattern(curEnv) then begin
Result := opEve; //devuelve referencia
exit;
end;
end;
exit(nil); //no enccontró
end;
function TSynFacilComplet.GetIconList: TImageList;
begin
Exit(MenuComplet.IconList);
end;
procedure TSynFacilComplet.MenuComplet_OnExecute(Sender: TObject);
{Este evento se genera antes de abrir el menú de completado.
Se puede abrir al pulsar una tecla común. La otra opción es por un atajo.
Llena la lista "AvailItems", con los ítems que correspondan de acuerdo a la posición
actual del cursor y de la configuración del archivo XML.
Luego llena el menú contextual con los ítems filtrados de acuerdo a la posición actual.}
var
opEve: TFaOpenEvent;
begin
MenuComplet.ItemList.Clear; //inicia menú
//Prepara para llenar la lista de completado
curEnv.LookAround(ed, CaseSensComp); //Lee entorno.
CurOpenEve := nil;
opEve := FindOpenEventMatching; //Busca evento de apertura que aplica
if opEve<>nil then begin
//Se cumple el evento en la posición actual del cursor
opEve.LoadItems(curEnv); //carga los ítems con los que trabajará.
CurOpenEve := opEve; //guarda referencia
end;
//Llena el menú de completado
FillCompletMenuFiltered; //hace el primer filtrado
{$IFDEF Verbose}
debugln('Llenado con %d', [MenuComplet.ItemList.Count]);
{$ENDIF}
end;
procedure TSynFacilComplet.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure SeleccionarPalabra;
{Selecciona, la palabra actual de la lista de completado. Usamos nuestra propia
rutina en vez de OnValidate(), para poder reemplazar identificadores de acuerdo
a la definición de sintaxis, además de otros tipos de tokens.}
var
NewWord: String;
obj: TObject;
begin
if CurrentLines = nil then exit;
//Reemplaza actual
obj := MenuComplet.ItemList.Objects[MenuComplet.Position];
if obj=nil then begin
//Puede pasar cuando no se ha asignado un objeto, sino solo texto
end else begin
NewWord := TFaCompletItem(obj).Replac;
CurOpenEve.DoAction(ed, curEnv, NewWord); //realiza la acción programada
end;
CloseCompletionWindow; //cierra
end;
begin
//debugln(' Form.OnKeyDown Key='+ IntToStr(Key) +':'+IntToStr(ed.CaretX));
case Key of
VK_RETURN: begin
if Shift= [] then begin
if SelectOnEnter then //solo si está permitido reemplazar
SeleccionarPalabra;
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
end else begin
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
CloseCompletionWindow; //cierra
end;
end;
VK_HOME: begin
if Shift = [] then begin //envía al editor
ed.CommandProcessor(ecLineStart, #0, nil);
MenuComplet.Deactivate; //desactiva
end else if Shift = [ssShift] then begin
ed.CommandProcessor(ecSelLineStart, #0, nil);
MenuComplet.Deactivate; //desactiva
end;
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
end;
VK_END: begin
if Shift = [] then begin //envía al editor
ed.CommandProcessor(ecLineEnd, #0, nil);
MenuComplet.Deactivate; //desactiva
end else if Shift = [ssShift] then begin
ed.CommandProcessor(ecSelLineEnd, #0, nil);
MenuComplet.Deactivate; //desactiva
end;
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
end;
VK_BACK: begin
if Shift = [] then begin //sin Ctrl o Shift
ed.CommandProcessor(ecDeleteLastChar, #0, nil); //envía al editor
if CheckForClose then begin Key:=VK_UNKNOWN; exit end;
FillCompletMenuFiltered;
end;
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
end;
VK_DELETE: begin
if Shift = [] then begin //sin Ctrl o Shift
ed.CommandProcessor(ecDeleteChar, #0, nil); //envía al editor
if CheckForClose then begin Key:=VK_UNKNOWN; exit end;
FillCompletMenuFiltered;
end;
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
end;
VK_LEFT: begin
if Shift = [] then begin //envía al editor
ed.CommandProcessor(ecLeft, #0, nil);
if CheckForClose then begin Key:=VK_UNKNOWN; exit end;
FillCompletMenuFiltered;
end else if Shift = [ssShift] then begin
ed.CommandProcessor(ecSelLeft, #0, nil);
MenuComplet.Deactivate; //desactiva
end else if Shift = [ssCtrl] then begin
ed.CommandProcessor(ecWordLeft, #0, nil);
MenuComplet.Deactivate; //desactiva
end else if Shift = [ssShift,ssCtrl] then begin
ed.CommandProcessor(ecSelWordLeft, #0, nil);
MenuComplet.Deactivate; //desactiva
end;
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
end;
VK_RIGHT: begin
if Shift = [] then begin //envía al editor
ed.CommandProcessor(ecRight, #0, nil);
if CheckForClose then begin Key:=VK_UNKNOWN; exit end;
FillCompletMenuFiltered;
end else if Shift = [ssShift] then begin
ed.CommandProcessor(ecSelRight, #0, nil);
MenuComplet.Deactivate; //desactiva
end else if Shift = [ssCtrl] then begin
ed.CommandProcessor(ecWordRight, #0, nil);
MenuComplet.Deactivate; //desactiva
end else if Shift = [ssShift,ssCtrl] then begin
ed.CommandProcessor(ecSelWordRight, #0, nil);
MenuComplet.Deactivate; //desactiva
end;
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
end;
VK_TAB: begin
if Shift = [] then begin
SeleccionarPalabra;
SearchOnKeyUp := false; {para que no intente buscar luego en el evento KeyUp,
porque TAB está configurado como tecla válida para abrir la lista, y si
se abre, (y no se ha isertado el TAB), aparecerá de nuevo el mismo
identificador en la lista}
Key:=VK_UNKNOWN; //marca para que no lo procese SynCompletion
end;
end;
end;
//si no lo procesó aquí, lo procesará SynCompletion
end;
procedure TSynFacilComplet.FormUTF8KeyPress(Sender: TObject;
var UTF8Key: TUTF8Char);
//Este evento se dispara cuando ya está visible la ventana de autocompletado y por
//lo tanto no se generará el evento KeyUp
begin
//Como este evento se genera apneas pulsar una tecla, primero pasamos la tecla al
//editor para que lo procese y así tendremos el texto modificado, como si estuviéramos
//después de un KeyUp().
ed.CommandProcessor(ecChar, UTF8Key, nil);
UTF8Key := ''; //limpiamos para que ya no lo procese SynCompletion
//ahora ya tenemos al editor cambiado
//Las posibles opciones ya se deben haber llenado. Aquí solo filtramos.
if CheckForClose then exit;
FillCompletMenuFiltered;
end;
procedure TSynFacilComplet.UTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
{Debe recibir la tecla pulsada aquí, y guardarla para KeyUp, porque allí no se puede
reconocer caracteres ASCII. Se usa UTF para hacerlo más fléxible}
begin
UtfKey:=UTF8Key; //guarda tecla
end;
procedure TSynFacilComplet.KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
{Verifica la tecla pulsada, para determinar si abrir o no el menú de ayuda contextual
Debe llamarse después de que el editor ha procesado el evento, para tener
el estado final del editor
Este evento solo se ejecutará una vez antes de abrir la ventana de autocompletado}
begin
if not CompletionOn then exit;
if not OpenOnKeyUp then exit;
if not SearchOnKeyUp then begin
//Se ha inhabilitado este evento para el completado
SearchOnKeyUp := true;
exit;
end;
//verificación principal
if MenuComplet.IsActive then begin
//verifica si debe desaparecer la ventana, por mover el cursor a una posición anterior
// if CompareCarets(Pos0, CurrentEditor.CaretXY) < 0 then
// Deactivate;
exit; //ya está mostrado
end;
if ed = NIL then exit; //no hay editor
if ed.SelectionMode <> smNormal then exit; //para no interferir en modo columna
{Llama a OpenCompletionWindow(), con información del teclado, para que evalúe si
corresponde abrir la ventana de completado. De ser así, llamará a MenuComplet_OnExecute.}
OpenCompletionWindow(Key, Shift, UtfKey); //solo se mostrará si hay ítems
UtfKey := ''; //limpia por si la siguiente tecla pulsada no dispara a UTF8KeyPress()
SearchOnKeyUp := true; //limpia bandera
End;
procedure TSynFacilComplet.FillCompletMenuFiltered;
{Llena el menú de completado a partir de "AvailItems", aplicando el filtro de "CurOpenEve"
}
begin
//Genera la lista que coincide
{ Este proceso puede ser lento si se actualizan muchas opciones en la lista }
MenuComplet.ItemList.Clear; {Limpia todo aquí porque este método es llamado desde distintos
puntos del programa.}
if CurOpenEve <> nil then begin
CurOpenEve.FillFilteredIn(curEnv, MenuComplet.ItemList);
end;
MenuComplet.Refresh;
end;
procedure TSynFacilComplet.OpenCompletionWindow(vKey: word; vShift: TShiftState;
vUtfKey: TUTF8Char);
//Abre la ayuda contextual, en la posición del cursor.
var
p:TPoint;
begin
//Verifica si se va a abrir la lista por tecla común. La otra opción es por un atajo
if (vKey in [VK_BACK, VK_TAB] ) and (vShift=[]) then begin
//Esta tecla es válida
{$IFDEF Verbose}
debugln('--Tecla válida para abrir menú: %d', [vKey]);
{$ENDIF}
end else if (vUtfKey<>'') and (vUtfKey[1] in [#8,#9,' '..'@','A'..'z']) then begin
//Esta tecla es válida
{$IFDEF Verbose}
debugln('--Tecla válida para abrir menú: %d', [vKey]);
{$ENDIF}
end else begin
//Los otros casos no se consideran que deban explorarse
{$IFDEF Verbose}
debugln('--Tecla no válida para abrir menú: %d', [vKey]);
{$ENDIF}
exit;
end;
//Calcula posición donde aparecerá el menú de completado
p := Point(ed.CaretXPix,ed.CaretYPix + ed.LineHeight);
p.X:=Max(0,Min(p.X, ed.ClientWidth - MenuComplet.Width));
p := ed.ClientToScreen(p);
//Abre menú contextual, llamando primero a OnExecute(). Solo se mostrará si tiene elementos.
MenuComplet.Execute('', p.x, p.y); //pasa una clave cualquiera para identificación posterior
end;
procedure TSynFacilComplet.CloseCompletionWindow;
//Cierra la ventana del menú contextual
begin
MenuComplet.Deactivate;
end;
constructor TSynFacilComplet.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
curEnv := TFaCursorEnviron.Create(self);
OpenEvents := TFaOpenEvents.Create(True);
CompletLists := TFaCompletionLists.Create(true);
CaseSensComp := false; //por defecto
CompletionOn := true; //activo por defecto
SelectOnEnter := true;
UtfKey := ''; //limpia
SearchOnKeyUp := true; //Para iniciar la búsqueda
end;
destructor TSynFacilComplet.Destroy;
begin
if MenuComplet<>nil then MenuComplet.Destroy; //por si no lo liberaron
CompletLists.Destroy;
OpenEvents.Destroy;
curEnv.Destroy;
inherited Destroy;
end;
end.
EvoUMLPlugin/src/SynFacilHighlighter.pas 0 → 100644
View file @ 29d6d4f7
This source diff could not be displayed because it is too large. You can view the blob instead.
EvoUMLPlugin/src/fModelMappingsGenerationOptions.dfm
View file @ 29d6d4f7
object ModelMappingsGenerationOptions: TModelMappingsGenerationOptions object ModelMappingsGenerationOptions: TModelMappingsGenerationOptions
Left = 795 Left = 795
Height = 515 Height = 644
Top = 263 Top = 263
Width = 376 Width = 470
BorderStyle = bsDialog BorderStyle = bsDialog
Caption = 'Model Mappings options' Caption = 'Model Mappings options'
ClientHeight = 515 ClientHeight = 644
ClientWidth = 376 ClientWidth = 470
Color = clBtnFace Color = clBtnFace
DesignTimePPI = 120
OnDestroy = FormDestroy OnDestroy = FormDestroy
OnShow = FormShow OnShow = FormShow
ParentFont = True
Position = poScreenCenter Position = poScreenCenter
LCLVersion = '2.1.0.0' LCLVersion = '2.0.10.0'
object Panel1: TPanel object Panel1: TPanel
Left = 0 Left = 0
Height = 56 Height = 70
Top = 459 Top = 574
Width = 376 Width = 470
Align = alBottom Align = alBottom
ClientHeight = 56 ClientHeight = 70
ClientWidth = 376 ClientWidth = 470
ParentFont = False
TabOrder = 0 TabOrder = 0
object BitBtn1: TBitBtn object BitBtn1: TBitBtn
Left = 160 Left = 200
Height = 34 Height = 42
Top = 14 Top = 18
Width = 100 Width = 125
Caption = 'Generate' Caption = 'Generate'
Default = True Default = True
Glyph.Data = { Glyph.Data = {
...@@ -74,62 +75,68 @@ object ModelMappingsGenerationOptions: TModelMappingsGenerationOptions ...@@ -74,62 +75,68 @@ object ModelMappingsGenerationOptions: TModelMappingsGenerationOptions
FBFBFBFBFBFBFBFBDEDEDEDEDEDEDEDEDEDEDEDEDEDEDEDEDEDE FBFBFBFBFBFBFBFBDEDEDEDEDEDEDEDEDEDEDEDEDEDEDEDEDEDE
} }
OnClick = BitBtn1Click OnClick = BitBtn1Click
ParentFont = False
TabOrder = 1 TabOrder = 1
end end
object BitBtn2: TBitBtn object BitBtn2: TBitBtn
Left = 268 Left = 335
Height = 34 Height = 42
Top = 14 Top = 18
Width = 100 Width = 125
Cancel = True Cancel = True
DefaultCaption = True DefaultCaption = True
Kind = bkCancel Kind = bkCancel
ModalResult = 2 ModalResult = 2
NumGlyphs = 2 NumGlyphs = 2
ParentFont = False
TabOrder = 0 TabOrder = 0
end end
object BitBtn3: TBitBtn object BitBtn3: TBitBtn
Left = 7 Left = 9
Height = 25 Height = 31
Top = 23 Top = 29
Width = 89 Width = 111
Caption = 'Load Default' Caption = 'Load Default'
OnClick = BitBtn3Click OnClick = BitBtn3Click
ParentFont = False
TabOrder = 2 TabOrder = 2
end end
object ckbDefault: TCheckBox object ckbDefault: TCheckBox
Left = 7 Left = 9
Height = 19 Height = 24
Top = 3 Top = 4
Width = 58 Width = 73
Caption = 'Default' Caption = 'Default'
Checked = True Checked = True
ParentFont = False
State = cbChecked State = cbChecked
TabOrder = 3 TabOrder = 3
end end
end end
object Panel2: TPanel object Panel2: TPanel
Left = 0 Left = 0
Height = 459 Height = 574
Top = 0 Top = 0
Width = 376 Width = 470
Align = alClient Align = alClient
ClientHeight = 459 ClientHeight = 574
ClientWidth = 376 ClientWidth = 470
ParentFont = False
TabOrder = 1 TabOrder = 1
object Label1: TLabel object Label1: TLabel
Left = 8 Left = 10
Height = 15 Height = 20
Top = 8 Top = 10
Width = 91 Width = 112
Caption = 'Output directory:' Caption = 'Output directory:'
ParentColor = False ParentColor = False
ParentFont = False
end end
object SpeedButton1: TSpeedButton object SpeedButton1: TSpeedButton
Left = 345 Left = 431
Height = 22 Height = 28
Top = 2 Top = 2
Width = 23 Width = 29
Flat = True Flat = True
Glyph.Data = { Glyph.Data = {
36030000424D3603000000000000360000002800000010000000100000000100 36030000424D3603000000000000360000002800000010000000100000000100
...@@ -160,102 +167,112 @@ object ModelMappingsGenerationOptions: TModelMappingsGenerationOptions ...@@ -160,102 +167,112 @@ object ModelMappingsGenerationOptions: TModelMappingsGenerationOptions
85180C8518FF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FF 85180C8518FF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FF
} }
OnClick = SpeedButton1Click OnClick = SpeedButton1Click
ParentFont = False
end end
object GroupBox1: TGroupBox object GroupBox1: TGroupBox
Left = 8 Left = 10
Height = 80 Height = 100
Top = 240 Top = 300
Width = 360 Width = 450
Caption = 'Output file name' Caption = 'Output file name'
ClientHeight = 60 ClientHeight = 75
ClientWidth = 356 ClientWidth = 446
ParentFont = False
TabOrder = 2 TabOrder = 2
object lblFileExists: TLabel object lblFileExists: TLabel
Left = 8 Left = 10
Height = 14 Height = 16
Top = 34 Top = 42
Width = 194 Width = 251
Caption = 'File already exists at specified directory.' Caption = 'File already exists at specified directory.'
Font.CharSet = ANSI_CHARSET Font.CharSet = ANSI_CHARSET
Font.Color = clRed Font.Color = clRed
Font.Height = -11 Font.Height = -14
Font.Name = 'Arial' Font.Name = 'Arial'
ParentColor = False ParentColor = False
ParentFont = False ParentFont = False
end end
object edtFileName: TEdit object edtFileName: TEdit
Left = 6 Left = 8
Height = 23 Height = 28
Top = 8 Top = 10
Width = 338 Width = 422
OnChange = edtFileNameChange OnChange = edtFileNameChange
ParentFont = False
TabOrder = 0 TabOrder = 0
end end
end end
object GroupBox2: TGroupBox object GroupBox2: TGroupBox
Left = 8 Left = 10
Height = 56 Height = 70
Top = 326 Top = 408
Width = 360 Width = 450
Caption = 'Options' Caption = 'Options'
ClientHeight = 36 ClientHeight = 45
ClientWidth = 356 ClientWidth = 446
ParentFont = False
TabOrder = 0 TabOrder = 0
object ckbIgnoreXSD: TCheckBox object ckbIgnoreXSD: TCheckBox
Left = 8 Left = 10
Height = 19 Height = 24
Top = 8 Top = 10
Width = 122 Width = 153
Caption = 'Ignore XSD schema' Caption = 'Ignore XSD schema'
ParentFont = False
TabOrder = 0 TabOrder = 0
end end
end end
object GroupBox3: TGroupBox object GroupBox3: TGroupBox
Left = 8 Left = 10
Height = 56 Height = 70
Top = 393 Top = 491
Width = 360 Width = 450
Caption = 'Target Code Laguage' Caption = 'Target Code Laguage'
ClientHeight = 36 ClientHeight = 45
ClientWidth = 356 ClientWidth = 446
ParentFont = False
TabOrder = 1 TabOrder = 1
object rdObjectPascal: TRadioButton object rdObjectPascal: TRadioButton
Left = 8 Left = 10
Height = 19 Height = 24
Top = 8 Top = 10
Width = 91 Width = 113
Caption = 'Object Pascal' Caption = 'Object Pascal'
OnClick = rdLanguageClick OnClick = rdLanguageClick
ParentFont = False
TabOrder = 0 TabOrder = 0
end end
object rdCSharp: TRadioButton object rdCSharp: TRadioButton
Left = 160 Left = 200
Height = 19 Height = 24
Top = 8 Top = 10
Width = 35 Width = 42
Caption = 'C#' Caption = 'C#'
OnClick = rdLanguageClick OnClick = rdLanguageClick
ParentFont = False
TabOrder = 1 TabOrder = 1
end end
object rdJava: TRadioButton object rdJava: TRadioButton
Left = 272 Left = 340
Height = 19 Height = 24
Top = 8 Top = 10
Width = 42 Width = 52
Caption = 'Java' Caption = 'Java'
OnClick = rdLanguageClick OnClick = rdLanguageClick
ParentFont = False
TabOrder = 2 TabOrder = 2
end end
end end
object dlbDirectory: TShellTreeView object dlbDirectory: TShellTreeView
Left = 8 Left = 10
Height = 200 Height = 250
Top = 32 Top = 40
Width = 360 Width = 450
BorderWidth = 1 BorderWidth = 1
ExpandSignType = tvestPlusMinus ExpandSignType = tvestPlusMinus
FileSortType = fstNone FileSortType = fstNone
Images = ImageList1 Images = ImageList1
ParentFont = False
ReadOnly = True ReadOnly = True
TabOrder = 3 TabOrder = 3
OnGetImageIndex = dlbDirectoryGetImageIndex OnGetImageIndex = dlbDirectoryGetImageIndex
...@@ -265,21 +282,46 @@ object ModelMappingsGenerationOptions: TModelMappingsGenerationOptions ...@@ -265,21 +282,46 @@ object ModelMappingsGenerationOptions: TModelMappingsGenerationOptions
end end
object OpenDialog1: TOpenDialog object OpenDialog1: TOpenDialog
Filter = '.pas|*.pas' Filter = '.pas|*.pas'
Left = 184 Left = 230
Top = 24 Top = 30
end end
object ImageList1: TImageList object ImageList1: TImageList
Left = 255 Left = 319
Top = 15 Top = 19
Bitmap = { Bitmap = {
4C7A010000001000000010000000E20000000000000078DA63601878A0646061 4C69010000001000000010000000000000000000000000000000000000000000
C1641A12CA601A0AC12621A18AFA1616C4EA572F5FB18A69E1FFFF0C0BA078FE 0000000000000000000000000000000000000000000000000000000000000000
FFFFCE4B1F3C26DA8CEC55ABE07A0960B645FFFF979FFEFB1FA77EA03B9816E1 0000000000000000000000000000000000000000000000000000000000000000
C7BA1BB1EB6759F2FFBFF2B1FFFF354E11C69157FEFE37F7058619927EDE75C4 0000000000000000000000000000000000000000000000000000000000000000
E90561EBF3FFFE2BB8A3EA17DD4EBC7EDFCBFFFF1BF920F43302FD2DBD9778FD 0000000000000000000000000000000000002230383802355455003555550035
B1D781711480D0CFB2F4FF7FF983C4EB57EA58BE0A39FC385602C58E12AFDFA9 555500345455212F383800000000000000000000000000000000000000000000
7F055CBF79DD8A55D21BFFFD573BF6EFBFC609C2D8E2CCBFFF9EE9058530FD3A 0000000000000000000000000000000000002777A8AA02A1FFFF00A0FFFF00A0
C61616C27621A1BC0EC144615957A8BF070100002DAF7BBC FFFF009FFFFF43A5E0E3212F3838000000000000000000000000000000000000
000000000000000000000000000000000000006BAAAA00A0FFFF00A0FFFF00A0
FFFF00A0FFFF00A0FFFF00A0FFFF00A0FFFF00A0FFFF00A0FFFF00A0FFFF06A2
FFFF77CBFDFF000000000000000000000000006BAAAA00A0FFFF00A0FFFF00A1
FFFF02A2FFFF02A2FFFF02A2FFFF02A2FFFF02A2FFFF02A2FFFF02A2FFFF02A2
FFFF2DB1FDFF000000000000000000000000006BAAAA00A0FFFF04A4FFFF23C6
FFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CA
FFFF28CAFFFF59D4FDFF374D545500000000006BAAAA00A0FFFF0DAEFFFF28CA
FFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CA
FFFF28CAFFFF3BCFFEFF2047545500000000006BAAAA00A0FFFF15B7FFFF28CA
FFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CA
FFFF28CAFFFF4DD3FFFF324C545500000000006BAAAA01A1FFFF1BBDFFFF28CA
FFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CA
FFFF28CAFFFF5DD7FFFF4350545500000000006BAAAA04A5FFFF1FC1FFFF28CA
FFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CA
FFFF28CAFFFF2288A7AA0000000000000000006BAAAA08A9FFFF22C5FFFF28CA
FFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CAFFFF28CA
FFFF28CAFFFF428FA8AA0000000000000000377EA8AA1BB1FEFF26C6FEFF28C8
FEFF28C8FEFF28C8FEFF28C8FEFF28C8FEFF28C8FEFF28C8FEFF28C8FEFF28C8
FEFF38CCFEFF4967707100000000000000002C333838133E54550D4053550D40
53550D4053550D4053550D4053550D4053550D4053550D4053550D4053550D40
53551D4554550000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000
} }
BitmapAdv = { BitmapAdv = {
4C69010000004C7A010000001800000018000000E00000000000000078DA6360 4C69010000004C7A010000001800000018000000E00000000000000078DA6360
......
EvoUMLPlugin/src/ituExplorerV2.dfm
View file @ 29d6d4f7
This source diff could not be displayed because it is too large. You can view the blob instead.
EvoUMLPlugin/src/ituExplorerV2.pas
View file @ 29d6d4f7
...@@ -3,11 +3,32 @@ unit ituExplorerV2; ...@@ -3,11 +3,32 @@ unit ituExplorerV2;
interface interface
uses uses
LCLIntf, SysUtils, Variants, Classes, Graphics, Controls, Forms, LCLIntf, SysUtils, Variants, Classes, Graphics, Controls, Forms, Clipbrd,
Clipbrd, Dialogs, ExtCtrls, StdCtrls, ComCtrls, ActnList, Dialogs, ExtCtrls, StdCtrls, ComCtrls, ActnList, LCLType,
LCLType, acuSQLDialectManager, ImgList, acuframework, acuSQLDialectManager, ImgList, acuframework, utuMessage, IntegracaoDelphiSUML,
IntegracaoDelphiSUML, acuObjectExplorer, Menus, Buttons, SynEdit, acuObjectExplorer, Menus, Buttons, SynEdit, SynHighlighterSQL, SynCompletion,
SynHighlighterSQL, SynCompletion, acuModel, acuRepositorySQL; acuModel, acuRepositorySQL, SynEditKeyCmds, SynHighlighterPython,SynFacilHighlighter,SynFacilCompletion,SynFacilBasic, Types;
const
__OID = 'OID';
__WHERE = 'WHERE';
__SELECT = 'SELECT';
__FROM = 'FROM';
__JOIN = 'JOIN';
__ON = 'ON';
__VIRGULA = ',';
__AS = 'AS';
__ORDER = 'ORDER';
__BY = 'BY';
__GROUP = 'GROUP';
__PARENTESES_ABERTO = '(';
__PARENTESES_FECHADO = ')';
__EXISTS = 'EXISTS';
__IN = 'IN';
__PONTO = '.';
__ASTERICO = '*';
__CARACTERES_ESPECIAIS = '=,<>()^~*-+./[]{}#@$%&"!@#$%&*''_';
type type
...@@ -26,16 +47,21 @@ type ...@@ -26,16 +47,21 @@ type
TExplorerV2 = class(TForm) TExplorerV2 = class(TForm)
actExecute: TAction; actExecute: TAction;
actCancel: TAction; actCancel: TAction;
edtClasse: TEdit;
gbAgrupamento: TGroupBox;
ilModel: TImageList; ilModel: TImageList;
Label2: TLabel;
lvXMLListResult: TListView; lvXMLListResult: TListView;
memXMLTextResult: TMemo; memXMLTextResult: TMemo;
OQLObjects: TObjectExplorer; OQLObjects: TObjectExplorer;
pnFiltroClasse: TPanel;
pcXMLResults: TPageControl; pcXMLResults: TPageControl;
rbHieraquia: TRadioButton;
rbSequencial: TRadioButton;
ReconnectDB: TAction; ReconnectDB: TAction;
sbStatusBar: TStatusBar; sbStatusBar: TStatusBar;
spResultXML: TSplitter; spResultXML: TSplitter;
spResultObject: TSplitter; spResultObject: TSplitter;
SynCompletion1: TSynCompletion;
SynEditOQL: TSynEdit; SynEditOQL: TSynEdit;
SynEditSQL: TSynEdit; SynEditSQL: TSynEdit;
SynSQLSyn1: TSynSQLSyn; SynSQLSyn1: TSynSQLSyn;
...@@ -74,10 +100,18 @@ type ...@@ -74,10 +100,18 @@ type
tsError: TTabSheet; tsError: TTabSheet;
memErrorText: TMemo; memErrorText: TMemo;
pnlActionBar: TPanel; pnlActionBar: TPanel;
procedure opEveLoadItems(opEve: TFaOpenEvent; curEnv: TFaCursorEnviron; out Cancel: boolean);
procedure actModelPanelExecute(Sender: TObject); procedure actModelPanelExecute(Sender: TObject);
procedure edtClasseChange(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormShow(Sender: TObject); procedure FormShow(Sender: TObject);
procedure actResultsPanelExecute(Sender: TObject); procedure actResultsPanelExecute(Sender: TObject);
procedure rbSequencialClick(Sender: TObject);
procedure SynEditOQLCommandProcessed(Sender: TObject;
var Command: TSynEditorCommand; var AChar: TUTF8Char; Data: pointer);
procedure SynEditOQLKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure SynEditOQLUTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
procedure tvModelExplorerGetSelectedIndex(Sender: TObject; Node: TTreeNode); procedure tvModelExplorerGetSelectedIndex(Sender: TObject; Node: TTreeNode);
procedure tvModelExplorerItemExpanding(Sender: TObject; Node: TTreeNode; var AllowExpansion: Boolean); procedure tvModelExplorerItemExpanding(Sender: TObject; Node: TTreeNode; var AllowExpansion: Boolean);
procedure XMLQueryExecute(Sender: TObject); procedure XMLQueryExecute(Sender: TObject);
...@@ -94,6 +128,8 @@ type ...@@ -94,6 +128,8 @@ type
procedure FormDestroy(Sender: TObject); procedure FormDestroy(Sender: TObject);
private private
{ Private declarations } { Private declarations }
fAlias,
fKeywords : TStrings;
fExecuting: Boolean; fExecuting: Boolean;
fMetaModel: acMetaModel; fMetaModel: acMetaModel;
fMetaModelPersistenceMap: acMetaModelPersistenceMapSQL; fMetaModelPersistenceMap: acMetaModelPersistenceMapSQL;
...@@ -103,12 +139,51 @@ type ...@@ -103,12 +139,51 @@ type
fSchema: String; fSchema: String;
fUtil: TUtil; fUtil: TUtil;
fLastExecErrorFlag: Boolean; fLastExecErrorFlag: Boolean;
fopEvenSearchSelect,
fopEvenSearchFrom,
fopEvenSearchWhere,
fopEvenSelectAposPonto,
fopEvenFromAposPonto,
fopEvenWhereAposPonto,
fopEvenselectCompleto,
fopEvenFromCompleto,
fopEvenWhereCompleto : TFaOpenEvent;
fhlt1 : TSynFacilComplet;
procedure MontarModelExploreSequencial(Sender: TObject; Node: TTreeNode);
procedure MontarModelExploreHieraquia(Sender: TObject; Node: TTreeNode);
procedure SetMetaModel(const Value: acMetaModel); procedure SetMetaModel(const Value: acMetaModel);
procedure ResizeColumns(piListView: TListView); procedure ResizeColumns(piListView: TListView);
function GetStringEntreParenteses(piString : string) : string; function GetStringEntreParenteses(piString : string) : string;
function GetNumeroDeStringOID (piString : string) : string; function GetNumeroDeStringOID (piString : string) : string;
function GetClassTicket(piBloco,piPropertyName : string):acClassTicket;
procedure CopiaTextoObjeto (piObjeto : TTreeNode); procedure CopiaTextoObjeto (piObjeto : TTreeNode);
function BuscaParcial(piSubstring,piTexto :string;piretirarEspaco : boolean = true): boolean;
function BuscaParcialClasse(piCLasse: string; piFiltrar: boolean): boolean;
function BuscarParcialChildClass(piClassTicket : acClassTicket; piFiltrar: boolean): boolean;
function FindParcialNodeClass(piClassTicketPai : acClassTicket; piFiltrar: boolean):acClassTicket;
procedure LoadListCompletion(piLinha:string;piAceitaAtributo : boolean;piLista : TStrings);
//
function RetirarTextoDepois(piTextoEntrada,piPalavraRetirar: string;out piTextoAntes : string): string;
function RetirarTextoAntes(piTextoEntrada,piPalavraRetirar: string;out piTextoDepois : string;piSemPalavra : boolean = true): string;
function RetirarTextoEntre(piTextoEntrada,piPalavraInicio,piPalavraFim: string;out piTextoDepois : string;piSemPalavraFim : boolean=true): string;
procedure LoadAliasOQLEdit(piTexto : string;piAlias: TStrings);
function ContemPalavra(piPalavra,piTextoEntrada: string): boolean;
function ContemPalavrasEspeciais (piTextoEntrada: string): boolean;
procedure AddAliasListas(piLinhas: string;piAlias : TStrings);
function LoadAliasBlocoFROMOQLEdit(piTexto: string; piAlias: TStrings): string;
function GetClassTicketByNameRelation(piNameObjeto : string; out piNameAntObjeto : string;piRetonarClassAnterior : boolean = false) : acClassTicket;
function GetClassTicketByNameANDAlias(piNameObjeto : string) : acClassTicket;
//
function GetTextoAfterWord(piSynEdit: TSynEdit): string;
function GetTextoBeforeWord(piSynEdit: TSynEdit): string;
function GetWordsBetweenPoint(piSynEdit: TSynEdit): string;
function GetTextBetweenLines(piSynEdit: TSynEdit; out piWord : string; out piCareWordXY :TPoint): string;
function RetirarPalavraChaveOLQ(piSynEdit :TSynEdit;opEve: TFaOpenEvent):string;
function IsKeyword(piItem : string): boolean;
function GetTextBetweenWord(piSynEdit :TSynEdit;piWordPos: TPoint;piWord : string) : string;
function IsExepressaoValida(piOpEve: TFaOpenEvent;piTexto : string; piTemPalavraAntes : Boolean = false):boolean;
function GetPrevWordPosValida(piSynEdit: TSynEdit) :TPoint;
protected protected
procedure CreateParams(var Params : TCreateParams); override; procedure CreateParams(var Params : TCreateParams); override;
function Connect : acPersistenceSession; function Connect : acPersistenceSession;
...@@ -119,6 +194,7 @@ type ...@@ -119,6 +194,7 @@ type
property Util: TUtil read fUtil; property Util: TUtil read fUtil;
property SQLDialect: acAbstractSQLDialect read fSQLDialect; property SQLDialect: acAbstractSQLDialect read fSQLDialect;
property Schema: String read fSchema; property Schema: String read fSchema;
end; end;
var var
...@@ -127,10 +203,22 @@ var ...@@ -127,10 +203,22 @@ var
implementation implementation
uses ituDataBaseLogin, DateUtils, acuObject, acuOQL, acuOQLtoSQLTranslator, uses ituDataBaseLogin, DateUtils, acuObject, acuOQL, acuOQLtoSQLTranslator,
utuMessage, ituOQLParams; ituOQLParams;
{$R *.dfm} {$R *.dfm}
function TiraAcentos(const s : string): string;
const
Acentos = '';
Letras = 'AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioue';
var
i: Integer;
begin
Result := S;
for i := 1 to Length(Acentos) do
while Pos(acentos[i],Result)>0 do
Result[Pos(acentos[i],Result)]:=Letras[i];
end;
procedure TExplorerV2.actExecuteExecute(Sender: TObject); procedure TExplorerV2.actExecuteExecute(Sender: TObject);
var lSession: acPersistenceSession; var lSession: acPersistenceSession;
lList: acPersistentObjectList; lList: acPersistentObjectList;
...@@ -344,6 +432,12 @@ begin ...@@ -344,6 +432,12 @@ begin
end; end;
end; end;
procedure TExplorerV2.edtClasseChange(Sender: TObject);
begin
tvModelExplorer.Items.Clear;
MetaModel := fUtil.MetaModel;
end;
procedure TExplorerV2.actResultsPanelExecute(Sender: TObject); procedure TExplorerV2.actResultsPanelExecute(Sender: TObject);
var var
lAction : TAction; lAction : TAction;
...@@ -391,6 +485,68 @@ begin ...@@ -391,6 +485,68 @@ begin
end; end;
end; end;
procedure TExplorerV2.rbSequencialClick(Sender: TObject);
begin
end;
procedure TExplorerV2.SynEditOQLCommandProcessed(Sender: TObject;
var Command: TSynEditorCommand; var AChar: TUTF8Char; Data: pointer);
begin
//fhlt1.CloseCompletionWindow;
end;
procedure TExplorerV2.SynEditOQLKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
var lmostrar : boolean;
lChar : string;
begin
lmostrar := true;
// Ctrl + Espao
if ( (Shift = [ssCtrl]) and (Key = 86) )
then
begin
lmostrar := false;
end;
//ssShift
if ( Shift = [ssShift]) then
begin
if Key in [49,52,53,54,55] then
begin
lmostrar := false;
end;
end
else if Key <> 190 then // Ponto(.)
begin
lChar := VK2Char(Key);
if Pos(lChar,'?') > 0 then
begin
lmostrar := false;
end;
end;
//backspace //Espao
if key in[8,32] then
begin
lmostrar := false;
end;
if lmostrar then
begin
fhlt1.KeyUp(Sender, Key, Shift);
end;
end;
procedure TExplorerV2.SynEditOQLUTF8KeyPress(Sender: TObject;
var UTF8Key: TUTF8Char);
begin
fhlt1.UTF8KeyPress(Sender, UTF8Key);
end;
procedure TExplorerV2.tvModelExplorerGetSelectedIndex(Sender: TObject; Node: TTreeNode); procedure TExplorerV2.tvModelExplorerGetSelectedIndex(Sender: TObject; Node: TTreeNode);
begin begin
Node.SelectedIndex := Node.ImageIndex; Node.SelectedIndex := Node.ImageIndex;
...@@ -485,197 +641,1670 @@ begin ...@@ -485,197 +641,1670 @@ begin
Clipbrd.Clipboard.AsText := lString; Clipbrd.Clipboard.AsText := lString;
end; end;
procedure TExplorerV2.CreateParams(var Params: TCreateParams); function TExplorerV2.BuscaParcial(piSubstring, piTexto: string;piretirarEspaco : boolean = true): boolean;
var lSubstring,
lTexto : string;
begin begin
inherited CreateParams(Params); if trim(piSubstring) <> '' then
{$IFDEF LCLWin32} begin
// Params.WndParent := 0; if piretirarEspaco then
{$ENDIF} begin
end; lSubstring := TiraAcentos(trim(UpperCase(piSubstring)));
end
else
begin
lSubstring := TiraAcentos(UpperCase(piSubstring));
end;
lTexto := TiraAcentos(trim(UpperCase(piTexto)));
result := Pos(lSubstring,lTexto) > 0;
end
else
begin
result := true;
end;
procedure TExplorerV2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end; end;
procedure TExplorerV2.FormCreate(Sender: TObject); function TExplorerV2.BuscaParcialClasse(piCLasse: string; piFiltrar: boolean): boolean;
var lMetaModelGenOpt: TMetaModelGenerationOptions; var lClasseTree,
lClasseP : string;
begin begin
if piFiltrar then
begin
lClasseP := TiraAcentos(trim(UpperCase(edtClasse.Text)));
lClasseTree := TiraAcentos(trim(UpperCase(piCLasse)));
result := Pos(lClasseP,lClasseTree) > 0;
end
else
begin
result := true;
end;
lMetaModelGenOpt.CheckDBAttributeNameLength := true;
lMetaModelGenOpt.CheckDBTableNameLength := true;
fUtil := TUtil.Create;
fUtil.AlimentarMetamodel(lMetaModelGenOpt, nil);
FMetaModelPersistenceMap := fUtil.MetaModelPersistenceMap;
MetaModel := fUtil.MetaModel;
end;
procedure TExplorerV2.FormDestroy(Sender: TObject);
begin
fUtil.Free;
end; end;
procedure TExplorerV2.FormShow(Sender: TObject); function TExplorerV2.BuscarParcialChildClass( piClassTicket : acClassTicket;
piFiltrar: boolean): boolean;
var lEnumeratorChild : acEnumerator;
lClassTicketChild : acClassTicket;
begin begin
OQLQuery.Execute; result := BuscaParcialClasse(piClassTicket.PersistentObjectClassName,piFiltrar);
if not result then
begin
lEnumeratorChild := piClassTicket.DirectDescendants.GetEnumerator;
try
while not lEnumeratorChild.EOL do
begin
lClassTicketChild := acClassTicket(lEnumeratorChild.Current);
if BuscaParcialClasse(lClassTicketChild.PersistentObjectClassName,piFiltrar) then
begin
result := true;
break;
end
else if BuscarParcialChildClass(lClassTicketChild,piFiltrar) then
begin
result := true;
break;
end;
spResultObject.Visible := False; lEnumeratorChild.MoveNext;
spResultObject.Align := alNone; end;
spResultXML.Visible := False; finally
spResultXML.Align := alNone; lEnumeratorChild.Free;
end;
end;
pnlResult.Visible := False;
pcEditor.ActivePageIndex := 0;
pcResults.ActivePageIndex := 1;
end; end;
function TExplorerV2.GetNumeroDeStringOID(piString: string): string; function TExplorerV2.FindParcialNodeClass(piClassTicketPai: acClassTicket;
var piFiltrar: boolean): acClassTicket;
lString : string; var lEnumeratorChild : acEnumerator;
lEnum : Integer; lClassTicketChild : acClassTicket;
begin begin
lString := ''; result := nil;
// Verifica se a string tem mais que 4 caracteres if BuscaParcialClasse(piClassTicketPai.PersistentObjectClassName,piFiltrar) then
if Length(piString) > 4 then
begin begin
// Extrai os 4 primeiros caracteres da string result := piClassTicketPai;
for lEnum := 1 to 4 do end
else
begin begin
lString := Concat(lString,piString[lEnum]) lEnumeratorChild := piClassTicketPai.DirectDescendants.GetEnumerator;
end; try
// Se a string comear com OID: esses 4 primeiro caracteres sero excludos while not lEnumeratorChild.EOL do
if lString = 'OID:' then
begin begin
lString := ''; lClassTicketChild := acClassTicket(lEnumeratorChild.Current);
for lEnum := 5 to Length(piString) do if BuscaParcialClasse(lClassTicketChild.PersistentObjectClassName,piFiltrar) then
begin begin
lString := Concat(lString,piString[lEnum]) result := lClassTicketChild;
end;
end end
// Caso contrrio copia-se a string toda
else else
begin begin
lString := ''; result :=FindParcialNodeClass(lClassTicketChild,piFiltrar);
for lEnum := 1 to Length(piString) do end;
if Assigned(result) then
begin begin
lString := Concat(lString,piString[lEnum]) break;
end;
lEnumeratorChild.MoveNext;
end;
finally
lEnumeratorChild.Free;
end;
end;
end;
{
procedure TExplorerV2.ExecutarSybCompletion(piSynCompletion: TSynCompletion);
var apoint,temppoint:tpoint;
begin
//will compare the schema_tablename to a list of available schema names for the current database.
temppoint := SynEditOQL.CaretXY;
temppoint.y := temppoint.y+1;
apoint := SynEditOQL.ClientToScreen(SynEditOQL.RowColumnToPixels(temppoint));
piSynCompletion.Execute('',apoint);
end; }
procedure TExplorerV2.LoadListCompletion(piLinha: string; piAceitaAtributo: boolean; piLista: TStrings);
var lClassTicketCurrent : acClassTicket;
//lClassTicketAux: acClassTicket;
lEnumerator : acEnumerator;
li,
li_Pos : integer;
ls_ant_objeto,
ls_aux,
ls_Objeto : string;
lRelationTicket : acRelationTicket;
lbAchei : boolean;
lAttributeTicket : acAttributeTicket;
begin
piLista.Clear;
li_Pos := Pos ('..',piLinha);
if li_Pos > 0 then
begin
exit;
end;
li_Pos := Pos (__PONTO,piLinha);
if li_Pos <= 0 then
begin
lEnumerator := self.MetaModel.ClassTickets.GetEnumerator;
try
while not lEnumerator.EOL do
begin
lClassTicketCurrent := acClassTicket(lEnumerator.Current);
if BuscaParcial(piLinha,lClassTicketCurrent.PersistentObjectClassName,false) then
begin
piLista.Add(lClassTicketCurrent.PersistentObjectClassName);
end; end;
lEnumerator.MoveNext;
end;
finally
lEnumerator.Free;
end; end;
end end
else else
begin begin
lString := piString;
end;
Result := lString;
end;
function TExplorerV2.GetStringEntreParenteses(piString: string): string; lClassTicketCurrent := self.GetClassTicketByNameRelation(piLinha,ls_ant_objeto,true);
var if Assigned(lClassTicketCurrent) then
lString : string;
lEnum : Integer;
flagDadosDesejados : Boolean;
begin
flagDadosDesejados := False;
lString := '';
for lEnum := 1 to Length(piString) do
begin begin
// Fim dos dados entre parenteses //ShowMessage(ls_ant_objeto);
if piString[lEnum] = ')' then repeat
flagDadosDesejados := False; if piAceitaAtributo then
if flagDadosDesejados then
begin begin
lString := Concat(lString,piString[lEnum]) for li := 0 to pred(lClassTicketCurrent.Attributes.Count) do
begin
lAttributeTicket := acAttributeTicket(lClassTicketCurrent.Attributes.Objects[li]);
if lAttributeTicket.Stereotype = acAttributeStereotype.pvPersistent then
begin
if BuscaParcial(ls_ant_objeto,__OID) then
begin
if piLista.IndexOf(__OID) < 0 then
begin
piLista.Add(__OID);
end; end;
// Inicio dos dados entre parenteses
if piString[lEnum] = '(' then
flagDadosDesejados := True;
end; end;
Result := lString; if BuscaParcial(ls_ant_objeto,lAttributeTicket.AttributeName) then
end; begin
piLista.Add(lAttributeTicket.AttributeName);
end;
procedure TExplorerV2.memOQLQuery2DragDrop(Sender, Source: TObject; X,Y: Integer); end;
function FromClause(piNode: TTreeNode; var poPath: string): string; end;
end;
for li := 0 to pred(lClassTicketCurrent.RelationTicketsIn.Count) do
begin begin
if piNode.Level = 1 lRelationTicket := acRelationTicket(lClassTicketCurrent.RelationTicketsIn.Objects[li]);
then begin if trim(lRelationTicket.DestinationPropertyName) <> '' then
poPath := acClassTicket(piNode.Data).PersistentObjectClassName; begin
result := poPath; if BuscaParcial(ls_ant_objeto,lRelationTicket.DestinationPropertyName) then
end piLista.Add(lRelationTicket.DestinationPropertyName);
else begin
result := FromClause(piNode.Parent, poPath);
poPath := poPath + '.' + copy(piNode.Text, 1, pred(pos(':', piNode.Text)));
result := result + ', ' + #13#10 + ' ' + poPath;
end; end;
end; end;
var lCaption: string;
lNode: TTreeNode; for li := 0 to pred(lClassTicketCurrent.RelationTicketsOut.Count) do
lPath: string;
lFrom: string;
lSelect: string;
begin
if Source is TTreeView then
begin begin
lNode := TTreeView(Source).Selected; lRelationTicket := acRelationTicket(lClassTicketCurrent.RelationTicketsOut.Objects[li]);
if (TObject(lNode.Data) is acClassTicket) if trim(lRelationTicket.OriginPropertyName) <> '' then
then begin
lCaption := acClassTicket(lNode.Data).PersistentObjectClassName;
if GetKeyState(VK_CONTROL) < 0
then SynEditOQL.SelText := #13#10 +
'SELECT ' + lCaption + #13#10 +
'FROM ' + lCaption
else SynEditOQL.SelText := lCaption;
end
else if (TObject(lNode.Data) is acAttributeTicket) then
begin begin
if GetKeyState(VK_CONTROL) < 0 if BuscaParcial(ls_ant_objeto,lRelationTicket.OriginPropertyName) then
then begin piLista.Add(lRelationTicket.OriginPropertyName);
lCaption := (TObject(lNode.Parent.data) as acClassTicket).PersistentObjectClassName; end;
lFrom := FromClause(lNode.Parent, lPath); end;
lSelect := copy(lPath, 1, pred(pos('.', lPath))); lClassTicketCurrent := lClassTicketCurrent.ParentClassTicket;
if lSelect = '' then lSelect := lPath; until lClassTicketCurrent = nil
SynEditOQL.SelText := #13#10 +
'SELECT ' + lSelect + #13#10 +
'FROM ' + lFrom + #13#10 +
'WHERE ' + lPath + '.' + acAttributeTicket(lNode.Data).AttributeName + ' = ';
end else SynEditOQL.SelText := acAttributeTicket(lNode.Data).AttributeName;
end; end;
end; end;
end; end;
procedure TExplorerV2.memOQLQuery2DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); function TExplorerV2.RetirarTextoDepois(piTextoEntrada,
var piPalavraRetirar: string; out piTextoAntes: string): string;
lNode: TTreeNode; var ls_texto : string;
li_PosInicial : integer;
begin begin
if Source is TTreeView then result := '';
if piTextoEntrada <> '' then
begin begin
if Accept then ls_texto := UpperCase(piTextoEntrada);
li_PosInicial := Pos(piPalavraRetirar,ls_texto);
if li_PosInicial > 0 then
begin begin
lNode := TTreeView(Source).Selected; if Length(piPalavraRetirar) > 1 then
Accept := ((TObject(lNode.Data) is acClassTicket) or (TObject(lNode.Data) is acAttributeTicket)); begin
if (State = dsDragEnter) and (Sender is TWinControl) then TWinControl(Sender).SetFocus; li_PosInicial := li_PosInicial + Length(piPalavraRetirar);
piTextoAntes := trim(Copy(piTextoEntrada,0,li_PosInicial -1));
end end
else
begin
piTextoAntes := trim(Copy(piTextoEntrada,0,li_PosInicial));
end; end;
end; result := trim(Copy(piTextoEntrada,li_PosInicial + 1,Length(piTextoEntrada)));
procedure TExplorerV2.OQLObjectstvExplorerKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
// Copia dados do objeto ao apertar Ctrl + C
if (Key = 67) and (Shift = [ssCtrl]) then
begin
if Assigned(OQLObjects.tvExplorer.Selected) then
CopiaTextoObjeto(OQLObjects.tvExplorer.Selected);
end; end;
end;
end; end;
procedure TExplorerV2.OQLObjectstvExplorerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); function TExplorerV2.RetirarTextoAntes(piTextoEntrada,piPalavraRetirar: string; out piTextoDepois: string; piSemPalavra: boolean): string;
var var ls_texto : string;
lPoint : TPoint; li_PosFinal : integer;
begin begin
GetCursorPos(lPoint); result := '';
if (Button = mbRight) then if piTextoEntrada <> '' then
begin begin
pmCopiar.Popup(lPoint.X ,lPoint.Y ); ls_texto := UpperCase(piTextoEntrada);
li_PosFinal := Pos(piPalavraRetirar,ls_texto);
if li_PosFinal > 0 then
begin
if piSemPalavra then
begin
li_PosFinal := li_PosFinal-1;
end;
result := trim(Copy(piTextoEntrada,0,li_PosFinal));
piTextoDepois := trim(Copy(piTextoEntrada,li_PosFinal ,Length(piTextoEntrada)));
if (not piSemPalavra) and (Length(result) = 1) then
begin
result := '';
end;
end;
end;
end;
function TExplorerV2.RetirarTextoEntre(piTextoEntrada, piPalavraInicio,
piPalavraFim: string; out piTextoDepois: string; piSemPalavraFim: boolean): string;
var ls_TextoAntes,
ls_texto : string;
li_PosFinal : integer;
begin
piTextoDepois := piTextoEntrada;
result := '';
if piTextoEntrada <> '' then
begin
ls_Texto := RetirarTextoDepois(piTextoEntrada,piPalavraInicio,ls_TextoAntes);
ls_Texto := RetirarTextoAntes(ls_Texto,piPalavraFim,piTextoDepois,piSemPalavraFim);
if ls_Texto <> '' then
begin
result := trim(ls_Texto);
end;
end;
end;
procedure TExplorerV2.LoadAliasOQLEdit(piTexto: string; piAlias: TStrings);
var ls_texto,
ls_TextoDepois,
ls_textoAntes,
ls_Entrada,
ls_saida : string;
lAcheiTexto : boolean;
begin
ls_Entrada := piTexto;
ls_texto := trim(RetirarTextoEntre(ls_Entrada,__PARENTESES_ABERTO,__PARENTESES_FECHADO,ls_TextoDepois,false));
if ls_texto = '' then
begin
LoadAliasBlocoFROMOQLEdit(ls_Entrada,piAlias);
end
else
begin
ls_textoAntes := RetirarTextoAntes(ls_Entrada,__PARENTESES_ABERTO,ls_saida,false);
ls_textoAntes := ls_textoAntes + ls_TextoDepois;
ls_textoAntes := trim(StringReplace(ls_textoAntes,'()','',[rfReplaceAll]));
LoadAliasOQLEdit(ls_texto,piAlias);
LoadAliasOQLEdit(ls_textoAntes,piAlias);
end;
end;
function TExplorerV2.ContemPalavra(piPalavra, piTextoEntrada: string): boolean;
var ls_texto : string;
begin
result := false;
if piTextoEntrada <> '' then
begin
ls_texto := trim(UpperCase(piTextoEntrada));
result := Pos(trim(UpperCase(piPalavra)),ls_texto) > 0;
end;
end;
function TExplorerV2.ContemPalavrasEspeciais(piTextoEntrada: string): boolean;
begin
result := ContemPalavra(__SELECT,piTextoEntrada) or
ContemPalavra(__WHERE,piTextoEntrada) or
ContemPalavra(__VIRGULA,piTextoEntrada) or
ContemPalavra(__ORDER,piTextoEntrada) or
ContemPalavra(__GROUP,piTextoEntrada) or
ContemPalavra(__BY,piTextoEntrada);
end;
procedure TExplorerV2.AddAliasListas(piLinhas: string; piAlias: TStrings);
var ls_texto,
ls_espaco : string;
li_Pos : integer;
ls_name_ant_objeto,
ls_Alias : string;
ls_classe : string;
lClassTicketCurrent: acClassTicket;
liIndex : Integer;
begin
ls_Alias := '';
if (piLinhas <> '') and (not ContemPalavrasEspeciais(piLinhas)) then
begin
ls_espaco := ' ';
ls_texto := LowerCase(piLinhas);
li_Pos := Pos(ls_espaco,trim(ls_texto));
if li_Pos > 0 then
begin
ls_classe := trim(Copy(ls_texto,0,li_Pos -1));
ls_Alias := trim(Copy(ls_texto,li_Pos + 1,Length(ls_texto)));
if ContemPalavra(__AS,ls_Alias) then
begin
ls_texto := trim(Copy(ls_texto,li_Pos + 1, Length(ls_texto)));
li_Pos := Pos(ls_espaco,trim(ls_texto));
if li_Pos > 0 then
begin
ls_Alias := trim(Copy(ls_texto,li_Pos + 1, Length(ls_texto)));
end;
end;
end
else
begin
ls_classe := ls_texto;
ls_alias := '';
end;
if (ls_Alias <> '') and (ls_classe <> '') then
begin
lClassTicketCurrent := self.GetClassTicketByNameRelation(ls_classe,ls_name_ant_objeto);
if Assigned(lClassTicketCurrent) then
begin
liIndex := piAlias.IndexOf(ls_Alias);
if liIndex < 0 then
begin
piAlias.AddObject(UpperCase(ls_Alias),lClassTicketCurrent);
end
else
begin
piAlias.Objects[liIndex] := lClassTicketCurrent;
end;
end;
end;
end;
end;
function TExplorerV2.LoadAliasBlocoFROMOQLEdit(piTexto: string;
piAlias: TStrings): string;
var ls_texto,
ls_Entrada,
ls_saida : string;
lAcheiTexto : boolean;
begin
ls_entrada := trim(RetirarTextoAntes(piTexto,__WHERE,ls_saida));
if ls_entrada = '' then
begin
ls_entrada := piTexto;
end;
ls_texto := RetirarTextoEntre(ls_Entrada,__FROM,__VIRGULA,ls_Saida);
if ls_texto <> '' then
begin
AddAliasListas(ls_texto,piAlias);
ls_Entrada := ls_saida;
lAcheiTexto := true;
end;
while lAcheiTexto do
begin
lAcheiTexto := false;
ls_texto := RetirarTextoEntre(ls_Entrada,__VIRGULA,__VIRGULA,ls_Saida);
if ls_texto <> '' then
begin
AddAliasListas(ls_texto,piAlias);
ls_Entrada := ls_saida;
lAcheiTexto := true;
end;
ls_texto := RetirarTextoEntre(ls_Entrada,__JOIN,__ON,ls_Saida);
if ls_texto <> '' then
begin
AddAliasListas(ls_texto,piAlias);
ls_Entrada := ls_saida;
lAcheiTexto := true;
end;
end;
ls_texto := RetirarTextoDepois(ls_Entrada,__FROM,ls_saida);
if ls_texto = '' then
begin
ls_texto := RetirarTextoDepois(ls_Entrada,__VIRGULA,ls_saida);
if ls_texto = '' then
begin
ls_texto := ls_Entrada;
end;
end;
if ls_texto <> '' then
begin
if ContemPalavra(__WHERE,ls_texto) then
begin
ls_texto := RetirarTextoAntes(ls_texto,__WHERE,ls_saida);
end
else if ContemPalavra(__GROUP,ls_texto) then
begin
ls_texto := RetirarTextoAntes(ls_texto,__GROUP,ls_saida);
end
else if ContemPalavra(__ORDER,ls_texto) then
begin
ls_texto := RetirarTextoAntes(ls_texto,__ORDER,ls_saida);
end;
if ContemPalavra(__EXISTS,ls_texto) then
begin
ls_texto := RetirarTextoAntes(ls_texto,__EXISTS,ls_saida);
end;
if ContemPalavra(__PARENTESES_ABERTO,ls_texto) then
begin
ls_texto := trim(StringReplace(ls_texto,'(','',[rfReplaceAll]));
end;
if ContemPalavra(__PARENTESES_FECHADO,ls_texto) then
begin
ls_texto := trim(StringReplace(ls_texto,')','',[rfReplaceAll]));
end;
AddAliasListas(ls_texto,piAlias);
end;
result := ls_Entrada;
end;
function TExplorerV2.GetClassTicketByNameRelation(piNameObjeto: string; out piNameAntObjeto : string;piRetonarClassAnterior : boolean = false): acClassTicket;
var lClassTicketCurrent,
lCassTicketAnterior,
lClassTicketAux: acClassTicket;
lEnumerator : acEnumerator;
li,
li_Pos : integer;
ls_ant_objeto,
ls_aux,
ls_Objeto : string;
lRelationTicket : acRelationTicket;
lbAchei : boolean;
begin
li_Pos := Pos (__PONTO,piNameObjeto);
if li_Pos > 0 then
begin
ls_aux := trim(piNameObjeto);
ls_Objeto := trim(Copy(ls_aux,0,li_Pos -1));
lClassTicketCurrent := Self.GetClassTicketByNameANDAlias(ls_Objeto);
while li_Pos > 0 do
begin
lCassTicketAnterior := lClassTicketCurrent;
lClassTicketAux := nil;
ls_aux := trim(Copy(ls_aux,li_Pos +1,Length(ls_aux)));
ls_ant_objeto := ls_aux;
li_Pos := Pos (__PONTO,ls_aux);
if li_Pos > 0 then
begin
ls_Objeto := trim(Copy(ls_aux,0,li_Pos -1));
end
else
begin
ls_Objeto := ls_aux;;
end;
if Assigned(lClassTicketCurrent) and (ls_Objeto <> '') then
begin
lbAchei := false;
for li := 0 to pred(lClassTicketCurrent.RelationTicketsIn.Count) do
begin
lRelationTicket := acRelationTicket(lClassTicketCurrent.RelationTicketsIn.Objects[li]);
if SameText(lRelationTicket.DestinationPropertyName, ls_Objeto) then
begin
lClassTicketAux := lRelationTicket.OriginClassTicket;
ls_ant_objeto := '';
lbAchei := true;
break;
end;
end;
if not lbAchei then
begin
for li := 0 to pred(lClassTicketCurrent.RelationTicketsOut.Count) do
begin
lRelationTicket := acRelationTicket(lClassTicketCurrent.RelationTicketsOut.Objects[li]);
if SameText(lRelationTicket.OriginPropertyName, ls_Objeto) then
begin
lClassTicketAux := lRelationTicket.DestinationClassTicket;
ls_ant_objeto := '';
break;
end;
end;
end;
lClassTicketCurrent := lClassTicketAux;
end;
end;
result := lClassTicketCurrent;
if (trim(ls_ant_objeto) <> '') and (not Assigned(result)) then;
begin
if piRetonarClassAnterior then
begin
result := lCassTicketAnterior;
end;
end;
end
else
begin
//result := self.MetaModel.GetClassTicketByName(piNameObjeto);
result := Self.GetClassTicketByNameANDAlias(piNameObjeto);
end;
piNameAntObjeto := ls_ant_objeto;
end;
function TExplorerV2.GetClassTicketByNameANDAlias(piNameObjeto: string): acClassTicket;
var li_index : integer;
begin
result := self.MetaModel.GetClassTicketByName(piNameObjeto);
if not Assigned(result) then
begin
li_index := fAlias.IndexOf(upperCase(piNameObjeto));
if li_index >= 0 then
begin
result := acClassTicket(fAlias.Objects[li_index]);
end;
end;
end;
function TExplorerV2.GetTextoAfterWord(piSynEdit: TSynEdit): string;
var lWord : string;
p1,p2,PointAtual: TPoint;
begin
p1 := piSynEdit.PrevWordPos;
lWord := piSynEdit.GetWordAtRowCol(p1);
p1.X := p1.X + Length(lWord);
PointAtual := piSynEdit.CaretXY;
P2 := PointAtual;
result := piSynEdit.TextBetweenPoints[p1,p2];
if (trim(result) = '') and (p1.Y <> p2.Y) then
begin
p1.X := 0;
result := piSynEdit.TextBetweenPoints[p1,p2];
while (trim(result) = '') and (p1.Y > 0) do
begin
p2.Y := p1.Y;
p1.Y := p1.Y - 1;
result := piSynEdit.TextBetweenPoints[p1,p2];
end;
if trim(result) <> '' then
begin
p2.Y := p1.Y;
p2.X := Length(result);
piSynEdit.CaretXY := p2;
p1 := piSynEdit.PrevWordPos;
lWord := piSynEdit.GetWordAtRowCol(p1);
p1.X := p1.X + Length(lWord);
result := piSynEdit.TextBetweenPoints[p1,p2];
piSynEdit.CaretXY := PointAtual;;
end;
end
end;
function TExplorerV2.GetTextoBeforeWord(piSynEdit: TSynEdit): string;
var p1,p2: TPoint;
begin
p1 := piSynEdit.CaretXY;
p2 := piSynEdit.NextWordPos;
result := piSynEdit.TextBetweenPoints[p1,p2];
end;
function TExplorerV2.GetWordsBetweenPoint(piSynEdit: TSynEdit): string;
var lWord,
lWordAux,
ls_caractere,
ls_texto : string;
li_CareWordX,
li_LenWord,
li_PosInicio,
li_LenFim : integer;
p1,p2: TPoint;
begin
ls_texto := GetTextBetweenLines(piSynEdit,lWord,p1);
p2 := p1;
result := lWord;
li_PosInicio := p1.X;
li_LenFim := Length(lWord);
while (li_PosInicio > 0) and (lWord <> '') do
begin
p1.X := li_PosInicio - 1;
ls_caractere := trim(Copy(ls_texto,p1.X,1));
if ls_caractere = __PONTO then
begin
lWord := trim(piSynEdit.GetWordAtRowCol(p1));
li_LenWord := Length(lWord);
li_LenFim := li_LenFim + li_LenWord + 1;
p1.X := p1.X - li_LenWord;
end
else if ls_caractere = '' then
begin
break;
end
else
begin
lWordAux := trim(piSynEdit.GetWordAtRowCol(p1));
if (lWordAux)<> lWord then
begin
break;
end;
end;
li_PosInicio := p1.X;
end;
result := trim(Copy(ls_texto,li_PosInicio,li_LenFim));
if Pos(__PONTO,result) = 1 then
begin
result := trim(Copy(result,2,li_LenFim));
end;
end;
function TExplorerV2.GetTextBetweenLines(piSynEdit: TSynEdit; out
piWord: string; out piCareWordXY: TPoint): string;
var p1, p2, PointAtual: TPoint;
lLen : integer;
begin
//p1 := piSynEdit.PrevWordPos;
p1 := Self.GetPrevWordPosValida(piSynEdit);
piCareWordXY := p1;
p2 := piSynEdit.CaretXY;
PointAtual := P2;
if p1.Y <> p2.Y then
begin
piWord := trim(piSynEdit.GetWordAtRowCol(p1));
p1.X := 0;
if ((p2.Y - p1.Y) > 0) AND
(piWord = '') then
begin
result := piSynEdit.TextBetweenPoints[p1,p2];
while (trim(result) = '') and (p1.Y > 0) do
begin
p2.Y := p1.Y;
p1.Y := p1.Y - 1;
result := piSynEdit.TextBetweenPoints[p1,p2];
end;
lLen := Length(result);
piSynEdit.CaretX := lLen;
piSynEdit.CaretY := p1.Y;
piCareWordXY := piSynEdit.PrevWordPos;
piWord := trim(piSynEdit.GetWordAtRowCol(piCareWordXY));
piSynEdit.CaretXY:= PointAtual;
end
else
begin
result := piSynEdit.TextBetweenPoints[p1,p2];
piCareWordXY.X := piCareWordXY.X - Length(piWord);
end;
result := StringReplace(result,#13,'',[rfReplaceAll]);
result := StringReplace(result,#10,'',[rfReplaceAll]);
end
else
begin
result := piSynEdit.LineText;
piWord := trim(piSynEdit.GetWordAtRowCol(p1));
end;
end;
{
procedure TExplorerV2.PreparaSynCompletion;
var lAceitaAtributo : boolean;
ls_espaco,
ls_Aux : string;
li_Pos : integer;
p1,zeroPoint : TPoint;
begin
scpListCompletion.ItemList.Clear;
p1 := SynEditOQL.CaretXY ;
zeroPoint.X := 0;
zeroPoint.y := SynEditOQL.CaretY;
ls_aux := trim(SynEditOQL.TextBetweenPoints[zeroPoint,p1]);
ls_espaco := ' ';
lAceitaAtributo := true;
li_Pos := Pos(__FROM,uppercase(ls_aux));
if li_Pos > 0 then
begin
ls_aux:=trim(Copy(ls_aux,li_Pos + Length(__FROM),Length(ls_aux)));
lAceitaAtributo:= false;
end;
li_Pos := Pos(__SELECT,uppercase(ls_aux));
if li_Pos > 0 then
begin
ls_aux:=trim(Copy(ls_aux,li_Pos + Length(__SELECT),Length(ls_aux)));
lAceitaAtributo:= false;;
end;
li_Pos := Pos(__WHERE,uppercase(ls_aux));
if li_Pos > 0 then
begin
ls_aux:=trim(Copy(ls_aux,li_Pos + Length(__WHERE),Length(ls_aux)));
lAceitaAtributo:= true;;
end;
li_Pos := Pos(ls_espaco,trim(ls_aux));
while li_Pos > 0 do
begin
ls_aux:=trim(Copy(ls_aux,li_Pos + 1,Length(ls_aux)));
li_Pos := Pos(ls_espaco,ls_aux);
end;
LoadListCompletion(ls_aux,lAceitaAtributo,scpListCompletion.ItemList);
end; }
function TExplorerV2.RetirarPalavraChaveOLQ(piSynEdit: TSynEdit;opEve: TFaOpenEvent): string;
var lTextAfterWord,
lTextNextPoint: string;
lTemPalavra : Boolean;
begin
lTextAfterWord := GetTextoAfterWord(piSynEdit);
result := GetWordsBetweenPoint(piSynEdit);
lTextNextPoint := GetTextoBeforeWord(piSynEdit);
if not IsKeyword(result) then
begin
lTemPalavra := trim(result) <> '';
if (result <> '') and (lTextAfterWord <> '') then
begin
if trim(lTextAfterWord) <> '' then
begin
if SameText(__PONTO,lTextAfterWord) then
begin
result := result + lTextAfterWord
end
else
begin
result := lTextAfterWord;
if Trim(lTextAfterWord) = Trim(result) then
begin
lTemPalavra := false;
end;
if IsExepressaoValida(OpEve,trim(lTextAfterWord),lTemPalavra) then
begin
result := '';
end;
end;
end
else if trim(lTextAfterWord) = '' then
begin
if IsExepressaoValida(opEve,trim(Result)) then
begin
result := '';
end
else
begin
result := result + lTextAfterWord;
end;
end;
end
else if (lTextAfterWord <> '') then
begin
if not IsExepressaoValida(opEve,trim(lTextAfterWord),lTemPalavra) then
begin
result := lTextAfterWord;
end;
end
else if (Result <> '') then
begin
if IsExepressaoValida(opEve,trim(Result)) then
begin
result := '';
end;
end;
end
else
begin
lTemPalavra := false;
if (trim(lTextAfterWord) = '') or (trim(lTextNextPoint) = '') then
begin
result := '';
if not IsExepressaoValida(opEve,trim(lTextAfterWord),lTemPalavra) then
begin
result := lTextAfterWord;
end;
if not IsExepressaoValida(opEve,trim(lTextNextPoint),lTemPalavra) then
begin
result := lTextNextPoint;
end;
if not IsExepressaoValida(opEve,trim(lTextAfterWord),lTemPalavra) then
begin
result := lTextAfterWord;
end;
if not IsExepressaoValida(opEve,trim(lTextNextPoint),lTemPalavra) then
begin
result := lTextNextPoint;
end;
end;
end;
end;
function TExplorerV2.IsKeyword(piItem: string): boolean;
var li_index : integer;
begin
result := false;
li_index := fKeywords.IndexOf(piItem);
if li_index >= 0 then
begin
result := true;
end;
end;
function TExplorerV2.GetTextBetweenWord(piSynEdit :TSynEdit;piWordPos: TPoint;piWord: string): string;
var p1, p2: TPoint;
li_Pos : integer;
lWord : string;
begin
lWord := trim(piSynEdit.GetWordAtRowCol(piWordPos));
p1 := piWordPos;
p2 := piSynEdit.CaretXY;
if ((p2.Y - p1.Y) > 0) AND
(lWord = '') then
begin
result := '';
while (result = '') and (p1.Y > 0) do
begin
p1.Y := p1.Y - 1;
result := piSynEdit.TextBetweenPoints[p1,p2];
end;
end
else
begin
if p2.Y <> p1.Y then
begin
p1.X := p1.X - Length(lWord);
end;
result := piSynEdit.TextBetweenPoints[p1,p2];
end;
{li_Pos := Pos(piWord,piSynEdit.LineText);
p1 := piSynEdit.CaretXY;
if li_pos > 0 then
begin
p1.X:= li_Pos;
end;
result := piSynEdit.TextBetweenPoints[p1, piSynEdit.CaretXY]; }
end;
function TExplorerV2.IsExepressaoValida(piOpEve: TFaOpenEvent; piTexto: string;piTemPalavraAntes : Boolean = false ): boolean;
var ls_expressao : string;
li_Pos,
li_Len : integer;
ls_Caractere : string;
begin
result := true;
ls_expressao := '';
li_Pos := 1;
li_len := Length(piTexto);
if (piOpEve = fopEvenSelectCompleto) or
(piOpEve = fopEvenSearchSelect)
then
begin
if piTemPalavraAntes then
begin
ls_expressao := '=,(^*&';
end
else
begin
ls_expressao := '=,()^*#@$%&"!%''_-';
if (trim(piTexto) = __ASTERICO) then
begin
li_Pos := li_Len + 1;
result := false;
end;
end;
end
else if (piOpEve = fopEvenFromCompleto) or
(piOpEve = fopEvenSearchFrom)
then
begin
if piTemPalavraAntes then
begin
ls_expressao := ',(&^~';
end
else
begin
ls_expressao := '=,()^~#@$%&"!*''_-';
end
end
else if (piOpEve = fopEvenWhereCompleto) or
(piOpEve = fopEvenSearchWhere)
then
begin
if piTemPalavraAntes then
begin
ls_expressao := '=<>(^~*-+/&';
end
else
begin
ls_expressao := __CARACTERES_ESPECIAIS;
end;
end;
while li_Pos <= li_Len do
begin
ls_Caractere := trim(Copy(piTexto,li_Pos,1));
if ls_Caractere <> '' then
begin
if Pos(ls_Caractere,ls_expressao) <= 0 then
begin
result := false;
break;
end;
end;
li_Pos := li_Pos + 1;
end;
end;
function TExplorerV2.GetPrevWordPosValida(piSynEdit: TSynEdit): TPoint;
var lWordAnt,
lWord : string;
begin
result := piSynEdit.PrevWordPos;
lWordAnt := trim(piSynEdit.GetWordAtRowCol(result));
if lWordAnt = '' then
begin
while (trim(lWordAnt) = '') and (result.Y > 0) do
begin
result.Y := result.Y - 1;
lWordAnt := trim(piSynEdit.GetWordAtRowCol(result));
end;
result.X := result.X + Length(lWordAnt) + 1;
lWord := trim(piSynEdit.GetWordAtRowCol(result));
while lWord <> lWordAnt do
begin
lWordAnt := lWord;
result.X := result.X + Length(lWord);
lWord := trim(piSynEdit.GetWordAtRowCol(result));
end;
end;
end;
procedure TExplorerV2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
{$IFDEF LCLWin32}
// Params.WndParent := 0;
{$ENDIF}
end;
procedure TExplorerV2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
procedure TExplorerV2.FormCreate(Sender: TObject);
var lMetaModelGenOpt: TMetaModelGenerationOptions;
lSelectBlock,
lSelectSec,
lFromSec,
lWhereSec: TFaSynBlock;
li : integer;
begin
lMetaModelGenOpt.CheckDBAttributeNameLength := true;
lMetaModelGenOpt.CheckDBTableNameLength := true;
fUtil := TUtil.Create;
fUtil.AlimentarMetamodel(lMetaModelGenOpt, nil);
FMetaModelPersistenceMap := fUtil.MetaModelPersistenceMap;
MetaModel := fUtil.MetaModel;
fKeywords := TStringList.Create;
fKeywords.Add(__SELECT);
fKeywords.Add(__FROM);
fKeywords.Add(__WHERE);
fKeywords.Add(__ORDER);
fKeywords.Add(__BY);
fKeywords.Add(__JOIN);
fKeywords.Add(__GROUP);
fKeywords.Add(__EXISTS);
fKeywords.Add(__IN);
fAlias := TStringList.Create;
fhlt1 := TSynFacilComplet.Create(self); //my highlighter
//Here the syntax is defined
// ...
fhlt1.SelectEditor(SynEditOQL);
fhlt1.Rebuild;
fhlt1.CompletionOn:=true;
fhlt1.OpenOnKeyUp:=true;
fhlt1.SelectOnEnter:= true;
fhlt1.DefTokIdentif('[$A-Za-z_]', '[A-Za-z0-9_]*');
fhlt1.KeywordAttribute.Foreground:=clBlue;
for li := 0 to fKeywords.Count - 1 do
begin
fhlt1.AddKeyword(fKeywords.Strings[li]);
end;
lSelectSec := fhlt1.AddSection(__SELECT);
lFromSec := fhlt1.AddSection(__FROM);
lWhereSec := fhlt1.AddSection(__WHERE);
fopEvenSearchSelect := fhlt1.AddOpenEvent('identifier','',fil_LastIdentPart);
//fopEvenSearchSelect.Action := pac_Rep_LastTok;
fopEvenSearchSelect.block := lSelectSec;
fopEvenSearchFrom := fhlt1.AddOpenEvent('identifier','',fil_LastIdentPart);
//fopEvenSearchFrom.Action := pac_Rep_LastTok;
fopEvenSearchFrom.block := lFromSec;
fopEvenSearchWhere := fhlt1.AddOpenEvent('identifier','',fil_LastIdentPart);
//fopEvenSearchWhere.Action := pac_Rep_LastTok;
fopEvenSearchWhere.block := lWhereSec;
fopEvenSelectAposPonto := fhlt1.AddOpenEvent('identifier,''.''','',fil_None);
fopEvenSelectAposPonto.Action := pac_Insert;
fopEvenSelectAposPonto.block := lSelectSec;
fopEvenFromAposPonto := fhlt1.AddOpenEvent('identifier,''.''','',fil_None);
fopEvenFromAposPonto.Action := pac_Insert;
fopEvenFromAposPonto.block := lFromSec;
fopEvenWhereAposPonto := fhlt1.AddOpenEvent('identifier,''.''','',fil_None);
fopEvenWhereAposPonto.Action := pac_Insert;
fopEvenWhereAposPonto.block := lWhereSec;
fopEvenSelectCompleto := fhlt1.AddOpenEvent('','',fil_None);
fopEvenselectCompleto.Action := pac_Insert;;
fopEvenSelectCompleto.block := lSelectSec;
fopEvenFromCompleto := fhlt1.AddOpenEvent('','',fil_None);
fopEvenFromCompleto.Action := pac_Insert;;
fopEvenFromCompleto.block := lFromSec;
fopEvenWhereCompleto := fhlt1.AddOpenEvent('','',fil_None);
fopEvenWhereCompleto.Action := pac_Insert;;
fopEvenWhereCompleto.block := lWhereSec;
fopEvenFromAposPonto.OnLoadItems :=opEveLoadItems;
fopEvenSelectAposPonto.OnLoadItems :=opEveLoadItems;
fopEvenWhereAposPonto.OnLoadItems :=opEveLoadItems;
fopEvenselectCompleto.OnLoadItems :=opEveLoadItems;
fopEvenFromCompleto.OnLoadItems :=opEveLoadItems;
fopEvenWhereCompleto.OnLoadItems :=opEveLoadItems;
fopEvenSearchSelect.OnLoadItems :=opEveLoadItems;
fopEvenSearchFrom.OnLoadItems :=opEveLoadItems;
fopEvenSearchWhere.OnLoadItems :=opEveLoadItems;
end;
procedure TExplorerV2.FormDestroy(Sender: TObject);
begin
fUtil.Free;
fhlt1.UnSelectEditor;
fhlt1.Free;
fKeywords.Free;
fAlias.Free;
end;
procedure TExplorerV2.opEveLoadItems(opEve: TFaOpenEvent;
curEnv: TFaCursorEnviron; out Cancel: boolean);
var lLista : TStrings;
ls_Texto,
lLinha : string;
lAceitaAtributo : boolean;
li : integer;
begin
opEve.ClearAvails;
lAceitaAtributo := false;
ls_Texto := SynEditOQL.GetWordAtRowCol(SynEditOQL.CaretXY);
if not IsKeyword(ls_Texto) then
begin
if (opEve = fopEvenSelectAposPonto) or
(opEve = fopEvenWhereAposPonto) or
(opEve = fopEvenFromAposPonto) or
(opEve = fopEvenWhereCompleto) or
(opEve = fopEvenSearchWhere) or
(opEve = fopEvenSearchSelect) or
(opEve = fopEvenselectCompleto)
then
begin
LoadAliasOQLEdit(SynEditOQL.Text,fAlias);
if (opEve = fopEvenWhereCompleto) or
(opEve = fopEvenSearchWhere) or
(opEve = fopEvenWhereAposPonto)
then
begin
lAceitaAtributo := true;
end
else if (opEve = fopEvenSelectAposPonto) or
(opEve = fopEvenSearchSelect) or
(opEve = fopEvenselectCompleto)
then
begin
if XMLQuery.Checked then
begin
lAceitaAtributo := true;
end;
end;
end;
lLista := TStringList.Create;
try
lLinha := RetirarPalavraChaveOLQ(SynEditOQL,opEve);
LoadListCompletion(lLinha,lAceitaAtributo,lLista);
if lLista.Count > 0 then
begin
opEve.AddAvail('');
end;
for li := 0 to lLista.Count - 1 do
begin
opEve.AddAvail(lLista.Strings[li]);
end
finally
lLista.Free;
end;
end;
Cancel := true;
end;
procedure TExplorerV2.MontarModelExploreSequencial(Sender: TObject; Node: TTreeNode);
var lClassTicket: acClassTicket;
lAttributeTicket: acAttributeTicket;
lRelationTicket: acRelationTicket;
lCardinality: string;
lEnumerator: acEnumerator;
li: integer;
targetNode : TTreeNode;
lFiltro : boolean;
begin
lFiltro := trim(edtClasse.Text) <> '';
if Node.HasChildren and (Node.Count = 0)then
begin
Node.Owner.BeginUpdate;
try
if (TObject(Node.Data) is acMetaModel) then
begin
lEnumerator := acMetaModel(Node.Data).ClassTickets.GetEnumerator;
while not lEnumerator.EOL do
begin
lClassTicket := acClassTicket(lEnumerator.Current);
if BuscaParcialClasse(lClassTicket.PersistentObjectClassName,lFiltro) then
begin
targetNode := Node.Owner.AddChildObject(Node, lClassTicket.PersistentObjectClassName, lClassTicket);
targetNode.ImageIndex := 6;
targetNode.HasChildren := True;
end;
lEnumerator.MoveNext;
end;
end
else if (TObject(Node.Data) is acClassTicket) then
begin
lClassTicket := acClassTicket(Node.Data);
repeat
for li := 0 to pred(lClassTicket.Attributes.Count) do
begin
lAttributeTicket := acAttributeTicket(lClassTicket.Attributes.Objects[li]);
if lAttributeTicket.Stereotype = acAttributeStereotype.pvPersistent then
begin
targetNode := Node.Owner.AddChildObject(Node, lAttributeTicket.AttributeName + ': ' + lAttributeTicket.AttributeType, lAttributeTicket);
if lAttributeTicket.Mandatory then
targetNode.ImageIndex := 5
else
targetNode.ImageIndex := 0;
end;
end;
for li := 0 to pred(lClassTicket.RelationTicketsIn.Count) do
begin
lRelationTicket := acRelationTicket(lClassTicket.RelationTicketsIn.Objects[li]);
if lRelationTicket.DestinationMaxMultiplicity = N
then lCardinality := '*'
else lCardinality := inttostr(lRelationTicket.DestinationMaxMultiplicity);
if lRelationTicket.DestinationPropertyName <> '' then
begin
targetNode := Node.Owner.AddChildObject(Node, lRelationTicket.DestinationPropertyName + ': (' + lCardinality + ') ' + lRelationTicket.OriginClassTicket.PersistentObjectClassName, lRelationTicket.OriginClassTicket);
targetNode.HasChildren := True;
if lRelationTicket.DestinationMaxMultiplicity = N then
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 4
else
targetNode.ImageIndex := 2;
end
else
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 3
else
targetNode.ImageIndex := 1;
end;
end;
end;
for li := 0 to pred(lClassTicket.RelationTicketsOut.Count) do
begin
lRelationTicket := acRelationTicket(lClassTicket.RelationTicketsOut.Objects[li]);
if lRelationTicket.OriginPropertyName <> '' then
begin
if lRelationTicket.OriginMaxMultiplicity = N
then lCardinality := '*'
else lCardinality := inttostr(lRelationTicket.OriginMaxMultiplicity);
targetNode := Node.Owner.AddChildObject(Node, lRelationTicket.OriginPropertyName + ': (' + lCardinality + ') ' + lRelationTicket.DestinationClassTicket.PersistentObjectClassName, lRelationTicket.DestinationClassTicket);
targetNode.HasChildren := True;
if lRelationTicket.OriginMaxMultiplicity = N then
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 4
else
targetNode.ImageIndex := 2;
end
else
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 3
else
targetNode.ImageIndex := 1;
end;
end;
end;
lClassTicket := lClassTicket.ParentClassTicket;
until lClassTicket = nil;
end;
finally
Node.Owner.EndUpdate;
end;
end;
end;
procedure TExplorerV2.MontarModelExploreHieraquia(Sender: TObject; Node: TTreeNode);
var lClassTicketChild,
lClassTicketPatriarc,
lClassTicket: acClassTicket;
lAttributeTicket: acAttributeTicket;
lRelationTicket: acRelationTicket;
lCardinality: string;
lEnumeratorChild,
lEnumerator: acEnumerator;
li: integer;
lNodePatriarc,
targetNode : TTreeNode;
lFiltroIgualFilho,
lbIncluir,
lFiltroIgualPai,
lAchei,
lFiltro : boolean;
begin
lFiltro := trim(edtClasse.Text) <> '';
if Node.HasChildren and (Node.Count = 0) then
begin
Node.Owner.BeginUpdate;
try
if (TObject(Node.Data) is acMetaModel) then
begin
//Carregas o pai
lEnumerator := acMetaModel(Node.Data).ClassTickets.GetEnumerator;
try
while not lEnumerator.EOL do
begin
lClassTicket := acClassTicket(lEnumerator.Current);
lAchei := false;
lFiltroIgualFilho := false;
if not Assigned(lClassTicket.ParentClassTicket) then
begin
lClassTicketChild := FindParcialNodeClass(lClassTicket,lFiltro);
if Assigned(lClassTicketChild) then
begin
if lClassTicket <> lClassTicketChild then
begin
if not Assigned(Node.Owner.FindNodeWithData(lClassTicket)) then
begin
lAchei := true;
lFiltroIgualFilho := true;
end;
end
else
begin
lAchei := true;
end;
if lAchei then
begin
targetNode := Node.Owner.AddChildObject(Node, lClassTicket.PersistentObjectClassName, lClassTicket);
targetNode.ImageIndex := 6;
targetNode.HasChildren := True;
if lFiltroIgualFilho then
begin
targetNode.Expanded := true;
end;
end;
end;
end;
lEnumerator.MoveNext;
end;
finally
lEnumerator.Free;
end;
end
else if (TObject(Node.Data) is acClassTicket) then
begin
lClassTicket := acClassTicket(Node.Data);
for li := 0 to pred(lClassTicket.Attributes.Count) do
begin
lAttributeTicket := acAttributeTicket(lClassTicket.Attributes.Objects[li]);
if lAttributeTicket.Stereotype = acAttributeStereotype.pvPersistent then
begin
targetNode := Node.Owner.AddChildObject(Node, lAttributeTicket.AttributeName + ': ' + lAttributeTicket.AttributeType, lAttributeTicket);
if lAttributeTicket.Mandatory then
targetNode.ImageIndex := 5
else
targetNode.ImageIndex := 0;
end;
end;
for li := 0 to pred(lClassTicket.RelationTicketsIn.Count) do
begin
lRelationTicket := acRelationTicket(lClassTicket.RelationTicketsIn.Objects[li]);
if lRelationTicket.DestinationMaxMultiplicity = N
then lCardinality := '*'
else lCardinality := inttostr(lRelationTicket.DestinationMaxMultiplicity);
if lRelationTicket.DestinationPropertyName <> '' then
begin
targetNode := Node.Owner.AddChildObject(Node, lRelationTicket.DestinationPropertyName + ': (' + lCardinality + ') ' + lRelationTicket.OriginClassTicket.PersistentObjectClassName, lRelationTicket.OriginClassTicket);
targetNode.HasChildren := True;
if lRelationTicket.DestinationMaxMultiplicity = N then
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 4
else
targetNode.ImageIndex := 2;
end
else
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 3
else
targetNode.ImageIndex := 1;
end;
end;
end;
for li := 0 to pred(lClassTicket.RelationTicketsOut.Count) do
begin
lRelationTicket := acRelationTicket(lClassTicket.RelationTicketsOut.Objects[li]);
if lRelationTicket.OriginPropertyName <> '' then
begin
if lRelationTicket.OriginMaxMultiplicity = N
then lCardinality := '*'
else lCardinality := inttostr(lRelationTicket.OriginMaxMultiplicity);
targetNode := Node.Owner.AddChildObject(Node, lRelationTicket.OriginPropertyName + ': (' + lCardinality + ') ' + lRelationTicket.DestinationClassTicket.PersistentObjectClassName, lRelationTicket.DestinationClassTicket);
targetNode.HasChildren := True;
if lRelationTicket.OriginMaxMultiplicity = N then
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 4
else
targetNode.ImageIndex := 2;
end
else
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 3
else
targetNode.ImageIndex := 1;
end;
end;
end;
if lClassTicket.HasDescendants then
begin
//Carrega os filhos
if Assigned(lClassTicket.PatriarcClassTicket) then
begin
lFiltroIgualPai := BuscaParcialClasse(lClassTicket.PatriarcClassTicket.PersistentObjectClassName,lFiltro);
end
else
begin
lFiltroIgualPai := BuscaParcialClasse(lClassTicket.PersistentObjectClassName,lFiltro);
end;
lEnumerator := lClassTicket.DirectDescendants.GetEnumerator;
try
while not lEnumerator.EOL do
begin
lClassTicketChild := acClassTicket(lEnumerator.Current);
lFiltroIgualFilho := BuscarParcialChildClass(lClassTicketChild,lFiltro);
lbIncluir := lFiltroIgualPai or lFiltroIgualFilho;
if lbIncluir then
begin
targetNode := Node.Owner.AddChildObject(Node, lClassTicketChild.PersistentObjectClassName, lClassTicketChild);
targetNode.ImageIndex := 6;
targetNode.HasChildren := True;
if lFiltroIgualFilho then
begin
targetNode.Expanded := true;
end;
end;
lEnumerator.MoveNext;
end;
finally
lEnumerator.Free;
end;
end;
end;
finally
Node.Owner.EndUpdate;
end;
end;
end;
procedure TExplorerV2.FormShow(Sender: TObject);
begin
OQLQuery.Execute;
spResultObject.Visible := False;
spResultObject.Align := alNone;
spResultXML.Visible := False;
spResultXML.Align := alNone;
pnlResult.Visible := False;
pcEditor.ActivePageIndex := 0;
pcResults.ActivePageIndex := 1;
end;
function TExplorerV2.GetNumeroDeStringOID(piString: string): string;
var
lString : string;
lEnum : Integer;
begin
lString := '';
// Verifica se a string tem mais que 4 caracteres
if Length(piString) > 4 then
begin
// Extrai os 4 primeiros caracteres da string
for lEnum := 1 to 4 do
begin
lString := Concat(lString,piString[lEnum])
end;
// Se a string comear com OID: esses 4 primeiro caracteres sero excludos
if lString = 'OID:' then
begin
lString := '';
for lEnum := 5 to Length(piString) do
begin
lString := Concat(lString,piString[lEnum])
end;
end
// Caso contrrio copia-se a string toda
else
begin
lString := '';
for lEnum := 1 to Length(piString) do
begin
lString := Concat(lString,piString[lEnum])
end;
end;
end
else
begin
lString := piString;
end;
Result := lString;
end;
function TExplorerV2.GetClassTicket(piBloco, piPropertyName: string
): acClassTicket;
var lEnumerator: acEnumerator;
lRelationTicket : acRelationTicket;
begin
lEnumerator := MetaModel.RelationTickets.GetEnumerator;
try
while not lEnumerator.EOL do
begin
lRelationTicket := acRelationTicket(lEnumerator.Current);
//if lRelationTicket.;
lEnumerator.MoveNext;
end;
finally
lEnumerator.Free;
end;
end;
function TExplorerV2.GetStringEntreParenteses(piString: string): string;
var
lString : string;
lEnum : Integer;
flagDadosDesejados : Boolean;
begin
flagDadosDesejados := False;
lString := '';
for lEnum := 1 to Length(piString) do
begin
// Fim dos dados entre parenteses
if piString[lEnum] = ')' then
flagDadosDesejados := False;
if flagDadosDesejados then
begin
lString := Concat(lString,piString[lEnum])
end;
// Inicio dos dados entre parenteses
if piString[lEnum] = '(' then
flagDadosDesejados := True;
end;
Result := lString;
end;
procedure TExplorerV2.memOQLQuery2DragDrop(Sender, Source: TObject; X,Y: Integer);
function FromClause(piNode: TTreeNode; var poPath: string): string;
begin
if piNode.Level = 1
then begin
poPath := acClassTicket(piNode.Data).PersistentObjectClassName;
result := poPath;
end
else begin
result := FromClause(piNode.Parent, poPath);
poPath := poPath + '.' + copy(piNode.Text, 1, pred(pos(':', piNode.Text)));
result := result + ', ' + #13#10 + ' ' + poPath;
end;
end;
var lCaption: string;
lNode: TTreeNode;
lPath: string;
lFrom: string;
lSelect: string;
begin
if Source is TTreeView then
begin
lNode := TTreeView(Source).Selected;
if (TObject(lNode.Data) is acClassTicket)
then begin
lCaption := acClassTicket(lNode.Data).PersistentObjectClassName;
if GetKeyState(VK_CONTROL) < 0
then SynEditOQL.SelText := #13#10 +
'SELECT ' + lCaption + #13#10 +
'FROM ' + lCaption
else SynEditOQL.SelText := lCaption;
end
else if (TObject(lNode.Data) is acAttributeTicket) then
begin
if GetKeyState(VK_CONTROL) < 0
then begin
lCaption := (TObject(lNode.Parent.data) as acClassTicket).PersistentObjectClassName;
lFrom := FromClause(lNode.Parent, lPath);
lSelect := copy(lPath, 1, pred(pos('.', lPath)));
if lSelect = '' then lSelect := lPath;
SynEditOQL.SelText := #13#10 +
'SELECT ' + lSelect + #13#10 +
'FROM ' + lFrom + #13#10 +
'WHERE ' + lPath + '.' + acAttributeTicket(lNode.Data).AttributeName + ' = ';
end else SynEditOQL.SelText := acAttributeTicket(lNode.Data).AttributeName;
end;
end;
end;
procedure TExplorerV2.memOQLQuery2DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
var
lNode: TTreeNode;
begin
if Source is TTreeView then
begin
if Accept then
begin
lNode := TTreeView(Source).Selected;
Accept := ((TObject(lNode.Data) is acClassTicket) or (TObject(lNode.Data) is acAttributeTicket));
if (State = dsDragEnter) and (Sender is TWinControl) then TWinControl(Sender).SetFocus;
end
end;
end;
procedure TExplorerV2.OQLObjectstvExplorerKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
// Copia dados do objeto ao apertar Ctrl + C
if (Key = 67) and (Shift = [ssCtrl]) then
begin
if Assigned(OQLObjects.tvExplorer.Selected) then
CopiaTextoObjeto(OQLObjects.tvExplorer.Selected);
end;
end;
procedure TExplorerV2.OQLObjectstvExplorerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
lPoint : TPoint;
begin
GetCursorPos(lPoint);
if (Button = mbRight) then
begin
pmCopiar.Popup(lPoint.X ,lPoint.Y );
end; end;
end; end;
...@@ -780,105 +2409,14 @@ begin ...@@ -780,105 +2409,14 @@ begin
end; end;
procedure TExplorerV2.tvModelExplorerItemExpanding(Sender: TObject; Node: TTreeNode; var AllowExpansion: Boolean); procedure TExplorerV2.tvModelExplorerItemExpanding(Sender: TObject; Node: TTreeNode; var AllowExpansion: Boolean);
var lClassTicket: acClassTicket;
lAttributeTicket: acAttributeTicket;
lRelationTicket: acRelationTicket;
lCardinality: string;
lEnumerator: acEnumerator;
li: integer;
targetNode : TTreeNode;
begin begin
if Node.HasChildren and (Node.Count = 0)then if rbSequencial.Checked then
begin
Node.Owner.BeginUpdate;
try
if (TObject(Node.Data) is acMetaModel) then
begin
lEnumerator := acMetaModel(Node.Data).ClassTickets.GetEnumerator;
while not lEnumerator.EOL do
begin
lClassTicket := acClassTicket(lEnumerator.Current);
targetNode := Node.Owner.AddChildObject(Node, lClassTicket.PersistentObjectClassName, lClassTicket);
targetNode.ImageIndex := 6;
targetNode.HasChildren := True;
lEnumerator.MoveNext;
end;
end
else if (TObject(Node.Data) is acClassTicket) then
begin
lClassTicket := acClassTicket(Node.Data);
repeat
for li := 0 to pred(lClassTicket.Attributes.Count) do
begin
lAttributeTicket := acAttributeTicket(lClassTicket.Attributes.Objects[li]);
if lAttributeTicket.Stereotype = acAttributeStereotype.pvPersistent then
begin begin
targetNode := Node.Owner.AddChildObject(Node, lAttributeTicket.AttributeName + ': ' + lAttributeTicket.AttributeType, lAttributeTicket); MontarModelExploreSequencial(Sender,Node);
if lAttributeTicket.Mandatory then
targetNode.ImageIndex := 5
else
targetNode.ImageIndex := 0;
end;
end;
for li := 0 to pred(lClassTicket.RelationTicketsIn.Count) do
begin
lRelationTicket := acRelationTicket(lClassTicket.RelationTicketsIn.Objects[li]);
if lRelationTicket.DestinationMaxMultiplicity = N
then lCardinality := '*'
else lCardinality := inttostr(lRelationTicket.DestinationMaxMultiplicity);
if lRelationTicket.DestinationPropertyName <> '' then
begin
targetNode := Node.Owner.AddChildObject(Node, lRelationTicket.DestinationPropertyName + ': (' + lCardinality + ') ' + lRelationTicket.OriginClassTicket.PersistentObjectClassName, lRelationTicket.OriginClassTicket);
targetNode.HasChildren := True;
if lRelationTicket.DestinationMaxMultiplicity = N then
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 4
else
targetNode.ImageIndex := 2;
end
else
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 3
else
targetNode.ImageIndex := 1;
end;
end;
end;
for li := 0 to pred(lClassTicket.RelationTicketsOut.Count) do
begin
lRelationTicket := acRelationTicket(lClassTicket.RelationTicketsOut.Objects[li]);
if lRelationTicket.OriginPropertyName <> '' then
begin
if lRelationTicket.OriginMaxMultiplicity = N
then lCardinality := '*'
else lCardinality := inttostr(lRelationTicket.OriginMaxMultiplicity);
targetNode := Node.Owner.AddChildObject(Node, lRelationTicket.OriginPropertyName + ': (' + lCardinality + ') ' + lRelationTicket.DestinationClassTicket.PersistentObjectClassName, lRelationTicket.DestinationClassTicket);
targetNode.HasChildren := True;
if lRelationTicket.OriginMaxMultiplicity = N then
begin
if lRelationTicket.DestinationMinMultiplicity = 1 then
targetNode.ImageIndex := 4
else
targetNode.ImageIndex := 2;
end end
else else if rbHieraquia.Checked then
begin begin
if lRelationTicket.DestinationMinMultiplicity = 1 then MontarModelExploreHieraquia(Sender,Node);
targetNode.ImageIndex := 3
else
targetNode.ImageIndex := 1;
end;
end;
end;
lClassTicket := lClassTicket.ParentClassTicket;
until lClassTicket = nil;
end;
finally
Node.Owner.EndUpdate;
end;
end; end;
end; end;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment