romfast/foxbin2prg
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
5d6197282d3efe6b5614177f8e3a88a4487fc5fb
foxbin2prg/foxbin2prg.prg
fdbozzo 5d6197282d Changeset: 190 fdbozzo - 07/03/2014 18:52:38: 
- Arreglo bug vcx/scx: valor character con longitud >255 en propiedad de addobject, se regenera con tag <fb2p_value> incluido (Ryan Harris)
2014-03-07 18:56:09 +01:00

17850 lines
615 KiB
Plaintext
Raw Blame History

*---------------------------------------------------------------------------------------------------
* Módulo.........: FOXBIN2PRG.PRG - PARA VISUAL FOXPRO 9.0
* Autor..........: Fernando D. Bozzo (mailto:fdbozzo@gmail.com) - http://fdbozzo.blogspot.com
* Fecha creación.: 04/11/2013
*
* LICENCIA:
* Esta obra está sujeta a la licencia Reconocimiento-CompartirIgual 4.0 Internacional de Creative Commons.
* Para ver una copia de esta licencia, visite http://creativecommons.org/licenses/by-sa/4.0/deed.es_ES.
*
* LICENCE:
* This work is licensed under the Creative Commons Attribution 4.0 International License.
* To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/.
*
*---------------------------------------------------------------------------------------------------
* DESCRIPCIÓN....: CONVIERTE EL ARCHIVO VCX/SCX/PJX INDICADO A UN "PRG HÍBRIDO" PARA POSTERIOR RECONVERSIÓN.
* * EL PRG HÍBRIDO ES UN PRG CON ALGUNAS SECCIONES BINARIAS (OLE DATA, ETC)
* * EL OBJETIVO ES PODER USARLO COMO REEMPLAZO DEL SCCTEXT.PRG, PODER HACER MERGE
* DEL CÓDIGO DIRECTAMENTE SOBRE ESTE NUEVO PRG Y GUARDARLO EN UNA HERRAMIENTA DE SCM
* COMO CVS O SIMILAR SIN NECESIDAD DE GUARDAR LOS BINARIOS ORIGINALES.
* * EXTENSIONES GENERADAS: VC2, SC2, PJ2 (...o VCA, SCA, PJA con archivo conf.)
* * CONFIGURACIÓN: SI SE CREA UN ARCHIVO FOXBIN2PRG.CFG, SE PUEDEN CAMBIAR LAS EXTENSIONES
* PARA PODER USARLO CON SOURCESAFE PONIENDO LAS EQUIVALENCIAS ASÍ:
*
* extension: VC2=VCA
* extension: SC2=SCA
* extension: PJ2=PJA
*
* USO/USE:
* DO FOXBIN2PRG.PRG WITH "<path>\FILE.VCX" && Genera "<path>\FILE.VC2" (BIN TO PRG CONVERSION)
* DO FOXBIN2PRG.PRG WITH "<path>\FILE.VC2" && Genera "<path>\FILE.VCX" (PRG TO BIN CONVERSION)
*
* DO FOXBIN2PRG.PRG WITH "<path>\FILE.SCX" && Genera "<path>\FILE.SC2" (BIN TO PRG CONVERSION)
* DO FOXBIN2PRG.PRG WITH "<path>\FILE.SC2" && Genera "<path>\FILE.SCX" (PRG TO BIN CONVERSION)
*
* DO FOXBIN2PRG.PRG WITH "<path>\FILE.PJX" && Genera "<path>\FILE.PJ2" (BIN TO PRG CONVERSION)
* DO FOXBIN2PRG.PRG WITH "<path>\FILE.PJ2" && Genera "<path>\FILE.PJX" (PRG TO BIN CONVERSION)
*
*---------------------------------------------------------------------------------------------------
* <HISTORIAL DE CAMBIOS Y NOTAS IMPORTANTES>
* 04/11/2013 FDBOZZO v1.0 Creación inicial de las clases y soporte de los archivos VCX/SCX/PJX
* 22/11/2013 FDBOZZO v1.1 Corrección de bugs
* 23/11/2013 FDBOZZO v1.2 Corrección de bugs, limpieza de código y refactorización
* 24/11/2013 FDBOZZO v1.3 Corrección de bugs, limpieza de código y refactorización
* 27/11/2013 FDBOZZO v1.4 Agregado soporte comodines *.VCX, configuración de extensiones (vca), parámetro p/log
* 27/11/2013 FDBOZZO v1.5 Arreglo bug que no generaba form completo
* 01/12/2013 FDBOZZO v1.6 Refactorización completa generación BIN y PRG, cambio de algoritmos, arreglo de bugs, Unit Testing con FoxUnit
* 02/12/2013 FDBOZZO v1.7 Arreglo bug "Name", barra de progreso, agregado mensaje de ayuda si se llama sin parámetros, verificación y logueo de archivos READONLY con debug activa
* 03/12/2013 FDBOZZO v1.8 Arreglo bug "Name" (otra vez), sort encapsulado y reutilizado para versiones TEXTO y BIN por seguridad
* 06/12/2013 FDBOZZO v1.9 Arreglo bug pérdida de propiedades causado por una mejora anterior
* 06/12/2013 FDBOZZO v1.10 Arreglo del bug de mezcla de métodos de una clase con la siguiente
* 07/12/2013 FDBOZZO v1.11 Arreglo del bug de _amembers detectado por Edgar K.con la clase BlowFish.vcx (http://www.tortugaproductiva.galeon.com/docs/blowfish/index.html)
* 07/12/2013 FDBOZZO v1.12 Agregado soporte preliminar de conversión de reportes y etiquetas (FRX/LBX)
* 08/12/2013 FDBOZZO v1.13 Arreglo bug "Error 1924, TOREG is not an object"
* 15/12/2013 FDBOZZO v1.14 Arreglo de bug AutoCenter y registro COMMENT en regeneración de forms
* 08/12/2013 FDBOZZO v1.15 Agregado soporte preliminar de conversión de tablas, índices y bases de datos (DBF,CDX,DBC)
* 18/12/2013 FDBOZZO v1.16 Agregado soporte para menús (MNX)
* 03/01/2014 FDBOZZO v1.17 Agregado Unit Testing de menús y arreglo de las incidencias del menu
* 05/01/2013 FDBOZZO v1.18 Agregado soporte para generar estructuras TEXTO de DBFs anteriores a VFP 9, pero los binarios a VFP 9 // Arreglado bug de datos faltantes en campos de vistas // Arreglado bug mnx
* 08/01/2014 FDBOZZO v1.19 Arreglo bug SCX-VCX: Orden incorrecto en Reserved3 ocaciona que no se disparen eventos ACCESS (y probablemente ASIGN)
* 08/01/2014 FDBOZZO v1.19 Arreglo bug DBF: Tipo de índice generado incorrecto en DB2 cuando es Candidate
* 08/01/2014 FDBOZZO v1.19 Agregado soporte para convertir PJM a PJ2
* 08/01/2014 FDBOZZO v1.19 Agregada validación al convertir Menús con estructura anterior a VFP9
* 08/01/2014 FDBOZZO v1.19 Cambiada la propiedad "Autor" por "Author" en los archivos MN2
* 08/01/2014 FDBOZZO v1.19.1 Cambio en los headers de los archivos TX2 para quitar el timestamp "Generated" que causa diferencias innecesarias
* 08/01/2014 FDBOZZO v1.19.2 Arreglo de bug PJ2: Al regenerar da un error por buscar "Autor" en vez de "Author"
* 08/01/2014 FDBOZZO v1.19.3 Cambio en los timestamps de los TXT para mantener los valores vacíos que generaban muchísimas diferencias
* 22/01/2014 FDBOZZO v1.19.4 Nuevo parámetro Recompile para forzar la recompilación. Ahora por defecto el binario no se recompila para ganar velocidad y evitar errores. Debe recompilar manualmente.
* 22/01/2014 FDBOZZO v1.19.4 DBC: Agregado soporte para comentarios multilínea (propiedad Comment)
* 26/01/2014 FDBOZZO v1.19.5 Agregado soporte multiidioma y traducción al Inglés
* 01/02/2014 FDBOZZO v1.19.6 Agregada compatibilidad con SourceSafe para Diff y Merge
* 02/02/2014 FDBOZZO v1.19.7 Encapsulación de objetos OLE en el propio control o clase // Blocksize ajustado
* 03/02/2014 FDBOZZO v1.19.8 Arreglo bug pageframe (error activePage)
* 08/02/2014 FDBOZZO v1.19.9 Nuevos items de config.en foxbin2prg.cfg / Bug en Localización / Mejora log / Parametrización Nº backups / Timestamps desactivados por defecto
* 09/02/2014 FDBOZZO v1.19.10 Parametrización soporte de tipo de conversión por archivo / ClearUniqueID
* 13/02/2014 FDBOZZO v1.19.11 Optimizaciones WITH/ENDWITH (16%+velocidad) / Arreglo bug #IF anidados
* 21/02/2014 FDBOZZO v1.19.12 Centralizar ZOrder controles en metadata de cabecera de clase para minimizar diferencias / También mover UniqueIDs y Timestamps a metadata
* 26/02/2014 FDBOZZO v1.19.13 Arreglo bug TimeStamp en archivo cfg / ExtraBackupLevels se puede desactivar / Optimizaciones / Casos FoxUnit
* 01/03/2014 FDBOZZO v1.19.14 Arreglo bug regresion cuando no se define ExtraBackupLevels no hace backups / Optimización carga cfg en batch
* 04/03/2014 FDBOZZO v1.19.15 Arreglo bugs: OLE TX2 legacy / NoTimestamp=0 / DBFs backlink
* 07/03/2014 FDBOZZO v1.19.16
* </HISTORIAL DE CAMBIOS Y NOTAS IMPORTANTES>
*
*---------------------------------------------------------------------------------------------------
* <TESTEO Y REPORTE DE BUGS (AGRADECIMIENTOS)>
* 23/11/2013 Luis Martínez REPORTE BUG scx v1.4: En algunos forms solo se generaba el dataenvironment (arreglado en v.1.5)
* 27/11/2013 Fidel Charny REPORTE BUG vcx v1.5: Error en el guardado de ciertas propiedades de array (arreglado en v.1.6)
* 02/12/2013 Fidel Charny REPORTE BUG scx v1.6: Se pierden algunas propiedades y no muestra picture si "Name" no es la última (arreglado en v.1.7)
* 03/12/2013 Fidel Charny REPORTE BUG scx v1.7: Se siguen perdiendo algunas propiedades por implementación defectuosa del arreglo anterior (arreglado en v.1.8)
* 03/12/2013 Fidel Charny REPORTE BUG scx v1.8: Se siguen perdiendo algunas propiedades por implementación defectuosa de una mejora anterior (arreglado en v.1.9)
* 06/12/2013 Fidel Charny REPORTE BUG scx v1.9: Cuando hay métodos que tienen el mismo nombre, aparecen mezclados en objetos a los que no corresponden (arreglado en v.1.10)
* 07/12/2013 Edgar Kummers REPORTE BUG vcx v1.10: Cuando se parsea una clase con un _memberdata largo, se parsea mal y se corrompe el valor (arreglado en v.1.11)
* 08/12/2013 Fidel Charny REPORTE BUG frx v1.12: Cuando se convierten algunos reportes da "Error 1924, TOREG is not an object" (arreglado en v.1.13)
* 14/12/2013 Arturo Ramos REPORTE BUG scx v1.13: La regeneración de los forms (SCX) no respeta la propiedad AutoCenter, estando pero no funcionando. (arreglado en v.1.14)
* 14/12/2013 Fidel Charny REPORTE BUG scx v1.13: La regeneración de los forms (SCX) no regenera el último registro COMMENT (arreglado en v.1.14)
* 01/01/2014 Fidel Charny REPORTE BUG mnx v1.16: El menú no siempre respeta la posición original LOCATION y a veces se genera mal el MNX (se arregla en v1.17)
* 05/01/2014 Fidel Charny REPORTE BUG mnx v1.17: Se genera cláusula "DO" o llamada Command cuando no Procedure ni Command que llamar // Diferencia de Case en NAME (se arregla en v1.18)
* 20/02/2014 Ryan Harris PROPUESTA DE MEJORA v1.19.11: Centralizar los ZOrder de los controles en metadata de cabecera de la clase para minimizar diferencias
* 23/02/2014 Ryan Harris BUG cfg v1.19.12: Si se define NoTimestamp en FoxBin2Prg.cfg, se toma el valor opuesto (solucionado en v1.19.13)
* 27/02/2014 BUG REGRESION v1.19.13: Si no se define ExtraBackupLevels no se generan backups (solucionado en v1.19.14)
* 06/03/2014 Ryan Harris REPORTE BUG vcx/scx v1.19.15: Algunas propiedades no mantienen su visibilidad Hidden/Protected
* </TESTEO Y REPORTE DE BUGS (AGRADECIMIENTOS)>
*
*---------------------------------------------------------------------------------------------------
* TRAMIENTOS ESPECIALES DE ASIGNACIONES DE PROPIEDADES:
* PROPIEDAD ARREGLO Y EJEMPLO
*------------------------- --------------------------------------------------------------------------------------
* _memberdata Se separan las definiciones en lineas para evitar una sola muy larga
*
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_InputFile (v! IN ) Nombre completo (fullpath) del archivo a convertir
* tcType ( ) Por ahora se mantiene por compatibilidad con SCCTEXT.PRG
* tcTextName ( ) Por ahora se mantiene por compatibilidad con SCCTEXT.PRG
* tlGenText ( ) Por ahora se mantiene por compatibilidad con SCCTEXT.PRG
* tcDontShowErrors (v? IN ) '1' para NO mostrar errores con MESSAGEBOX
* tcDebug (v? IN ) '1' para depurar en el sitio donde ocurre el error (solo modo desarrollo)
* tcDontShowProgress (v? IN ) '1' para NO mostrar la ventana de progreso
* tcOriginalFileName (v? IN ) Sirve para los casos en los que inputFile es un nombre temporal y se quiere generar
* el nombre correcto dentro de la versión texto (por ej: en los PJ2 y las cabeceras)
* tcRecompile (v? IN ) Indica recompilar ('1') el binario una vez regenerado. [Cambio de funcionamiento por defecto]
* Este cambio es para ganar tiempo, velocidad y seguridad. Además la recompilación que hace FoxBin2Prg
* se hace desde el directorio del archivo, con lo que las referencias relativas pueden
* generar errores de compilación, típicamente los #include.
* NOTA: Si en vez de '1' se indica un Path (p.ej, el del proyecto, se usará como base para recompilar
* tcNoTimestamps ( ) Sin uso. Utilizar el archivo de configuración.
*
* Ej: DO FOXBIN2PRG.PRG WITH "C:\DESA\INTEGRACION\LIBRERIA.VCX"
*---------------------------------------------------------------------------------------------------
LPARAMETERS tc_InputFile, tcType, tcTextName, tlGenText, tcDontShowErrors, tcDebug, tcDontShowProgress, tcOriginalFileName, tcRecompile, tcNoTimestamps
*-- NO modificar! / Do NOT change!
#DEFINE C_CMT_I '*--'
#DEFINE C_CMT_F '--*'
#DEFINE C_CLASSDATA_I '*< CLASSDATA:'
#DEFINE C_CLASSDATA_F '/>'
#DEFINE C_LEN_CLASSDATA_I LEN(C_CLASSDATA_I)
#DEFINE C_OBJECTDATA_I '*< OBJECTDATA:'
#DEFINE C_OBJECTDATA_F '/>'
#DEFINE C_LEN_OBJECTDATA_I LEN(C_OBJECTDATA_I)
#DEFINE C_OLE_I '*< OLE:'
#DEFINE C_OLE_F '/>'
#DEFINE C_LEN_OLE_I LEN(C_OLE_I)
#DEFINE C_DEFINED_PAM_I '*<DefinedPropArrayMethod>'
#DEFINE C_DEFINED_PAM_F '*</DefinedPropArrayMethod>'
#DEFINE C_LEN_DEFINED_PAM_I LEN(C_DEFINED_PAM_I)
#DEFINE C_LEN_DEFINED_PAM_F LEN(C_DEFINED_PAM_F)
#DEFINE C_END_OBJECT_I '*< END OBJECT:'
#DEFINE C_END_OBJECT_F '/>'
#DEFINE C_LEN_END_OBJECT_I LEN(C_END_OBJECT_I)
#DEFINE C_FB2PRG_META_I '*< FOXBIN2PRG:'
#DEFINE C_FB2PRG_META_F '/>'
#DEFINE C_DEFINE_CLASS 'DEFINE CLASS'
#DEFINE C_ENDDEFINE 'ENDDEFINE'
#DEFINE C_TEXT 'TEXT'
#DEFINE C_ENDTEXT 'ENDTEXT'
#DEFINE C_PROCEDURE 'PROCEDURE'
#DEFINE C_ENDPROC 'ENDPROC'
#DEFINE C_WITH 'WITH'
#DEFINE C_ENDWITH 'ENDWITH'
#DEFINE C_SRV_HEAD_I '*<ServerHead>'
#DEFINE C_SRV_HEAD_F '*</ServerHead>'
#DEFINE C_SRV_DATA_I '*<ServerData>'
#DEFINE C_SRV_DATA_F '*</ServerData>'
#DEFINE C_DEVINFO_I '*<DevInfo>'
#DEFINE C_DEVINFO_F '*</DevInfo>'
#DEFINE C_BUILDPROJ_I '*<BuildProj>'
#DEFINE C_BUILDPROJ_F '*</BuildProj>'
#DEFINE C_PROJPROPS_I '*<ProjectProperties>'
#DEFINE C_PROJPROPS_F '*</ProjectProperties>'
#DEFINE C_FILE_META_I '*< FileMetadata:'
#DEFINE C_FILE_META_F '/>'
#DEFINE C_FILE_CMTS_I '*<FileComments>'
#DEFINE C_FILE_CMTS_F '*</FileComments>'
#DEFINE C_FILE_EXCL_I '*<ExcludedFiles>'
#DEFINE C_FILE_EXCL_F '*</ExcludedFiles>'
#DEFINE C_FILE_TXT_I '*<TextFiles>'
#DEFINE C_FILE_TXT_F '*</TextFiles>'
#DEFINE C_FB2P_VALUE_I '<fb2p_value>'
#DEFINE C_FB2P_VALUE_F '</fb2p_value>'
#DEFINE C_LEN_FB2P_VALUE_I LEN(C_FB2P_VALUE_I)
#DEFINE C_LEN_FB2P_VALUE_F LEN(C_FB2P_VALUE_F)
#DEFINE C_VFPDATA_I '<VFPData>'
#DEFINE C_VFPDATA_F '</VFPData>'
#DEFINE C_MEMBERDATA_I C_VFPDATA_I
#DEFINE C_MEMBERDATA_F C_VFPDATA_F
#DEFINE C_LEN_MEMBERDATA_I LEN(C_MEMBERDATA_I)
#DEFINE C_LEN_MEMBERDATA_F LEN(C_MEMBERDATA_F)
#DEFINE C_DATA_I '<![CDATA['
#DEFINE C_DATA_F ']]>'
#DEFINE C_TAG_REPORTE 'Reportes'
#DEFINE C_TAG_REPORTE_I '<' + C_TAG_REPORTE + '>'
#DEFINE C_TAG_REPORTE_F '</' + C_TAG_REPORTE + '>'
#DEFINE C_DBF_HEAD_I '<DBF'
#DEFINE C_DBF_HEAD_F '/>'
#DEFINE C_LEN_DBF_HEAD_I LEN(C_DBF_HEAD_I)
#DEFINE C_LEN_DBF_HEAD_F LEN(C_DBF_HEAD_F)
#DEFINE C_CDX_I '<indexFile>'
#DEFINE C_CDX_F '</indexFile>'
#DEFINE C_LEN_CDX_I LEN(C_CDX_I)
#DEFINE C_LEN_CDX_F LEN(C_CDX_F)
#DEFINE C_LEN_INDEX_I LEN(C_INDEX_I)
#DEFINE C_LEN_INDEX_F LEN(C_INDEX_F)
#DEFINE C_DATABASE_I '<DATABASE>'
#DEFINE C_DATABASE_F '</DATABASE>'
#DEFINE C_STORED_PROC_I '<STOREDPROCEDURES><![CDATA['
#DEFINE C_STORED_PROC_F ']]></STOREDPROCEDURES>'
#DEFINE C_TABLE_I '<TABLE>'
#DEFINE C_TABLE_F '</TABLE>'
#DEFINE C_TABLES_I '<TABLES>'
#DEFINE C_TABLES_F '</TABLES>'
#DEFINE C_VIEW_I '<VIEW>'
#DEFINE C_VIEW_F '</VIEW>'
#DEFINE C_VIEWS_I '<VIEWS>'
#DEFINE C_VIEWS_F '</VIEWS>'
#DEFINE C_FIELD_I '<FIELD>'
#DEFINE C_FIELD_F '</FIELD>'
#DEFINE C_FIELDS_I '<FIELDS>'
#DEFINE C_FIELDS_F '</FIELDS>'
#DEFINE C_CONNECTION_I '<CONNECTION>'
#DEFINE C_CONNECTION_F '</CONNECTION>'
#DEFINE C_CONNECTIONS_I '<CONNECTIONS>'
#DEFINE C_CONNECTIONS_F '</CONNECTIONS>'
#DEFINE C_RELATION_I '<RELATION>'
#DEFINE C_RELATION_F '</RELATION>'
#DEFINE C_RELATIONS_I '<RELATIONS>'
#DEFINE C_RELATIONS_F '</RELATIONS>'
#DEFINE C_INDEX_I '<INDEX>'
#DEFINE C_INDEX_F '</INDEX>'
#DEFINE C_INDEXES_I '<INDEXES>'
#DEFINE C_INDEXES_F '</INDEXES>'
#DEFINE C_PROC_CODE_I '*<Procedures>'
#DEFINE C_PROC_CODE_F '*</Procedures>'
#DEFINE C_SETUPCODE_I '*<SetupCode>'
#DEFINE C_SETUPCODE_F '*</SetupCode>'
#DEFINE C_CLEANUPCODE_I '*<CleanupCode>'
#DEFINE C_CLEANUPCODE_F '*</CleanupCode>'
#DEFINE C_MENUCODE_I '*<MenuCode>'
#DEFINE C_MENUCODE_F '*</MenuCode>'
#DEFINE C_MENUTYPE_I '*<MenuType>'
#DEFINE C_MENUTYPE_F '</MenuType>'
#DEFINE C_MENULOCATION_I '*<MenuLocation>'
#DEFINE C_MENULOCATION_F '</MenuLocation>'
*--
#DEFINE C_TAB CHR(9)
#DEFINE C_CR CHR(13)
#DEFINE C_LF CHR(10)
#DEFINE CR_LF C_CR + C_LF
#DEFINE C_MPROPHEADER REPLICATE( CHR(1), 517 )
*-- Fin / End
*-- From FOXPRO.H
*-- File Object Type Property
#DEFINE FILETYPE_DATABASE "d" && Database (.DBC)
#DEFINE FILETYPE_FREETABLE "D" && Free table (.DBF)
#DEFINE FILETYPE_QUERY "Q" && Query (.QPR)
#DEFINE FILETYPE_FORM "K" && Form (.SCX)
#DEFINE FILETYPE_REPORT "R" && Report (.FRX)
#DEFINE FILETYPE_LABEL "B" && Label (.LBX)
#DEFINE FILETYPE_CLASSLIB "V" && Class Library (.VCX)
#DEFINE FILETYPE_PROGRAM "P" && Program (.PRG)
#DEFINE FILETYPE_APILIB "L" && API Library (.FLL)
#DEFINE FILETYPE_APPLICATION "Z" && Application (.APP)
#DEFINE FILETYPE_MENU "M" && Menu (.MNX)
#DEFINE FILETYPE_TEXT "T" && Text (.TXT, .H., etc.)
#DEFINE FILETYPE_OTHER "x" && Other file types not enumerated above
*-- Server Object Instancing Property
#DEFINE SERVERINSTANCE_SINGLEUSE 1 && Single use server
#DEFINE SERVERINSTANCE_NOTCREATABLE 2 && Instances creatable only inside Visual FoxPro
#DEFINE SERVERINSTANCE_MULTIUSE 3 && Multi-use server
*-- Fin / End
*******************************************************************************************************************
*-- INTERNACIONALIZACIÓN / INTERNATIONALIZATION
*******************************************************************************************************************
#IF FILE('foxbin2prg.h') && DO NOT CHANGE THIS! Just rename the .H file
#INCLUDE foxbin2prg.h && DO NOT CHANGE THIS! Just rename the .H file
#ELSE
*---------------------------------------------------------------------------------------------------------
*-- TRANSLACIÓN AL ESPAÑOL
*---------------------------------------------------------------------------------------------------------
#DEFINE C_ASTERISK_EXT_NOT_ALLOWED_LOC "No se admiten extensiones * o ? porque es peligroso (se pueden pisar binarios con archivo xx2 vacíos)."
#DEFINE C_BACKLINK_CANT_UPDATE_BL_LOC "No se pudo actualizar el backlink"
#DEFINE C_BACKLINK_OF_TABLE_LOC "de la tabla"
#DEFINE C_BACKUP_OF_LOC "Haciendo Backup de: "
#DEFINE C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC "No se puede generar el archivo [<<THIS.c_OutputFile>>] porque es ReadOnly"
#DEFINE C_CONFIGFILE_LOC "Usando archivo de configuración:"
#DEFINE C_CONVERTER_UNLOAD_LOC "Descarga del conversor"
#DEFINE C_CONVERTING_FILE_LOC "Convirtiendo archivo"
#DEFINE C_DATA_ERROR_CANT_PARSE_UNPAIRING_DOUBLE_QUOTES_LOC "Error de datos: No se puede parsear porque las comillas no son pares en la línea <<lcMetadatos>>"
#DEFINE C_DUPLICATED_FILE_LOC "Archivo duplicado"
#DEFINE C_ENDDEFINE_MARKER_NOT_FOUND_LOC "No se ha encontrado el marcador de fin [ENDDEFINE] de la línea <<TRANSFORM( toClase._Inicio )>> para el identificador [<<toClase._Nombre>>]"
#DEFINE C_END_MARKER_NOT_FOUND_LOC "No se ha encontrado el marcador de fin [<<ta_ID_Bloques(lnPrimerID,2)>>] que cierra al marcador de inicio [<<ta_ID_Bloques(lnPrimerID,1)>>] de la línea <<TRANSFORM(taBloquesExclusion(tnBloquesExclusion,1))>>"
#DEFINE C_FIELD_NOT_FOUND_ON_FILE_STRUCTURE_LOC "No se encontró el campo [<<laProps(I)>>] en la estructura del archivo <<DBF('TABLABIN')>>"
#DEFINE C_FILE_DOESNT_EXIST_LOC "El archivo no existe:"
#DEFINE C_FILE_NAME_IS_NOT_SUPPORTED_LOC "El archivo [<<.c_InputFile>>] no está soportado"
#DEFINE C_FILE_NOT_FOUND_LOC "No se encontró el archivo"
#DEFINE C_EXTENSION_RECONFIGURATION_LOC "Reconfiguración de extensión:"
#DEFINE C_FOXBIN2PRG_ERROR_CAPTION_LOC "FOXBIN2PRG: ERROR!!"
#DEFINE C_FOXBIN2PRG_INFO_SINTAX_LOC "FOXBIN2PRG: INFORMACIÓN DE SINTAXIS"
#DEFINE C_FOXBIN2PRG_INFO_SINTAX_EXAMPLE_LOC "FOXBIN2PRG <cEspecArchivo.Ext> [,cType ,cTextName ,cGenText ,cNoMostrarErrores ,cDebug, cDontShowProgress, cOriginalFileName, cRecompile, cNoTimestamps]" + CR_LF + CR_LF ;
+ "Ejemplo para generar los TXT de todos los VCX de 'c:\desa\clases', sin mostrar ventana de error y generando archivo LOG: " + CR_LF ;
+ " FOXBIN2PRG 'c:\desa\clases\*.vcx' '0' '0' '0' '1' '1'" + CR_LF + CR_LF ;
+ "Ejemplo para generar los VCX de todos los TXT de 'c:\desa\clases', sin mostrar ventana de error y sin LOG: " + CR_LF ;
+ " FOXBIN2PRG 'c:\desa\clases\*.vc2' '0' '0' '0' '1' '0'"
#DEFINE C_FOXBIN2PRG_JUST_VFP_9_LOC "¡FOXBIN2PRG es solo para Visual FoxPro 9.0!"
#DEFINE C_FOXBIN2PRG_WARN_CAPTION_LOC "FOXBIN2PRG: ¡ATENCIÓN!"
#DEFINE C_MENU_NOT_IN_VFP9_FORMAT_LOC "El Menú [<<THIS.c_InputFile>>] NO está en formato VFP 9! - Por favor convertirlo a VFP 9 con MODIFY MENU <<JUSTFNAME((THIS.c_InputFile))>>"
#DEFINE C_NAMES_CAPITALIZATION_PROGRAM_FOUND_LOC "* Se ha encontrado el programa de capitalización de nombres [<<lcEXE_CAPS>>]"
#DEFINE C_NAMES_CAPITALIZATION_PROGRAM_NOT_FOUND_LOC "* No se ha encontrado el programa de capitalización de nombres [<<lcEXE_CAPS>>]"
#DEFINE C_OBJECT_NAME_WITHOUT_OBJECT_OREG_LOC "Objeto [<<toObj.CLASS>>] no contiene el objeto oReg (nivel <<TRANSFORM(tnNivel)>>)"
#DEFINE C_ONLY_SETNAME_AND_GETNAME_RECOGNIZED_LOC "Operación no reconocida. Solo re reconoce SETNAME y GETNAME."
#DEFINE C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC "Optimización: El archivo de salida [<<THIS.c_OutputFile>>] no se sobreescribe por ser igual al generado."
#DEFINE C_PROCEDURE_NOT_CLOSED_ON_LINE_LOC "Procedimiento sin cerrar. La última línea de código debe ser ENDPROC. [<<laLineas(1)>>]"
#DEFINE C_PROCESSING_LOC "Procesando archivo"
#DEFINE C_PROCESS_PROGRESS_LOC "Avance del proceso:"
#DEFINE C_PROPERTY_NAME_NOT_RECOGNIZED_LOC "Propiedad [<<TRANSFORM(tnPropertyID)>>] no reconocida."
#DEFINE C_REQUESTING_CAPITALIZATION_OF_FILE_LOC "- Solicitado capitalizar el archivo [<<tcFileName>>]"
#DEFINE C_SOURCEFILE_LOC "Archivo origen: "
#DEFINE C_STRUCTURE_NESTING_ERROR_ENDPROC_EXPECTED_LOC "Error de anidamiento de estructuras. Se esperaba ENDPROC pero se encontró ENDDEFINE en la clase <<toClase._Nombre>> (<<loProcedure._Nombre>>), línea <<TRANSFORM(I)>> del archivo <<THIS.c_InputFile>>"
#DEFINE C_STRUCTURE_NESTING_ERROR_ENDPROC_EXPECTED_2_LOC "Error de anidamiento de estructuras. Se esperaba ENDPROC pero se encontró ENDDEFINE en la clase <<toClase._Nombre>> (<<toObjeto._Nombre>>.<<loProcedure._Nombre>>), línea <<TRANSFORM(I)>> del archivo <<THIS.c_InputFile>>"
#DEFINE C_UNKNOWN_CLASS_NAME_LOC "Clase [<<THIS.CLASS>>] desconocida"
#DEFINE C_WARN_TABLE_ALIAS_ON_INDEX_EXPRESSION_LOC "¡¡ATENCIÓN!!" + CR_LF+ "ASEGÚRESE DE QUE NO ESTÁ USANDO UN ALIAS DE TABLA EN LAS EXPRESIONES DE LOS ÍNDICES!! (ej: index on <<UPPER(JUSTSTEM(THIS.c_InputFile))>>.campo tag nombreclave)"
#ENDIF
*******************************************************************************************************************
LOCAL loCnv AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
LOCAL lnResp, loEx AS EXCEPTION
*SYS(2030,1)
*SYS(2335,0)
*IF PCOUNT() > 1 && Saltear las querys de SourceSafe sobre soporte de archivos
* SET STEP ON
* MESSAGEBOX( SYS(5)+CURDIR(),64+4096,PROGRAM(),5000)
*ENDIF
loCnv = CREATEOBJECT("c_foxbin2prg")
loEx = NULL
lnResp = loCnv.ejecutar( tc_InputFile, tcType, tcTextName, tlGenText, tcDontShowErrors, tcDebug ;
, '', NULL, @loEx, .F., tcOriginalFileName, tcRecompile, tcNoTimestamps )
ADDPROPERTY(_SCREEN, 'ExitCode', lnResp)
*IF _VFP.STARTMODE <= 1
* RETURN lnResp
*ENDIF
*-- Muy útil para procesos batch que capturan el código de error
IF _VFP.STARTMODE > 1 AND NOT EMPTY(lnResp) AND VARTYPE(loEx) = "O"
DECLARE ExitProcess IN Win32API INTEGER ExitCode
ExitProcess(1)
ENDIF
loEx = NULL
loCnv = NULL
RELEASE loEx, loCnv
SET COVERAGE TO
RETURN lnResp
QUIT
*******************************************************************************************************************
DEFINE CLASS c_foxbin2prg AS CUSTOM
#IF .F.
LOCAL THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="convertir" display="Convertir"/>] ;
+ [<memberdata name="c_curdir" display="c_CurDir"/>] ;
+ [<memberdata name="c_foxbin2prg_fullpath" display="c_Foxbin2prg_FullPath"/>] ;
+ [<memberdata name="c_foxbin2prg_configfile" display="c_Foxbin2prg_ConfigFile"/>] ;
+ [<memberdata name="c_inputfile" display="c_InputFile"/>] ;
+ [<memberdata name="c_originalfilename" display="c_OriginalFileName"/>] ;
+ [<memberdata name="c_outputfile" display="c_OutputFile"/>] ;
+ [<memberdata name="c_type" display="c_Type"/>] ;
+ [<memberdata name="c_logfile" display="c_LogFile"/>] ;
+ [<memberdata name="c_textlog" display="c_TextLog"/>] ;
+ [<memberdata name="c_db2" display="c_DB2"/>] ;
+ [<memberdata name="c_dc2" display="c_DC2"/>] ;
+ [<memberdata name="c_fr2" display="c_FR2"/>] ;
+ [<memberdata name="c_lb2" display="c_LB2"/>] ;
+ [<memberdata name="c_mn2" display="c_MN2"/>] ;
+ [<memberdata name="c_pj2" display="c_PJ2"/>] ;
+ [<memberdata name="c_sc2" display="c_SC2"/>] ;
+ [<memberdata name="c_vc2" display="c_VC2"/>] ;
+ [<memberdata name="changefileattribute" display="ChangeFileAttribute"/>] ;
+ [<memberdata name="compilefoxprobinary" display="compileFoxProBinary"/>] ;
+ [<memberdata name="dobackup" display="doBackup"/>] ;
+ [<memberdata name="ejecutar" display="Ejecutar"/>] ;
+ [<memberdata name="evaluarconfiguracion" display="EvaluarConfiguracion"/>] ;
+ [<memberdata name="exception2str" display="Exception2Str"/>] ;
+ [<memberdata name="get_program_header" display="get_PROGRAM_HEADER"/>] ;
+ [<memberdata name="getnext_bak" display="getNext_BAK"/>] ;
+ [<memberdata name="lfilemode" display="lFileMode"/>] ;
+ [<memberdata name="l_clearuniqueid" display="l_ClearUniqueID"/>] ;
+ [<memberdata name="l_configevaluated" display="l_ConfigEvaluated"/>] ;
+ [<memberdata name="l_debug" display="l_Debug"/>] ;
+ [<memberdata name="l_methodsort_enabled" display="l_MethodSort_Enabled"/>] ;
+ [<memberdata name="l_propsort_enabled" display="l_PropSort_Enabled"/>] ;
+ [<memberdata name="l_recompile" display="l_Recompile"/>] ;
+ [<memberdata name="l_reportsort_enabled" display="l_ReportSort_Enabled"/>] ;
+ [<memberdata name="l_test" display="l_Test"/>] ;
+ [<memberdata name="l_showerrors" display="l_ShowErrors"/>] ;
+ [<memberdata name="l_showprogress" display="l_ShowProgress"/>] ;
+ [<memberdata name="l_notimestamps" display="l_NoTimestamps"/>] ;
+ [<memberdata name="normalizarcapitalizacionarchivos" display="normalizarCapitalizacionArchivos"/>] ;
+ [<memberdata name="n_extrabackuplevels" display="n_ExtraBackupLevels"/>] ;
+ [<memberdata name="n_fb2prg_version" display="n_FB2PRG_Version"/>] ;
+ [<memberdata name="o_conversor" display="o_Conversor"/>] ;
+ [<memberdata name="o_frm_avance" display="o_Frm_Avance"/>] ;
+ [<memberdata name="o_fso" display="o_FSO"/>] ;
+ [<memberdata name="pjx_conversion_support" display="PJX_Conversion_Support"/>] ;
+ [<memberdata name="vcx_conversion_support" display="VCX_Conversion_Support"/>] ;
+ [<memberdata name="scx_conversion_support" display="SCX_Conversion_Support"/>] ;
+ [<memberdata name="frx_conversion_support" display="FRX_Conversion_Support"/>] ;
+ [<memberdata name="lbx_conversion_support" display="LBX_Conversion_Support"/>] ;
+ [<memberdata name="mnx_conversion_support" display="MNX_Conversion_Support"/>] ;
+ [<memberdata name="dbf_conversion_support" display="DBF_Conversion_Support"/>] ;
+ [<memberdata name="dbc_conversion_support" display="DBC_Conversion_Support"/>] ;
+ [<memberdata name="renamefile" display="RenameFile"/>] ;
+ [<memberdata name="tienesoporte_bin2prg" display="TieneSoporte_Bin2Prg"/>] ;
+ [<memberdata name="tienesoporte_prg2bin" display="TieneSoporte_Prg2Bin"/>] ;
+ [<memberdata name="writelog" display="writeLog"/>] ;
+ [<memberdata name="writelog_flush" display="writeLog_Flush"/>] ;
+ [</VFPData>]
*--
n_FB2PRG_Version = 1.19
*--
c_Foxbin2prg_FullPath = ''
c_Foxbin2prg_ConfigFile = ''
c_CurDir = ''
c_InputFile = ''
c_OriginalFileName = ''
c_LogFile = ''
c_TextLog = ''
c_OutputFile = ''
c_Type = ''
lFileMode = .F.
l_ConfigEvaluated = .F.
l_Debug = .F.
l_Test = .F.
l_ShowErrors = .F.
l_ShowProgress = .F.
l_Recompile = .F.
l_NoTimestamps = .T.
l_ClearUniqueID = .F.
l_MethodSort_Enabled = .T. && Para Unit Testing se puede cambiar a .F. para buscar diferencias
l_PropSort_Enabled = .T. && Para Unit Testing se puede cambiar a .F. para buscar diferencias
l_ReportSort_Enabled = .T. && Para Unit Testing se puede cambiar a .F. para buscar diferencias
n_ExtraBackupLevels = 1
nClassTimeStamp = ''
o_Conversor = NULL
o_Frm_Avance = NULL
o_FSO = NULL
c_VC2 = 'VC2' && VCX
c_SC2 = 'SC2' && SCX
c_PJ2 = 'PJ2' && PJX
c_FR2 = 'FR2' && FRX
c_LB2 = 'LB2' && LBX
c_DB2 = 'DB2' && DBF
c_DC2 = 'DC2' && DBC
c_MN2 = 'MN2' && MNX
PJX_Conversion_Support = 2
VCX_Conversion_Support = 2
SCX_Conversion_Support = 2
FRX_Conversion_Support = 2
LBX_Conversion_Support = 2
MNX_Conversion_Support = 2
DBF_Conversion_Support = 1
DBC_Conversion_Support = 2
PROCEDURE INIT
SET DELETED ON
SET DATE YMD
SET HOURS TO 24
SET CENTURY ON
SET SAFETY OFF
SET TABLEPROMPT OFF
SET POINT TO '.'
SET SEPARATOR TO ','
THIS.c_Foxbin2prg_FullPath = SUBSTR( SYS(16), AT( 'C_FOXBIN2PRG.INIT', SYS(16) ) + LEN('C_FOXBIN2PRG.INIT') + 1 )
THIS.c_Foxbin2prg_ConfigFile = FORCEEXT( THIS.c_Foxbin2prg_FullPath, 'CFG' )
THIS.c_CurDir = SYS(5) + CURDIR()
THIS.o_FSO = NEWOBJECT("Scripting.FileSystemObject")
ADDPROPERTY(_SCREEN, 'ExitCode', 0)
ENDPROC
PROCEDURE DESTROY
TRY
LOCAL lcFileCDX
lcFileCDX = FORCEPATH( "TABLABIN.CDX", JUSTPATH(THIS.c_InputFile) )
IF FILE( lcFileCDX )
ERASE ( lcFileCDX )
ENDIF
THIS.writeLog_Flush()
CATCH
ENDTRY
ENDPROC
PROCEDURE ChangeFileAttribute
* Using Win32 Functions in Visual FoxPro
* example=103
* Changing file attributes
LPARAMETERS tcFileName, tcAttrib
tcAttrib = UPPER(tcAttrib)
#DEFINE FILE_ATTRIBUTE_READONLY 1
#DEFINE FILE_ATTRIBUTE_HIDDEN 2
#DEFINE FILE_ATTRIBUTE_SYSTEM 4
#DEFINE FILE_ATTRIBUTE_DIRECTORY 16
#DEFINE FILE_ATTRIBUTE_ARCHIVE 32
#DEFINE FILE_ATTRIBUTE_NORMAL 128
#DEFINE FILE_ATTRIBUTE_TEMPORARY 512
#DEFINE FILE_ATTRIBUTE_COMPRESSED 2048
DECLARE SHORT SetFileAttributes IN kernel32 STRING tcFileName, INTEGER dwFileAttributes
DECLARE INTEGER GetFileAttributes IN kernel32 STRING tcFileName
* read current attributes for this file
dwFileAttributes = GetFileAttributes(tcFileName)
IF dwFileAttributes = -1
* the file does not exist
RETURN
ENDIF
IF dwFileAttributes > 0
IF '+R' $ tcAttrib
dwFileAttributes = BITOR(dwFileAttributes, FILE_ATTRIBUTE_READONLY)
ENDIF
IF '+A' $ tcAttrib
dwFileAttributes = BITOR(dwFileAttributes, FILE_ATTRIBUTE_ARCHIVE)
ENDIF
IF '+S' $ tcAttrib
dwFileAttributes = BITOR(dwFileAttributes, FILE_ATTRIBUTE_SYSTEM)
ENDIF
IF '+H' $ tcAttrib
dwFileAttributes = BITOR(dwFileAttributes, FILE_ATTRIBUTE_HIDDEN)
ENDIF
IF '+D' $ tcAttrib
dwFileAttributes = BITOR(dwFileAttributes, FILE_ATTRIBUTE_DIRECTORY)
ENDIF
IF '+N' $ tcAttrib
dwFileAttributes = BITOR(dwFileAttributes, FILE_ATTRIBUTE_NORMAL)
ENDIF
IF '+T' $ tcAttrib
dwFileAttributes = BITOR(dwFileAttributes, FILE_ATTRIBUTE_TEMPORARY)
ENDIF
IF '+C' $ tcAttrib
dwFileAttributes = BITOR(dwFileAttributes, FILE_ATTRIBUTE_COMPRESSED)
ENDIF
IF '-R' $ tcAttrib AND BITAND(dwFileAttributes, FILE_ATTRIBUTE_READONLY) = FILE_ATTRIBUTE_READONLY
dwFileAttributes = dwFileAttributes - FILE_ATTRIBUTE_READONLY
ENDIF
IF '-A' $ tcAttrib AND BITAND(dwFileAttributes, FILE_ATTRIBUTE_ARCHIVE) = FILE_ATTRIBUTE_ARCHIVE
dwFileAttributes = dwFileAttributes - FILE_ATTRIBUTE_ARCHIVE
ENDIF
IF '-S' $ tcAttrib AND BITAND(dwFileAttributes, FILE_ATTRIBUTE_SYSTEM) = FILE_ATTRIBUTE_SYSTEM
dwFileAttributes = dwFileAttributes - FILE_ATTRIBUTE_SYSTEM
ENDIF
IF '-H' $ tcAttrib AND BITAND(dwFileAttributes, FILE_ATTRIBUTE_HIDDEN) = FILE_ATTRIBUTE_HIDDEN
dwFileAttributes = dwFileAttributes - FILE_ATTRIBUTE_HIDDEN
ENDIF
IF '-D' $ tcAttrib AND BITAND(dwFileAttributes, FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY
dwFileAttributes = dwFileAttributes - FILE_ATTRIBUTE_DIRECTORY
ENDIF
IF '-N' $ tcAttrib AND BITAND(dwFileAttributes, FILE_ATTRIBUTE_NORMAL) = FILE_ATTRIBUTE_NORMAL
dwFileAttributes = dwFileAttributes - FILE_ATTRIBUTE_NORMAL
ENDIF
IF '-T' $ tcAttrib AND BITAND(dwFileAttributes, FILE_ATTRIBUTE_TEMPORARY) = FILE_ATTRIBUTE_TEMPORARY
dwFileAttributes = dwFileAttributes - FILE_ATTRIBUTE_TEMPORARY
ENDIF
IF '-C' $ tcAttrib AND BITAND(dwFileAttributes, FILE_ATTRIBUTE_COMPRESSED) = FILE_ATTRIBUTE_COMPRESSED
dwFileAttributes = dwFileAttributes - FILE_ATTRIBUTE_COMPRESSED
ENDIF
* setting selected attributes
=SetFileAttributes(tcFileName, dwFileAttributes)
ENDIF
ENDPROC
PROCEDURE compileFoxProBinary
LPARAMETERS tcFileName
LOCAL lcType
tcFileName = EVL(tcFileName, THIS.c_OutputFile)
lcType = UPPER(JUSTEXT(tcFileName))
DO CASE
CASE lcType = 'VCX'
COMPILE CLASSLIB (tcFileName)
CASE lcType = 'SCX'
COMPILE FORM (tcFileName)
CASE lcType = 'FRX'
COMPILE REPORT (tcFileName)
CASE lcType = 'LBX'
COMPILE LABEL (tcFileName)
CASE lcType = 'DBC'
COMPILE DATABASE (tcFileName)
ENDCASE
ENDPROC
PROCEDURE doBackup
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toEx (@? IN ) Objeto Exception con información del error
* tlRelanzarError (v? IN ) Indica si se debe relanzar el error
* tcBakFile_1 (@? OUT) Nombre del archivo backup 1 (vcx,scx,pjx,frx,lbx,dbf,dbc,mnx,vc2,sc2,pj2,etc)
* tcBakFile_2 (@? OUT) Nombre del archivo backup 2 (vct,sct,pjt,frt,lbt,fpt,dct,mnt,etc)
* tcBakFile_3 (@? OUT) Nombre del archivo backup 1 (vcx,scx,pjx,cdx,dcx,etc)
*---------------------------------------------------------------------------------------------------
LPARAMETERS toEx, tlRelanzarError, tcBakFile_1, tcBakFile_2, tcBakFile_3
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lcNext_Bak, lcExt_1, lcExt_2, lcExt_3
STORE '' TO tcBakFile_1, tcBakFile_2, tcBakFile_3
WITH THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
IF THIS.n_ExtraBackupLevels > 0 THEN
lcNext_Bak = .getNext_BAK( .c_OutputFile )
lcExt_1 = JUSTEXT( .c_OutputFile )
tcBakFile_1 = FORCEEXT(.c_OutputFile, lcExt_1 + lcNext_Bak)
DO CASE
CASE INLIST( lcExt_1, .c_PJ2, .c_VC2, .c_SC2, .c_FR2, .c_LB2, .c_DB2, .c_DC2, .c_MN2, 'PJM' )
*-- Extensiones TEXTO
CASE lcExt_1 = 'DBF'
*-- DBF
lcExt_2 = 'FPT'
lcExt_3 = 'CDX'
tcBakFile_2 = FORCEEXT(.c_OutputFile, lcExt_2 + lcNext_Bak)
tcBakFile_3 = FORCEEXT(.c_OutputFile, lcExt_3 + lcNext_Bak)
CASE lcExt_1 = 'DBC'
*-- DBC
lcExt_2 = 'DCT'
lcExt_3 = 'DCX'
tcBakFile_2 = FORCEEXT(.c_OutputFile, lcExt_2 + lcNext_Bak)
tcBakFile_3 = FORCEEXT(.c_OutputFile, lcExt_3 + lcNext_Bak)
OTHERWISE
*-- PJX, VCX, SCX, FRX, LBX, MNX
lcExt_2 = LEFT(lcExt_1,2) + 'T'
tcBakFile_2 = FORCEEXT(.c_OutputFile, lcExt_2 + lcNext_Bak)
ENDCASE
IF NOT EMPTY(lcExt_1) AND FILE( FORCEEXT(.c_OutputFile, lcExt_1) )
*-- LOG
DO CASE
CASE EMPTY(lcExt_2)
.writeLog( C_BACKUP_OF_LOC + FORCEEXT(.c_OutputFile,lcExt_1) )
CASE EMPTY(lcExt_3)
.writeLog( C_BACKUP_OF_LOC + FORCEEXT(.c_OutputFile,lcExt_1) + '/' + lcExt_2 )
OTHERWISE
.writeLog( C_BACKUP_OF_LOC + FORCEEXT(.c_OutputFile,lcExt_1) + '/' + lcExt_2 + '/' + lcExt_3 )
ENDCASE
*-- COPIA BACKUP
COPY FILE ( FORCEEXT(.c_OutputFile, lcExt_1) ) TO ( tcBakFile_1 )
IF NOT EMPTY(lcExt_2) AND FILE( FORCEEXT(.c_OutputFile, lcExt_2) )
COPY FILE ( FORCEEXT(.c_OutputFile, lcExt_2) ) TO ( tcBakFile_2 )
ENDIF
IF NOT EMPTY(lcExt_3) AND FILE( FORCEEXT(.c_OutputFile, lcExt_3) )
COPY FILE ( FORCEEXT(.c_OutputFile, lcExt_3) ) TO ( tcBakFile_3 )
ENDIF
ENDIF
ENDIF
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
IF tlRelanzarError
THROW
ENDIF
ENDTRY
RETURN
ENDPROC
PROCEDURE cargar_frm_avance
THIS.o_Frm_Avance = CREATEOBJECT("frm_avance")
ENDPROC
PROCEDURE EvaluarConfiguracion
LPARAMETERS tcDontShowProgress, tcDontShowErrors, tcNoTimestamps, tcDebug, tcRecompile, tcExtraBackupLevels
LOCAL lcConfigFile, llExisteConfig, laConfig(1), I, lcConfData, lcExt
WITH THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
IF NOT .l_ConfigEvaluated
lcConfigFile = THIS.c_Foxbin2prg_ConfigFile
llExisteConfig = FILE( lcConfigFile )
IF llExisteConfig
.writeLog( C_CONFIGFILE_LOC + ' ' + lcConfigFile )
FOR I = 1 TO ALINES( laConfig, FILETOSTR( lcConfigFile ), 1+4 )
laConfig(I) = LOWER( laConfig(I) )
DO CASE
CASE LEFT( laConfig(I), 1 ) == '*'
LOOP
CASE LEFT( laConfig(I), 10 ) == LOWER('Extension:')
lcConfData = ALLTRIM( SUBSTR( laConfig(I), 11 ) )
lcExt = 'c_' + ALLTRIM( GETWORDNUM( lcConfData, 1, '=' ) )
IF PEMSTATUS( THIS, lcExt, 5 )
.ADDPROPERTY( lcExt, UPPER( ALLTRIM( GETWORDNUM( lcConfData, 2, '=' ) ) ) )
*.writeLog( 'Reconfiguración de extensión:' + ' ' + lcExt + ' a ' + UPPER( ALLTRIM( GETWORDNUM( lcConfData, 2, '=' ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > ' + C_EXTENSION_RECONFIGURATION_LOC + ' ' + lcExt + ' a ' + UPPER( ALLTRIM( GETWORDNUM( lcConfData, 2, '=' ) ) ) )
ENDIF
CASE LEFT( laConfig(I), 17 ) == LOWER('DontShowProgress:')
tcDontShowProgress = ALLTRIM( SUBSTR( laConfig(I), 18 ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > tcDontShowProgress: ' + TRANSFORM(tcDontShowProgress) )
CASE LEFT( laConfig(I), 15 ) == LOWER('DontShowErrors:')
tcDontShowErrors = ALLTRIM( SUBSTR( laConfig(I), 16 ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > tcDontShowErrors: ' + TRANSFORM(tcDontShowErrors) )
CASE LEFT( laConfig(I), 13 ) == LOWER('NoTimestamps:')
tcNoTimestamps = ALLTRIM( SUBSTR( laConfig(I), 14 ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > tcNoTimestamps: ' + TRANSFORM(tcNoTimestamps) )
CASE LEFT( laConfig(I), 6 ) == LOWER('Debug:')
tcDebug = ALLTRIM( SUBSTR( laConfig(I), 7 ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > tcDebug: ' + TRANSFORM(tcDebug) )
CASE LEFT( laConfig(I), 18 ) == LOWER('ExtraBackupLevels:')
tcExtraBackupLevels = ALLTRIM( SUBSTR( laConfig(I), 19 ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > tcExtraBackupLevels: ' + TRANSFORM(tcExtraBackupLevels) )
CASE LEFT( laConfig(I), 14 ) == LOWER('ClearUniqueID:')
.l_ClearUniqueID = ( ALLTRIM( SUBSTR( laConfig(I), 15 ) ) == '1' )
.writeLog( JUSTFNAME(lcConfigFile) + ' > ClearUniqueID: ' + TRANSFORM(ALLTRIM( SUBSTR( laConfig(I), 15 )) ) )
CASE LEFT( laConfig(I), 23 ) == LOWER('PJX_Conversion_Support:')
.PJX_Conversion_Support = INT( VAL( ALLTRIM( SUBSTR( laConfig(I), 24 ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > PJX_Conversion_Support: ' + TRANSFORM(.PJX_Conversion_Support) )
CASE LEFT( laConfig(I), 23 ) == LOWER('VCX_Conversion_Support:')
.VCX_Conversion_Support = INT( VAL( ALLTRIM( SUBSTR( laConfig(I), 24 ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > VCX_Conversion_Support: ' + TRANSFORM(.VCX_Conversion_Support) )
CASE LEFT( laConfig(I), 23 ) == LOWER('SCX_Conversion_Support:')
.SCX_Conversion_Support = INT( VAL( ALLTRIM( SUBSTR( laConfig(I), 24 ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > SCX_Conversion_Support: ' + TRANSFORM(.SCX_Conversion_Support) )
CASE LEFT( laConfig(I), 23 ) == LOWER('FRX_Conversion_Support:')
.FRX_Conversion_Support = INT( VAL( ALLTRIM( SUBSTR( laConfig(I), 24 ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > FRX_Conversion_Support: ' + TRANSFORM(.FRX_Conversion_Support) )
CASE LEFT( laConfig(I), 23 ) == LOWER('LBX_Conversion_Support:')
.LBX_Conversion_Support = INT( VAL( ALLTRIM( SUBSTR( laConfig(I), 24 ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > LBX_Conversion_Support: ' + TRANSFORM(.LBX_Conversion_Support) )
CASE LEFT( laConfig(I), 23 ) == LOWER('MNX_Conversion_Support:')
.MNX_Conversion_Support = INT( VAL( ALLTRIM( SUBSTR( laConfig(I), 24 ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > MNX_Conversion_Support: ' + TRANSFORM(.MNX_Conversion_Support) )
CASE LEFT( laConfig(I), 23 ) == LOWER('DBF_Conversion_Support:')
.DBF_Conversion_Support = INT( VAL( ALLTRIM( SUBSTR( laConfig(I), 24 ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > DBF_Conversion_Support: ' + TRANSFORM(.DBF_Conversion_Support) )
CASE LEFT( laConfig(I), 23 ) == LOWER('DBC_Conversion_Support:')
.DBC_Conversion_Support = INT( VAL( ALLTRIM( SUBSTR( laConfig(I), 24 ) ) ) )
.writeLog( JUSTFNAME(lcConfigFile) + ' > DBC_Conversion_Support: ' + TRANSFORM(.DBC_Conversion_Support) )
ENDCASE
ENDFOR
ENDIF
.l_ShowProgress = NOT (TRANSFORM(tcDontShowProgress)=='1')
.l_ShowErrors = NOT (TRANSFORM(tcDontShowErrors) == '1')
.l_Recompile = (EMPTY(tcRecompile) OR TRANSFORM(tcRecompile) == '1' OR DIRECTORY(tcRecompile))
.l_NoTimestamps = NOT (TRANSFORM(tcNoTimestamps) == '0')
.l_Debug = (TRANSFORM(tcDebug)=='1')
tcExtraBackupLevels = EVL( tcExtraBackupLevels, TRANSFORM( .n_ExtraBackupLevels ) )
.n_ExtraBackupLevels = INT( VAL( TRANSFORM(tcExtraBackupLevels) ) )
.writeLog( '---' )
.writeLog( '> l_ShowProgress: ' + TRANSFORM(.l_ShowProgress) )
.writeLog( '> l_ShowErrors: ' + TRANSFORM(.l_ShowErrors) )
.writeLog( '> l_Recompile: ' + TRANSFORM(.l_Recompile) + ' (' + EVL(tcRecompile,'') + ')' )
.writeLog( '> l_NoTimestamps: ' + TRANSFORM(.l_NoTimestamps) )
.writeLog( '> ClearUniqueID: ' + TRANSFORM(.l_ClearUniqueID) )
.writeLog( '> l_Debug: ' + TRANSFORM(.l_Debug) )
.writeLog( '> n_ExtraBackupLevels: ' + TRANSFORM(.n_ExtraBackupLevels) )
.l_ConfigEvaluated = .T.
ENDIF && .l_ConfigEvaluated
ENDWITH && THIS
RETURN
ENDPROC
PROCEDURE TieneSoporte_Bin2Prg
LPARAMETERS tcExt
LOCAL llTieneSoporte
WITH THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
llTieneSoporte = ICASE( tcExt == 'PJX', .PJX_Conversion_Support >= 1 ;
, tcExt == 'VCX', .VCX_Conversion_Support >= 1 ;
, tcExt == 'SCX', .SCX_Conversion_Support >= 1 ;
, tcExt == 'FRX', .FRX_Conversion_Support >= 1 ;
, tcExt == 'LBX', .LBX_Conversion_Support >= 1 ;
, tcExt == 'MNX', .MNX_Conversion_Support >= 1 ;
, tcExt == 'DBF', .DBF_Conversion_Support >= 1 ;
, tcExt == 'DBC', .DBC_Conversion_Support >= 1 ;
, .F. )
ENDWITH && THIS
RETURN llTieneSoporte
ENDPROC
PROCEDURE TieneSoporte_Prg2Bin
LPARAMETERS tcExt
LOCAL llTieneSoporte
WITH THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
llTieneSoporte = ICASE( tcExt == .c_PJ2, .PJX_Conversion_Support >= 2 ;
, tcExt == .c_VC2, .VCX_Conversion_Support >= 2 ;
, tcExt == .c_SC2, .SCX_Conversion_Support >= 2 ;
, tcExt == .c_FR2, .FRX_Conversion_Support >= 2 ;
, tcExt == .c_LB2, .LBX_Conversion_Support >= 2 ;
, tcExt == .c_MN2, .MNX_Conversion_Support >= 2 ;
, tcExt == .c_DB2, .DBF_Conversion_Support >= 2 ;
, tcExt == .c_DC2, .DBC_Conversion_Support >= 2 ;
, .F. )
ENDWITH && THIS
RETURN llTieneSoporte
ENDPROC
PROCEDURE ejecutar
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_InputFile (!v IN ) Nombre del archivo de entrada
* tcType (?v IN ) NO DISPONIBLE. Se mantiene por compatibilidad con SourceSafe
* tcTextName (?v IN ) NO DISPONIBLE. Se mantiene por compatibilidad con SourceSafe
* tlGenText (?v IN ) NO DISPONIBLE. Se mantiene por compatibilidad con SourceSafe
* tcDontShowErrors (?v IN ) '1' para no mostrar mensajes de error (MESSAGEBOX)
* tcDebug (?v IN ) '1' para habilitar modo debug (SOLO DESARROLLO)
* tcDontShowProgress (?v IN ) '1' para inhabilitar la barra de progreso
* toModulo (?@ OUT) Referencia de objeto del módulo generado (para Unit Testing)
* toEx (?@ OUT) Objeto con información del error
* tlRelanzarError (?v IN ) Indica si el error debe relanzarse o no
* tcOriginalFileName (v? IN ) Sirve para los casos en los que inputFile es un nombre temporal y se quiere generar
* el nombre correcto dentro de la versión texto (por ej: en los PJ2 y las cabeceras)
* tcRecompile (v? IN ) Indica recompilar ('1') el binario una vez regenerado. [Cambio de funcionamiento por defecto]
* Este cambio es para ganar tiempo, velocidad y seguridad. Además la recompilación que hace FoxBin2Prg
* se hace desde el directorio del archivo, con lo que las referencias relativas pueden
* generar errores de compilación, típicamente los #include.
* NOTA: Si en vez de '1' se indica un Path (p.ej, el del proyecto, se usará como base para recompilar
* tcNoTimestamps ( ) Sin uso. Utilizar el archivo de configuración.
* tcBackupLevels (v? IN ) Indica la cantidad de niveles de backup a realizar (por defecto '1')
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS tc_InputFile, tcType, tcTextName, tlGenText, tcDontShowErrors, tcDebug, tcDontShowProgress ;
, toModulo, toEx AS EXCEPTION, tlRelanzarError, tcOriginalFileName, tcRecompile, tcNoTimestamps ;
, tcBackupLevels
TRY
LOCAL I, lcPath, lnCodError, lcFileSpec, lcFile, laFiles(1,5) ;
, lnFileCount, lcErrorInfo ;
, loEx AS EXCEPTION ;
, loFSO AS Scripting.FileSystemObject
WITH THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
lnCodError = 0
.writeLog( .c_Foxbin2prg_FullPath + CR_LF ;
+ C_TAB + 'tc_InputFile: ' + TRANSFORM(tc_InputFile) + CR_LF ;
+ C_TAB + 'tcType: ' + TRANSFORM(tcType) + CR_LF;
+ C_TAB + 'tcTextName: ' + TRANSFORM(tcTextName) + CR_LF ;
+ C_TAB + 'tlGenText: ' + TRANSFORM(tlGenText) + CR_LF ;
+ C_TAB + 'tcDontShowErrors: ' + TRANSFORM(tcDontShowErrors) + CR_LF ;
+ C_TAB + 'tcDebug: ' + TRANSFORM(tcDebug) + CR_LF ;
+ C_TAB + 'tcDontShowProgress: ' + TRANSFORM(tcDontShowProgress) + CR_LF ;
+ C_TAB + 'toModulo: ' + TRANSFORM(toModulo) + CR_LF ;
+ C_TAB + 'toEx: ' + TRANSFORM(toEx) + CR_LF ;
+ C_TAB + 'tlRelanzarError: ' + TRANSFORM(tlRelanzarError) + CR_LF ;
+ C_TAB + 'tcOriginalFileName: ' + TRANSFORM(tcOriginalFileName) + CR_LF ;
+ C_TAB + 'tcRecompile: ' + TRANSFORM(tcRecompile) + CR_LF ;
+ C_TAB + 'tcNoTimestamps: ' + TRANSFORM(tcNoTimestamps) )
tcRecompile = EVL(tcRecompile,'1')
tcNoTimestamps = '1' &&EVL(tcNoTimestamps,'1')
IF _VFP.STARTMODE > 0
SET ESCAPE OFF
ENDIF
loFSO = .o_FSO
DO CASE
CASE VERSION(5) < 900
*-- '¡FOXBIN2PRG es solo para Visual FoxPro 9.0!'
MESSAGEBOX( C_FOXBIN2PRG_JUST_VFP_9_LOC, 0+64+4096, C_FOXBIN2PRG_WARN_CAPTION_LOC, 60000 )
lnCodError = 1
CASE EMPTY(tc_InputFile)
*-- (Ejemplo de sintaxis y uso)
MESSAGEBOX( C_FOXBIN2PRG_INFO_SINTAX_EXAMPLE_LOC, 0+64+4096, C_FOXBIN2PRG_INFO_SINTAX_LOC, 60000 )
lnCodError = 1
OTHERWISE
*-- Ejecución normal
*-- ARCHIVO DE CONFIGURACIÓN
.EvaluarConfiguracion( @tcDontShowProgress, @tcDontShowErrors, @tcNoTimestamps, @tcDebug, @tcRecompile, @tcBackupLevels )
IF .l_ShowProgress
.cargar_frm_avance()
ENDIF
*-- Evaluación de FileSpec de entrada
DO CASE
CASE '*' $ JUSTEXT( tc_InputFile ) OR '?' $ JUSTEXT( tc_InputFile )
IF .l_ShowErrors
*MESSAGEBOX( 'No se admiten extensiones * o ? porque es peligroso (se pueden pisar binarios con archivo xx2 vacíos).', 0+48+4096, 'FOXBIN2PRG: ERROR!!', 60000 )
MESSAGEBOX( C_ASTERISK_EXT_NOT_ALLOWED_LOC, 0+48+4096, C_FOXBIN2PRG_ERROR_CAPTION_LOC, 60000 )
ELSE
ERROR C_ASTERISK_EXT_NOT_ALLOWED_LOC
ENDIF
CASE '*' $ JUSTSTEM( tc_InputFile )
*-- SE QUIEREN TODOS LOS ARCHIVOS DE UNA EXTENSIÓN
lcFileSpec = FULLPATH( tc_InputFile )
DO CASE
CASE .l_Recompile AND LEN(tcRecompile) > 3 AND DIRECTORY(tcRecompile)
CD (tcRecompile)
CASE tcRecompile == '1'
CD (JUSTPATH(lcFileSpec))
ENDCASE
.c_LogFile = ADDBS( JUSTPATH( lcFileSpec ) ) + STRTRAN( JUSTFNAME( lcFileSpec ), '*', '_ALL' ) + '.LOG'
IF .l_Debug
IF FILE( .c_LogFile )
ERASE ( .c_LogFile )
ENDIF
ENDIF
lnFileCount = ADIR( laFiles, lcFileSpec, '', 1 )
IF .l_ShowProgress
.o_Frm_Avance.nMAX_VALUE = lnFileCount
ENDIF
FOR I = 1 TO lnFileCount
lcFile = FORCEPATH( laFiles(I,1), JUSTPATH( lcFileSpec ) )
.o_Frm_Avance.lbl_TAREA.CAPTION = C_PROCESSING_LOC + ' ' + lcFile + '...'
.o_Frm_Avance.nVALUE = I
IF .l_ShowProgress
.o_Frm_Avance.SHOW()
ENDIF
IF FILE( lcFile )
lnCodError = .Convertir( lcFile, toModulo, toEx, tlRelanzarError, tcOriginalFileName )
ENDIF
ENDFOR
OTHERWISE
*-- UN ARCHIVO INDIVIDUAL O CONSULTA DE SOPORTE DE ARCHIVO
IF LEN(NVL(tc_InputFile,'')) = 1
*-- Consulta de soporte de conversión (compatibilidad con SourceSafe)
*-- SourceSafe consulta el tipo de soporte de cada archivo antes del Checkin/Checkout
*-- para saber si se puede hacer Diff y Merge.
*-- Para los códigos de tipo de archivo ver ayuda de "Type Property"
DO CASE
CASE tc_InputFile == FILETYPE_DATABASE
lnCodError = .DBC_Conversion_Support
CASE tc_InputFile == FILETYPE_FREETABLE
lnCodError = .DBF_Conversion_Support
CASE tc_InputFile == FILETYPE_FORM
lnCodError = .SCX_Conversion_Support
CASE tc_InputFile == FILETYPE_LABEL
lnCodError = .LBX_Conversion_Support
CASE tc_InputFile == FILETYPE_MENU
lnCodError = .MNX_Conversion_Support
CASE tc_InputFile == FILETYPE_REPORT
lnCodError = .FRX_Conversion_Support
CASE tc_InputFile == FILETYPE_CLASSLIB
lnCodError = .VCX_Conversion_Support
CASE tc_InputFile $ 'J' && PJX (J no exite en FoxPro, es un valor inventado para evitar conflicto con los tipos existentes)
lnCodError = .PJX_Conversion_Support
OTHERWISE
lnCodError = -1
ENDCASE
ELSE
IF EVL(tcType,'0') <> '0' AND EVL(tcTextName,'0') <> '0'
*-- Compatibilidad con SourceSafe
IF NOT tlGenText
*-- COMPATIBILIDAD CON SOURCESAFE. 30/01/2014
*-- Create BINARIO desde versión TEXTO
*-- Como el archivo de entrada siempre es el binario cuando se usa SCCAPI,
*-- para se debe regenerar el binario (tlGenText=.F.) se debe usar como
*-- archivo de entrada tcTextName en su lugar. Aquí los intercambio.
tc_InputFile = tcTextName
.l_Recompile = .T.
ENDIF
ENDIF
IF FILE(tc_InputFile)
ERASE ( tc_InputFile + '.ERR' )
DO CASE
CASE .l_Recompile AND LEN(tcRecompile) > 3 AND DIRECTORY(tcRecompile)
CD (tcRecompile)
CASE tcRecompile == '1'
CD (JUSTPATH(tc_InputFile))
ENDCASE
.c_LogFile = tc_InputFile + '.LOG'
ERASE ( .c_LogFile )
lnCodError = .Convertir( tc_InputFile, toModulo, toEx, .T., tcOriginalFileName )
ENDIF
ENDIF
ENDCASE
ENDCASE
ENDWITH && THIS
CATCH TO toEx
lnCodError = toEx.ERRORNO
lcErrorInfo = THIS.Exception2Str(toEx) + CR_LF + CR_LF + C_SOURCEFILE_LOC + THIS.c_InputFile
ADDPROPERTY(_SCREEN, 'ExitCode', toEx.ERRORNO)
TRY
STRTOFILE( lcErrorInfo, EVL(tc_InputFile,'foxbin2prg') + '.ERR' )
CATCH TO loEx2
ENDTRY
IF THIS.l_Debug
IF _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THIS.writeLog( lcErrorInfo )
ENDIF
IF THIS.l_Debug AND THIS.l_ShowErrors
MESSAGEBOX( lcErrorInfo, 0+16+4096, C_FOXBIN2PRG_ERROR_CAPTION_LOC, 60000 )
ENDIF
IF tlRelanzarError
THROW
ENDIF
FINALLY
IF THIS.l_ShowProgress
THIS.o_Frm_Avance.HIDE()
THIS.o_Frm_Avance.RELEASE()
STORE NULL TO THIS.o_Frm_Avance
ENDIF
CD (JUSTPATH(THIS.c_CurDir))
*SET PATH TO (lcPath)
ENDTRY
RETURN lnCodError
ENDPROC
PROCEDURE Convertir
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_InputFile (!v IN ) Nombre del archivo de entrada
* toModulo (?@ OUT) Referencia de objeto del módulo generado (para Unit Testing)
* toEx (?@ OUT) Objeto con información del error
* tlRelanzarError (?v IN ) Indica si el error debe relanzarse o no
* tcOriginalFileName (v? IN ) Sirve para los casos en los que inputFile es un nombre temporal y se quiere generar
* el nombre correcto dentro de la versión texto (por ej: en los PJ2 y las cabeceras)
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS tc_InputFile, toModulo, toEx AS EXCEPTION, tlRelanzarError, tcOriginalFileName
TRY
LOCAL lnCodError, lcErrorInfo, laDirFile(1,5), lcExtension ;
, loFSO AS Scripting.FileSystemObject
lnCodError = 0
WITH THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
loFSO = .o_FSO
.c_InputFile = FULLPATH( tc_InputFile )
IF ADIR( laDirFile, .c_InputFile, '', 1 ) = 0
*ERROR 'No se encontró el archivo [' + .c_InputFile + ']'
ERROR C_FILE_NOT_FOUND_LOC + ' [' + .c_InputFile + ']'
ENDIF
.c_InputFile = loFSO.GetAbsolutePathName( FORCEPATH( laDirFile(1,1), JUSTPATH(.c_InputFile) ) )
IF NOT EMPTY(tcOriginalFileName)
tcOriginalFileName = loFSO.GetAbsolutePathName( tcOriginalFileName )
ENDIF
.c_OriginalFileName = EVL( tcOriginalFileName, .c_InputFile )
IF UPPER( JUSTEXT(.c_OriginalFileName) ) = 'PJM'
.c_OriginalFileName = FORCEEXT(.c_OriginalFileName,'pjx')
ENDIF
.writeLog( '> c_OriginalFileName: ' + .c_OriginalFileName )
.o_Conversor = NULL
IF NOT FILE(.c_InputFile)
ERROR C_FILE_DOESNT_EXIST_LOC + ' [' + .c_InputFile + ']'
ENDIF
lcExtension = UPPER( JUSTEXT(.c_InputFile) )
DO CASE
CASE lcExtension = 'VCX'
IF NOT INLIST(.VCX_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_VC2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_vcx_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_VC2 ), '+N' )
CASE lcExtension = 'SCX'
IF NOT INLIST(.SCX_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_SC2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_scx_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_SC2 ), '+N' )
CASE lcExtension = 'PJX'
IF NOT INLIST(.PJX_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_PJ2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_pjx_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_PJ2 ), '+N' )
CASE lcExtension = 'PJM'
IF NOT INLIST(.PJX_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_PJ2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_pjm_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_PJ2 ), '+N' )
CASE lcExtension = 'FRX'
IF NOT INLIST(.FRX_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_FR2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_frx_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_FR2 ), '+N' )
CASE lcExtension = 'LBX'
IF NOT INLIST(.LBX_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_LB2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_frx_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_LB2 ), '+N' )
CASE lcExtension = 'DBF'
IF NOT INLIST(.DBF_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_DB2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_dbf_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_DB2 ), '+N' )
CASE lcExtension = 'DBC'
IF NOT INLIST(.DBC_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_DC2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_dbc_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_DC2 ), '+N' )
CASE lcExtension = 'MNX'
IF NOT INLIST(.MNX_Conversion_Support, 1, 2)
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, .c_MN2 )
.o_Conversor = CREATEOBJECT( 'c_conversor_mnx_a_prg' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, .c_MN2 ), '+N' )
CASE lcExtension = .c_VC2
IF .VCX_Conversion_Support <> 2
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, 'VCX' )
.o_Conversor = CREATEOBJECT( 'c_conversor_prg_a_vcx' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'VCX' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'VCT' ), '+N' )
CASE lcExtension = .c_SC2
IF .SCX_Conversion_Support <> 2
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, 'SCX' )
.o_Conversor = CREATEOBJECT( 'c_conversor_prg_a_scx' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'SCX' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'SCT' ), '+N' )
CASE lcExtension = .c_PJ2
IF .PJX_Conversion_Support <> 2
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, 'PJX' )
.o_Conversor = CREATEOBJECT( 'c_conversor_prg_a_pjx' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'PJX' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'PJT' ), '+N' )
CASE lcExtension = .c_FR2
IF .FRX_Conversion_Support <> 2
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, 'FRX' )
.o_Conversor = CREATEOBJECT( 'c_conversor_prg_a_frx' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'FRX' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'FRT' ), '+N' )
CASE lcExtension = .c_LB2
IF .LBX_Conversion_Support <> 2
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, 'LBX' )
.o_Conversor = CREATEOBJECT( 'c_conversor_prg_a_frx' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'LBX' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'LBT' ), '+N' )
CASE lcExtension = .c_DB2
IF .DBF_Conversion_Support <> 2
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, 'DBF' )
.o_Conversor = CREATEOBJECT( 'c_conversor_prg_a_dbf' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'DBF' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'FPT' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'CDX' ), '+N' )
CASE lcExtension = .c_DC2
IF .DBC_Conversion_Support <> 2
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, 'DBC' )
.o_Conversor = CREATEOBJECT( 'c_conversor_prg_a_dbc' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'DBC' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'DCX' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'DCT' ), '+N' )
CASE lcExtension = .c_MN2
IF .MNX_Conversion_Support <> 2
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDIF
.c_OutputFile = FORCEEXT( .c_InputFile, 'MNX' )
.o_Conversor = CREATEOBJECT( 'c_conversor_prg_a_mnx' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'MNX' ), '+N' )
.ChangeFileAttribute( FORCEEXT( .c_InputFile, 'MNT' ), '+N' )
OTHERWISE
*ERROR 'El archivo [' + .c_InputFile + '] no está soportado'
ERROR (TEXTMERGE(C_FILE_NAME_IS_NOT_SUPPORTED_LOC))
ENDCASE
.c_Type = UPPER(JUSTEXT(.c_OutputFile))
.o_Conversor.c_InputFile = .c_InputFile
.o_Conversor.c_OutputFile = .c_OutputFile
.o_Conversor.c_LogFile = .c_LogFile
.o_Conversor.l_Debug = .l_Debug
.o_Conversor.l_Test = .l_Test
.o_Conversor.n_FB2PRG_Version = .n_FB2PRG_Version
.o_Conversor.l_MethodSort_Enabled = .l_MethodSort_Enabled
.o_Conversor.l_PropSort_Enabled = .l_PropSort_Enabled
.o_Conversor.l_ReportSort_Enabled = .l_ReportSort_Enabled
.o_Conversor.c_OriginalFileName = .c_OriginalFileName
.o_Conversor.c_Foxbin2prg_FullPath = .c_Foxbin2prg_FullPath
*--
.o_Conversor.Convertir( @toModulo, .F., THIS )
.c_TextLog = .c_TextLog + CR_LF + .o_Conversor.c_TextLog && Recojo el LOG que haya generado el conversor
.normalizarCapitalizacionArchivos()
ENDWITH && THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
CATCH TO toEx
lnCodError = toEx.ERRORNO
lcErrorInfo = THIS.Exception2Str(toEx) + CR_LF + CR_LF + C_SOURCEFILE_LOC + THIS.c_InputFile
IF THIS.l_Debug
IF _VFP.STARTMODE = 0
SET STEP ON
ENDIF
*THIS.writeLog( lcErrorInfo )
ENDIF
*IF THIS.l_Debug AND THIS.l_ShowErrors
* MESSAGEBOX( lcErrorInfo, 0+16+4096, C_FOXBIN2PRG_ERROR_CAPTION_LOC, 60000 )
*ENDIF
IF tlRelanzarError && Usado en Unit Testing
THROW
ENDIF
FINALLY
loFSO = NULL
THIS.o_Conversor = NULL
THIS.writeLog_Flush()
ENDTRY
RETURN lnCodError
ENDPROC
PROCEDURE get_PROGRAM_HEADER
LOCAL lcText
lcText = ''
*-- Cabecera del PRG e inicio de DEF_CLASS
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
*--------------------------------------------------------------------------------------------------------------------------------------------------------
* (ES) AUTOGENERADO - ¡¡ATENCIÓN!! - ¡¡NO PENSADO PARA EJECUTAR!! USAR SOLAMENTE PARA INTEGRAR CAMBIOS Y ALMACENAR CON HERRAMIENTAS SCM!!
* (EN) AUTOGENERATED - ATTENTION!! - NOT INTENDED FOR EXECUTION!! USE ONLY FOR MERGING CHANGES AND STORING WITH SCM TOOLS!!
*--------------------------------------------------------------------------------------------------------------------------------------------------------
<<C_FB2PRG_META_I>> Version="<<TRANSFORM(THIS.n_FB2PRG_Version)>>" SourceFile="<<LOWER( JUSTFNAME( EVL( THIS.c_OriginalFileName, THIS.c_InputFile ) ) )>>" <<C_FB2PRG_META_F>> (Solo para binarios VFP 9 / Only for VFP 9 binaries)
*
ENDTEXT
RETURN lcText
ENDPROC
PROCEDURE getNext_BAK
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_OutputFilename (!v IN ) Nombre del archivo de salida a crear el backup
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS tcOutputFileName
LOCAL lcNext_Bak, I
lcNext_Bak = '.BAK'
FOR I = 1 TO THIS.n_ExtraBackupLevels
IF I = 1
IF NOT FILE( tcOutputFileName + '.BAK' )
lcNext_Bak = '.BAK'
EXIT
ENDIF
ELSE
IF NOT FILE( tcOutputFileName + '.' + PADL(I-1,1,'0') + '.BAK' )
lcNext_Bak = '.' + PADL(I-1,1,'0') + '.BAK'
EXIT
ENDIF
ENDIF
ENDFOR
RETURN lcNext_Bak
ENDPROC
*******************************************************************************************************************
PROCEDURE normalizarCapitalizacionArchivos
TRY
LOCAL lcPath, lcEXE_CAPS, lcOutputFile ;
, loFSO AS Scripting.FileSystemObject
WITH THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
lcPath = JUSTPATH(.c_Foxbin2prg_FullPath)
lcEXE_CAPS = FORCEPATH( 'filename_caps.exe', lcPath )
loFSO = .o_FSO
IF FILE(lcEXE_CAPS)
*.writeLog( '* Se ha encontrado el programa de capitalización de nombres [' + lcEXE_CAPS + ']' )
.writeLog( TEXTMERGE(C_NAMES_CAPITALIZATION_PROGRAM_FOUND_LOC) )
ELSE
*-- No existe el programa de capitalización, así que no se capitalizan los nombres.
*.writeLog( '* No se ha encontrado el programa de capitalización de nombres [' + lcEXE_CAPS + ']' )
.writeLog( TEXTMERGE(C_NAMES_CAPITALIZATION_PROGRAM_NOT_FOUND_LOC) )
EXIT
ENDIF
.RenameFile( .c_OutputFile, lcEXE_CAPS, loFSO )
DO CASE
CASE .c_Type = 'PJX'
.RenameFile( FORCEEXT(.c_OutputFile,'PJT'), lcEXE_CAPS, loFSO )
CASE .c_Type = 'VCX'
.RenameFile( FORCEEXT(.c_OutputFile,'VCT'), lcEXE_CAPS, loFSO )
CASE .c_Type = 'SCX'
.RenameFile( FORCEEXT(.c_OutputFile,'SCT'), lcEXE_CAPS, loFSO )
CASE .c_Type = 'FRX'
.RenameFile( FORCEEXT(.c_OutputFile,'FRT'), lcEXE_CAPS, loFSO )
CASE .c_Type = 'LBX'
.RenameFile( FORCEEXT(.c_OutputFile,'LBT'), lcEXE_CAPS, loFSO )
CASE .c_Type = 'DBF'
IF FILE( FORCEEXT(.c_OutputFile,'FPT') )
.RenameFile( FORCEEXT(.c_OutputFile,'FPT'), lcEXE_CAPS, loFSO )
ENDIF
IF FILE( FORCEEXT(.c_OutputFile,'CDX') )
.RenameFile( FORCEEXT(.c_OutputFile,'CDX'), lcEXE_CAPS, loFSO )
ENDIF
CASE .c_Type = 'DBC'
.RenameFile( FORCEEXT(.c_OutputFile,'DCX'), lcEXE_CAPS, loFSO )
.RenameFile( FORCEEXT(.c_OutputFile,'DCT'), lcEXE_CAPS, loFSO )
CASE .c_Type = 'MNX'
.RenameFile( FORCEEXT(.c_OutputFile,'MNT'), lcEXE_CAPS, loFSO )
ENDCASE
ENDWITH && THIS
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE RenameFile
LPARAMETERS tcFileName, tcEXE_CAPS, toFSO AS Scripting.FileSystemObject
LOCAL lcLog, laFile(1,5)
*THIS.writeLog( '- Se ha solicitado capitalizar el archivo [' + tcFileName + ']' )
THIS.writeLog( TEXTMERGE(C_REQUESTING_CAPITALIZATION_OF_FILE_LOC) )
THIS.ChangeFileAttribute( tcFileName, '+N' )
lcLog = ''
DO (tcEXE_CAPS) WITH tcFileName, '', 'F', lcLog, .T.
THIS.writeLog( lcLog )
ENDPROC
*******************************************************************************************************************
PROCEDURE writeLog
LPARAMETERS tcText
TRY
THIS.c_TextLog = THIS.c_TextLog + TTOC(DATETIME(),3) + ' ' + EVL(tcText,'') + CR_LF
CATCH
ENDTRY
ENDPROC
*******************************************************************************************************************
PROCEDURE writeLog_Flush
IF THIS.l_Debug AND NOT EMPTY(THIS.c_TextLog)
STRTOFILE( THIS.c_TextLog + CR_LF, THIS.c_LogFile, 1 )
THIS.c_TextLog = ''
ENDIF
ENDPROC
*******************************************************************************************************************
HIDDEN PROCEDURE Exception2Str
LPARAMETERS toEx AS EXCEPTION
LOCAL lcError
lcError = 'Error ' + TRANSFORM(toEx.ERRORNO) + ', ' + toEx.MESSAGE + CR_LF ;
+ toEx.PROCEDURE + ', ' + TRANSFORM(toEx.LINENO) + CR_LF ;
+ toEx.LINECONTENTS + CR_LF + CR_LF ;
+ EVL(toEx.USERVALUE,'')
RETURN lcError
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS frm_avance AS FORM
HEIGHT = 79
WIDTH = 628
SHOWWINDOW = 2
DOCREATE = .T.
AUTOCENTER = .T.
BORDERSTYLE = 2
CAPTION = C_PROCESS_PROGRESS_LOC + ' '
CONTROLBOX = .F.
BACKCOLOR = RGB(255,255,255)
nMAX_VALUE = 100
nVALUE = 0
NAME = "FRM_AVANCE"
ADD OBJECT shp_base AS SHAPE WITH ;
TOP = 50, ;
LEFT = 12, ;
HEIGHT = 13, ;
WIDTH = 601, ;
CURVATURE = 15, ;
NAME = "shp_base"
ADD OBJECT shp_avance AS SHAPE WITH ;
TOP = 50, ;
LEFT = 12, ;
HEIGHT = 13, ;
WIDTH = 36, ;
CURVATURE = 15, ;
BACKCOLOR = RGB(255,255,128), ;
BORDERCOLOR = RGB(255,0,0), ;
NAME = "shp_Avance"
ADD OBJECT lbl_TAREA AS LABEL WITH ;
BACKSTYLE = 0, ;
CAPTION = ".", ;
HEIGHT = 17, ;
LEFT = 12, ;
TOP = 20, ;
WIDTH = 604, ;
NAME = "lbl_Tarea"
PROCEDURE nvalue_assign
LPARAMETERS vNewVal
WITH THIS
.nVALUE = m.vNewVal
.shp_avance.WIDTH = m.vNewVal * .shp_base.WIDTH / .nMAX_VALUE
ENDWITH
ENDPROC
PROCEDURE INIT
THIS.nVALUE = 0
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_base AS SESSION
#IF .F.
LOCAL THIS AS c_conversor_base OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="analizarasignacion_tag_indicado" display="analizarAsignacion_TAG_Indicado"/>] ;
+ [<memberdata name="buscarobjetodelmetodopornombre" display="buscarObjetoDelMetodoPorNombre"/>] ;
+ [<memberdata name="comprobarexpresionvalida" display="comprobarExpresionValida"/>] ;
+ [<memberdata name="convertir" display="Convertir"/>] ;
+ [<memberdata name="decode_specialcodes_1_31" display="decode_SpecialCodes_1_31"/>] ;
+ [<memberdata name="desnormalizarasignacion" display="desnormalizarAsignacion"/>] ;
+ [<memberdata name="desnormalizarvalorpropiedad" display="desnormalizarValorPropiedad"/>] ;
+ [<memberdata name="desnormalizarvalorxml" display="desnormalizarValorXML"/>] ;
+ [<memberdata name="encode_specialcodes_1_31" display="encode_SpecialCodes_1_31"/>] ;
+ [<memberdata name="exception2str" display="Exception2Str"/>] ;
+ [<memberdata name="filetypecode" display="fileTypeCode"/>] ;
+ [<memberdata name="get_separatedlineandcomment" display="get_SeparatedLineAndComment"/>] ;
+ [<memberdata name="get_separatedpropandvalue" display="get_SeparatedPropAndValue"/>] ;
+ [<memberdata name="get_valuefromnullterminatedvalue" display="get_ValueFromNullTerminatedValue"/>] ;
+ [<memberdata name="identificarbloquesdeexclusion" display="identificarBloquesDeExclusion"/>] ;
+ [<memberdata name="lineisonlycommentandnometadata" display="lineIsOnlyCommentAndNoMetadata"/>] ;
+ [<memberdata name="normalizarasignacion" display="normalizarAsignacion"/>] ;
+ [<memberdata name="normalizarvalorpropiedad" display="normalizarValorPropiedad"/>] ;
+ [<memberdata name="normalizarvalorxml" display="normalizarValorXML"/>] ;
+ [<memberdata name="sortpropsandvalues" display="sortPropsAndValues"/>] ;
+ [<memberdata name="sortpropsandvalues_setandgetscxpropnames" type="method" display="sortPropsAndValues_SetAndGetSCXPropNames"/>] ;
+ [<memberdata name="writelog" display="writeLog"/>] ;
+ [<memberdata name="c_curdir" display="c_CurDir"/>] ;
+ [<memberdata name="c_foxbin2prg_fullpath" display="c_Foxbin2prg_FullPath"/>] ;
+ [<memberdata name="c_inputfile" display="c_InputFile"/>] ;
+ [<memberdata name="c_logfile" display="c_LogFile"/>] ;
+ [<memberdata name="c_originalfilename" display="c_OriginalFileName"/>] ;
+ [<memberdata name="c_outputfile" display="c_OutputFile"/>] ;
+ [<memberdata name="c_textlog" display="c_TextLog"/>] ;
+ [<memberdata name="c_type" display="c_Type"/>] ;
+ [<memberdata name="l_debug" display="l_Debug"/>] ;
+ [<memberdata name="l_test" display="l_Test"/>] ;
+ [<memberdata name="l_methodsort_enabled" display="l_MethodSort_Enabled"/>] ;
+ [<memberdata name="l_propsort_enabled" display="l_PropSort_Enabled"/>] ;
+ [<memberdata name="l_reportsort_enabled" display="l_ReportSort_Enabled"/>] ;
+ [<memberdata name="n_fb2prg_version" display="n_FB2PRG_Version"/>] ;
+ [<memberdata name="ofso" display="oFSO"/>] ;
+ [</VFPData>]
l_Debug = .F.
l_Test = .F.
c_InputFile = ''
c_OutputFile = ''
lFileMode = .F.
nClassTimeStamp = ''
n_FB2PRG_Version = 1.0
c_Foxbin2prg_FullPath = ''
c_Type = ''
c_CurDir = ''
c_LogFile = ''
c_TextLog = ''
l_MethodSort_Enabled = .T.
l_PropSort_Enabled = .T.
l_ReportSort_Enabled = .T.
c_OriginalFileName = ''
oFSO = NULL
*******************************************************************************************************************
PROCEDURE INIT
SET DELETED ON
SET DATE YMD
SET HOURS TO 24
SET CENTURY ON
SET SAFETY OFF
SET TABLEPROMPT OFF
SET BLOCKSIZE TO 0
PUBLIC C_FB2PRG_CODE
C_FB2PRG_CODE = '' && Contendrá todo el código generado
THIS.c_CurDir = SYS(5) + CURDIR()
THIS.oFSO = CREATEOBJECT( "Scripting.FileSystemObject")
ENDPROC
*******************************************************************************************************************
PROCEDURE DESTROY
C_FB2PRG_CODE = ''
USE IN (SELECT("TABLABIN"))
THIS.writeLog( C_CONVERTER_UNLOAD_LOC )
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarAsignacion_TAG_Indicado
*-- DETALLES: Este método está pensado para leer los tags FB2P_VALUE y MEMBERDATA, que tienen esta sintaxis:
*
* _memberdata = <VFPData>
* <memberdata name="mimetodo" display="miMetodo"/>
* </VFPData> && XML Metadata for customizable properties
*
* <fb2p_value>Este es un&#13;valor especial</fb2p_value>
*
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcPropName (!v IN ) Nombre de la propiedad
* tcValue (!v IN ) Valor (o inicio del valor) de la propiedad
* taProps (!@ IN ) El array con las líneas del código donde buscar
* tnProp_Count (!@ IN ) Cantidad de líneas de código
* I (!@ IN ) Línea actualmente evaluada
* tcTAG_I (!v IN ) TAG de inicio <tag>
* tcTAG_F (!v IN ) TAG de fin </tag>
* tnLEN_TAG_I (!v IN ) Longitud del tag de inicio
* tnLEN_TAG_F (!v IN ) Longitud del tag de fin
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS tcPropName, tcValue, taProps, tnProp_Count, I, tcTAG_I, tcTAG_F, tnLEN_TAG_I, tnLEN_TAG_F
EXTERNAL ARRAY taProps
LOCAL llBloqueEncontrado, loEx AS EXCEPTION
TRY
IF LEFT( tcValue, tnLEN_TAG_I) == tcTAG_I
llBloqueEncontrado = .T.
LOCAL lcLine, lnArrayCols
WITH THIS AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
*-- Propiedad especial
IF tcTAG_F $ tcValue && El fin de tag está "inline"
.desnormalizarValorPropiedad( @tcPropName, @tcValue, '' )
EXIT
ENDIF
tcValue = ''
lnArrayCols = ALEN(taProps,2)
FOR I = I + 1 TO tnProp_Count
IF lnArrayCols = 0
lcLine = LTRIM( taProps(I), 0, ' ', CHR(9) ) && Quito espacios y TABS de la izquierda
ELSE
lcLine = LTRIM( taProps(I,1), 0, ' ', CHR(9) ) && Quito espacios y TABS de la izquierda
ENDIF
DO CASE
CASE LEFT( lcLine, tnLEN_TAG_F ) == tcTAG_F
*-- <EndTag>
tcValue = tcTAG_I + SUBSTR( tcValue, 3 ) + tcTAG_F
.desnormalizarValorPropiedad( @tcPropName, @tcValue, '' )
I = I + 1
EXIT
CASE tcTAG_F $ lcLine
*-- Data-Data-Data-<EndTag>
tcValue = tcTAG_I + SUBSTR( tcValue, 3 ) + LEFT( lcLine, AT( tcTAG_F, lcLine )-1 ) + tcTAG_F
.desnormalizarValorPropiedad( @tcPropName, @tcValue, '' )
I = I + 1
EXIT
OTHERWISE
*-- Data
tcValue = tcValue + CR_LF + lcLine
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE buscarObjetoDelMetodoPorNombre
LPARAMETERS tcNombreObjeto, toClase
*-- Caso 1: Un método de un objeto de la clase
*-- buscarObjetoDelMetodoPorNombre( 'command1', loClase )
*-- Caso 2: Un método de un objeto heredado que no está definido en esta librería
*-- buscarObjetoDelMetodoPorNombre( 'cnt_descripcion.Cntlista.cmgAceptarCancelar.cmdCancelar', loClase )
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnObjeto, I, X, N, lcRutaDelNombre ;
, loObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
STORE 0 TO N, lnObjeto
*-- El método puede pertenecer a esta clase, a un objeto de esta clase,
*-- o a un objeto heredado que no está definido en esta clase, sino en otra,
*-- y para la cual la ruta a buscar es parcial.
*-- Por ejemplo, el caso 2 puede que el objeto que hay sea 'cnt_descripcion.Cntlista'
*-- y el botón sea heredado, pero se le haya redefinido su método Click aquí.
FOR X = OCCURS( '.', tcNombreObjeto + '.' ) TO 1 STEP -1
N = N + 1
lcRutaDelNombre = LEFT( tcNombreObjeto, RAT( '.', tcNombreObjeto + '.', N ) - 1 )
FOR I = 1 TO toClase._AddObject_Count
loObjeto = toClase._AddObjects(I)
*-- Busco tanto el [nombre] del método como [class.nombre]+[nombre] del método
IF LOWER(loObjeto._Nombre) == LOWER(toClase._ObjName) + '.' + lcRutaDelNombre ;
OR LOWER(loObjeto._Nombre) == lcRutaDelNombre
lnObjeto = I
EXIT
ENDIF
ENDFOR
IF lnObjeto > 0
EXIT
ENDIF
ENDFOR
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lnObjeto
ENDPROC
*******************************************************************************************************************
FUNCTION comprobarExpresionValida
LPARAMETERS tcAsignacion, tnCodError, tcExpNormalizada
LOCAL llError, loEx AS EXCEPTION
TRY
tcExpNormalizada = NORMALIZE( tcAsignacion )
CATCH TO loEx
llError = .T.
tnCodError = loEx.ERRORNO
ENDTRY
RETURN NOT llError
ENDFUNC
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase correspondiente con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
THIS.writeLog( '' )
THIS.writeLog( C_CONVERTING_FILE_LOC + ' ' + THIS.c_OutputFile + '...' )
ENDPROC
PROCEDURE decode_SpecialCodes_1_31
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcText (@! IN ) Decodifica los primeros 31 caracteres ASCII de {nCode} a CHR(nCode)
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcText
LOCAL I
FOR I = 0 TO 31
tcText = STRTRAN( tcText, '{' + TRANSFORM(I) + '}', CHR(I) )
ENDFOR
RETURN tcText
ENDPROC
*******************************************************************************************************************
PROCEDURE desnormalizarAsignacion
LPARAMETERS tcAsignacion
LOCAL lcPropName, lcValor, lnCodError, lcExpNormalizada, lnPos, lcComentario
THIS.get_SeparatedPropAndValue( @tcAsignacion, @lcPropName, @lcValor )
lcComentario = ''
THIS.desnormalizarValorPropiedad( @lcPropName, @lcValor, @lcComentario )
tcAsignacion = lcPropName + ' = ' + lcValor
RETURN tcAsignacion
ENDPROC
*******************************************************************************************************************
PROCEDURE desnormalizarValorPropiedad
LPARAMETERS tcProp, tcValue, tcComentario
LOCAL lnCodError, lnPos, lcValue
tcComentario = ''
*-- Ajustes de algunos casos especiales
DO CASE
CASE tcProp == '_memberdata'
*-- Me quedo con lo importante y quito los CHR(0) y longitud que a veces agrega al inicio
lcValue = ''
FOR I = 1 TO OCCURS( '/>', tcValue )
TEXT TO lcValue TEXTMERGE ADDITIVE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<STREXTRACT( tcValue, '<memberdata ', '/>', I, 1+4 )>>
ENDTEXT
ENDFOR
TEXT TO tcValue TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<VFPData>
<<SUBSTR( lcValue, 3)>>
</VFPData>
ENDTEXT
IF LEN(lcValue) > 255
tcValue = C_MPROPHEADER + STR( LEN(tcValue), 8 ) + tcValue
ELSE
tcValue = CHRTRAN( tcValue, CR_LF, '' )
ENDIF
CASE LEFT( tcValue, C_LEN_FB2P_VALUE_I ) == C_FB2P_VALUE_I
*-- Valor especial Fox con cabecera CHR(1): Debo agregarla y desnormalizar el valor
tcValue = STRTRAN( STRTRAN( STREXTRACT( tcValue, C_FB2P_VALUE_I, C_FB2P_VALUE_F, 1, 1 ), '&#13;', C_CR ), '&#10;', C_LF )
tcValue = C_MPROPHEADER + STR( LEN(tcValue), 8 ) + tcValue
ENDCASE
RETURN tcValue
ENDFUNC
*******************************************************************************************************************
PROCEDURE desnormalizarValorXML
LPARAMETERS tcValor
*-- DESNORMALIZA EL TEXTO INDICADO, EXPANDIENDO LOS SÍMBOLOS XML ESPECIALES.
LOCAL lnPos, lnPos2, lnAscii
tcValor = STRTRAN(tcValor, CHR(38)+'gt;', '>') && >
tcValor = STRTRAN(tcValor, CHR(38)+'lt;', '<') && <
tcValor = STRTRAN(tcValor, CHR(38)+'quot;', CHR(34)) && "
tcValor = STRTRAN(tcValor, CHR(38)+'apos;', CHR(39)) && '
tcValor = STRTRAN(tcValor, CHR(38)+'amp;', CHR(38)) && &
*-- Obtengo los Hex
DO WHILE .T.
lnPos = AT( CHR(38)+'#x', tcValor )
IF lnPos = 0
EXIT
ENDIF
lnPos2 = lnPos + 1 + AT( ';', SUBSTR( tcValor, lnPos + 2, 4 ) )
lnAscii = EVALUATE( '0' + SUBSTR( tcValor, lnPos + 3, lnPos2 - lnPos - 3 ) )
tcValor = STUFF(tcValor, lnPos, lnPos2 - lnPos + 1, CHR(lnAscii)) && ASCII
ENDDO
*-- Obtengo los Dec
DO WHILE .T.
lnPos = AT( CHR(38)+'#', tcValor )
IF lnPos = 0
EXIT
ENDIF
lnPos2 = lnPos + 1 + AT( ';', SUBSTR( tcValor, lnPos + 2, 4 ) )
lnAscii = EVALUATE( SUBSTR( tcValor, lnPos + 2, lnPos2 - lnPos - 2 ) )
tcValor = STUFF(tcValor, lnPos, lnPos2 - lnPos + 1, CHR(lnAscii)) && ASCII
ENDDO
RETURN tcValor
ENDPROC
*******************************************************************************************************************
PROCEDURE encode_SpecialCodes_1_31
LPARAMETERS tcText
LOCAL I
FOR I = 0 TO 31
tcText = STRTRAN( tcText, CHR(I), '{' + TRANSFORM(I) + '}' )
ENDFOR
RETURN tcText
ENDPROC
*******************************************************************************************************************
HIDDEN PROCEDURE Exception2Str
LPARAMETERS toEx AS EXCEPTION
LOCAL lcError
lcError = 'Error ' + TRANSFORM(toEx.ERRORNO) + ', ' + toEx.MESSAGE + CHR(13) + CHR(13) ;
+ toEx.PROCEDURE + ', ' + TRANSFORM(toEx.LINENO) + CHR(13) + CHR(13) ;
+ toEx.LINECONTENTS
RETURN lcError
ENDPROC
*******************************************************************************************************************
PROCEDURE fileTypeCode
LPARAMETERS tcExtension
tcExtension = UPPER(tcExtension)
RETURN ICASE( tcExtension = 'DBC', 'd' ;
, tcExtension = 'DBF', 'D' ;
, tcExtension = 'QPR', 'Q' ;
, tcExtension = 'SCX', 'K' ;
, tcExtension = 'FRX', 'R' ;
, tcExtension = 'LBX', 'B' ;
, tcExtension = 'VCX', 'V' ;
, tcExtension = 'PRG', 'P' ;
, tcExtension = 'FLL', 'L' ;
, tcExtension = 'APP', 'Z' ;
, tcExtension = 'EXE', 'Z' ;
, tcExtension = 'MNX', 'M' ;
, tcExtension = 'TXT', 'T' ;
, tcExtension = 'FPW', 'T' ;
, tcExtension = 'H', 'T' ;
, 'x' )
ENDPROC
FUNCTION GetTimeStamp
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tnTimeStamp (v! IN ) Timestamp en formato numérico
*---------------------------------------------------------------------------------------------------
LPARAMETERS tnTimeStamp
*-- CONVIERTE UN DATO TIMESTAMP NUMERICO USADO POR LOS ARCHIVOS SCX/VCX/etc. EN TIPO DATETIME
TRY
LOCAL lcTimeStamp,lnYear,lnMonth,lnDay,lnHour,lnMinutes,lnSeconds,lcTime,lnHour,ltTimeStamp,lnResto ;
,lcTimeStamp_Ret, laDir[1,5], loEx AS EXCEPTION
lcTimeStamp_Ret = ''
IF EMPTY(tnTimeStamp)
IF THIS.lFileMode
IF ADIR(laDir,THIS.c_InputFile)=0
EXIT
ENDIF
ltTimeStamp = EVALUATE( '{^' + DTOC(laDir(1,3)) + ' ' + TRANSFORM(laDir(1,4)) + '}' )
*-- En mi arreglo, si la hora pasada tiene 32 segundos o más, redondeo al siguiente minuto, ya que
*-- la descodificación posterior de GetTimeStamp tiene ese margen de error.
IF SEC(m.ltTimeStamp) >= 32
ltTimeStamp = m.ltTimeStamp + 28
ENDIF
lcTimeStamp_Ret = TTOC( ltTimeStamp )
EXIT
ENDIF
tnTimeStamp = THIS.nClassTimeStamp
IF EMPTY(tnTimeStamp)
EXIT
ENDIF
ENDIF
*-- YYYY YYYM MMMD DDDD HHHH HMMM MMMS SSSS
lnResto = tnTimeStamp
lnYear = INT( lnResto / 2**25 + 1980)
lnResto = lnResto % 2**25
lnMonth = INT( lnResto / 2**21 )
lnResto = lnResto % 2**21
lnDay = INT( lnResto / 2**16 )
lnResto = lnResto % 2**16
lnHour = INT( lnResto / 2**11 )
lnResto = lnResto % 2**11
lnMinutes = INT( lnResto / 2**5 )
lnResto = lnResto % 2**5
lnSeconds = lnResto
lcTimeStamp = STR(lnYear,4) + "/" + STR(lnMonth,2) + "/" + STR(lnDay,2) + " " ;
+ STR(lnHour,2) + ":" + STR(lnMinutes,2) + ":" + STR(lnSeconds,2)
ltTimeStamp = EVALUATE( "{^" + lcTimeStamp + "}" )
lcTimeStamp_Ret = TTOC( ltTimeStamp )
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcTimeStamp_Ret
ENDPROC
PROCEDURE get_SeparatedLineAndComment
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Línea a separar del comentario
* tcComment (@? OUT) Comentario
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, tcComment
LOCAL ln_AT_Cmt
tcComment = ''
IF '&'+'&' $ tcLine
ln_AT_Cmt = AT( '&'+'&', tcLine)
tcComment = LTRIM( SUBSTR( tcLine, ln_AT_Cmt + 2 ) )
tcLine = RTRIM( LEFT( tcLine, ln_AT_Cmt - 1 ), 0, ' ', CHR(9) ) && Quito espacios y TABS
ENDIF
RETURN
ENDPROC
PROCEDURE get_SeparatedPropAndValue
*-- Devuelve el valor separado de la propiedad.
*-- Si se indican más de 3 parámetros, evalúa el valor completo a través de las líneas de código
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taCodeLines (!@ IN ) El array con las líneas del código donde buscar
* tnCodeLines (!@ IN ) Cantidad de líneas de código
* taBloquesExclusion (!@ IN ) Array con las posiciones de inicio/fin de los bloques de exclusion
* tnBloquesExclusion (!@ IN ) Cantidad de bloques de exclusión
* toModulo (?@ OUT) Objeto con toda la información del módulo analizado
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS tcAsignacion, tcPropName, tcValue, toClase, taCodeLines, tnCodeLines, I
LOCAL ln_AT_Cmt
STORE '' TO tcPropName, tcValue
*-- EVALUAR UNA ASIGNACIÓN ESPECÍFICA INLINE
IF '=' $ tcAsignacion
ln_AT_Cmt = AT( '=', tcAsignacion)
tcPropName = ALLTRIM( LEFT( tcAsignacion, ln_AT_Cmt - 2 ), 0, ' ', CHR(9) ) && Quito espacios y TABS
tcValue = ALLTRIM( SUBSTR( tcAsignacion, ln_AT_Cmt + 2 ) )
IF PCOUNT() > 3
*-- EVALUAR UNA ASIGNACIÓN QUE PUEDE SER MULTILÍNEA (memberdata, fb2p_value, etc)
WITH THIS AS c_conversor_base OF 'FOXBIN2PRG.PRG'
DO CASE
CASE .analizarAsignacion_TAG_Indicado( @tcPropName, @tcValue, @taCodeLines, tnCodeLines, @I ;
, C_FB2P_VALUE_I, C_FB2P_VALUE_F, C_LEN_FB2P_VALUE_I, C_LEN_FB2P_VALUE_F )
*-- FB2P_VALUE
CASE .analizarAsignacion_TAG_Indicado( @tcPropName, @tcValue, @taCodeLines, tnCodeLines, @I ;
, C_MEMBERDATA_I, C_MEMBERDATA_F, C_LEN_MEMBERDATA_I, C_LEN_MEMBERDATA_F )
*-- MEMBERDATA
OTHERWISE
*-- Propiedad normal
.desnormalizarValorPropiedad( @tcPropName, @tcValue, '' )
ENDCASE
ENDWITH && THIS
ENDIF
ENDIF
RETURN
ENDPROC
************************************************************************************************
PROCEDURE get_ValueFromNullTerminatedValue
LPARAMETERS tcNullTerminatedValue
LOCAL lcValue, lnNullPos
lnNullPos = AT(CHR(0), tcNullTerminatedValue )
IF lnNullPos = 0
lcValue = CHRTRAN( tcNullTerminatedValue, ['], ["] )
ELSE
lcValue = CHRTRAN( LEFT( tcNullTerminatedValue, lnNullPos - 1 ), ['], ["] )
ENDIF
RETURN lcValue
ENDPROC
*******************************************************************************************************************
PROCEDURE identificarBloquesDeCodigo
LPARAMETERS taCodeLines, tnCodeLines, taBloquesExclusion, tnBloquesExclusion, toModulo
ENDPROC
*******************************************************************************************************************
PROCEDURE lineaExcluida
LPARAMETERS tn_Linea, tnBloquesExclusion, taBloquesExclusion
EXTERNAL ARRAY taBloquesExclusion
LOCAL X, llExcluida
FOR X = 1 TO tnBloquesExclusion
IF BETWEEN( tn_Linea, taBloquesExclusion(X,1), taBloquesExclusion(X,2) )
llExcluida = .T.
EXIT
ENDIF
ENDFOR
RETURN llExcluida
ENDPROC
*******************************************************************************************************************
PROCEDURE lineIsOnlyCommentAndNoMetadata
LPARAMETERS tcLine, tcComment
LOCAL lllineIsOnlyCommentAndNoMetadata, ln_AT_Cmt
THIS.get_SeparatedLineAndComment( @tcLine, @tcComment )
DO CASE
CASE LEFT(tcLine,2) == '*<'
tcComment = tcLine
CASE EMPTY(tcLine) OR LEFT(tcLine, 1) == '*' OR LEFT(tcLine + ' ', 5) == 'NOTE ' && Vacía o Comentarios
lllineIsOnlyCommentAndNoMetadata = .T.
ENDCASE
RETURN lllineIsOnlyCommentAndNoMetadata
ENDPROC
*******************************************************************************************************************
PROCEDURE normalizarAsignacion
LPARAMETERS tcAsignacion, tcComentario
LOCAL lcPropName, lcValor, lnCodError, lcExpNormalizada, lnPos
THIS.get_SeparatedPropAndValue( @tcAsignacion, @lcPropName, @lcValor )
tcComentario = ''
THIS.normalizarValorPropiedad( @lcPropName, @lcValor, @tcComentario )
tcAsignacion = lcPropName + ' = ' + lcValor
RETURN tcAsignacion
ENDPROC
*******************************************************************************************************************
PROCEDURE normalizarValorPropiedad
LPARAMETERS tcProp, tcValue, tcComentario
LOCAL lcValue, I
tcComentario = ''
*-- Ajustes de algunos casos especiales
DO CASE
CASE tcProp == '_memberdata'
lcValue = ''
FOR I = 1 TO OCCURS( '/>', tcValue )
TEXT TO lcValue TEXTMERGE ADDITIVE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<STREXTRACT( tcValue, '<memberdata ', '/>', I, 1+4 )>>
ENDTEXT
ENDFOR
TEXT TO tcValue TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<VFPData>
<<SUBSTR( lcValue, 3)>>
<<>> </VFPData>
ENDTEXT
CASE LEFT( tcValue, C_LEN_FB2P_VALUE_I ) == C_FB2P_VALUE_I
*-- Valor especial Fox con cabecera CHR(1): Debo quitarla y normalizar el valor
tcValue = C_FB2P_VALUE_I ;
+ STRTRAN( STRTRAN( STRTRAN( STRTRAN( ;
STREXTRACT( tcValue, C_FB2P_VALUE_I, C_FB2P_VALUE_F, 1, 1 ) ;
, CR_LF, '&#13+10;' ), C_CR, '&#13;' ), C_LF, '&#10;' ), '&#13+10;', CR_LF ) ;
+ C_FB2P_VALUE_F
ENDCASE
RETURN tcValue
ENDPROC
*******************************************************************************************************************
PROCEDURE normalizarValorXML
LPARAMETERS tcValor
*-- NORMALIZA EL TEXTO INDICADO, COMPRIMIENDO LOS SÍMBOLOS XML ESPECIALES.
tcValor = STRTRAN(tcValor, CHR(38), CHR(38) + 'amp;') && reemplaza & por &amp; &&
tcValor = STRTRAN(tcValor, CHR(39), CHR(38) + 'apos;') && reemplaza ' por &apos; &&
tcValor = STRTRAN(tcValor, CHR(34), CHR(38) + 'quot;') && reemplaza " por &quot; &&
tcValor = STRTRAN(tcValor, '<', CHR(38) + 'lt;') && reemplaza < por &lt; &&
tcValor = STRTRAN(tcValor, '>', CHR(38) + 'gt;') && reemplaza > por &gt; &&
tcValor = STRTRAN(tcValor, CHR(13)+CHR(10), CHR(10)) && reeemplaza CR+LF por LF
tcValor = CHRTRAN(tcValor, CHR(13), CHR(10)) && reemplaza CR por LF
RETURN tcValor
ENDPROC
*******************************************************************************************************************
FUNCTION RowTimeStamp(ltDateTime)
* Generate a FoxPro 3.0-style row timestamp
*-- CONVIERTE UN DATO TIPO DATETIME EN TIMESTAMP NUMERICO USADO POR LOS ARCHIVOS SCX/VCX/etc.
LOCAL lcTimeValue, tnTimeStamp
TRY
IF EMPTY(ltDateTime)
tnTimeStamp = 0
EXIT
ENDIF
IF VARTYPE(m.ltDateTime) <> 'T'
m.ltDateTime = DATETIME()
ENDIF
tnTimeStamp = ( YEAR(m.ltDateTime) - 1980) * 2^25 ;
+ MONTH(m.ltDateTime) * 2^21 ;
+ DAY(m.ltDateTime) * 2^16 ;
+ HOUR(m.ltDateTime) * 2^11 ;
+ MINUTE(m.ltDateTime) * 2^5 ;
+ SEC(m.ltDateTime)
ENDTRY
RETURN INT(tnTimeStamp)
ENDFUNC
*******************************************************************************************************************
PROCEDURE sortPropsAndValues_SetAndGetSCXPropNames
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcOperation (!v IN ) Operación a realizar ("SETNAME" o "GETNAME")
* tcPropName (!v IN ) Nombre de la propiedad
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS tcOperation, tcPropName
LOCAL lcPropName
lcPropName = tcPropName
tcOperation = UPPER(EVL(tcOperation,''))
*-- Por defecto son todas System Properties
DO CASE
CASE tcOperation == 'GETNAME'
lcPropName = SUBSTR(tcPropName,5)
CASE NOT tcOperation == 'SETNAME'
ERROR C_ONLY_SETNAME_AND_GETNAME_RECOGNIZED_LOC
CASE lcPropName == 'ErasePage' && PageFrame: Debe estar antes que PageCount
lcPropName = 'A002' + lcPropName
CASE lcPropName == 'PageCount' && PageFrame: Debe estar antes que ActivePage
lcPropName = 'A003' + lcPropName
CASE lcPropName == 'ActivePage' && PageFrame: Debe estar antes que Top/Left/With/Height
lcPropName = 'A004' + lcPropName
CASE lcPropName == 'ButtonCount'
lcPropName = 'A005' + lcPropName
CASE lcPropName == 'ColumnCount'
lcPropName = 'A010' + lcPropName
CASE lcPropName == 'Value'
lcPropName = 'A015' + lcPropName
CASE lcPropName == 'Comment'
lcPropName = 'A020' + lcPropName
CASE lcPropName == 'ControlSource'
lcPropName = 'A025' + lcPropName
CASE lcPropName == 'DataSession'
lcPropName = 'A030' + lcPropName
CASE lcPropName == 'DeleteMark'
lcPropName = 'A035' + lcPropName
CASE lcPropName == 'ScaleMode'
lcPropName = 'A040' + lcPropName
CASE lcPropName == 'Tag'
lcPropName = 'A045' + lcPropName
CASE lcPropName == 'Top'
lcPropName = 'A050' + lcPropName
CASE lcPropName == 'Left'
lcPropName = 'A055' + lcPropName
CASE lcPropName == 'Height'
lcPropName = 'A060' + lcPropName
CASE lcPropName == 'Width'
lcPropName = 'A065' + lcPropName
CASE lcPropName == 'MaxLength'
lcPropName = 'A070' + lcPropName
CASE lcPropName == 'Alias'
lcPropName = 'A075' + lcPropName
CASE lcPropName == 'BufferModeOverride'
lcPropName = 'A080' + lcPropName
CASE lcPropName == 'Order'
lcPropName = 'A085' + lcPropName
CASE lcPropName == 'OrderDirection'
lcPropName = 'A090' + lcPropName
CASE lcPropName == 'CursorSource'
lcPropName = 'A095' + lcPropName
CASE lcPropName == 'Exclusive'
lcPropName = 'A100' + lcPropName
CASE lcPropName == 'Filter'
lcPropName = 'A105' + lcPropName
CASE lcPropName == 'Panel'
lcPropName = 'A110' + lcPropName
CASE lcPropName == 'ReadOnly'
lcPropName = 'A115' + lcPropName
CASE lcPropName == 'RecordSource'
lcPropName = 'A120' + lcPropName
CASE lcPropName == 'RecordSourceType'
lcPropName = 'A125' + lcPropName
CASE lcPropName == 'NoDataOnLoad'
lcPropName = 'A130' + lcPropName
CASE lcPropName == 'OpenViews'
lcPropName = 'A135' + lcPropName
CASE lcPropName == 'AutoOpenTables'
lcPropName = 'A140' + lcPropName
CASE lcPropName == 'AutoCloseTables'
lcPropName = 'A145' + lcPropName
CASE lcPropName == 'InitialSelectedAlias'
lcPropName = 'A150' + lcPropName
CASE lcPropName == 'DataSource'
lcPropName = 'A155' + lcPropName
CASE lcPropName == 'DataSourceType '
lcPropName = 'A160' + lcPropName
CASE lcPropName == 'Desktop'
lcPropName = 'A165' + lcPropName
CASE lcPropName == 'ShowWindow'
lcPropName = 'A170' + lcPropName
CASE lcPropName == 'ScrollBars'
lcPropName = 'A175' + lcPropName
CASE lcPropName == 'ShowInTaskBar'
lcPropName = 'A180' + lcPropName
CASE lcPropName == 'DoCreate'
lcPropName = 'A185' + lcPropName
CASE lcPropName == 'Tag'
lcPropName = 'A190' + lcPropName
CASE lcPropName == 'OLEDragMode'
lcPropName = 'A195' + lcPropName
CASE lcPropName == 'OLEDragPicture'
lcPropName = 'A200' + lcPropName
CASE lcPropName == 'OLEDropMode'
lcPropName = 'A205' + lcPropName
CASE lcPropName == 'OLEDropEffects'
lcPropName = 'A210' + lcPropName
CASE lcPropName == 'ShowTips'
lcPropName = 'A215' + lcPropName
CASE lcPropName == 'BufferMode'
lcPropName = 'A220' + lcPropName
CASE lcPropName == 'AutoCenter'
lcPropName = 'A225' + lcPropName
CASE lcPropName == 'AutoSize'
lcPropName = 'A230' + lcPropName
CASE lcPropName == 'WordWrap'
lcPropName = 'A235' + lcPropName
CASE lcPropName == 'Picture'
lcPropName = 'A240' + lcPropName
CASE lcPropName == 'BackStyle'
lcPropName = 'A245' + lcPropName
CASE lcPropName == 'BorderStyle'
lcPropName = 'A250' + lcPropName
CASE lcPropName == 'BorderWidth'
lcPropName = 'A255' + lcPropName
CASE lcPropName == 'Caption'
lcPropName = 'A260' + lcPropName
CASE lcPropName == 'ControlBox'
lcPropName = 'A265' + lcPropName
CASE lcPropName == 'Closable'
lcPropName = 'A270' + lcPropName
CASE lcPropName == 'Curvature'
lcPropName = 'A275' + lcPropName
CASE lcPropName == 'FontBold'
lcPropName = 'A280' + lcPropName
CASE lcPropName == 'FontCondense'
lcPropName = 'A285' + lcPropName
CASE lcPropName == 'FontExtend'
lcPropName = 'A290' + lcPropName
CASE lcPropName == 'FontItalic'
lcPropName = 'A295' + lcPropName
CASE lcPropName == 'FontName'
lcPropName = 'A300' + lcPropName
CASE lcPropName == 'FontOutline'
lcPropName = 'A305' + lcPropName
CASE lcPropName == 'FontShadow'
lcPropName = 'A310' + lcPropName
CASE lcPropName == 'FontSize'
lcPropName = 'A315' + lcPropName
CASE lcPropName == 'FontStrikethru'
lcPropName = 'A320' + lcPropName
CASE lcPropName == 'FontUnderline'
lcPropName = 'A325' + lcPropName
CASE lcPropName == 'HalfHeightCaption'
lcPropName = 'A330' + lcPropName
CASE lcPropName == 'Margin'
lcPropName = 'A335' + lcPropName
CASE lcPropName == 'MaxButton'
lcPropName = 'A340' + lcPropName
CASE lcPropName == 'MinButton'
lcPropName = 'A345' + lcPropName
CASE lcPropName == 'Movable'
lcPropName = 'A350' + lcPropName
CASE lcPropName == 'MaxHeight'
lcPropName = 'A355' + lcPropName
CASE lcPropName == 'MaxWidth'
lcPropName = 'A360' + lcPropName
CASE lcPropName == 'MinHeight'
lcPropName = 'A365' + lcPropName
CASE lcPropName == 'MinWidth'
lcPropName = 'A370' + lcPropName
CASE lcPropName == 'MaxTop'
lcPropName = 'A375' + lcPropName
CASE lcPropName == 'MaxLeft'
lcPropName = 'A380' + lcPropName
CASE lcPropName == 'MDIForm'
lcPropName = 'A385' + lcPropName
CASE lcPropName == 'MousePointer'
lcPropName = 'A390' + lcPropName
CASE lcPropName == 'MouseIcon'
lcPropName = 'A395' + lcPropName
CASE lcPropName == 'Visible'
lcPropName = 'A400' + lcPropName
CASE lcPropName == 'ClipControls'
lcPropName = 'A405' + lcPropName
CASE lcPropName == 'DrawMode'
lcPropName = 'A410' + lcPropName
CASE lcPropName == 'DrawStyle'
lcPropName = 'A415' + lcPropName
CASE lcPropName == 'DrawWidth'
lcPropName = 'A420' + lcPropName
CASE lcPropName == 'FillStyle'
lcPropName = 'A425' + lcPropName
CASE lcPropName == 'Enabled'
lcPropName = 'A430' + lcPropName
CASE lcPropName == 'Icon'
lcPropName = 'A435' + lcPropName
CASE lcPropName == 'KeyPreview'
lcPropName = 'A440' + lcPropName
CASE lcPropName == 'TabIndex'
lcPropName = 'A445' + lcPropName
CASE lcPropName == 'TabStop'
lcPropName = 'A450' + lcPropName
CASE lcPropName == 'TitleBar'
lcPropName = 'A455' + lcPropName
CASE lcPropName == 'WindowType'
lcPropName = 'A460' + lcPropName
CASE lcPropName == 'WindowState'
lcPropName = 'A465' + lcPropName
CASE lcPropName == 'LockScreen'
lcPropName = 'A470' + lcPropName
CASE lcPropName == 'AlwaysOnTop'
lcPropName = 'A475' + lcPropName
CASE lcPropName == 'AlwaysOnBottom'
lcPropName = 'A480' + lcPropName
CASE lcPropName == 'SizeBox'
lcPropName = 'A485' + lcPropName
CASE lcPropName == 'SpecialEffect'
lcPropName = 'A490' + lcPropName
CASE lcPropName == 'ZoomBox'
lcPropName = 'A495' + lcPropName
CASE lcPropName == 'ZOrderSet'
lcPropName = 'A500' + lcPropName
CASE lcPropName == 'HelpContextID'
lcPropName = 'A505' + lcPropName
CASE lcPropName == 'WhatsThisHelpID'
lcPropName = 'A510' + lcPropName
CASE lcPropName == 'WhatsThisHelp'
lcPropName = 'A515' + lcPropName
CASE lcPropName == 'WhatsThisButton'
lcPropName = 'A520' + lcPropName
CASE lcPropName == 'RightToLeft'
lcPropName = 'A525' + lcPropName
CASE lcPropName == 'DefOleLCID'
lcPropName = 'A530' + lcPropName
CASE lcPropName == 'MacDesktop'
lcPropName = 'A535' + lcPropName
CASE lcPropName == 'ColorSource'
lcPropName = 'A540' + lcPropName
CASE lcPropName == 'ForeColor'
lcPropName = 'A545' + lcPropName
CASE lcPropName == 'DisableForeColor'
lcPropName = 'A550' + lcPropName
CASE lcPropName == 'BackColor'
lcPropName = 'A555' + lcPropName
CASE lcPropName == 'FillColor'
lcPropName = 'A560' + lcPropName
CASE lcPropName == 'HScrollSmallChange'
lcPropName = 'A565' + lcPropName
CASE lcPropName == 'VScrollSmallChange'
lcPropName = 'A570' + lcPropName
CASE lcPropName == 'ContinuousScroll'
lcPropName = 'A575' + lcPropName
CASE lcPropName == 'Themes'
lcPropName = 'A580' + lcPropName
CASE lcPropName == 'BindControls'
lcPropName = 'A585' + lcPropName
CASE lcPropName == 'AllowOutput'
lcPropName = 'A590' + lcPropName
CASE lcPropName == 'Dockable'
lcPropName = 'A595' + lcPropName
CASE lcPropName == '_memberdata'
lcPropName = 'A995' + lcPropName
CASE lcPropName == 'Name' && System "Name" property
lcPropName = 'A999' + lcPropName
OTHERWISE && User Property
lcPropName = 'A998' + lcPropName
ENDCASE
RETURN lcPropName
ENDPROC
*******************************************************************************************************************
PROCEDURE sortPropsAndValues
* KNOWLEDGE BASE:
* 02/12/2013 FDBOZZO Fidel Charny me pasó un ejemplo donde se pierden propiedades físicamente
* si se ordenan alfabéticamente en un ADD OBJECT. Pierde "picture" y otras más.
* Pareciera que la última debe ser "Name".
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taPropsAndValues (!@ IN ) El array con las propiedades y valores del objeto o clase
* tnPropsAndValues_Count (!v IN ) Cantidad de propiedades
* tnSortType (!v IN ) Tipo de sort:
* 0=Solo separar propiedades de clase y de objetos (.)
* 1=Sort completo de propiedades (para la versión TEXTO)
* 2=Sort completo de propiedades con "Name" al final (para la versión BIN)
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS taPropsAndValues, tnPropsAndValues_Count, tnSortType
EXTERNAL ARRAY taPropsAndValues
TRY
LOCAL I, X, lnArrayCols, laPropsAndValues(1,2), lcPropName, lcSortedMemo, lcMethods
lnArrayCols = ALEN( taPropsAndValues, 2 )
DIMENSION laPropsAndValues( tnPropsAndValues_Count, lnArrayCols )
ACOPY( taPropsAndValues, laPropsAndValues )
WITH THIS AS c_conversor_base OF 'FOXBIN2PRG.PRG'
IF m.tnSortType >= 1
* CON SORT:
* - A las que no tienen '.' les pongo 'A' por delante, y al resto 'B' por delante para que queden al final
FOR I = 1 TO m.tnPropsAndValues_Count
IF '.' $ laPropsAndValues(I,1)
IF m.tnSortType = 2
laPropsAndValues(I,1) = 'B' + JUSTSTEM(laPropsAndValues(I,1)) + '.' ;
+ .sortPropsAndValues_SetAndGetSCXPropNames( 'SETNAME', JUSTEXT(laPropsAndValues(I,1)) )
ELSE
laPropsAndValues(I,1) = 'B' + laPropsAndValues(I,1)
ENDIF
ELSE
IF m.tnSortType = 2
laPropsAndValues(I,1) = .sortPropsAndValues_SetAndGetSCXPropNames( 'SETNAME', laPropsAndValues(I,1) )
ELSE
laPropsAndValues(I,1) = 'A' + laPropsAndValues(I,1)
ENDIF
ENDIF
ENDFOR
IF .l_PropSort_Enabled
ASORT( laPropsAndValues, 1, -1, 0, 1)
ENDIF
FOR I = 1 TO m.tnPropsAndValues_Count
*-- Quitar caracteres agregados antes del SORT
IF '.' $ laPropsAndValues(I,1)
IF m.tnSortType = 2
taPropsAndValues(I,1) = JUSTSTEM( SUBSTR( laPropsAndValues(I,1), 2 ) ) + '.' ;
+ .sortPropsAndValues_SetAndGetSCXPropNames( 'GETNAME', JUSTEXT(laPropsAndValues(I,1)) )
ELSE
taPropsAndValues(I,1) = SUBSTR( laPropsAndValues(I,1), 2 )
ENDIF
ELSE
IF m.tnSortType = 2
taPropsAndValues(I,1) = .sortPropsAndValues_SetAndGetSCXPropNames( 'GETNAME', laPropsAndValues(I,1) )
ELSE
taPropsAndValues(I,1) = SUBSTR( laPropsAndValues(I,1), 2 )
ENDIF
ENDIF
taPropsAndValues(I,2) = laPropsAndValues(I,2)
IF lnArrayCols >= 3
taPropsAndValues(I,3) = laPropsAndValues(I,3)
ENDIF
ENDFOR
ELSE && m.tnSortType = 0
*-- SIN SORT: Creo 2 arrays, el bueno y el temporal, y al terminar agrego el temporal al bueno.
*-- Debo separar las props.normales de las de los objetos (ocurre cuando es un ADD OBJECT)
X = 0
*-- PRIMERO las que no tienen punto
FOR I = 1 TO m.tnPropsAndValues_Count
IF EMPTY( laPropsAndValues(I,1) )
LOOP
ENDIF
IF NOT '.' $ laPropsAndValues(I,1)
X = X + 1
taPropsAndValues(X,1) = laPropsAndValues(I,1)
taPropsAndValues(X,2) = laPropsAndValues(I,2)
IF lnArrayCols >= 3
taPropsAndValues(X,3) = laPropsAndValues(I,3)
ENDIF
ENDIF
ENDFOR
*-- LUEGO las demás props.
FOR I = 1 TO m.tnPropsAndValues_Count
IF EMPTY( laPropsAndValues(I,1) )
LOOP
ENDIF
IF '.' $ laPropsAndValues(I,1)
X = X + 1
taPropsAndValues(X,1) = laPropsAndValues(I,1)
taPropsAndValues(X,2) = laPropsAndValues(I,2)
IF lnArrayCols >= 3
taPropsAndValues(X,3) = laPropsAndValues(I,3)
ENDIF
ENDIF
ENDFOR
ENDIF
ENDWITH && THIS AS C_CONVERSOR_BASE OF 'FOXBIN2PRG.PRG'
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE writeLog
LPARAMETERS tcText
TRY
THIS.c_TextLog = THIS.c_TextLog + TTOC(DATETIME(),3) + ' ' + EVL(tcText,'') + CR_LF
CATCH
ENDTRY
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_prg_a_bin AS c_conversor_base
#IF .F.
LOCAL THIS AS c_conversor_prg_a_bin OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="analizarbloque_add_object" display="analizarBloque_ADD_OBJECT"/>] ;
+ [<memberdata name="analizarbloque_defined_pam" display="analizarBloque_DEFINED_PAM"/>] ;
+ [<memberdata name="analizarbloque_define_class" display="analizarBloque_DEFINE_CLASS"/>] ;
+ [<memberdata name="analizarbloque_enddefine" display="analizarBloque_ENDDEFINE"/>] ;
+ [<memberdata name="analizarbloque_foxbin2prg" display="analizarBloque_FoxBin2Prg"/>] ;
+ [<memberdata name="analizarbloque_hidden" display="analizarBloque_HIDDEN"/>] ;
+ [<memberdata name="analizarbloque_include" display="analizarBloque_INCLUDE"/>] ;
+ [<memberdata name="analizarbloque_classmetadata" display="analizarBloque_CLASSMETADATA"/>] ;
+ [<memberdata name="analizarbloque_objectmetadata" display="analizarBloque_OBJECTMETADATA"/>] ;
+ [<memberdata name="analizarbloque_ole_def" display="analizarBloque_OLE_DEF"/>] ;
+ [<memberdata name="analizarbloque_procedure" display="analizarBloque_PROCEDURE"/>] ;
+ [<memberdata name="analizarbloque_protected" display="analizarBloque_PROTECTED"/>] ;
+ [<memberdata name="analizarlineasdeprocedure" display="analizarLineasDeProcedure"/>] ;
+ [<memberdata name="classmethods2memo" display="classMethods2Memo"/>] ;
+ [<memberdata name="classprops2memo" display="classProps2Memo"/>] ;
+ [<memberdata name="createclasslib" display="createClasslib"/>] ;
+ [<memberdata name="createclasslib_recordheader" display="createClasslib_RecordHeader"/>] ;
+ [<memberdata name="createform" display="createForm"/>] ;
+ [<memberdata name="createform_recordheader" display="createForm_RecordHeader"/>] ;
+ [<memberdata name="createproject" display="createProject"/>] ;
+ [<memberdata name="createproject_recordheader" display="createProject_RecordHeader"/>] ;
+ [<memberdata name="createreport" display="createReport"/>] ;
+ [<memberdata name="createmenu" display="createMenu"/>] ;
+ [<memberdata name="defined_pam2memo" display="defined_PAM2Memo"/>] ;
+ [<memberdata name="eltextoevaluadoeseltokenindicado" display="elTextoEvaluadoEsElTokenIndicado"/>] ;
+ [<memberdata name="emptyrecord" display="emptyRecord"/>] ;
+ [<memberdata name="escribirarchivobin" display="escribirArchivoBin"/>] ;
+ [<memberdata name="evaluate_pam" display="Evaluate_PAM"/>] ;
+ [<memberdata name="evaluardefiniciondeprocedure" display="evaluarDefinicionDeProcedure"/>] ;
+ [<memberdata name="getclassmethodcomment" display="getClassMethodComment"/>] ;
+ [<memberdata name="getclasspropertycomment" display="getClassPropertyComment"/>] ;
+ [<memberdata name="get_listnameswithvaluesfrom_inline_metadatatag" display="get_ListNamesWithValuesFrom_InLine_MetadataTag"/>] ;
+ [<memberdata name="get_valuebyname_fromlistnameswithvalues" display="get_ValueByName_FromListNamesWithValues"/>] ;
+ [<memberdata name="hiddenandprotected_pam" display="hiddenAndProtected_PAM"/>] ;
+ [<memberdata name="identificarbloquesdeexclusion" display="identificarBloquesDeExclusion"/>] ;
+ [<memberdata name="insert_allobjects" display="insert_AllObjects"/>] ;
+ [<memberdata name="insert_object" display="insert_Object"/>] ;
+ [<memberdata name="objectmethods2memo" display="objectMethods2Memo"/>] ;
+ [<memberdata name="set_line" display="set_Line"/>] ;
+ [<memberdata name="strip_dimensions" display="strip_Dimensions"/>] ;
+ [</VFPData>]
*******************************************************************************************************************
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase correspondiente con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
ENDPROC
*******************************************************************************************************************
FUNCTION get_ValueByName_FromListNamesWithValues
*-- ASIGNO EL VALOR DEL ARRAY DE DATOS Y VALORES PARA LA PROPIEDAD INDICADA
LPARAMETERS tcPropName, tcValueType, taPropsAndValues
LOCAL lnPos, luPropValue
lnPos = ASCAN( taPropsAndValues, tcPropName, 1, 0, 1, 1+2+4+8)
IF lnPos = 0 OR EMPTY( taPropsAndValues( lnPos, 2 ) )
*-- Valores no encontrados o vacíos
luPropValue = ''
ELSE
luPropValue = taPropsAndValues( lnPos, 2 )
ENDIF
DO CASE
CASE tcValueType = 'I'
luPropValue = CAST( luPropValue AS INTEGER )
CASE tcValueType = 'N'
luPropValue = CAST( luPropValue AS DOUBLE )
CASE tcValueType = 'T'
luPropValue = CAST( luPropValue AS DATETIME )
CASE tcValueType = 'D'
luPropValue = CAST( luPropValue AS DATE )
CASE tcValueType = 'E'
luPropValue = EVALUATE( luPropValue )
OTHERWISE && Asumo 'C' para lo demás
luPropValue = luPropValue
ENDCASE
RETURN luPropValue
ENDFUNC
*******************************************************************************************************************
PROCEDURE get_ListNamesWithValuesFrom_InLine_MetadataTag
*-- OBTENGO EL ARRAY DE DATOS Y VALORES DE LA LINEA DE METADATOS INDICADA
*-- NOTA: Los valores NO PUEDEN contener comillas dobles en su valor, ya que generaría un error al parsearlos.
*-- Ejemplo:
*< FileMetadata: Type="V" Cpid="1252" Timestamp="1131901580" ID="1129207528" ObjRev="544" />
*< OLE: Nombre="frm_form.Pageframe1.Page1.Cnt_controles_h.Olecontrol1" Parent="frm_form.Pageframe1.Page1.Cnt_controles_h" ObjName="Olecontrol1" Checksum="1685567300" Value="0M8R4KGxGuEAAAAAAAAAAAAAAAAAAAAAPg...ADAP7AAAA==" />
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLineWithMetadata (@! IN ) Línea con metadatos y un tag de metadatos
* taPropsAndValues (@! OUT) Array a devolver con las propiedades y valores encontrados
* tnPropsAndValues_Count (@! OUT) Cantidad de propiedades encontradas
* tcLeftTag (v! IN ) TAG de inicio de los metadatos
* tcRightTag (v! IN ) TAG de fin de los metadatos
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS tcLineWithMetadata, taPropsAndValues, tnPropsAndValues_Count, tcLeftTag, tcRightTag
EXTERNAL ARRAY taPropsAndValues
LOCAL lcMetadatos, I, lnEqualSigns, lcNextVar, lcStr, lcVirtualMeta, lnPos1, lnPos2, lnLastPos, lnCantComillas
STORE '' TO lcVirtualMeta
STORE 0 TO lnPos1, lnPos2, lnLastPos, tnPropsAndValues_Count, I
lcMetadatos = ALLTRIM( STREXTRACT( tcLineWithMetadata, tcLeftTag, tcRightTag, 1, 1) )
lnCantComillas = OCCURS( '"', lcMetadatos )
IF lnCantComillas % 2 <> 0 && Valido que las comillas "" sean pares
*ERROR "Error de datos: No se puede parsear porque las comillas no son pares en la línea [" + lcMetadatos + "]"
ERROR (TEXTMERGE(C_DATA_ERROR_CANT_PARSE_UNPAIRING_DOUBLE_QUOTES_LOC))
ENDIF
lnLastPos = 1
DIMENSION taPropsAndValues( lnCantComillas / 2, 2 )
*-------------------------------------------------------------------------------------
* IMPORTANTE!!
* ------------
* SI SE SEPARAN LAS IGUALDADES CON ESPACIOS, ÉSTAS DEJAN DE RECONOCERSE!! (prop = "valor" en vez de prop="valor")
* TENER EN CUENTA AL GENERAR EL TEXTO O AL MODIFICARLO MANUALMENTE AL MERGEAR
*-------------------------------------------------------------------------------------
FOR I = 1 TO lnCantComillas STEP 2
tnPropsAndValues_Count = tnPropsAndValues_Count + 1
* Type="V" Cpid="1252"
* ^ ^ => Posiciones del par de comillas dobles
lnPos1 = AT( '"', lcMetadatos, I )
lnPos2 = AT( '"', lcMetadatos, I + 1 )
* Type="V" Cpid="1252"
* ^ ^ ^ => LastPos, lnPos1 y lnPos2
taPropsAndValues(tnPropsAndValues_Count,1) = ALLTRIM( GETWORDNUM( SUBSTR( lcMetadatos, lnLastPos, lnPos1 - lnLastPos ), 1, '=' ) )
taPropsAndValues(tnPropsAndValues_Count,2) = SUBSTR( lcMetadatos, lnPos1 + 1, lnPos2 - lnPos1 - 1 )
lnLastPos = lnPos2 + 1
ENDFOR
RETURN
ENDPROC
PROCEDURE elTextoEvaluadoEsElTokenIndicado
LPARAMETERS tcLine, ta_ID_Bloques, tnLen_IDFinBQ, X, tnIniFin
LOCAL llEncontrado, lcWord
TRY
IF tnIniFin = 1
*-- TOKENS DE INICIO
IF UPPER( LEFT( tcLine, LEN(ta_ID_Bloques(X,1)) ) ) == ta_ID_Bloques(X,1)
*-- Evaluar casos especiales
lcWord = UPPER( ALLTRIM(GETWORDNUM(tcLine,1) ) )
IF ta_ID_Bloques(X,1) == 'TEXT' AND NOT lcWord == 'TEXT'
EXIT
ENDIF
llEncontrado = .T.
ENDIF
ELSE
*-- TOKENS DE FIN
IF LEFT( UPPER( tcLine ), tnLen_IDFinBQ ) == ta_ID_Bloques(X,2) && Fin de bloque encontrado (#ENDI, ENDTEXT, etc)
*-- Evaluar casos especiales
lcWord = UPPER( ALLTRIM(GETWORDNUM(tcLine,1) ) )
IF ta_ID_Bloques(X,2) == 'ENDT' AND NOT lcWord == LEFT( 'ENDTEXT', LEN(lcWord) )
EXIT
ENDIF
llEncontrado = .T.
ENDIF
ENDIF
ENDTRY
RETURN llEncontrado
ENDPROC
PROCEDURE identificarBloquesDeExclusion
LPARAMETERS taCodeLines, tnCodeLines, ta_ID_Bloques, taBloquesExclusion, tnBloquesExclusion
* LOS BLOQUES DE EXCLUSIÓN SON AQUELLOS QUE TIENEN TEXT/ENDTEXT OF #IF .F./#ENDIF Y SE USAN PARA NO BUSCAR
* INSTRUCCIONES COMO "DEFINE CLASS" O "PROCEDURE" EN LOS MISMOS.
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taCodeLines (!@ IN ) El array con las líneas del código de texto donde buscar
* tnCodeLines (?@ IN ) Cantidad de líneas de código
* ta_ID_Bloques (?@ IN ) Array de pares de identificadores (2 cols). Ej: '#IF .F.','#ENDI' ; 'TEXT','ENDTEXT' ; etc
* taBloquesExclusion (?@ OUT) Array con las posiciones de los bloques (2 cols). Ej: 3,14 ; 23,58 ; etc
* tnBloquesExclusion (?@ OUT) Cantidad de bloques de exclusión
*--------------------------------------------------------------------------------------------------------------
EXTERNAL ARRAY ta_ID_Bloques, taBloquesExclusion
TRY
LOCAL lnBloques, I, X, lnPrimerID, lnLen_IDFinBQ, lnID_Bloques_Count, lcWord, lnAnidamientos
DIMENSION taBloquesExclusion(1,2)
STORE 0 TO tnBloquesExclusion, lnPrimerID, I, X, lnLen_IDFinBQ
IF tnCodeLines > 1
IF EMPTY(ta_ID_Bloques)
DIMENSION ta_ID_Bloques(2,2)
ta_ID_Bloques(1,1) = '#IF'
ta_ID_Bloques(1,2) = '#ENDI'
ta_ID_Bloques(2,1) = 'TEXT'
ta_ID_Bloques(2,2) = 'ENDT'
lnID_Bloques_Count = ALEN( ta_ID_Bloques, 1 )
ENDIF
*-- Búsqueda del ID de inicio de bloque
WITH THIS AS c_conversor_prg_a_bin OF 'FOXBIN2PRG.PRG'
FOR I = 1 TO tnCodeLines
* Reduzco los espacios. Ej: '#IF .F. && cmt' ==> '#IF .F.&&cmt'
lcLine = LTRIM( STRTRAN( STRTRAN( CHRTRAN( taCodeLines(I), CHR(9), ' ' ), ' ', ' ' ), ' ', ' ' ) )
IF .lineIsOnlyCommentAndNoMetadata( @lcLine )
LOOP
ENDIF
lnPrimerID = 0
FOR X = 1 TO lnID_Bloques_Count
lnLen_IDFinBQ = LEN( ta_ID_Bloques(X,2) )
IF .elTextoEvaluadoEsElTokenIndicado( @lcLine, @ta_ID_Bloques, lnLen_IDFinBQ, X, 1 )
lnPrimerID = X
lnAnidamientos = 1
EXIT
ENDIF
ENDFOR
IF lnPrimerID > 0 && Se ha identificado un ID de bloque excluyente
tnBloquesExclusion = tnBloquesExclusion + 1
lnLen_IDFinBQ = LEN( ta_ID_Bloques(lnPrimerID,2) )
DIMENSION taBloquesExclusion(tnBloquesExclusion,2)
taBloquesExclusion(tnBloquesExclusion,1) = I
* Búsqueda del ID de fin de bloque
FOR I = I + 1 TO tnCodeLines
* Reduzco los espacios. Ej: '#IF .F. && cmt' ==> '#IF .F.&&cmt'
lcLine = LTRIM( STRTRAN( STRTRAN( CHRTRAN( taCodeLines(I), CHR(9), ' ' ), ' ', ' ' ), ' ', ' ' ) )
IF .lineIsOnlyCommentAndNoMetadata( @lcLine )
LOOP
ENDIF
DO CASE
CASE .elTextoEvaluadoEsElTokenIndicado( @lcLine, @ta_ID_Bloques, lnLen_IDFinBQ, X, 1 )
lnAnidamientos = lnAnidamientos + 1
CASE .elTextoEvaluadoEsElTokenIndicado( @lcLine, @ta_ID_Bloques, lnLen_IDFinBQ, X, 2 )
lnAnidamientos = lnAnidamientos - 1
IF lnAnidamientos = 0
taBloquesExclusion(tnBloquesExclusion,2) = I
EXIT
ENDIF
ENDCASE
ENDFOR
*-- Validación
IF EMPTY(taBloquesExclusion(tnBloquesExclusion,2))
*ERROR 'No se ha encontrado el marcador de fin [' + ta_ID_Bloques(lnPrimerID,2) ;
+ '] que cierra al marcador de inicio [' + ta_ID_Bloques(lnPrimerID,1) ;
+ '] de la línea ' + TRANSFORM(taBloquesExclusion(tnBloquesExclusion,1))
ERROR (TEXTMERGE(C_END_MARKER_NOT_FOUND_LOC))
ENDIF
ENDIF
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_FoxBin2Prg
*------------------------------------------------------
*-- Analiza el bloque <FOXBIN2PRG>
*------------------------------------------------------
LPARAMETERS toModulo, tcLine, taCodeLines, I, tnCodeLines
LOCAL llBloqueEncontrado, laPropsAndValues(1,2), lnPropsAndValues_Count
IF LEFT( tcLine + ' ', LEN(C_FB2PRG_META_I) + 1 ) == C_FB2PRG_META_I + ' '
llBloqueEncontrado = .T.
*-- Metadatos del módulo
THIS.get_ListNamesWithValuesFrom_InLine_MetadataTag( @tcLine, @laPropsAndValues, @lnPropsAndValues_Count, C_FB2PRG_META_I, C_FB2PRG_META_F )
toModulo._Version = THIS.get_ValueByName_FromListNamesWithValues( 'Version', 'N', @laPropsAndValues )
toModulo._SourceFile = THIS.get_ValueByName_FromListNamesWithValues( 'SourceFile', 'C', @laPropsAndValues )
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE createProject
CREATE TABLE (THIS.c_OutputFile) ;
( NAME M ;
, TYPE C(1) ;
, ID N(10) ;
, TIMESTAMP N(10) ;
, OUTFILE M ;
, HOMEDIR M ;
, EXCLUDE L ;
, MAINPROG L ;
, SAVECODE L ;
, DEBUG L ;
, ENCRYPT L ;
, NOLOGO L ;
, CMNTSTYLE N(1) ;
, OBJREV N(5) ;
, DEVINFO M ;
, SYMBOLS M ;
, OBJECT M ;
, CKVAL N(6) ;
, CPID N(5) ;
, OSTYPE C(4) ;
, OSCREATOR C(4) ;
, COMMENTS M ;
, RESERVED1 M ;
, RESERVED2 M ;
, SCCDATA M ;
, LOCAL L ;
, KEY C(32) ;
, USER M )
USE (THIS.c_OutputFile) ALIAS TABLABIN AGAIN SHARED
ENDPROC
*******************************************************************************************************************
PROCEDURE createProject_RecordHeader
LPARAMETERS toProject
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
INSERT INTO TABLABIN ;
( NAME ;
, TYPE ;
, TIMESTAMP ;
, OUTFILE ;
, HOMEDIR ;
, SAVECODE ;
, DEBUG ;
, ENCRYPT ;
, NOLOGO ;
, CMNTSTYLE ;
, OBJREV ;
, DEVINFO ;
, OBJECT ;
, RESERVED1 ;
, RESERVED2 ;
, LOCAL ;
, KEY ) ;
VALUES ;
( UPPER(EVL(THIS.c_OriginalFileName,THIS.c_OutputFile)) ;
, 'H' ;
, 0 ;
, '<Source>' + CHR(0) ;
, toProject._HomeDir + CHR(0) ;
, toProject._SaveCode ;
, toProject._Debug ;
, toProject._Encrypted ;
, toProject._NoLogo ;
, toProject._CmntStyle ;
, 260 ;
, toProject.getRowDeviceInfo() ;
, toProject._HomeDir + CHR(0) ;
, UPPER(THIS.c_OutputFile) ;
, toProject._ServerHead.getRowServerInfo() ;
, .T. ;
, UPPER( JUSTSTEM( THIS.c_OutputFile) ) )
ENDPROC
*******************************************************************************************************************
PROCEDURE createClasslib
CREATE TABLE (THIS.c_OutputFile) ;
( PLATFORM C(8) ;
, UNIQUEID C(10) ;
, TIMESTAMP N(10) ;
, CLASS M ;
, CLASSLOC M ;
, BASECLASS M ;
, OBJNAME M ;
, PARENT M ;
, PROPERTIES M ;
, PROTECTED M ;
, METHODS M ;
, OBJCODE M NOCPTRANS ;
, OLE M ;
, OLE2 M ;
, RESERVED1 M ;
, RESERVED2 M ;
, RESERVED3 M ;
, RESERVED4 M ;
, RESERVED5 M ;
, RESERVED6 M ;
, RESERVED7 M ;
, RESERVED8 M ;
, USER M )
USE (THIS.c_OutputFile) ALIAS TABLABIN AGAIN SHARED
ENDPROC
*******************************************************************************************************************
PROCEDURE createClasslib_RecordHeader
INSERT INTO TABLABIN ;
( PLATFORM ;
, UNIQUEID ;
, RESERVED1 ) ;
VALUES ;
( 'COMMENT' ;
, 'Class' ;
, 'VERSION = 3.00' )
ENDPROC
*******************************************************************************************************************
PROCEDURE createForm
CREATE TABLE (THIS.c_OutputFile) ;
( PLATFORM C(8) ;
, UNIQUEID C(10) ;
, TIMESTAMP N(10) ;
, CLASS M ;
, CLASSLOC M ;
, BASECLASS M ;
, OBJNAME M ;
, PARENT M ;
, PROPERTIES M ;
, PROTECTED M ;
, METHODS M ;
, OBJCODE M NOCPTRANS ;
, OLE M ;
, OLE2 M ;
, RESERVED1 M ;
, RESERVED2 M ;
, RESERVED3 M ;
, RESERVED4 M ;
, RESERVED5 M ;
, RESERVED6 M ;
, RESERVED7 M ;
, RESERVED8 M ;
, USER M )
USE (THIS.c_OutputFile) ALIAS TABLABIN AGAIN SHARED
ENDPROC
*******************************************************************************************************************
PROCEDURE createForm_RecordHeader
INSERT INTO TABLABIN ;
( PLATFORM ;
, UNIQUEID ;
, RESERVED1 ) ;
VALUES ;
( 'COMMENT' ;
, 'Screen' ;
, 'VERSION = 3.00' )
ENDPROC
*******************************************************************************************************************
PROCEDURE createReport
CREATE TABLE (THIS.c_OutputFile) ;
( 'PLATFORM' C(8) ;
, 'UNIQUEID' C(10) ;
, 'TIMESTAMP' N(10) ;
, 'OBJTYPE' N(2) ;
, 'OBJCODE' N(3) ;
, 'NAME' M ;
, 'EXPR' M ;
, 'VPOS' N(9,3) ;
, 'HPOS' N(9,3) ;
, 'HEIGHT' N(9,3) ;
, 'WIDTH' N(9,3) ;
, 'STYLE' M ;
, 'PICTURE' M ;
, 'ORDER' M NOCPTRANS ;
, 'UNIQUE' L ;
, 'COMMENT' M ;
, 'ENVIRON' L ;
, 'BOXCHAR' C(1) ;
, 'FILLCHAR' C(1) ;
, 'TAG' M ;
, 'TAG2' M NOCPTRANS ;
, 'PENRED' N(5) ;
, 'PENGREEN' N(5) ;
, 'PENBLUE' N(5) ;
, 'FILLRED' N(5) ;
, 'FILLGREEN' N(5) ;
, 'FILLBLUE' N(5) ;
, 'PENSIZE' N(5) ;
, 'PENPAT' N(5) ;
, 'FILLPAT' N(5) ;
, 'FONTFACE' M ;
, 'FONTSTYLE' N(3) ;
, 'FONTSIZE' N(3) ;
, 'MODE' N(3) ;
, 'RULER' N(1) ;
, 'RULERLINES' N(1) ;
, 'GRID' L ;
, 'GRIDV' N(2) ;
, 'GRIDH' N(2) ;
, 'FLOAT' L ;
, 'STRETCH' L ;
, 'STRETCHTOP' L ;
, 'TOP' L ;
, 'BOTTOM' L ;
, 'SUPTYPE' N(1) ;
, 'SUPREST' N(1) ;
, 'NOREPEAT' L ;
, 'RESETRPT' N(2) ;
, 'PAGEBREAK' L ;
, 'COLBREAK' L ;
, 'RESETPAGE' L ;
, 'GENERAL' N(3) ;
, 'SPACING' N(3) ;
, 'DOUBLE' L ;
, 'SWAPHEADER' L ;
, 'SWAPFOOTER' L ;
, 'EJECTBEFOR' L ;
, 'EJECTAFTER' L ;
, 'PLAIN' L ;
, 'SUMMARY' L ;
, 'ADDALIAS' L ;
, 'OFFSET' N(3) ;
, 'TOPMARGIN' N(3) ;
, 'BOTMARGIN' N(3) ;
, 'TOTALTYPE' N(2) ;
, 'RESETTOTAL' N(2) ;
, 'RESOID' N(3) ;
, 'CURPOS' L ;
, 'SUPALWAYS' L ;
, 'SUPOVFLOW' L ;
, 'SUPRPCOL' N(1) ;
, 'SUPGROUP' N(2) ;
, 'SUPVALCHNG' L ;
, 'SUPEXPR' M ;
, 'USER' M )
USE (THIS.c_OutputFile) ALIAS TABLABIN AGAIN SHARED
ENDPROC
*******************************************************************************************************************
PROCEDURE createMenu
CREATE TABLE (THIS.c_OutputFile) ;
( 'OBJTYPE' Numeric(2) ;
, 'OBJCODE' Numeric(2) ;
, 'NAME' MEMO ;
, 'PROMPT' MEMO ;
, 'COMMAND' MEMO ;
, 'MESSAGE' MEMO ;
, 'PROCTYPE' Numeric(1) ;
, 'PROCEDURE' MEMO ;
, 'SETUPTYPE' Numeric(1) ;
, 'SETUP' MEMO ;
, 'CLEANTYPE' Numeric(1) ;
, 'CLEANUP' MEMO ;
, 'MARK' CHARACTER(1) ;
, 'KEYNAME' MEMO ;
, 'KEYLABEL' MEMO ;
, 'SKIPFOR' MEMO ;
, 'NAMECHANGE' Logical ;
, 'NUMITEMS' Numeric(2) ;
, 'LEVELNAME' CHARACTER(10) ;
, 'ITEMNUM' CHARACTER(3) ;
, 'COMMENT' MEMORY(4) ;
, 'LOCATION' Numeric(2) ;
, 'SCHEME' Numeric(2) ;
, 'SYSRES' Numeric(1) ;
, 'RESNAME' MEMORY(4) )
USE (THIS.c_OutputFile) ALIAS TABLABIN AGAIN SHARED
ENDPROC
*******************************************************************************************************************
PROCEDURE emptyRecord
LOCAL loReg
SCATTER MEMO BLANK NAME loReg
RETURN loReg
ENDPROC
*******************************************************************************************************************
PROCEDURE escribirArchivoBin
LPARAMETERS toModulo
ENDPROC
*******************************************************************************************************************
PROCEDURE classProps2Memo
*-- ARMA EL MEMO DE PROPERTIES CON LAS PROPIEDADES Y SUS VALORES
LPARAMETERS toClase
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
*-- ESTRUCTURA A ANALIZAR: Propiedades normales, con CR codificado (<fb2p_value>) y con CR+LF (<fb2p_value>)
* HEIGHT = 2.73
* NAME = "c1"
* prop1 = .F. && Mi prop 1
* prop_especial_cr = <fb2p_value>Este es el valor 1&#10;Este el 2&#10;Y Este bajo Shift_Enter el 3</fb2p_value>
* prop_especial_crlf = <fb2p_value>
* Este es el valor 1
* Este el 2
* Y Este bajo Shift_Enter el 3
* </fb2p_value>
* WIDTH = 27.40
* _MEMBERDATA = <VFPData>
* <memberdata NAME="mimetodo" DISPLAY="miMetodo"/>
* <memberdata NAME="mimetodo2" DISPLAY="miMetodo2"/>
* </VFPData> && XML Metadata for customizable properties
*-- Fin: ESTRUCTURA A ANALIZAR:
TRY
LOCAL lcDefinedPAM, lnPos, lnPos2, laProps(1,2), lcLine, lcPropName, lcValue, I, lcAsignacion, lcMemo ;
, laPropsAndValues(1,2), lnPropsAndValues_Count
lcMemo = ''
IF toClase._Prop_Count > 0
DIMENSION laPropsAndValues( toClase._Prop_Count, 3 )
ACOPY( toClase._Props, laPropsAndValues )
lnPropsAndValues_Count = toClase._Prop_Count
*-- REORDENO LAS PROPIEDADES
THIS.sortPropsAndValues( @laPropsAndValues, lnPropsAndValues_Count, 2 )
*-- ARMO EL MEMO A DEVOLVER
FOR I = 1 TO lnPropsAndValues_Count
lcMemo = lcMemo + laPropsAndValues(I,1) + ' = ' + laPropsAndValues(I,2) + CR_LF
ENDFOR
ENDIF && laProps > 0
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcMemo
ENDPROC
*******************************************************************************************************************
PROCEDURE objectProps2Memo
*-- ARMA EL MEMO DE PROPERTIES CON LAS PROPIEDADES Y SUS VALORES
LPARAMETERS toObjeto, toClase
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG' ;
, toObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL lcMemo, I, laPropsAndValues(1,2), lcPropName, lcValue
lcMemo = ''
IF toObjeto._Prop_Count > 0
DIMENSION laPropsAndValues( toObjeto._Prop_Count, 2 )
ACOPY( toObjeto._Props, laPropsAndValues )
*-- REORDENO LAS PROPIEDADES
THIS.sortPropsAndValues( @laPropsAndValues, toObjeto._Prop_Count, 2 )
*-- ARMO EL MEMO A DEVOLVER
FOR I = 1 TO toObjeto._Prop_Count
lcMemo = lcMemo + laPropsAndValues(I,1) + ' = ' + laPropsAndValues(I,2) + CR_LF
ENDFOR
ENDIF
RETURN lcMemo
ENDPROC
*******************************************************************************************************************
PROCEDURE classMethods2Memo
LPARAMETERS toClase
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL lcMemo, I, X, lcNombreObjeto ;
, loProcedure AS CL_PROCEDURE OF 'FOXBIN2PRG.PRG'
lcMemo = ''
*-- Recorrer los métodos
FOR I = 1 TO toClase._Procedure_Count
loProcedure = NULL
loProcedure = toClase._Procedures(I)
IF '.' $ loProcedure._Nombre
*-- cboNombre.InteractiveChange ==> No debe acortarse por ser método modificado de combobox heredado de la clase
*-- cntDatos.txtEdad.Valid ==> Debe acortarse si cntDatos es un objeto existente
lcNombreObjeto = LEFT( loProcedure._Nombre, AT('.', loProcedure._Nombre) - 1 )
IF THIS.buscarObjetoDelMetodoPorNombre( lcNombreObjeto, toClase ) = 0
TEXT TO lcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<C_PROCEDURE>> <<loProcedure._Nombre>>
ENDTEXT
ELSE
TEXT TO lcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<C_PROCEDURE>> <<SUBSTR( loProcedure._Nombre, AT('.', loProcedure._Nombre) + 1 )>>
ENDTEXT
ENDIF
ELSE
TEXT TO lcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<C_PROCEDURE>> <<loProcedure._Nombre>>
ENDTEXT
ENDIF
*-- Incluir las líneas del método
FOR X = 1 TO loProcedure._ProcLine_Count
TEXT TO lcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<loProcedure._ProcLines(X)>>
ENDTEXT
ENDFOR
TEXT TO lcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_ENDPROC>>
<<>>
ENDTEXT
ENDFOR
loProcedure = NULL
RELEASE loProcedure
RETURN lcMemo
ENDPROC
*******************************************************************************************************************
PROCEDURE objectMethods2Memo
LPARAMETERS toObjeto, toClase
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG' ;
, toObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL lcMemo, I, X, lcNombreObjeto ;
, loProcedure AS CL_PROCEDURE OF 'FOXBIN2PRG.PRG'
lcMemo = ''
*-- Recorrer los métodos
FOR I = 1 TO toObjeto._Procedure_Count
loProcedure = NULL
loProcedure = toObjeto._Procedures(I)
TEXT TO lcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<C_PROCEDURE>> <<loProcedure._Nombre>>
ENDTEXT
*-- Incluir las líneas del método
FOR X = 1 TO loProcedure._ProcLine_Count
TEXT TO lcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<loProcedure._ProcLines(X)>>
ENDTEXT
ENDFOR
TEXT TO lcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_ENDPROC>>
<<>>
ENDTEXT
ENDFOR
loProcedure = NULL
RELEASE loProcedure
RETURN lcMemo
ENDPROC
*******************************************************************************************************************
PROCEDURE getClassPropertyComment
*-- Devuelve el comentario (columna 2 del array toClase._Props) de la propiedad indicada,
*-- buscándola en la columna 2 por su nombre.
LPARAMETERS tcPropName AS STRING, toClase
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL I, lcComentario
lcComentario = ''
FOR I = 1 TO toClase._Prop_Count
IF RTRIM( GETWORDNUM( toClase._Props(I,1), 1, '=' ) ) == tcPropName
lcComentario = toClase._Props( I, 2 )
EXIT
ENDIF
ENDFOR
RETURN lcComentario
ENDPROC
*******************************************************************************************************************
PROCEDURE getClassMethodComment
LPARAMETERS tcMethodName AS STRING, toClase
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL I, lcComentario ;
, loProcedure AS CL_PROCEDURE OF 'FOXBIN2PRG.PRG'
lcComentario = ''
FOR I = 1 TO toClase._Procedure_Count
loProcedure = toClase._Procedures(I)
IF loProcedure._Nombre == tcMethodName
lcComentario = loProcedure._Comentario
EXIT
ENDIF
ENDFOR
RETURN lcComentario
ENDPROC
*******************************************************************************************************************
PROCEDURE getTextFrom_BIN_FileStructure
TRY
LOCAL lcStructure, lnSelect
lnSelect = SELECT()
SELECT 0
USE (THIS.c_InputFile) AGAIN SHARED ALIAS _TABLABIN
COPY STRUCTURE EXTENDED TO ( FORCEPATH( '_FRX_STRUC.DBF', ADDBS( SYS(2023) ) ) )
**** CONTINUAR SI ES NECESARIO - SIN USO POR AHORA
CATCH TO loEx
THROW
FINALLY
USE IN (SELECT("_TABLABIN"))
SELECT (lnSelect)
ENDTRY
RETURN lcStructure
ENDPROC
*******************************************************************************************************************
PROCEDURE defined_PAM2Memo
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toClase (!@ IN ) Objeto de la Clase
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS toClase
RETURN toClase._Defined_PAM
ENDPROC
*******************************************************************************************************************
PROCEDURE strip_Dimensions
LPARAMETERS tcSeparatedCommaVars
LOCAL lnPos1, lnPos2, I
FOR I = OCCURS( '[', tcSeparatedCommaVars ) TO 1 STEP -1
lnPos1 = AT( '[', tcSeparatedCommaVars, I )
lnPos2 = AT( ']', tcSeparatedCommaVars, I )
tcSeparatedCommaVars = STUFF( tcSeparatedCommaVars, lnPos1, lnPos2 - lnPos1 + 1, '' )
ENDFOR
ENDPROC
*******************************************************************************************************************
PROCEDURE hiddenAndProtected_PAM
LPARAMETERS toClase
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL lcMemo, I, lcPAM, lcComentario
lcMemo = ''
WITH THIS AS c_conversor_prg_a_bin OF 'FOXBIN2PRG.PRG'
.Evaluate_PAM( @lcMemo, toClase._ProtectedProps, 'property', 'protected' )
.Evaluate_PAM( @lcMemo, toClase._HiddenProps, 'property', 'hidden' )
.Evaluate_PAM( @lcMemo, toClase._ProtectedMethods, 'method', 'protected' )
.Evaluate_PAM( @lcMemo, toClase._HiddenMethods, 'method', 'hidden' )
ENDWITH && THIS
RETURN lcMemo
ENDPROC
*******************************************************************************************************************
PROCEDURE Evaluate_PAM
LPARAMETERS tcMemo AS STRING, tcPAM AS STRING, tcPAM_Type AS STRING, tcPAM_Visibility AS STRING
LOCAL lcPAM, I
FOR I = 1 TO OCCURS( ',', tcPAM + ',' )
lcPAM = ALLTRIM( GETWORDNUM( tcPAM, I, ',' ) )
IF NOT EMPTY(lcPAM)
IF EVL(tcPAM_Visibility, 'normal') == 'hidden'
lcPAM = lcPAM + '^'
ENDIF
TEXT TO tcMemo ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<lcPAM>>
<<>>
ENDTEXT
ENDIF
ENDFOR
ENDPROC
*******************************************************************************************************************
PROCEDURE insert_Object
LPARAMETERS toClase, toObjeto, toFoxBin2Prg
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
LOCAL toObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
#ENDIF
WITH THIS AS c_conversor_prg_a_bin OF 'FOXBIN2PRG.PRG'
IF NOT .l_Test
LOCAL lcPropsMemo, lcMethodsMemo
lcPropsMemo = .objectProps2Memo( toObjeto, toClase )
lcMethodsMemo = .objectMethods2Memo( toObjeto, toClase )
*-- Inserto el objeto
INSERT INTO TABLABIN ;
( PLATFORM ;
, UNIQUEID ;
, TIMESTAMP ;
, CLASS ;
, CLASSLOC ;
, BASECLASS ;
, OBJNAME ;
, PARENT ;
, PROPERTIES ;
, PROTECTED ;
, METHODS ;
, OLE ;
, OLE2 ;
, RESERVED1 ;
, RESERVED2 ;
, RESERVED3 ;
, RESERVED4 ;
, RESERVED5 ;
, RESERVED6 ;
, RESERVED7 ;
, RESERVED8 ;
, USER) ;
VALUES ;
( 'WINDOWS' ;
, IIF( toFoxBin2Prg.l_ClearUniqueID, '', toObjeto._UniqueID ) ;
, IIF( toFoxBin2Prg.l_NoTimestamps, 0, toObjeto._TimeStamp ) ;
, toObjeto._Class ;
, toObjeto._ClassLib ;
, toObjeto._BaseClass ;
, toObjeto._ObjName ;
, toObjeto._Parent ;
, lcPropsMemo ;
, '' ;
, lcMethodsMemo ;
, toObjeto._Ole ;
, toObjeto._Ole2 ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, toObjeto._User )
ENDIF
ENDWITH && THIS
ENDPROC
*******************************************************************************************************************
PROCEDURE insert_AllObjects
*-- Recorro primero los objetos con ZOrder definido, y luego los demás
*-- NOTA: Como consecuencia de una integración de código, puede que se hayan agregado objetos nuevos (desconocidos),
*-- pero todo lo demás tiene un ZOrder definido, que es el número de registro original * 100.
LPARAMETERS toClase, toFoxBin2Prg
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL N, X, lcObjName, loObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
WITH THIS AS c_conversor_prg_a_bin OF 'FOXBIN2PRG.PRG'
IF toClase._AddObject_Count > 0
N = 0
*-- Armo array con el orden Z de los objetos
DIMENSION laObjNames( toClase._AddObject_Count, 2 )
FOR X = 1 TO toClase._AddObject_Count
loObjeto = toClase._AddObjects( X )
laObjNames( X, 1 ) = loObjeto._Nombre
laObjNames( X, 2 ) = loObjeto._ZOrder
ENDFOR
ASORT( laObjNames, 2, -1, 0, 1 )
*-- Escribo los objetos en el orden Z
FOR X = 1 TO toClase._AddObject_Count
lcObjName = laObjNames( X, 1 )
FOR EACH loObjeto IN toClase._AddObjects FOXOBJECT
*-- Verifico que sea el objeto que corresponde
IF loObjeto._WriteOrder = 0 AND loObjeto._Nombre == lcObjName
N = N + 1
loObjeto._WriteOrder = N
.insert_Object( toClase, loObjeto, toFoxBin2Prg )
EXIT
ENDIF
ENDFOR
ENDFOR
*-- Recorro los objetos Desconocidos
FOR EACH loObjeto IN toClase._AddObjects FOXOBJECT
IF loObjeto._WriteOrder = 0
.insert_Object( toClase, loObjeto, toFoxBin2Prg )
ENDIF
ENDFOR
ENDIF && toClase._AddObject_Count > 0
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE set_Line
LPARAMETERS tcLine, taCodeLines, I
tcLine = LTRIM( taCodeLines(I), 0, ' ', CHR(9) )
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarLineasDeProcedure
LPARAMETERS toClase, toObjeto, tcLine, taCodeLines, I, tnCodeLines, tcProcedureAbierto, tc_Comentario ;
, taBloquesExclusion, tnBloquesExclusion
EXTERNAL ARRAY taCodeLines
#IF .F.
LOCAL toObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llEsProcedureDeClase, loProcedure AS CL_PROCEDURE OF 'FOXBIN2PRG.PRG'
IF '.' $ tcProcedureAbierto AND VARTYPE(toObjeto) = 'O' AND toObjeto._Procedure_Count > 0
loProcedure = toObjeto._Procedures(toObjeto._Procedure_Count)
ELSE
llEsProcedureDeClase = .T.
loProcedure = toClase._Procedures(toClase._Procedure_Count)
ENDIF
WITH THIS AS c_conversor_prg_a_bin OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
IF NOT .lineaExcluida( I, tnBloquesExclusion, @taBloquesExclusion ) ;
AND NOT .lineIsOnlyCommentAndNoMetadata( @tcLine, @tc_Comentario )
DO CASE
CASE LEFT( tcLine, 8 ) + ' ' == C_ENDPROC + ' ' && Fin del PROCEDURE
tcProcedureAbierto = ''
EXIT
CASE LEFT( tcLine + ' ', 10 ) == C_ENDDEFINE + ' ' && Fin de bloque (ENDDEFINE) encontrado
IF llEsProcedureDeClase
*ERROR 'Error de anidamiento de estructuras. Se esperaba ENDPROC y se encontró ENDDEFINE en la clase ' ;
+ toClase._Nombre + ' (' + loProcedure._Nombre + ')' ;
+ ', línea ' + TRANSFORM(I) + ' del archivo ' + .c_InputFile
ERROR (TEXTMERGE(C_STRUCTURE_NESTING_ERROR_ENDPROC_EXPECTED_LOC))
ELSE
*ERROR 'Error de anidamiento de estructuras. Se esperaba ENDPROC y se encontró ENDDEFINE en la clase ' ;
+ toClase._Nombre + ' (' + toObjeto._Nombre + '.' + loProcedure._Nombre + ')' ;
+ ', línea ' + TRANSFORM(I) + ' del archivo ' + .c_InputFile
ERROR (TEXTMERGE(C_STRUCTURE_NESTING_ERROR_ENDPROC_EXPECTED_2_LOC))
ENDIF
ENDCASE
ENDIF
*-- Quito 2 TABS de la izquierda (si se puede y si el integrador/desarrollador no la lió quitándolos)
DO CASE
CASE LEFT( taCodeLines(I),2 ) = C_TAB + C_TAB
loProcedure.add_Line( SUBSTR(taCodeLines(I), 3) )
CASE LEFT( taCodeLines(I),1 ) = C_TAB
loProcedure.add_Line( SUBSTR(taCodeLines(I), 2) )
OTHERWISE
loProcedure.add_Line( taCodeLines(I) )
ENDCASE
ENDFOR
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_ADD_OBJECT
LPARAMETERS toModulo, toClase, tcLine, I, taCodeLines, tnCodeLines
EXTERNAL ARRAY taCodeLines
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
LOCAL toObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado
IF LEFT( tcLine, 11 ) == 'ADD OBJECT '
*-- Estructura a reconocer: ADD OBJECT 'frm_a.Check1' AS check [WITH]
llBloqueEncontrado = .T.
LOCAL laPropsAndValues(1,2), lnPropsAndValues_Count, Z, lcProp, lcValue, lcNombre, lcObjName
tcLine = CHRTRAN( tcLine, ['], ["] )
IF EMPTY(toClase._Fin_Cab)
toClase._Fin_Cab = I-1
toClase._Ini_Cuerpo = I
ENDIF
toObjeto = NULL
lcNombre = ALLTRIM( CHRTRAN( STREXTRACT(tcLine, 'ADD OBJECT ', ' AS ', 1, 1), ['"], [] ) )
lcObjName = JUSTEXT( '.' + lcNombre )
IF toClase.l_ObjectMetadataInHeader
FOR Z = 1 TO toClase._AddObject_Count
IF LOWER(toClase._AddObjects(Z)._Nombre) == LOWER(lcNombre) THEN
toObjeto = toClase._AddObjects(Z)
EXIT
ENDIF
ENDFOR
ENDIF
IF ISNULL(toObjeto)
toObjeto = CREATEOBJECT('CL_OBJETO')
*-- Luego se reasigna el ZOrder, pero si no lo hace, se pone último como si se acabara de agregar.
*-- Puede pasar si se agrega manualmente al TX2 y se olvida agregar la metadata OBJECTDATA.
toObjeto._ZOrder = 9999
toObjeto._Nombre = lcNombre
ENDIF
toObjeto._ObjName = lcObjName
IF '.' $ toObjeto._Nombre
toObjeto._Parent = toClase._ObjName + '.' + JUSTSTEM( toObjeto._Nombre )
ELSE
toObjeto._Parent = toClase._ObjName
ENDIF
toObjeto._Nombre = toObjeto._Parent + '.' + toObjeto._ObjName
toObjeto._Class = ALLTRIM( STREXTRACT(tcLine + ' WITH', ' AS ', ' WITH', 1, 1) )
IF NOT toClase.l_ObjectMetadataInHeader
toClase.add_Object( toObjeto )
ENDIF
*-- Propiedades del ADD OBJECT
WITH THIS
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
IF LEFT( tcLine, C_LEN_END_OBJECT_I) == C_END_OBJECT_I && Fin del ADD OBJECT y METADATOS
*< END OBJECT: baseclass = "olecontrol" Uniqueid = "_3X50L3I7V" OLEObject = "C:\WINDOWS\system32\FOXTLIB.OCX" checksum = "4101493921" />
.get_ListNamesWithValuesFrom_InLine_MetadataTag( @tcLine, @laPropsAndValues, @lnPropsAndValues_Count ;
, C_END_OBJECT_I, C_END_OBJECT_F )
toObjeto._ClassLib = .get_ValueByName_FromListNamesWithValues( 'ClassLib', 'C', @laPropsAndValues )
toObjeto._BaseClass = .get_ValueByName_FromListNamesWithValues( 'BaseClass', 'C', @laPropsAndValues )
IF NOT toClase.l_ObjectMetadataInHeader
toObjeto._UniqueID = .get_ValueByName_FromListNamesWithValues( 'UniqueID', 'C', @laPropsAndValues )
toObjeto._TimeStamp = INT( .RowTimeStamp( .get_ValueByName_FromListNamesWithValues( 'TimeStamp', 'T', @laPropsAndValues ) ) )
toObjeto._ZOrder = .get_ValueByName_FromListNamesWithValues( 'ZOrder', 'I', @laPropsAndValues )
ENDIF
toObjeto._Ole2 = .get_ValueByName_FromListNamesWithValues( 'OLEObject', 'C', @laPropsAndValues )
toObjeto._Ole = STRCONV( .get_ValueByName_FromListNamesWithValues( 'Value', 'C', @laPropsAndValues ), 14 )
IF NOT EMPTY( toObjeto._Ole2 ) && Le agrego "OLEObject = " delante
toObjeto._Ole2 = 'OLEObject = ' + toObjeto._Ole2 + CR_LF
ENDIF
*-- Ubico el objeto ole por su nombre (parent+objname), que no se repite.
IF EMPTY(toObjeto._Ole) && Si _Ole está vacío es porque el propio control no tiene la info y está en la cabecera (antiguo guardado)
IF toModulo.existeObjetoOLE( toObjeto._Nombre, @Z )
toObjeto._Ole = toModulo._Ole_Objs(Z)._Value
ENDIF
ENDIF
EXIT
ENDIF
IF RIGHT(tcLine, 3) == ', ;' && VALOR INTERMEDIO CON ", ;"
.get_SeparatedPropAndValue( LEFT(tcLine, LEN(tcLine) - 3), @lcProp, @lcValue, toClase, @taCodeLines, @tnCodeLines, @I )
toObjeto.add_Property( @lcProp, @lcValue )
ELSE && VALOR FINAL SIN ", ;" (JUSTO ANTES DEL <END OBJECT>)
.get_SeparatedPropAndValue( RTRIM(tcLine), @lcProp, @lcValue, toClase, @taCodeLines, @tnCodeLines, @I )
toObjeto.add_Property( @lcProp, @lcValue )
ENDIF
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_DEFINED_PAM
*--------------------------------------------------------------------------------------------------------------
* 07/01/2014 FDBOZZO Los *métodos deben ir siempre al final, si no los eventos ACCESS no se ejecutan!
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toClase (!@ IN ) Objeto de la Clase
* tcLine (!@ IN ) Línea de datos en evaluación
* taCodeLines (!@ IN ) El array con las líneas del código de texto donde buscar
* tnCodeLines (!@ IN ) Cantidad de líneas de código
* I (!@ IN ) Número de línea en evaluación
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS toClase, tcLine, taCodeLines, tnCodeLines, I
*-- ESTRUCTURA A ANALIZAR:
*<DefinedPropArrayMethod>
*m: *metodovacio_con_comentarios && Este método no tiene código, pero tiene comentarios. A ver que pasa!
*m: *mimetodo && Mi metodo
*p: prop1 && Mi prop 1
*p: prop_especial_cr &&
*a: ^array_1_d[1,0] && Array 1 dimensión (1)
*a: ^array_2_d[1,2] && Array una dimension (1,2)
*p: _memberdata && XML Metadata for customizable properties
*</DefinedPropArrayMethod>
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcDefinedPAM, lnPos, lnPos2, lcPAM_Name, lcItem, lcMethods
IF LEFT( tcLine, C_LEN_DEFINED_PAM_I) == C_DEFINED_PAM_I
llBloqueEncontrado = .T.
STORE '' TO lcDefinedPAM, lcItem, lcMethods
WITH THIS
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, C_LEN_DEFINED_PAM_F ) == C_DEFINED_PAM_F
I = I + 1
EXIT
OTHERWISE
lnPos = AT( ' ', tcLine, 1 )
lnPos2 = AT( '&'+'&', tcLine )
IF lnPos2 > 0
*-- Con comentarios
lcPAM_Name = LOWER( RTRIM( SUBSTR( tcLine, lnPos+1, lnPos2 - lnPos - 1 ), 0, ' ', CHR(9) ) )
lcItem = lcPAM_Name + ' ' + SUBSTR( tcLine, lnPos2 + 3 ) + CR_LF
*-- Separo propiedades y métodos
IF LEFT(lcItem,1) == '*'
lcMethods = lcMethods + lcItem
ELSE
lcDefinedPAM = lcDefinedPAM + lcItem
ENDIF
ELSE
*-- Sin comentarios
lcPAM_Name = LOWER( RTRIM( SUBSTR( tcLine, lnPos+1 ), 0, ' ', CHR(9) ) )
lcItem = lcPAM_Name + IIF( LEFT(lcPAM_Name,1) $ '^*' , ' ', '') + CR_LF
*-- Separo propiedades y métodos
IF LEFT(lcItem,1) == '*'
lcMethods = lcMethods + lcItem
ELSE
lcDefinedPAM = lcDefinedPAM + lcItem
ENDIF
ENDIF
ENDCASE
ENDFOR
ENDWITH && THIS
*-- Junto propiedades y los métodos al final.
toClase._Defined_PAM = lcDefinedPAM + lcMethods
I = I - 1
ENDIF
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_DEFINE_CLASS
LPARAMETERS toModulo, toClase, tcLine, taCodeLines, I, tnCodeLines, tcProcedureAbierto ;
, taBloquesExclusion, tnBloquesExclusion, tc_Comentario
EXTERNAL ARRAY taCodeLines, tnBloquesExclusion, taBloquesExclusion
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL llBloqueEncontrado
IF LEFT(tcLine + ' ', 13) == C_DEFINE_CLASS + ' '
TRY
llBloqueEncontrado = .T.
LOCAL Z, lcProp, lcValue, loEx AS EXCEPTION ;
, llCLASSMETADATA_Completed, llPROTECTED_Completed, llHIDDEN_Completed, llDEFINED_PAM_Completed ;
, llINCLUDE_Completed, llCLASS_PROPERTY_Completed, llOBJECTMETADATA_Completed ;
, loObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
STORE '' TO tcProcedureAbierto
toClase = CREATEOBJECT('CL_CLASE')
toClase._Nombre = ALLTRIM( STREXTRACT( tcLine, 'DEFINE CLASS ', ' AS ', 1, 1 ) )
toClase._ObjName = toClase._Nombre
toClase._Definicion = ALLTRIM( tcLine )
IF NOT ' OF ' $ UPPER(tcLine) && Puede no tener "OF libreria.vcx"
toClase._Class = ALLTRIM( CHRTRAN( STREXTRACT( tcLine + ' OLEPUBLIC', ' AS ', ' OLEPUBLIC', 1, 1 ), ["'], [] ) )
ELSE
toClase._Class = ALLTRIM( CHRTRAN( STREXTRACT( tcLine + ' OF ', ' AS ', ' OF ', 1, 1 ), ["'], [] ) )
ENDIF
toClase._ClassLoc = LOWER( ALLTRIM( CHRTRAN( STREXTRACT( tcLine + ' OLEPUBLIC', ' OF ', ' OLEPUBLIC', 1, 1 ), ["'], [] ) ) )
toClase._OlePublic = ' OLEPUBLIC' $ UPPER(tcLine)
toClase._Comentario = tc_Comentario
toClase._Inicio = I
toClase._Ini_Cab = I + 1
toModulo.add_Class( toClase )
*-- Ubico el objeto ole por su nombre (parent+objname), que no se repite.
IF toModulo.existeObjetoOLE( toClase._Nombre, @Z )
toClase._Ole = toModulo._Ole_Objs(Z)._Value
ENDIF
* Búsqueda del ID de fin de bloque (ENDDEFINE)
WITH THIS
FOR I = toClase._Ini_Cab TO tnCodeLines
tc_Comentario = ''
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine, @tc_Comentario )
LOOP
CASE .analizarBloque_PROCEDURE( @toModulo, @toClase, @loObjeto, @tcLine, @taCodeLines, @I, @tnCodeLines ;
, @tcProcedureAbierto, @tc_Comentario, @taBloquesExclusion, @tnBloquesExclusion )
*-- OJO: Esta se analiza primero a propósito, solo porque no puede estar detrás de PROTECTED y HIDDEN
llCLASS_PROPERTY_Completed = .T.
llPROTECTED_Completed = .T.
llHIDDEN_Completed = .T.
llINCLUDE_Completed = .T.
llCLASSMETADATA_Completed = .T.
llOBJECTMETADATA_Completed = .T.
llDEFINED_PAM_Completed = .T.
CASE NOT llPROTECTED_Completed AND .analizarBloque_PROTECTED( @toClase, @tcLine )
llPROTECTED_Completed = .T.
CASE NOT llHIDDEN_Completed AND .analizarBloque_HIDDEN( @toClase, @tcLine )
llHIDDEN_Completed = .T.
CASE NOT llINCLUDE_Completed AND .c_Type <> "SCX" AND .analizarBloque_INCLUDE( @toModulo, @toClase, @tcLine, @taCodeLines ;
, @I, @tnCodeLines, @tcProcedureAbierto )
llINCLUDE_Completed = .T.
CASE NOT llCLASSMETADATA_Completed AND .analizarBloque_CLASSMETADATA( @toClase, @tcLine )
llCLASSMETADATA_Completed = .T.
CASE NOT llOBJECTMETADATA_Completed AND .analizarBloque_OBJECTMETADATA( @toClase, @tcLine )
*llOBJECTMETADATA_Completed = .T.
CASE NOT llDEFINED_PAM_Completed AND .analizarBloque_DEFINED_PAM( @toClase, @tcLine, @taCodeLines, tnCodeLines, @I )
llDEFINED_PAM_Completed = .T.
CASE .analizarBloque_ADD_OBJECT( @toModulo, @toClase, @tcLine, @I, @taCodeLines, @tnCodeLines )
llCLASS_PROPERTY_Completed = .T.
llPROTECTED_Completed = .T.
llHIDDEN_Completed = .T.
llINCLUDE_Completed = .T.
llCLASSMETADATA_Completed = .T.
llOBJECTMETADATA_Completed = .T.
llDEFINED_PAM_Completed = .T.
CASE .analizarBloque_ENDDEFINE( @toClase, @tcLine, @I, @tcProcedureAbierto )
EXIT
CASE NOT llCLASS_PROPERTY_Completed AND EMPTY( toClase._Fin_Cab )
*-- Propiedades de la CLASE
*--
*-- NOTA: Las propiedades se agregan tal cual, incluso aunque estén separadas en
*-- varias líneas (memberdata y fb2p_value), ya que luego se ensamblan en classProps2Memo().
*
.get_SeparatedPropAndValue( RTRIM(tcLine), @lcProp, @lcValue, @toClase, @taCodeLines, tnCodeLines, @I )
toClase.add_Property( @lcProp, @lcValue, RTRIM(tc_Comentario) )
OTHERWISE
*-- Las líneas que pasan por aquí deberían estar vacías y ser de relleno del embellecimiento
ENDCASE
ENDFOR
*-- Validación
IF EMPTY( toClase._Fin )
*ERROR 'No se ha encontrado el marcador de fin [ENDDEFINE] ' ;
+ 'que cierra al marcador de inicio [DEFINE CLASS] ' ;
+ 'de la línea ' + TRANSFORM( toClase._Inicio ) + ' ' ;
+ 'para el identificador [' + toClase._Nombre + ']'
ERROR (TEXTMERGE(C_ENDDEFINE_MARKER_NOT_FOUND_LOC))
ENDIF
toClase._PROPERTIES = .classProps2Memo( toClase )
toClase._PROTECTED = .hiddenAndProtected_PAM( toClase )
toClase._METHODS = .classMethods2Memo( toClase )
toClase._RESERVED1 = IIF( .c_Type = 'SCX', '', 'Class' )
toClase._RESERVED2 = IIF( .c_Type = 'VCX' OR toClase._Nombre == 'Dataenvironment', TRANSFORM( toClase._AddObject_Count + 1 ), '' )
toClase._RESERVED3 = .defined_PAM2Memo( toClase )
toClase._RESERVED4 = toClase._ClassIcon
toClase._RESERVED5 = toClase._ProjectClassIcon
toClase._RESERVED6 = toClase._Scale
toClase._RESERVED7 = toClase._Comentario
toClase._RESERVED8 = toClase._includeFile
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_ENDDEFINE
LPARAMETERS toClase, tcLine, I, tcProcedureAbierto
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL llBloqueEncontrado
IF LEFT( tcLine + ' ', 10 ) == C_ENDDEFINE + ' ' && Fin de bloque (ENDDEF / ENDPROC) encontrado
llBloqueEncontrado = .T.
toClase._Fin = I
IF EMPTY( toClase._Ini_Cuerpo )
toClase._Ini_Cuerpo = I-1
ENDIF
toClase._Fin_Cuerpo = I-1
IF EMPTY( toClase._Fin_Cab )
toClase._Fin_Cab = I-1
ENDIF
STORE '' TO tcProcedureAbierto
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_HIDDEN
LPARAMETERS toClase, tcLine
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL llBloqueEncontrado
IF LEFT(tcLine, 7) == 'HIDDEN '
llBloqueEncontrado = .T.
toClase._HiddenProps = LOWER( ALLTRIM( SUBSTR( tcLine, 8 ) ) )
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_INCLUDE
LPARAMETERS toModulo, toClase, tcLine, taCodeLines, I, tnCodeLines, tcProcedureAbierto
LOCAL llBloqueEncontrado
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
IF LEFT(tcLine, 9) == '#INCLUDE '
llBloqueEncontrado = .T.
IF THIS.c_Type = 'SCX'
toModulo._includeFile = LOWER( ALLTRIM( CHRTRAN( SUBSTR( tcLine, 10 ), ["'], [] ) ) )
ELSE
toClase._includeFile = LOWER( ALLTRIM( CHRTRAN( SUBSTR( tcLine, 10 ), ["'], [] ) ) )
ENDIF
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_CLASSMETADATA
LPARAMETERS toClase, tcLine
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL llBloqueEncontrado
IF LEFT(tcLine, C_LEN_CLASSDATA_I) == C_CLASSDATA_I && METADATA de la CLASE
*< CLASSDATA: Baseclass="custom" Timestamp="2013/11/19 11:51:04" Scale="Foxels" Uniqueid="_3WF0VSTN1" ProjectClassIcon="container.ico" ClassIcon="toolbar.ico" />
LOCAL laPropsAndValues(1,2), lnPropsAndValues_Count
llBloqueEncontrado = .T.
WITH THIS
.get_ListNamesWithValuesFrom_InLine_MetadataTag( @tcLine, @laPropsAndValues, @lnPropsAndValues_Count, C_CLASSDATA_I, C_CLASSDATA_F )
toClase._BaseClass = .get_ValueByName_FromListNamesWithValues( 'BaseClass', 'C', @laPropsAndValues )
toClase._TimeStamp = INT( .RowTimeStamp( .get_ValueByName_FromListNamesWithValues( 'TimeStamp', 'T', @laPropsAndValues ) ) )
toClase._Scale = .get_ValueByName_FromListNamesWithValues( 'Scale', 'C', @laPropsAndValues )
toClase._UniqueID = .get_ValueByName_FromListNamesWithValues( 'UniqueID', 'C', @laPropsAndValues )
toClase._ProjectClassIcon = .get_ValueByName_FromListNamesWithValues( 'ProjectClassIcon', 'C', @laPropsAndValues )
toClase._ClassIcon = .get_ValueByName_FromListNamesWithValues( 'ClassIcon', 'C', @laPropsAndValues )
toClase._Ole2 = .get_ValueByName_FromListNamesWithValues( 'OLEObject', 'C', @laPropsAndValues )
IF EMPTY(toClase._Ole)
toClase._Ole = STRCONV( .get_ValueByName_FromListNamesWithValues( 'Value', 'C', @laPropsAndValues ), 14 )
ENDIF
ENDWITH && THIS
IF NOT EMPTY( toClase._Ole2 ) && Le agrego "OLEObject = " delante
toClase._Ole2 = 'OLEObject = ' + toClase._Ole2 + CR_LF
ENDIF
ENDIF
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE analizarBloque_OBJECTMETADATA
LPARAMETERS toClase, tcLine
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL llBloqueEncontrado
IF LEFT(tcLine, C_LEN_OBJECTDATA_I) == C_OBJECTDATA_I && METADATA del ADD OBJECT
*< OBJECTDATA: ObjName="txtValor" Timestamp="2013/11/19 11:51:04" Uniqueid="_3WF0VSTN1" />
LOCAL laPropsAndValues(1,2), lnPropsAndValues_Count, loObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
llBloqueEncontrado = .T.
toClase.l_ObjectMetadataInHeader = .T.
loObjeto = CREATEOBJECT('CL_OBJETO')
toClase.add_Object( loObjeto )
WITH THIS
.get_ListNamesWithValuesFrom_InLine_MetadataTag( @tcLine, @laPropsAndValues, @lnPropsAndValues_Count, C_OBJECTDATA_I, C_OBJECTDATA_F )
loObjeto._Nombre = .get_ValueByName_FromListNamesWithValues( 'ObjPath', 'C', @laPropsAndValues )
loObjeto._TimeStamp = INT( .RowTimeStamp( .get_ValueByName_FromListNamesWithValues( 'TimeStamp', 'T', @laPropsAndValues ) ) )
loObjeto._UniqueID = .get_ValueByName_FromListNamesWithValues( 'UniqueID', 'C', @laPropsAndValues )
ENDWITH && THIS
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_OLE_DEF
LPARAMETERS toModulo, tcLine, taCodeLines, I, tnCodeLines, tcProcedureAbierto
LOCAL llBloqueEncontrado
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
#ENDIF
IF LEFT( tcLine + ' ', C_LEN_OLE_I + 1 ) == C_OLE_I + ' '
llBloqueEncontrado = .T.
*-- Se encontró una definición de objeto OLE
*< OLE: Nombre="frm_d.ole_ImageControl2" parent="frm_d" objname="ole_ImageControl2" checksum="4171274922" value="b64-value" />
LOCAL laPropsAndValues(1,2), lnPropsAndValues_Count ;
, loOle AS CL_OLE OF 'FOXBIN2PRG.PRG'
loOle = NULL
loOle = CREATEOBJECT('CL_OLE')
WITH THIS
.get_ListNamesWithValuesFrom_InLine_MetadataTag( @tcLine, @laPropsAndValues, @lnPropsAndValues_Count, C_OLE_I, C_OLE_F )
loOle._Nombre = .get_ValueByName_FromListNamesWithValues( 'Nombre', 'C', @laPropsAndValues )
loOle._Parent = .get_ValueByName_FromListNamesWithValues( 'Parent', 'C', @laPropsAndValues )
loOle._ObjName = .get_ValueByName_FromListNamesWithValues( 'ObjName', 'C', @laPropsAndValues )
loOle._CheckSum = .get_ValueByName_FromListNamesWithValues( 'CheckSum', 'C', @laPropsAndValues )
loOle._Value = STRCONV( .get_ValueByName_FromListNamesWithValues( 'Value', 'C', @laPropsAndValues ), 14 )
ENDWITH
toModulo.add_OLE( loOle )
IF EMPTY( loOle._Value )
*-- Si el objeto OLE no tiene VALUE, es porque hay otro con el mismo contenido y no se duplicó para preservar espacio.
*-- Busco el VALUE del duplicado que se guardó y lo asigno nuevamente
FOR Z = 1 TO toModulo._Ole_Obj_count - 1
IF toModulo._Ole_Objs(Z)._CheckSum == loOle._CheckSum AND NOT EMPTY( toModulo._Ole_Objs(Z)._Value )
loOle._Value = toModulo._Ole_Objs(Z)._Value
EXIT
ENDIF
ENDFOR
ENDIF
loOle = NULL
RELEASE loOle
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_PROCEDURE
LPARAMETERS toModulo, toClase, toObjeto, tcLine, taCodeLines, I, tnCodeLines, tcProcedureAbierto ;
, tc_Comentario, taBloquesExclusion, tnBloquesExclusion
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
LOCAL toObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL llBloqueEncontrado
DO CASE
CASE LEFT( tcLine, 20 ) == 'PROTECTED PROCEDURE '
*-- Estructura a reconocer: PROTECTED PROCEDURE nombre_del_procedimiento
llBloqueEncontrado = .T.
tcProcedureAbierto = ALLTRIM( SUBSTR( tcLine, 21 ) )
THIS.evaluarDefinicionDeProcedure( @toClase, I, @tc_Comentario, tcProcedureAbierto, 'protected', @toObjeto )
CASE LEFT( tcLine, 17 ) == 'HIDDEN PROCEDURE '
*-- Estructura a reconocer: HIDDEN PROCEDURE nombre_del_procedimiento
llBloqueEncontrado = .T.
tcProcedureAbierto = ALLTRIM( SUBSTR( tcLine, 18 ) )
THIS.evaluarDefinicionDeProcedure( @toClase, I, @tc_Comentario, tcProcedureAbierto, 'hidden', @toObjeto )
CASE LEFT( tcLine, 10 ) == 'PROCEDURE '
*-- Estructura a reconocer: PROCEDURE [objeto.]nombre_del_procedimiento
llBloqueEncontrado = .T.
tcProcedureAbierto = ALLTRIM( SUBSTR( tcLine, 11 ) )
THIS.evaluarDefinicionDeProcedure( @toClase, I, @tc_Comentario, tcProcedureAbierto, 'normal', @toObjeto )
ENDCASE
IF llBloqueEncontrado
*-- Evalúo todo el contenido del PROCEDURE
THIS.analizarLineasDeProcedure( @toClase, @toObjeto, @tcLine, @taCodeLines, @I, @tnCodeLines, @tcProcedureAbierto ;
, @tc_Comentario, @taBloquesExclusion, @tnBloquesExclusion )
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_PROTECTED
LPARAMETERS toClase, tcLine
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
LOCAL llBloqueEncontrado
IF LEFT(tcLine, 10) == 'PROTECTED '
llBloqueEncontrado = .T.
toClase._ProtectedProps = LOWER( ALLTRIM( SUBSTR( tcLine, 11 ) ) )
ENDIF
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE evaluarDefinicionDeProcedure
LPARAMETERS toClase, tnX, tc_Comentario, tcProcName, tcProcType, toObjeto
*--------------------------------------------------------------------------------------------------------------
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG' ;
, toObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL I, lcNombreObjeto, lnObjProc ;
, loProcedure AS CL_PROCEDURE OF 'FOXBIN2PRG.PRG'
IF EMPTY(toClase._Fin_Cab)
toClase._Fin_Cab = tnX-1
toClase._Ini_Cuerpo = tnX
ENDIF
loProcedure = CREATEOBJECT("CL_PROCEDURE")
loProcedure._Nombre = tcProcName
loProcedure._ProcType = tcProcType
loProcedure._Comentario = tc_Comentario
*-- Anoto en HiddenMethods y ProtectedMethods según corresponda
DO CASE
CASE loProcedure._ProcType == 'hidden'
toClase._HiddenMethods = toClase._HiddenMethods + ',' + tcProcName
CASE loProcedure._ProcType == 'protected'
toClase._ProtectedMethods = toClase._ProtectedMethods + ',' + tcProcName
ENDCASE
*-- Agrego el objeto Procedimiento a la clase, o a un objeto de la clase.
IF '.' $ tcProcName
*-- Procedimiento de objeto
lcNombreObjeto = LOWER( JUSTSTEM( tcProcName ) )
*-- Busco el objeto al que corresponde el método
lnObjProc = THIS.buscarObjetoDelMetodoPorNombre( lcNombreObjeto, toClase )
IF lnObjProc = 0
*-- Procedimiento de clase
toClase.add_Procedure( loProcedure )
toObjeto = NULL
ELSE
*-- Procedimiento de objeto
toObjeto = toClase._AddObjects( lnObjProc )
toObjeto.add_Procedure( loProcedure )
ENDIF
ELSE
*-- Procedimiento de clase
toClase.add_Procedure( loProcedure )
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
STORE NULL TO loProcedure
RELEASE loProcedure
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE identificarBloquesDeCodigo
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taCodeLines (!@ IN ) El array con las líneas del código donde buscar
* tnCodeLines (!@ IN ) Cantidad de líneas de código
* taBloquesExclusion (!@ IN ) Array con las posiciones de inicio/fin de los bloques de exclusion
* tnBloquesExclusion (!@ IN ) Cantidad de bloques de exclusión
* toModulo (?@ OUT) Objeto con toda la información del módulo analizado
*
* NOTA:
* Como identificador se usa el nombre de clase o de procedimiento, según corresponda.
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS taCodeLines, tnCodeLines, taBloquesExclusion, tnBloquesExclusion, toModulo
EXTERNAL ARRAY taCodeLines, taBloquesExclusion
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL I, loEx AS EXCEPTION ;
, llFoxBin2Prg_Completed, llOLE_DEF_Completed, llINCLUDE_SCX_Completed ;
, lc_Comentario, lcProcedureAbierto, lcLine ;
, loClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
WITH THIS AS c_conversor_prg_a_bin OF 'FOXBIN2PRG.PRG'
STORE '' TO lcProcedureAbierto
.c_Type = UPPER(JUSTEXT(.c_OutputFile))
IF tnCodeLines > 1
*-- Defino el objeto de módulo y sus propiedades
toModulo = NULL
toModulo = CREATEOBJECT('CL_MODULO')
*-- Búsqueda del ID de inicio de bloque (DEFINE CLASS / PROCEDURE)
FOR I = 1 TO tnCodeLines
STORE '' TO lc_Comentario
.set_Line( @lcLine, @taCodeLines, I )
DO CASE
CASE .lineaExcluida( I, tnBloquesExclusion, @taBloquesExclusion ) ;
OR .lineIsOnlyCommentAndNoMetadata( @lcLine, @lc_Comentario ) && Excluida, vacía o solo Comentarios
CASE NOT llFoxBin2Prg_Completed AND .analizarBloque_FoxBin2Prg( toModulo, @lcLine, @taCodeLines, @I, tnCodeLines )
llFoxBin2Prg_Completed = .T.
CASE NOT llOLE_DEF_Completed AND .analizarBloque_OLE_DEF( @toModulo, @lcLine, @taCodeLines ;
, @I, tnCodeLines, @lcProcedureAbierto )
*-- Puede haber varios
CASE NOT llINCLUDE_SCX_Completed AND .c_Type = 'SCX' AND .analizarBloque_INCLUDE( @toModulo, @loClase, @lcLine ;
, @taCodeLines, @I, tnCodeLines, @lcProcedureAbierto )
* Específico para SCX que lo tiene al inicio
llINCLUDE_SCX_Completed = .T.
CASE .analizarBloque_DEFINE_CLASS( @toModulo, @loClase, @lcLine, @taCodeLines, @I, tnCodeLines ;
, @lcProcedureAbierto, @taBloquesExclusion, @tnBloquesExclusion, @lc_Comentario )
*-- Puede haber varias
ENDCASE
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
STORE NULL TO loClase
RELEASE loClase
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_prg_a_vcx AS c_conversor_prg_a_bin
#IF .F.
LOCAL THIS AS c_conversor_prg_a_vcx OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="escribirarchivobin" display="escribirArchivoBin"/>] ;
+ [</VFPData>]
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase CL_MODULO con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
TRY
LOCAL lnCodError, loReg, lcLine, laCodeLines(1), lnCodeLines, lnFB2P_Version, lcSourceFile ;
, laBloquesExclusion(1,2), lnBloquesExclusion, I
WITH THIS AS c_conversor_prg_a_vcx OF 'FOXBIN2PRG.PRG'
STORE 0 TO lnCodError, lnCodeLines, lnFB2P_Version
STORE '' TO lcLine, lcSourceFile
STORE NULL TO loReg, toModulo
C_FB2PRG_CODE = FILETOSTR( .c_InputFile )
lnCodeLines = ALINES( laCodeLines, C_FB2PRG_CODE )
toFoxBin2Prg.doBackup( .F., .T., '', '', '' )
*-- Creo la librería
.createClasslib()
*-- Identifico los TEXT/ENDTEXT, #IF .F./#ENDIF
.identificarBloquesDeExclusion( @laCodeLines, lnCodeLines, .F., @laBloquesExclusion, @lnBloquesExclusion )
*-- Identifico el inicio/fin de bloque, definición, cabecera y cuerpo de cada clase
.identificarBloquesDeCodigo( @laCodeLines, lnCodeLines, @laBloquesExclusion, lnBloquesExclusion, @toModulo )
.escribirArchivoBin( @toModulo, toFoxBin2Prg )
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE escribirArchivoBin
LPARAMETERS toModulo, toFoxBin2Prg
*-- Estructura del objeto toModulo generado:
*-- -----------------------------------------------------------------------------------------------------------
*-- Version Versión usada para generar la versión PRG analizada
*-- SourceFile Nombre original del archivo fuente de la conversión
*-- Ole_Obj_Count Cantidad de objetos definidos en el array ole_objs[]
*-- Ole_Objs[1] Array de objetos OLE definidos como clases
*-- ObjName Nombre del objeto OLE (OLE2)
*-- Parent Nombre del objeto Padre
*-- CheckSum Suma de verificación
*-- Value Valor del campo OLE
*-- Clases_Count Array con las posiciones de los addobjects, definicion y propiedades
*-- Clases[1] Array con los datos de las clases, definicion, propiedades y métodos
*-- Nombre El nombre de la clase (ej: "miClase")
*-- ObjName Nombre del objeto
*-- Parent Nombre del objeto Padre
*-- Class Clase de la que hereda la definición
*-- Classloc Librería donde está la definición de la clase
*-- Ole Información campo ole
*-- Ole2 Información campo ole2
*-- OlePublic Indica si la clase es OLEPublic o no (.T. / .F.)
*-- Uniqueid ID único
*-- Comentario El comentario de la clase (ej: "&& Mis comentarios")
*-- MetaData Información de metadata de la clase (baseclass, timestamp, scale)
*-- BaseClass Clase de base de la clase
*-- TimeStamp Timestamp de la clase
*-- Scale Scale de la clase (pixels, foxels)
*-- Definicion La definición de la clase (ej: "AS Custom OF LIBRERIA.VCX")
*-- Inicio/Fin Línea de inicio/fin de la clase (DEFINE CLASS/ENDDEFINE)
*-- Ini_Cab/Fin_Cab Línea de inicio/fin de la cabecera (def.propiedades, Hidden, Protected, #Include, CLASSDATA, DEFINED_PAM)
*-- Ini_Cuerpo/Fin_Cuerpo Línea de inicio/fin del cuerpo (ADD OBJECTs y PROCEDURES)
*-- HiddenProps Propiedades definidas como HIDDEN (ocultas)
*-- ProtectedProps Propiedades definidas como PROTECTED (protegidas)
*-- Defined_PAM Propiedades, eventos o métodos definidos por el usuario
*-- IncludeFile Nombre del archivo de inclusión
*-- Props_Count Cantidad de propiedades de la clase definicas en el array props[]
*-- Props[1,2] Array con todas las propiedades de la clase y sus valores. (col.1=Nombre, col.2=Comentario)
*-- AddObject_Count Cantidad de objetos definidos en el array addobjects[]
*-- AddObjects[1] Array con las posiciones de los addobjects, definicion y propiedades
*-- Nombre Nombre del objeto
*-- ObjName Nombre del objeto
*-- Parent Nombre del objeto Padre
*-- Clase Clase del objeto
*-- ClassLib Librería de clases de la que deriva la clase
*-- Baseclass Clase de base del objeto
*-- Uniqueid ID único
*-- Ole Información campo ole
*-- Ole2 Información campo ole2
*-- ZOrder Orden Z del objeto
*-- Props_Count Cantidad de propiedades del objeto
*-- Props[1] Array con todas las propiedades del objeto y sus valores
*-- Procedure_count Cantidad de procedimientos definidos en el array procedures[]
*-- Procedures[1] Array con las posiciones de los procedures, definicion y comentarios
*-- Nombre Nombre del procedure
*-- ProcType Tipo de procedimiento (normal, hidden, protected)
*-- Comentario Comentario el procedure
*-- ProcLine_Count Cantidad de líneas del procedimiento
*-- ProcLines[1] Líneas del procedimiento
*-- Procedure_count Cantidad de procedimientos definidos en el array procedures[]
*-- Procedures[1] Array con las posiciones de los procedures, definicion y comentarios
*-- Nombre Nombre del procedure
*-- ProcType Tipo de procedimiento (normal, hidden, protected)
*-- Comentario Comentario el procedure
*-- ProcLine_Count Cantidad de líneas del procedimiento
*-- ProcLines[1] Líneas del procedimiento
*-- -----------------------------------------------------------------------------------------------------------
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lcObjName, lnCodError, I, X, loEx AS EXCEPTION ;
, loClase AS CL_CLASE OF 'FOXBIN2PRG.PRG' ;
, loObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG' ;
, loFSO AS Scripting.FileSystemObject
WITH THIS AS c_conversor_prg_a_vcx OF 'FOXBIN2PRG.PRG'
loFSO = .oFSO
*-- Creo el registro de cabecera
.createClasslib_RecordHeader()
*-- Recorro las CLASES
FOR X = 1 TO 2
FOR I = 1 TO toModulo._Clases_Count
loClase = toModulo._Clases(I)
*-- El dataenvironment debe estar primero, luego lo demás.
IF X = 1 AND NOT loClase._BaseClass == 'dataenvironment' ;
OR X = 2 AND loClase._BaseClass == 'dataenvironment'
LOOP
ENDIF
*-- Inserto la clase
INSERT INTO TABLABIN ;
( PLATFORM ;
, UNIQUEID ;
, TIMESTAMP ;
, CLASS ;
, CLASSLOC ;
, BASECLASS ;
, OBJNAME ;
, PARENT ;
, PROPERTIES ;
, PROTECTED ;
, METHODS ;
, OLE ;
, OLE2 ;
, RESERVED1 ;
, RESERVED2 ;
, RESERVED3 ;
, RESERVED4 ;
, RESERVED5 ;
, RESERVED6 ;
, RESERVED7 ;
, RESERVED8 ;
, USER) ;
VALUES ;
( 'WINDOWS' ;
, IIF( toFoxBin2Prg.l_ClearUniqueID, '', loClase._UniqueID ) ;
, IIF( toFoxBin2Prg.l_NoTimestamps, 0, loClase._TimeStamp ) ;
, loClase._Class ;
, loClase._ClassLoc ;
, loClase._BaseClass ;
, loClase._ObjName ;
, loClase._Parent ;
, loClase._PROPERTIES ;
, loClase._PROTECTED ;
, loClase._METHODS ;
, loClase._Ole ;
, loClase._Ole2 ;
, loClase._RESERVED1 ;
, loClase._RESERVED2 ;
, loClase._RESERVED3 ;
, loClase._ClassIcon ;
, loClase._ProjectClassIcon ;
, loClase._Scale ;
, loClase._Comentario ;
, loClase._includeFile ;
, loClase._User )
.insert_AllObjects( @loClase, toFoxBin2Prg )
*-- Inserto el COMMENT
INSERT INTO TABLABIN ;
( PLATFORM ;
, UNIQUEID ;
, TIMESTAMP ;
, CLASS ;
, CLASSLOC ;
, BASECLASS ;
, OBJNAME ;
, PARENT ;
, PROPERTIES ;
, PROTECTED ;
, METHODS ;
, OLE ;
, OLE2 ;
, RESERVED1 ;
, RESERVED2 ;
, RESERVED3 ;
, RESERVED4 ;
, RESERVED5 ;
, RESERVED6 ;
, RESERVED7 ;
, RESERVED8 ;
, USER) ;
VALUES ;
( 'COMMENT' ;
, 'RESERVED' ;
, 0 ;
, '' ;
, '' ;
, '' ;
, loClase._ObjName ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, IIF(loClase._OlePublic, 'OLEPublic', '') ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' )
ENDFOR && I = 1 TO toModulo._Clases_Count
ENDFOR && X = 1 TO 2
USE IN (SELECT("TABLABIN"))
IF toFoxBin2Prg.l_Recompile
toFoxBin2Prg.compileFoxProBinary()
ENDIF
ENDWITH && THIS
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN lnCodError
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_prg_a_scx AS c_conversor_prg_a_bin
#IF .F.
LOCAL THIS AS c_conversor_prg_a_scx OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="escribirarchivobin" display="escribirArchivoBin"/>] ;
+ [</VFPData>]
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase CL_MODULO con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
TRY
LOCAL lnCodError, loReg, lcLine, laCodeLines(1), lnCodeLines, lnFB2P_Version, lcSourceFile ;
, laBloquesExclusion(1,2), lnBloquesExclusion, I
WITH THIS AS c_conversor_prg_a_scx OF 'FOXBIN2PRG.PRG'
STORE 0 TO lnCodError, lnCodeLines, lnFB2P_Version
STORE '' TO lcLine, lcSourceFile
STORE NULL TO loReg, toModulo
C_FB2PRG_CODE = FILETOSTR( .c_InputFile )
lnCodeLines = ALINES( laCodeLines, C_FB2PRG_CODE )
toFoxBin2Prg.doBackup( .F., .T., '', '', '' )
*-- Creo el form
.createForm()
*-- Identifico los TEXT/ENDTEXT, #IF .F./#ENDIF
.identificarBloquesDeExclusion( @laCodeLines, lnCodeLines, .F., @laBloquesExclusion, @lnBloquesExclusion )
*-- Identifico el inicio/fin de bloque, definición, cabecera y cuerpo de cada clase
.identificarBloquesDeCodigo( @laCodeLines, lnCodeLines, @laBloquesExclusion, lnBloquesExclusion, @toModulo )
.escribirArchivoBin( @toModulo, toFoxBin2Prg )
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE escribirArchivoBin
LPARAMETERS toModulo, toFoxBin2Prg
*-- Estructura del objeto toModulo generado:
*-- -----------------------------------------------------------------------------------------------------------
*-- Version Versión usada para generar la versión PRG analizada
*-- SourceFile Nombre original del archivo fuente de la conversión
*-- Ole_Obj_Count Cantidad de objetos definidos en el array ole_objs[]
*-- Ole_Objs[1] Array de objetos OLE definidos como clases
*-- ObjName Nombre del objeto OLE (OLE2)
*-- Parent Nombre del objeto Padre
*-- CheckSum Suma de verificación
*-- Value Valor del campo OLE
*-- Clases_Count Array con las posiciones de los addobjects, definicion y propiedades
*-- Clases[1] Array con los datos de las clases, definicion, propiedades y métodos
*-- Nombre El nombre de la clase (ej: "miClase")
*-- ObjName Nombre del objeto
*-- Parent Nombre del objeto Padre
*-- Class Clase de la que hereda la definición
*-- Classloc Librería donde está la definición de la clase
*-- Ole Información campo ole
*-- Ole2 Información campo ole2
*-- OlePublic Indica si la clase es OLEPublic o no (.T. / .F.)
*-- Uniqueid ID único
*-- Comentario El comentario de la clase (ej: "&& Mis comentarios")
*-- MetaData Información de metadata de la clase (baseclass, timestamp, scale)
*-- BaseClass Clase de base de la clase
*-- TimeStamp Timestamp de la clase
*-- Scale Scale de la clase (pixels, foxels)
*-- Definicion La definición de la clase (ej: "AS Custom OF LIBRERIA.VCX")
*-- Inicio/Fin Línea de inicio/fin de la clase (DEFINE CLASS/ENDDEFINE)
*-- Ini_Cab/Fin_Cab Línea de inicio/fin de la cabecera (def.propiedades, Hidden, Protected, #Include, CLASSDATA, DEFINED_PAM)
*-- Ini_Cuerpo/Fin_Cuerpo Línea de inicio/fin del cuerpo (ADD OBJECTs y PROCEDURES)
*-- HiddenProps Propiedades definidas como HIDDEN (ocultas)
*-- ProtectedProps Propiedades definidas como PROTECTED (protegidas)
*-- Defined_PAM Propiedades, eventos o métodos definidos por el usuario
*-- IncludeFile Nombre del archivo de inclusión
*-- Props_Count Cantidad de propiedades de la clase definicas en el array props[]
*-- Props[1,2] Array con todas las propiedades de la clase y sus valores. (col.1=Nombre, col.2=Comentario)
*-- AddObject_Count Cantidad de objetos definidos en el array addobjects[]
*-- AddObjects[1] Array con las posiciones de los addobjects, definicion y propiedades
*-- Nombre Nombre del objeto
*-- ObjName Nombre del objeto
*-- Parent Nombre del objeto Padre
*-- Clase Clase del objeto
*-- ClassLib Librería de clases de la que deriva la clase
*-- Baseclass Clase de base del objeto
*-- Uniqueid ID único
*-- Ole Información campo ole
*-- Ole2 Información campo ole2
*-- ZOrder Orden Z del objeto
*-- Props_Count Cantidad de propiedades del objeto
*-- Props[1] Array con todas las propiedades del objeto y sus valores
*-- Procedure_count Cantidad de procedimientos definidos en el array procedures[]
*-- Procedures[1] Array con las posiciones de los procedures, definicion y comentarios
*-- Nombre Nombre del procedure
*-- ProcType Tipo de procedimiento (normal, hidden, protected)
*-- Comentario Comentario el procedure
*-- ProcLine_Count Cantidad de líneas del procedimiento
*-- ProcLines[1] Líneas del procedimiento
*-- Procedure_count Cantidad de procedimientos definidos en el array procedures[]
*-- Procedures[1] Array con las posiciones de los procedures, definicion y comentarios
*-- Nombre Nombre del procedure
*-- ProcType Tipo de procedimiento (normal, hidden, protected)
*-- Comentario Comentario el procedure
*-- ProcLine_Count Cantidad de líneas del procedimiento
*-- ProcLines[1] Líneas del procedimiento
*-- -----------------------------------------------------------------------------------------------------------
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lcObjName, lnCodError, I, X, loEx AS EXCEPTION ;
, loClase AS CL_CLASE OF 'FOXBIN2PRG.PRG' ;
, loObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
WITH THIS AS c_conversor_prg_a_scx OF 'FOXBIN2PRG.PRG'
*-- Creo el registro de cabecera
.createForm_RecordHeader()
*-- El SCX tiene el INCLUDE en el primer registro
IF NOT EMPTY(toModulo._includeFile)
REPLACE RESERVED8 WITH toModulo._includeFile
ENDIF
*-- Recorro las CLASES
FOR X = 1 TO 2
FOR I = 1 TO toModulo._Clases_Count
loClase = toModulo._Clases(I)
*-- El dataenvironment debe estar primero, luego lo demás.
IF X = 1 AND NOT loClase._BaseClass == 'dataenvironment' ;
OR X = 2 AND loClase._BaseClass == 'dataenvironment'
LOOP
ENDIF
*-- Inserto la clase
INSERT INTO TABLABIN ;
( PLATFORM ;
, UNIQUEID ;
, TIMESTAMP ;
, CLASS ;
, CLASSLOC ;
, BASECLASS ;
, OBJNAME ;
, PARENT ;
, PROPERTIES ;
, PROTECTED ;
, METHODS ;
, OLE ;
, OLE2 ;
, RESERVED1 ;
, RESERVED2 ;
, RESERVED3 ;
, RESERVED4 ;
, RESERVED5 ;
, RESERVED6 ;
, RESERVED7 ;
, RESERVED8 ;
, USER) ;
VALUES ;
( 'WINDOWS' ;
, IIF( toFoxBin2Prg.l_ClearUniqueID, '', loClase._UniqueID ) ;
, IIF( toFoxBin2Prg.l_NoTimestamps, 0, loClase._TimeStamp ) ;
, loClase._Class ;
, loClase._ClassLoc ;
, loClase._BaseClass ;
, loClase._ObjName ;
, loClase._Parent ;
, loClase._PROPERTIES ;
, loClase._PROTECTED ;
, loClase._METHODS ;
, loClase._Ole ;
, loClase._Ole2 ;
, loClase._RESERVED1 ;
, loClase._RESERVED2 ;
, loClase._RESERVED3 ;
, loClase._ClassIcon ;
, loClase._ProjectClassIcon ;
, loClase._Scale ;
, loClase._Comentario ;
, loClase._includeFile ;
, loClase._User )
.insert_AllObjects( @loClase, toFoxBin2Prg )
ENDFOR && I = 1 TO toModulo._Clases_Count
ENDFOR && X = 1 TO 2
*-- Inserto el COMMENT final
INSERT INTO TABLABIN ;
( PLATFORM ;
, UNIQUEID ;
, TIMESTAMP ;
, CLASS ;
, CLASSLOC ;
, BASECLASS ;
, OBJNAME ;
, PARENT ;
, PROPERTIES ;
, PROTECTED ;
, METHODS ;
, OLE ;
, OLE2 ;
, RESERVED1 ;
, RESERVED2 ;
, RESERVED3 ;
, RESERVED4 ;
, RESERVED5 ;
, RESERVED6 ;
, RESERVED7 ;
, RESERVED8 ;
, USER) ;
VALUES ;
( 'COMMENT' ;
, 'RESERVED' ;
, 0 ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' ;
, '' )
USE IN (SELECT("TABLABIN"))
IF toFoxBin2Prg.l_Recompile
toFoxBin2Prg.compileFoxProBinary()
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_prg_a_pjx AS c_conversor_prg_a_bin
#IF .F.
LOCAL THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="escribirarchivobin" display="escribirArchivoBin"/>] ;
+ [<memberdata name="analizarbloque_buildproj" display="analizarBloque_BuildProj"/>] ;
+ [<memberdata name="analizarbloque_devinfo" display="analizarBloque_DevInfo"/>] ;
+ [<memberdata name="analizarbloque_excludedfiles" display="analizarBloque_ExcludedFiles"/>] ;
+ [<memberdata name="analizarbloque_filecomments" display="analizarBloque_FileComments"/>] ;
+ [<memberdata name="analizarbloque_serverhead" display="analizarBloque_ServerHead"/>] ;
+ [<memberdata name="analizarbloque_serverdata" display="analizarBloque_ServerData"/>] ;
+ [<memberdata name="analizarbloque_textfiles" display="analizarBloque_TextFiles"/>] ;
+ [<memberdata name="analizarbloque_projectproperties" display="analizarBloque_ProjectProperties"/>] ;
+ [</VFPData>]
*******************************************************************************************************************
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toProject (@! OUT) Objeto generado de clase CL_PROJECT con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toProject, toEx AS EXCEPTION, toFoxBin2Prg
DODEFAULT( @toProject, @toEx )
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, loReg, lcLine, laCodeLines(1), lnCodeLines, lnFB2P_Version, lcSourceFile ;
, laBloquesExclusion(1,2), lnBloquesExclusion, I
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
STORE 0 TO lnCodError, lnCodeLines, lnFB2P_Version
STORE '' TO lcLine, lcSourceFile
STORE NULL TO loReg, toModulo
C_FB2PRG_CODE = FILETOSTR( .c_InputFile )
lnCodeLines = ALINES( laCodeLines, C_FB2PRG_CODE )
toFoxBin2Prg.doBackup( .F., .T., '', '', '' )
*-- Creo solo la cabecera del proyecto
.createProject()
*-- Identifico los TEXT/ENDTEXT, #IF .F./#ENDIF
*.identificarBloquesDeExclusion( @laCodeLines, .F., @laBloquesExclusion, @lnBloquesExclusion )
*-- Identifico el inicio/fin de bloque, definición, cabecera y cuerpo de cada clase
.identificarBloquesDeCodigo( @laCodeLines, lnCodeLines, @laBloquesExclusion, lnBloquesExclusion, @toProject )
.escribirArchivoBin( @toProject, toFoxBin2Prg )
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE escribirArchivoBin
LPARAMETERS toProject, toFoxBin2Prg
*-- -----------------------------------------------------------------------------------------------------------
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL loReg, lnCodError, loEx AS EXCEPTION ;
, loServerHead AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG' ;
, loFile AS CL_PROJ_FILE OF 'FOXBIN2PRG.PRG'
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
toProject._HomeDir = CHRTRAN( toProject._HomeDir, ['], [] )
*-- Creo solo el registro de cabecera del proyecto
.createProject_RecordHeader( toProject )
lcMainProg = ''
IF NOT EMPTY(toProject._MainProg)
lcMainProg = LOWER( SYS(2014, toProject._MainProg, ADDBS(toProject._HomeDir) ) )
ENDIF
*-- Si hay ProjectHook de proyecto, lo inserto
IF NOT EMPTY(toProject._ProjectHookLibrary)
INSERT INTO TABLABIN ;
( NAME ;
, TYPE ;
, EXCLUDE ;
, KEY ;
, RESERVED1 ) ;
VALUES ;
( toProject._ProjectHookLibrary + CHR(0) ;
, 'W' ;
, .T. ;
, UPPER(JUSTSTEM(toProject._ProjectHookLibrary)) ;
, toProject._ProjectHookClass + CHR(0) )
ENDIF
*-- Si hay ICONO de proyecto, lo inserto
IF NOT EMPTY(toProject._Icon)
INSERT INTO TABLABIN ;
( NAME ;
, TYPE ;
, LOCAL ;
, KEY ) ;
VALUES ;
( SYS(2014, toProject._Icon, ADDBS(JUSTPATH(ADDBS(toProject._HomeDir)))) + CHR(0) ;
, 'i' ;
, .T. ;
, UPPER(JUSTSTEM(toProject._Icon)) )
ENDIF
*-- Agrego los ARCHIVOS
FOR EACH loFile IN toProject FOXOBJECT
INSERT INTO TABLABIN ;
( NAME ;
, TYPE ;
, EXCLUDE ;
, MAINPROG ;
, COMMENTS ;
, LOCAL ;
, CPID ;
, ID ;
, TIMESTAMP ;
, OBJREV ;
, KEY ) ;
VALUES ;
( loFile._Name + CHR(0) ;
, .fileTypeCode(JUSTEXT(loFile._Name)) ;
, loFile._Exclude ;
, (loFile._Name == lcMainProg) ;
, loFile._Comments ;
, .T. ;
, loFile._CPID ;
, IIF( toFoxBin2Prg.l_ClearUniqueID, 0, loFile._ID ) ;
, IIF( toFoxBin2Prg.l_NoTimestamps, 0, loFile._TimeStamp ) ;
, loFile._ObjRev ;
, UPPER(JUSTSTEM(loFile._Name)) )
ENDFOR
USE IN (SELECT("TABLABIN"))
ENDWITH && THIS
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN lnCodError
ENDPROC
*******************************************************************************************************************
PROCEDURE identificarBloquesDeCodigo
LPARAMETERS taCodeLines, tnCodeLines, taBloquesExclusion, tnBloquesExclusion, toProject
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taCodeLines (!@ IN ) El array con las líneas del código donde buscar
* tnCodeLines (!@ IN ) Cantidad de líneas de código
* taBloquesExclusion (!@ IN ) Array con las posiciones de inicio/fin de los bloques de exclusion
* tnBloquesExclusion (!@ IN ) Cantidad de bloques de exclusión
* toProject (?@ OUT) Objeto con toda la información del proyecto analizado
*
* NOTA:
* Como identificador se usa el nombre de clase o de procedimiento, según corresponda.
*--------------------------------------------------------------------------------------------------------------
EXTERNAL ARRAY taCodeLines, taBloquesExclusion
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL I, lc_Comentario, lcLine, llBuildProj_Completed, llDevInfo_Completed ;
, llServerHead_Completed, llFileComments_Completed, llFoxBin2Prg_Completed ;
, llExcludedFiles_Completed, llTextFiles_Completed, llProjectProperties_Completed
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
STORE 0 TO I
.c_Type = UPPER(JUSTEXT(.c_OutputFile))
IF tnCodeLines > 1
toProject = CREATEOBJECT('CL_PROJECT')
*toProject._HomeDir = ADDBS(JUSTPATH(.c_OutputFile))
FOR I = 1 TO tnCodeLines
.set_Line( @lcLine, @taCodeLines, I )
IF .lineIsOnlyCommentAndNoMetadata( @lcLine, @lc_Comentario ) && Vacía o solo Comentarios
LOOP
ENDIF
DO CASE
CASE NOT llFoxBin2Prg_Completed AND .analizarBloque_FoxBin2Prg( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
llFoxBin2Prg_Completed = .T.
CASE NOT llDevInfo_Completed AND .analizarBloque_DevInfo( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
llDevInfo_Completed = .T.
CASE NOT llServerHead_Completed AND .analizarBloque_ServerHead( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
llServerHead_Completed = .T.
CASE .analizarBloque_ServerData( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
*-- Puede haber varios servidores, por eso se siguen valuando
CASE NOT llBuildProj_Completed AND .analizarBloque_BuildProj( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
llBuildProj_Completed = .T.
CASE NOT llFileComments_Completed AND .analizarBloque_FileComments( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
llFileComments_Completed = .T.
CASE NOT llExcludedFiles_Completed AND .analizarBloque_ExcludedFiles( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
llExcludedFiles_Completed = .T.
CASE NOT llTextFiles_Completed AND .analizarBloque_TextFiles( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
llTextFiles_Completed = .T.
CASE NOT llProjectProperties_Completed AND .analizarBloque_ProjectProperties( toProject, @lcLine, @taCodeLines, @I, tnCodeLines )
llProjectProperties_Completed = .T.
ENDCASE
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_BuildProj
*------------------------------------------------------
*-- Analiza el bloque <BuildProj>
*------------------------------------------------------
LPARAMETERS toProject, tcLine, taCodeLines, I, tnCodeLines
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcComment, lcMetadatos, luValor ;
, laPropsAndValues(1,2), lnPropsAndValues_Count ;
, loFile AS CL_PROJ_FILE OF 'FOXBIN2PRG.PRG'
IF LEFT( tcLine, LEN(C_BUILDPROJ_I) ) == C_BUILDPROJ_I
llBloqueEncontrado = .T.
STORE NULL TO loProject, loFile
WITH THIS
FOR I = I + 1 TO tnCodeLines
lcComment = ''
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_BUILDPROJ_F) ) == C_BUILDPROJ_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine, @lcComment )
LOOP && Saltear comentarios
CASE UPPER( LEFT( tcLine, 14 ) ) == 'BUILD PROJECT '
LOOP
CASE UPPER( LEFT( tcLine, 5 ) ) == '.ADD('
* loFile: NAME,TYPE,EXCLUDE,COMMENTS
tcLine = CHRTRAN( tcLine, ["] + '[]', "'''" ) && Convierto "[] en '
loFile = CREATEOBJECT('CL_PROJ_FILE')
loFile._Name = ALLTRIM( STREXTRACT( tcLine, ['], ['] ) )
*-- Obtengo metadatos de los comentarios de FileMetadata:
*< FileMetadata: Type="V" Cpid="1252" Timestamp="1131901580" ID="1129207528" ObjRev="544" />
.get_ListNamesWithValuesFrom_InLine_MetadataTag( @lcComment, @laPropsAndValues ;
, @lnPropsAndValues_Count, C_FILE_META_I, C_FILE_META_F )
loFile._Type = .get_ValueByName_FromListNamesWithValues( 'Type', 'C', @laPropsAndValues )
loFile._CPID = .get_ValueByName_FromListNamesWithValues( 'CPID', 'I', @laPropsAndValues )
loFile._TimeStamp = .get_ValueByName_FromListNamesWithValues( 'Timestamp', 'I', @laPropsAndValues )
loFile._ID = .get_ValueByName_FromListNamesWithValues( 'ID', 'I', @laPropsAndValues )
loFile._ObjRev = .get_ValueByName_FromListNamesWithValues( 'ObjRev', 'I', @laPropsAndValues )
toProject.ADD( loFile, loFile._Name )
CASE UPPER( LEFT( tcLine, 10 ) ) == UPPER( '*<.HomeDir' )
toProject._HomeDir = STREXTRACT( tcLine, "'", "'" )
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_DevInfo
*------------------------------------------------------
*-- Analiza el bloque <DevInfo>
*------------------------------------------------------
LPARAMETERS toProject, tcLine, taCodeLines, I, tnCodeLines
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado ;
, loServerHead AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG'
IF LEFT( tcLine, LEN(C_DEVINFO_I) ) == C_DEVINFO_I
llBloqueEncontrado = .T.
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_DEVINFO_F) ) == C_DEVINFO_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine )
LOOP && Saltear comentarios
OTHERWISE
toProject.setParsedProjInfoLine( @tcLine )
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_ServerHead
*------------------------------------------------------
*-- Analiza el bloque <ServerHead>
*------------------------------------------------------
LPARAMETERS toProject, tcLine, taCodeLines, I, tnCodeLines
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado ;
, loServerHead AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG'
IF LEFT( tcLine, LEN(C_SRV_HEAD_I) ) == C_SRV_HEAD_I
llBloqueEncontrado = .T.
STORE NULL TO loServerHead, loServerData
loServerHead = toProject._ServerHead
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_SRV_HEAD_F) ) == C_SRV_HEAD_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine )
LOOP && Saltear comentarios
OTHERWISE
loServerHead.setParsedHeadInfoLine( @tcLine )
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_ServerData
*------------------------------------------------------
*-- Analiza el bloque <ServerData>
*------------------------------------------------------
LPARAMETERS toProject, tcLine, taCodeLines, I, tnCodeLines
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado ;
, loServerHead AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG' ;
, loServerData AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
IF LEFT( tcLine, LEN(C_SRV_DATA_I) ) == C_SRV_DATA_I
llBloqueEncontrado = .T.
STORE NULL TO loServerHead, loServerData
loServerHead = toProject._ServerHead
loServerData = loServerHead.getServerDataObject()
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_SRV_DATA_F) ) == C_SRV_DATA_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine )
LOOP && Saltear comentarios
OTHERWISE
loServerHead.setParsedInfoLine( loServerData, @tcLine )
ENDCASE
ENDFOR
ENDWITH && THIS
loServerHead.add_Server( loServerData )
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_FileComments
*------------------------------------------------------
*-- Analiza el bloque <FileComments>
*------------------------------------------------------
LPARAMETERS toProject, tcLine, taCodeLines, I, tnCodeLines
EXTERNAL ARRAY toProject
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcFile, lcComment ;
, loFile AS CL_PROJ_FILE OF 'FOXBIN2PRG.PRG'
IF LEFT( tcLine, LEN(C_FILE_CMTS_I) ) == C_FILE_CMTS_I
llBloqueEncontrado = .T.
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_FILE_CMTS_F) ) == C_FILE_CMTS_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine )
LOOP && Saltear comentarios
OTHERWISE
lcFile = LOWER( ALLTRIM( STRTRAN( CHRTRAN( NORMALIZE( STREXTRACT( tcLine, ".ITEM(", ")", 1, 1 ) ), ["], [] ), 'lcCurDir+', '', 1, 1, 1) ) )
lcComment = ALLTRIM( CHRTRAN( STREXTRACT( tcLine, "=", "", 1, 2 ), ['], [] ) )
loFile = toProject( lcFile )
loFile._Comments = lcComment
loFile = NULL
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_ExcludedFiles
*------------------------------------------------------
*-- Analiza el bloque <ExcludedFiles>
*------------------------------------------------------
LPARAMETERS toProject, tcLine, taCodeLines, I, tnCodeLines
EXTERNAL ARRAY toProject
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcFile, llExclude ;
, loFile AS CL_PROJ_FILE OF 'FOXBIN2PRG.PRG'
IF LEFT( tcLine, LEN(C_FILE_EXCL_I) ) == C_FILE_EXCL_I
llBloqueEncontrado = .T.
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_FILE_EXCL_F) ) == C_FILE_EXCL_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine )
LOOP && Saltear comentarios
OTHERWISE
lcFile = LOWER( ALLTRIM( STRTRAN( CHRTRAN( NORMALIZE( STREXTRACT( tcLine, ".ITEM(", ")", 1, 1 ) ), ["], [] ), 'lcCurDir+', '', 1, 1, 1) ) )
llExclude = EVALUATE( ALLTRIM( CHRTRAN( STREXTRACT( tcLine, "=", "", 1, 2 ), ['], [] ) ) )
loFile = toProject( lcFile )
loFile._Exclude = llExclude
loFile = NULL
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_TextFiles
*------------------------------------------------------
*-- Analiza el bloque <TextFiles>
*------------------------------------------------------
LPARAMETERS toProject, tcLine, taCodeLines, I, tnCodeLines
EXTERNAL ARRAY toProject
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcFile, lcType ;
, loFile AS CL_PROJ_FILE OF 'FOXBIN2PRG.PRG'
IF LEFT( tcLine, LEN(C_FILE_TXT_I) ) == C_FILE_TXT_I
llBloqueEncontrado = .T.
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_FILE_TXT_F) ) == C_FILE_TXT_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine )
LOOP && Saltear comentarios
OTHERWISE
lcFile = LOWER( ALLTRIM( STRTRAN( CHRTRAN( NORMALIZE( STREXTRACT( tcLine, ".ITEM(", ")", 1, 1 ) ), ["], [] ), 'lcCurDir+', '', 1, 1, 1) ) )
lcType = ALLTRIM( CHRTRAN( STREXTRACT( tcLine, "=", "", 1, 2 ), ['], [] ) )
loFile = toProject( lcFile )
loFile._Type = lcType
loFile = NULL
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_ProjectProperties
*------------------------------------------------------
*-- Analiza el bloque <ProjectProperties>
*------------------------------------------------------
LPARAMETERS toProject, tcLine, taCodeLines, I, tnCodeLines
#IF .F.
LOCAL toProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcLine
IF LEFT( tcLine, LEN(C_PROJPROPS_I) ) == C_PROJPROPS_I
llBloqueEncontrado = .T.
WITH THIS AS c_conversor_prg_a_pjx OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_PROJPROPS_F) ) == C_PROJPROPS_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine )
LOOP && Saltear comentarios
CASE LEFT( tcLine ,2 ) == '*<'
*--- Se asigna con EVALUATE() tal cual está en el PJ2, pero quitando el marcador *< />
lcLine = STUFF( ALLTRIM( STREXTRACT( tcLine, '*<', '/>' ) ), 2, 0, '_' )
toProject.setParsedProjInfoLine( lcLine )
CASE UPPER( LEFT( tcLine, 9 ) ) == '.SETMAIN('
*-- Cambio "SetMain()" por "_MainProg ="
lcLine = '._MainProg = ' + LOWER( STREXTRACT( ALLTRIM( tcLine), '.SetMain(', ')', 1, 1 ) )
toProject.setParsedProjInfoLine( lcLine )
OTHERWISE
*--- Se asigna con EVALUATE() tal cual está en el PJ2
lcLine = STUFF( ALLTRIM( tcLine), 2, 0, '_' )
toProject.setParsedProjInfoLine( lcLine )
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_prg_a_frx AS c_conversor_prg_a_bin
#IF .F.
LOCAL THIS AS c_conversor_prg_a_frx OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="escribirarchivobin" display="escribirArchivoBin"/>] ;
+ [<memberdata name="analizarbloque_cdata_inline" display="analizarBloque_CDATA_inline"/>] ;
+ [<memberdata name="analizarbloque_platform" display="analizarBloque_platform"/>] ;
+ [<memberdata name="analizarbloque_reportes" display="analizarBloque_Reportes"/>] ;
+ [</VFPData>]
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toReport (@! OUT) Objeto generado de clase CL_REPORT con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toReport, toEx AS EXCEPTION, toFoxBin2Prg
DODEFAULT( @toReport, @toEx )
#IF .F.
LOCAL toReport AS CL_REPORT OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, loEx AS EXCEPTION, loReg, lcLine, laCodeLines(1), lnCodeLines, lnFB2P_Version, lcSourceFile ;
, laBloquesExclusion(1,2), lnBloquesExclusion, I
WITH THIS AS c_conversor_prg_a_frx OF 'FOXBIN2PRG.PRG'
STORE 0 TO lnCodError, lnCodeLines, lnFB2P_Version
STORE '' TO lcLine, lcSourceFile
STORE NULL TO loReg, toModulo
C_FB2PRG_CODE = FILETOSTR( .c_InputFile )
lnCodeLines = ALINES( laCodeLines, C_FB2PRG_CODE )
toFoxBin2Prg.doBackup( .F., .T., '', '', '' )
*-- Creo el reporte
.createReport()
*-- Identifico el inicio/fin de bloque, definición, cabecera y cuerpo del reporte
.identificarBloquesDeCodigo( @laCodeLines, lnCodeLines, @laBloquesExclusion, lnBloquesExclusion, @toReport )
.escribirArchivoBin( @toReport, toFoxBin2Prg )
ENDWITH && THIS
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN lnCodError
ENDPROC
*******************************************************************************************************************
PROCEDURE escribirArchivoBin
LPARAMETERS toReport, toFoxBin2Prg
*-- -----------------------------------------------------------------------------------------------------------
#IF .F.
LOCAL toReport AS CL_REPORT OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL loReg, I, lcFieldType, lnFieldLen, lnFieldDec, lnNumCampo, laFieldTypes(1,18) ;
, luValor, lnCodError, loEx AS EXCEPTION
SELECT TABLABIN
AFIELDS( laFieldTypes )
*-- Agrego los registros
FOR EACH loReg IN toReport FOXOBJECT
IF toFoxBin2Prg.l_NoTimestamps
loReg.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loReg.UNIQUEID = ''
ENDIF
*-- Ajuste de los tipos de dato
FOR I = 1 TO AMEMBERS(laProps, loReg, 0)
lnNumCampo = ASCAN( laFieldTypes, laProps(I), 1, -1, 1, 1+2+4+8 )
IF lnNumCampo = 0
*ERROR 'No se encontró el campo [' + laProps(I) + '] en la estructura del archivo ' + DBF("TABLABIN")
ERROR (TEXTMERGE(C_FIELD_NOT_FOUND_ON_FILE_STRUCTURE_LOC))
ENDIF
lcFieldType = laFieldTypes(lnNumCampo,2)
lnFieldLen = laFieldTypes(lnNumCampo,3)
lnFieldDec = laFieldTypes(lnNumCampo,4)
luValor = EVALUATE('loReg.' + laProps(I))
DO CASE
CASE INLIST(lcFieldType, 'B') && Double
ADDPROPERTY( loReg, laProps(I), CAST( luValor AS &lcFieldType. (lnFieldPrec) ) )
CASE INLIST(lcFieldType, 'F', 'N', 'Y') && Float, Numeric, Currency
ADDPROPERTY( loReg, laProps(I), CAST( luValor AS &lcFieldType. (lnFieldLen, lnFieldDec) ) )
CASE INLIST(lcFieldType, 'W', 'G', 'M', 'Q', 'V', 'C') && Blob, General, Memo, Varbinary, Varchar, Character
ADDPROPERTY( loReg, laProps(I), luValor )
OTHERWISE && Demás tipos
ADDPROPERTY( loReg, laProps(I), CAST( luValor AS &lcFieldType. (lnFieldLen) ) )
ENDCASE
ENDFOR
INSERT INTO TABLABIN FROM NAME loReg
loReg = NULL
ENDFOR
USE IN (SELECT("TABLABIN"))
IF toFoxBin2Prg.l_Recompile
toFoxBin2Prg.compileFoxProBinary()
ENDIF
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN lnCodError
ENDPROC
*******************************************************************************************************************
PROCEDURE identificarBloquesDeCodigo
LPARAMETERS taCodeLines, tnCodeLines, taBloquesExclusion, tnBloquesExclusion, toReport
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taCodeLines (!@ IN ) El array con las líneas del código donde buscar
* tnCodeLines (!@ IN ) Cantidad de líneas de código
* taBloquesExclusion (?@ IN ) Sin uso
* tnBloquesExclusion (?@ IN ) Sin uso
* toReport (?@ OUT) Objeto con toda la información del reporte analizado
*
* NOTA:
* Como identificador se usa el nombre de clase o de procedimiento, según corresponda.
*--------------------------------------------------------------------------------------------------------------
EXTERNAL ARRAY taCodeLines, taBloquesExclusion
#IF .F.
LOCAL toReport AS CL_REPORT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL I, lc_Comentario, lcLine, llFoxBin2Prg_Completed
STORE 0 TO I
WITH THIS AS c_conversor_prg_a_frx OF 'FOXBIN2PRG.PRG'
.c_Type = UPPER(JUSTEXT(.c_OutputFile))
IF tnCodeLines > 1
toReport = NULL
toReport = CREATEOBJECT('CL_REPORT')
FOR I = 1 TO tnCodeLines
.set_Line( @lcLine, @taCodeLines, I )
IF .lineIsOnlyCommentAndNoMetadata( @lcLine, @lc_Comentario ) && Vacía o solo Comentarios
LOOP
ENDIF
DO CASE
CASE NOT llFoxBin2Prg_Completed AND .analizarBloque_FoxBin2Prg( toReport, @lcLine, @taCodeLines, @I, tnCodeLines )
llFoxBin2Prg_Completed = .T.
CASE .analizarBloque_Reportes( toReport, @lcLine, @taCodeLines, @I, tnCodeLines )
ENDCASE
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_CDATA_inline
*------------------------------------------------------
*-- Analiza el bloque <picture>
*------------------------------------------------------
LPARAMETERS toReport, tcLine, taCodeLines, I, tnCodeLines, toReg, tcPropName
#IF .F.
LOCAL toReport AS CL_REPORT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcValue, loEx AS EXCEPTION
IF LEFT(tcLine, 1 + LEN(tcPropName) + 1 + 9) == '<' + tcPropName + '>' + C_DATA_I
llBloqueEncontrado = .T.
IF C_DATA_F $ tcLine
lcValue = STREXTRACT( tcLine, C_DATA_I, C_DATA_F )
ADDPROPERTY( toReg, tcPropName, lcValue )
EXIT
ENDIF
*-- Tomo la primera parte del valor
lcValue = STREXTRACT( tcLine, C_DATA_I )
*-- Recorro las fracciones del valor
FOR I = I + 1 TO tnCodeLines
tcLine = taCodeLines(I)
IF C_DATA_F $ tcLine && Fin del valor
lcValue = lcValue + CR_LF + STREXTRACT( tcLine, '', C_DATA_F )
ADDPROPERTY( toReg, tcPropName, lcValue )
EXIT
ELSE && Otra fracción del valor
lcValue = lcValue + CR_LF + tcLine
ENDIF
ENDFOR
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'PropName=[' + TRANSFORM(tcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_platform
*------------------------------------------------------
*-- Analiza el bloque <platform=>
*------------------------------------------------------
LPARAMETERS toReport, tcLine, taCodeLines, I, tnCodeLines, toReg
#IF .F.
LOCAL toReport AS CL_REPORT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, X, lnPos, lnPos2, lcValue, lnLenPropName, laProps(1) ;
, lcComment, lcMetadatos, luValor ;
, laPropsAndValues(1,2), lnPropsAndValues_Count
IF LOWER( LEFT(tcLine, 10) ) == 'platform="'
llBloqueEncontrado = .T.
lnLastPos = 1
tcLine = ' ' + tcLine
FOR X = 1 TO AMEMBERS( laProps, toReg, 0 )
laProps(X) = ' ' + laProps(X)
lnPos = AT( LOWER(laProps(X)) + '="', tcLine )
IF lnPos > 0
lnLenPropName = LEN(laProps(X))
lnPos2 = AT( '"', SUBSTR( tcLine, lnPos + lnLenPropName + 2 ) )
lcValue = SUBSTR( tcLine, lnPos + lnLenPropName + 2, lnPos2 - 1 )
ADDPROPERTY( toReg, laProps(X), lcValue )
ENDIF
ENDFOR
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE analizarBloque_Reportes
*------------------------------------------------------
*-- Analiza el bloque <reportes>
*------------------------------------------------------
LPARAMETERS toReport, tcLine, taCodeLines, I, tnCodeLines
#IF .F.
LOCAL toReport AS CL_REPORT OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcComment, lcMetadatos, luValor ;
, laPropsAndValues(1,2), lnPropsAndValues_Count ;
, loReg
IF LEFT( tcLine, LEN(C_TAG_REPORTE) + 1 ) == '<' + C_TAG_REPORTE + ''
llBloqueEncontrado = .T.
WITH THIS AS c_conversor_prg_a_frx OF 'FOXBIN2PRG.PRG'
loReg = .emptyRecord()
FOR I = I + 1 TO tnCodeLines
lcComment = ''
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE LEFT( tcLine, LEN(C_TAG_REPORTE_F) ) == C_TAG_REPORTE_F
I = I + 1
EXIT
CASE .lineIsOnlyCommentAndNoMetadata( @tcLine, @lcComment )
LOOP && Saltear comentarios
CASE .analizarBloque_platform( toReport, @tcLine, @taCodeLines, @I, @tnCodeLines, @loReg )
CASE .analizarBloque_CDATA_inline( toReport, @tcLine, @taCodeLines, @I, tnCodeLines, @loReg, 'picture' )
CASE .analizarBloque_CDATA_inline( toReport, @tcLine, @taCodeLines, @I, tnCodeLines, @loReg, 'tag' )
*-- ARREGLO ALGUNOS VALORES CAMBIADOS AL TEXTUALIZAR
DO CASE
CASE loReg.ObjType == "1"
loReg.TAG = .decode_SpecialCodes_1_31( loReg.TAG )
CASE loReg.ObjType == "25"
loReg.TAG = SUBSTR(loReg.TAG,3) && Quito el ENTER agregado antes
OTHERWISE
loReg.TAG = .decode_SpecialCodes_1_31( loReg.TAG )
ENDCASE
CASE .analizarBloque_CDATA_inline( toReport, @tcLine, @taCodeLines, @I, tnCodeLines, @loReg, 'tag2' )
*-- ARREGLO ALGUNOS VALORES CAMBIADOS AL TEXTUALIZAR
loReg.TAG2 = STRCONV( loReg.TAG2,14 )
CASE .analizarBloque_CDATA_inline( toReport, @tcLine, @taCodeLines, @I, tnCodeLines, @loReg, 'penred' )
CASE .analizarBloque_CDATA_inline( toReport, @tcLine, @taCodeLines, @I, tnCodeLines, @loReg, 'style' )
CASE .analizarBloque_CDATA_inline( toReport, @tcLine, @taCodeLines, @I, tnCodeLines, @loReg, 'expr' )
CASE .analizarBloque_CDATA_inline( toReport, @tcLine, @taCodeLines, @I, tnCodeLines, @loReg, 'user' )
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
toReport.ADD( loReg )
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
ENDDEFINE && CLASS c_conversor_prg_a_frx AS c_conversor_prg_a_bin
*******************************************************************************************************************
DEFINE CLASS c_conversor_prg_a_dbf AS c_conversor_prg_a_bin
#IF .F.
LOCAL THIS AS c_conversor_prg_a_dbf OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="analizarbloque_table" display="analizarBloque_TABLE"/>] ;
+ [<memberdata name="analizarbloque_fields" display="analizarBloque_FIELDS"/>] ;
+ [<memberdata name="analizarbloque_indexes" display="analizarBloque_INDEXES"/>] ;
+ [</VFPData>]
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toTable (@! OUT) Objeto generado de clase CL_TABLE con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toTable, toEx AS EXCEPTION, toFoxBin2Prg
DODEFAULT( @toTable, @toEx )
#IF .F.
LOCAL toTable AS CL_DBF_TABLE OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, loEx AS EXCEPTION, loReg, lcLine, laCodeLines(1), lnCodeLines, lnFB2P_Version, lcSourceFile ;
, laBloquesExclusion(1,2), lnBloquesExclusion, I
STORE 0 TO lnCodError, lnCodeLines, lnFB2P_Version
STORE '' TO lcLine, lcSourceFile
STORE NULL TO loReg, toModulo
WITH THIS AS c_conversor_prg_a_dbf OF 'FOXBIN2PRG.PRG'
C_FB2PRG_CODE = FILETOSTR( .c_InputFile )
lnCodeLines = ALINES( laCodeLines, C_FB2PRG_CODE )
toFoxBin2Prg.doBackup( .F., .T., '', '', '' )
*-- Identifico el inicio/fin de bloque, definición, cabecera y cuerpo del reporte
.identificarBloquesDeCodigo( @laCodeLines, lnCodeLines, @laBloquesExclusion, lnBloquesExclusion, @toTable )
.escribirArchivoBin( @toTable )
ENDWITH && THIS
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN lnCodError
ENDPROC
*******************************************************************************************************************
PROCEDURE escribirArchivoBin
LPARAMETERS toTable
*-- -----------------------------------------------------------------------------------------------------------
#IF .F.
LOCAL toTable AS CL_DBF_TABLE OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL I, lnCodError, loEx AS EXCEPTION
LOCAL loField AS CL_DBF_FIELD OF 'FOXBIN2PRG.PRG'
LOCAL loIndex AS CL_DBF_INDEX OF 'FOXBIN2PRG.PRG'
LOCAL lcCreateTable, lcLongDec, lcFieldDef, lcIndex, ldLastUpdate, lcTempDBC
LOCAL loDBFUtils AS CL_DBF_UTILS OF 'FOXBIN2PRG.PRG'
WITH THIS AS c_conversor_prg_a_dbf OF 'FOXBIN2PRG.PRG'
loDBFUtils = CREATEOBJECT('CL_DBF_UTILS')
STORE 0 TO lnCodError
STORE '' TO lcIndex, lcFieldDef
ERASE (FORCEEXT(.c_OutputFile, 'DBF'))
ERASE (FORCEEXT(.c_OutputFile, 'FPT'))
ERASE (FORCEEXT(.c_OutputFile, 'CDX'))
IF EMPTY(toTable._Database)
lcCreateTable = 'CREATE TABLE "' + .c_OutputFile + '" FREE CodePage=' + toTable._CodePage + ' ('
ELSE
lcTempDBC = FORCEPATH( '_FB2P', JUSTPATH(.c_OutputFile) )
CREATE DATABASE ( lcTempDBC )
lcCreateTable = 'CREATE TABLE "' + .c_OutputFile + '" CodePage=' + toTable._CodePage + ' ('
ENDIF
*-- Conformo los campos
FOR EACH loField IN toTable._Fields FOXOBJECT
lcLongDec = ''
*-- Nombre, Tipo
lcFieldDef = lcFieldDef + ', ' + loField._Name + ' ' + loField._Type
*-- Longitud
IF INLIST( loField._Type, 'C', 'N', 'F', 'Q', 'V' )
lcLongDec = lcLongDec + '(' + loField._Width
ENDIF
*-- Decimales
IF INLIST( loField._Type, 'B', 'N', 'F' ) AND loField._Decimals > '0'
IF EMPTY(lcLongDec)
lcLongDec = lcLongDec + '('
ELSE
lcLongDec = lcLongDec + ','
ENDIF
lcLongDec = lcLongDec + loField._Decimals
ENDIF
IF NOT EMPTY(lcLongDec)
lcLongDec = lcLongDec + ')'
ENDIF
lcFieldDef = lcFieldDef + lcLongDec
*-- Null
lcFieldDef = lcFieldDef + IIF( loField._Null = '.T.', ' NULL', ' NOT NULL' )
*-- NoCPTran
IF loField._NoCPTran = '.T.'
lcFieldDef = lcFieldDef + ' NOCPTRANS'
ENDIF
*-- AutoInc
IF loField._AutoInc_NextVal <> '0'
lcFieldDef = lcFieldDef + ' AUTOINC NEXTVAL ' + loField._AutoInc_NextVal + ' STEP ' + loField._AutoInc_Step
ENDIF
loField = NULL
ENDFOR
lcCreateTable = lcCreateTable + SUBSTR(lcFieldDef,3) + ')'
&lcCreateTable.
*-- Regenero los índices
FOR EACH loIndex IN toTable._Indexes FOXOBJECT
lcIndex = 'INDEX ON ' + loIndex._Key + ' TAG ' + loIndex._TagName
IF loIndex._TagType = 'BINARY'
lcIndex = lcIndex + ' BINARY'
ELSE
lcIndex = lcIndex + ' COLLATE "' + loIndex._Collate + '"'
IF NOT EMPTY(loIndex._Filter)
lcIndex = lcIndex + ' FOR ' + loIndex._Filter
ENDIF
lcIndex = lcIndex + ' ' + loIndex._Order
IF NOT INLIST(loIndex._TagType, 'NORMAL', 'REGULAR')
*-- Si es PRIMARY lo cambio a CANDIDATE y luego lo recodifico
lcIndex = lcIndex + ' ' + STRTRAN( loIndex._TagType, 'PRIMARY', 'CANDIDATE' )
ENDIF
ENDIF
&lcIndex.
ENDFOR
USE IN (SELECT(JUSTSTEM(.c_OutputFile)))
*-- La actualización de la fecha sirve para evitar diferencias al regenerar el DBF
ldLastUpdate = EVALUATE( '{^' + toTable._LastUpdate + '}' )
loDBFUtils.write_DBC_BackLink( .c_OutputFile, toTable._Database, ldLastUpdate )
ENDWITH && THIS
CATCH TO loEx
lnCodError = loEx.ERRORNO
loEx.USERVALUE = 'lcIndex="' + TRANSFORM(lcIndex) + '"' + CR_LF ;
+ 'lcFieldDef="' + TRANSFORM(lcFieldDef) + '"' + CR_LF ;
+ 'lcCreateTable="' + TRANSFORM(lcCreateTable) + '"'
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT(JUSTSTEM(THIS.c_OutputFile)))
IF NOT EMPTY(lcTempDBC)
CLOSE DATABASES
ERASE (FORCEEXT(lcTempDBC,'DBC'))
ERASE (FORCEEXT(lcTempDBC,'DCT'))
ERASE (FORCEEXT(lcTempDBC,'DCX'))
ENDIF
ENDTRY
RETURN lnCodError
ENDPROC
*******************************************************************************************************************
PROCEDURE identificarBloquesDeCodigo
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taCodeLines (!@ IN ) El array con las líneas del código donde buscar
* tnCodeLines (!@ IN ) Cantidad de líneas de código
* taBloquesExclusion (?@ IN ) Sin uso
* tnBloquesExclusion (?@ IN ) Sin uso
* toTable (?@ OUT) Objeto con toda la información de la tabla analizada
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS taCodeLines, tnCodeLines, taBloquesExclusion, tnBloquesExclusion, toTable
EXTERNAL ARRAY taCodeLines, taBloquesExclusion
#IF .F.
LOCAL toTable AS CL_DBF_TABLE OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL I, lc_Comentario, lcLine, llFoxBin2Prg_Completed, llBloqueTable_Completed
STORE 0 TO I
WITH THIS AS c_conversor_prg_a_dbf OF 'FOXBIN2PRG.PRG'
.c_Type = UPPER(JUSTEXT(.c_OutputFile))
IF tnCodeLines > 1
toTable = NULL
toTable = CREATEOBJECT('CL_DBF_TABLE')
FOR I = 1 TO tnCodeLines
.set_Line( @lcLine, @taCodeLines, I )
IF .lineIsOnlyCommentAndNoMetadata( @lcLine, @lc_Comentario ) && Vacía o solo Comentarios
LOOP
ENDIF
DO CASE
CASE NOT llFoxBin2Prg_Completed AND .analizarBloque_FoxBin2Prg( toTable, @lcLine, @taCodeLines, @I, tnCodeLines )
llFoxBin2Prg_Completed = .T.
CASE NOT llBloqueTable_Completed AND toTable.analizarBloque( @lcLine, @taCodeLines, @I, tnCodeLines )
llBloqueTable_Completed = .T.
ENDCASE
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
ENDDEFINE && CLASS c_conversor_prg_a_dbf AS c_conversor_prg_a_bin
*******************************************************************************************************************
DEFINE CLASS c_conversor_prg_a_dbc AS c_conversor_prg_a_bin
#IF .F.
LOCAL THIS AS c_conversor_prg_a_dbc OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="analizarbloque_tables" display="analizarBloque_TABLES"/>] ;
+ [<memberdata name="analizarbloque_views" display="analizarBloque_VIEWS"/>] ;
+ [<memberdata name="analizarbloque_tablefields" display="analizarBloque_TABLEFIELDS"/>] ;
+ [<memberdata name="analizarbloque_viewfields" display="analizarBloque_VIEWFIELDS"/>] ;
+ [<memberdata name="analizarbloque_relations" display="analizarBloque_RELATIONS"/>] ;
+ [<memberdata name="analizarbloque_connections" display="analizarBloque_CONNECTIONS"/>] ;
+ [<memberdata name="analizarbloque_database" display="analizarBloque_DATABASE"/>] ;
+ [</VFPData>]
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toDatabase (@! OUT) Objeto generado de clase CL_DBC con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toDatabase, toEx AS EXCEPTION, toFoxBin2Prg
DODEFAULT( @toDatabase, @toEx )
#IF .F.
LOCAL toDatabase AS CL_DBC OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, loEx AS EXCEPTION, loReg, lcLine, laCodeLines(1), lnCodeLines, lnFB2P_Version, lcSourceFile ;
, laBloquesExclusion(1,2), lnBloquesExclusion, I
STORE 0 TO lnCodError, lnCodeLines, lnFB2P_Version
STORE '' TO lcLine, lcSourceFile
STORE NULL TO loReg, toModulo
WITH THIS AS c_conversor_prg_a_dbc OF 'FOXBIN2PRG.PRG'
C_FB2PRG_CODE = FILETOSTR( .c_InputFile )
lnCodeLines = ALINES( laCodeLines, C_FB2PRG_CODE )
toFoxBin2Prg.doBackup( .F., .T., '', '', '' )
*-- Creo la tabla
*.createTable()
*-- Identifico el inicio/fin de bloque, definición, cabecera y cuerpo del reporte
.identificarBloquesDeCodigo( @laCodeLines, lnCodeLines, @laBloquesExclusion, lnBloquesExclusion, @toDatabase )
.escribirArchivoBin( @toDatabase, toFoxBin2Prg )
ENDWITH && THIS
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN lnCodError
ENDPROC
*******************************************************************************************************************
PROCEDURE escribirArchivoBin
LPARAMETERS toDatabase, toFoxBin2Prg
*-- -----------------------------------------------------------------------------------------------------------
#IF .F.
LOCAL toDatabase AS CL_DBC OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, lcCreateTable, lcLongDec, lcFieldDef, lcIndex, ldLastUpdate
lnCodError = 0
STORE '' TO lcIndex, lcFieldDef
toDatabase.updateDBC( THIS.c_OutputFile )
IF toFoxBin2Prg.l_Recompile
toFoxBin2Prg.compileFoxProBinary()
ENDIF
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lnCodError
ENDPROC
*******************************************************************************************************************
PROCEDURE identificarBloquesDeCodigo
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taCodeLines (!@ IN ) El array con las líneas del código donde buscar
* tnCodeLines (!@ IN ) Cantidad de líneas de código
* taBloquesExclusion (?@ IN ) Sin uso
* tnBloquesExclusion (?@ IN ) Sin uso
* toDatabase (?@ OUT) Objeto con toda la información de la base de datos analizada
*
* NOTA:
* Como identificador se usa el nombre de clase o de procedimiento, según corresponda.
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS taCodeLines, tnCodeLines, taBloquesExclusion, tnBloquesExclusion, toDatabase
EXTERNAL ARRAY taCodeLines, taBloquesExclusion
#IF .F.
LOCAL toDatabase AS CL_DBC OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL I, lc_Comentario, lcLine, llFoxBin2Prg_Completed, llBloqueDatabase_Completed
STORE 0 TO I
WITH THIS AS c_conversor_prg_a_dbc OF 'FOXBIN2PRG.PRG'
.c_Type = UPPER(JUSTEXT(.c_OutputFile))
IF tnCodeLines > 1
toDatabase = NULL
toDatabase = CREATEOBJECT('CL_DBC')
FOR I = 1 TO tnCodeLines
.set_Line( @lcLine, @taCodeLines, I )
IF .lineIsOnlyCommentAndNoMetadata( @lcLine, @lc_Comentario ) && Vacía o solo Comentarios
LOOP
ENDIF
DO CASE
CASE NOT llFoxBin2Prg_Completed AND .analizarBloque_FoxBin2Prg( toDatabase, @lcLine, @taCodeLines, @I, tnCodeLines )
llFoxBin2Prg_Completed = .T.
CASE NOT llBloqueDatabase_Completed AND toDatabase.analizarBloque( @lcLine, @taCodeLines, @I, tnCodeLines )
llBloqueDatabase_Completed = .T.
ENDCASE
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
ENDDEFINE && CLASS c_conversor_prg_a_dbc AS c_conversor_prg_a_bin
*******************************************************************************************************************
DEFINE CLASS c_conversor_prg_a_mnx AS c_conversor_prg_a_bin
#IF .F.
LOCAL THIS AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="c_menulocation" display="c_MenuLocation"/>] ;
+ [<memberdata name="n_menutype" display="n_MenuType"/>] ;
+ [</VFPData>]
n_MenuType = 0
c_MenuLocation = ''
*******************************************************************************************************************
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toMenu (@! OUT) Objeto generado de clase CL_DBC con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toMenu, toEx AS EXCEPTION, toFoxBin2Prg
DODEFAULT( @toMenu, @toEx )
#IF .F.
LOCAL toMenu AS CL_MENU OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, loEx AS EXCEPTION, loReg, lcLine, laCodeLines(1), lnCodeLines, lnFB2P_Version, lcSourceFile ;
, laBloquesExclusion(1,2), lnBloquesExclusion
STORE 0 TO lnCodError, lnCodeLines, lnFB2P_Version
STORE '' TO lcLine, lcSourceFile
STORE NULL TO loReg, toModulo
WITH THIS AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
C_FB2PRG_CODE = FILETOSTR( .c_InputFile )
lnCodeLines = ALINES( laCodeLines, C_FB2PRG_CODE )
toFoxBin2Prg.doBackup( .F., .T., '', '', '' )
*-- Creo la tabla
.createMenu()
*-- Identifico el inicio/fin de bloque, definición, cabecera y cuerpo del reporte
.identificarBloquesDeCodigo( @laCodeLines, lnCodeLines, @laBloquesExclusion, lnBloquesExclusion, @toMenu )
.escribirArchivoBin( @toMenu )
ENDWITH && THIS
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN lnCodError
ENDPROC
PROCEDURE identificarBloquesDeCodigo
*--------------------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taCodeLines (!@ IN ) El array con las líneas del código donde buscar
* tnCodeLines (!@ IN ) Cantidad de líneas de código
* taBloquesExclusion (?@ IN ) Sin uso
* tnBloquesExclusion (?@ IN ) Sin uso
* toMenu (?@ OUT) Objeto con toda la información del menú analizado
*
* NOTA:
* Como identificador se usa el nombre de clase o de procedimiento, según corresponda.
*--------------------------------------------------------------------------------------------------------------
LPARAMETERS taCodeLines, tnCodeLines, taBloquesExclusion, tnBloquesExclusion, toMenu
EXTERNAL ARRAY taCodeLines, taBloquesExclusion
#IF .F.
LOCAL toMenu AS CL_MENU OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL I, lc_Comentario, lcLine, llFoxBin2Prg_Completed, llBloqueMenu_Completed
STORE 0 TO I
WITH THIS AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
.c_Type = UPPER(JUSTEXT(.c_OutputFile))
IF tnCodeLines > 1
toMenu = NULL
toMenu = CREATEOBJECT('CL_MENU')
FOR I = 1 TO tnCodeLines
.set_Line( @lcLine, @taCodeLines, I )
IF .lineIsOnlyCommentAndNoMetadata( @lcLine, @lc_Comentario ) && Vacía o solo Comentarios
LOOP
ENDIF
DO CASE
CASE NOT llFoxBin2Prg_Completed AND .analizarBloque_FoxBin2Prg( toMenu, @lcLine, @taCodeLines, @I, tnCodeLines )
llFoxBin2Prg_Completed = .T.
CASE NOT llBloqueMenu_Completed AND toMenu.analizarBloque( @lcLine, @taCodeLines, @I, tnCodeLines, THIS )
llBloqueMenu_Completed = .T.
ENDCASE
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
PROCEDURE escribirArchivoBin
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toMenu (@! OUT) Objeto generado de clase CL_DBC con la información leida del texto
*---------------------------------------------------------------------------------------------------
LPARAMETERS toMenu
#IF .F.
LOCAL toMenu AS CL_MENU OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, lcCreateTable, lcLongDec, lcFieldDef, lcIndex, ldLastUpdate
lnCodError = 0
STORE '' TO lcIndex, lcFieldDef
toMenu.updateMENU( THIS )
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT(JUSTSTEM(THIS.c_OutputFile)))
ENDTRY
RETURN lnCodError
ENDPROC
ENDDEFINE && CLASS c_conversor_prg_a_mnx AS c_conversor_prg_a_bin
*******************************************************************************************************************
DEFINE CLASS c_conversor_bin_a_prg AS c_conversor_base
#IF .F.
LOCAL THIS AS c_conversor_bin_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="convertir" display="Convertir"/>] ;
+ [<memberdata name="exception2str" display="Exception2Str"/>] ;
+ [<memberdata name="get_add_object_methods" display="get_ADD_OBJECT_METHODS"/>] ;
+ [<memberdata name="get_nombresobjetosolepublic" display="get_NombresObjetosOLEPublic"/>] ;
+ [<memberdata name="get_propsfrom_protected" display="get_PropsFrom_PROTECTED"/>] ;
+ [<memberdata name="get_propsandcommentsfrom_reserved3" display="get_PropsAndCommentsFrom_RESERVED3"/>] ;
+ [<memberdata name="get_propsandvaluesfrom_properties" display="get_PropsAndValuesFrom_PROPERTIES"/>] ;
+ [<memberdata name="indentarmemo" display="IndentarMemo"/>] ;
+ [<memberdata name="memoinoneline" display="MemoInOneLine"/>] ;
+ [<memberdata name="normalizarasignacion" display="normalizarAsignacion"/>] ;
+ [<memberdata name="set_multilinememowithaddobjectproperties" display="set_MultilineMemoWithAddObjectProperties"/>] ;
+ [<memberdata name="sortmethod" display="SortMethod"/>] ;
+ [<memberdata name="write_add_objects_withproperties" display="write_ADD_OBJECTS_WithProperties"/>] ;
+ [<memberdata name="write_all_object_methods" display="write_ALL_OBJECT_METHODS"/>] ;
+ [<memberdata name="write_cabecera_reporte" display="write_CABECERA_REPORTE"/>] ;
+ [<memberdata name="write_classmetadata" display="write_CLASSMETADATA"/>] ;
+ [<memberdata name="write_class_methods" display="write_CLASS_METHODS"/>] ;
+ [<memberdata name="write_class_properties" display="write_CLASS_PROPERTIES"/>] ;
+ [<memberdata name="write_dataenvironment_reporte" display="write_DATAENVIRONMENT_REPORTE"/>] ;
+ [<memberdata name="write_dbc_header" display="write_DBC_HEADER"/>] ;
+ [<memberdata name="write_dbc_connections" display="write_DBC_CONNECTIONS"/>] ;
+ [<memberdata name="write_dbc_tables" display="write_DBC_TABLES"/>] ;
+ [<memberdata name="write_dbc_table_fields" display="write_DBC_TABLE_FIELDS"/>] ;
+ [<memberdata name="write_dbc_table_indexes" display="write_DBC_TABLE_INDEXES"/>] ;
+ [<memberdata name="write_dbc_views" display="write_DBC_VIEWS"/>] ;
+ [<memberdata name="write_dbc_view_fields" display="write_DBC_VIEW_FIELDS"/>] ;
+ [<memberdata name="write_dbc_view_indexes" display="write_DBC_VIEW_INDEXES"/>] ;
+ [<memberdata name="write_dbc_relations" display="write_DBC_RELATIONS"/>] ;
+ [<memberdata name="write_dbf_header" display="write_DBF_HEADER"/>] ;
+ [<memberdata name="write_dbf_fields" display="write_DBF_FIELDS"/>] ;
+ [<memberdata name="write_dbf_indexes" display="write_DBF_INDEXES"/>] ;
+ [<memberdata name="write_detalle_reporte" display="write_DETALLE_REPORTE"/>] ;
+ [<memberdata name="write_defined_pam" display="write_DEFINED_PAM"/>] ;
+ [<memberdata name="write_define_class" display="write_DEFINE_CLASS"/>] ;
+ [<memberdata name="write_define_class_comments" display="write_Define_Class_COMMENTS"/>] ;
+ [<memberdata name="write_definicionobjetosole" display="write_DefinicionObjetosOLE"/>] ;
+ [<memberdata name="write_enddefine_sicorresponde" display="write_ENDDEFINE_SiCorresponde"/>] ;
+ [<memberdata name="write_hidden_properties" display="write_HIDDEN_Properties"/>] ;
+ [<memberdata name="write_include" display="write_INCLUDE"/>] ;
+ [<memberdata name="write_objectmetadata" display="write_OBJECTMETADATA"/>] ;
+ [<memberdata name="write_protected_properties" display="write_PROTECTED_Properties"/>] ;
+ [</VFPData>]
*******************************************************************************************************************
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase correspondiente con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
ENDPROC
*******************************************************************************************************************
PROCEDURE get_ADD_OBJECT_METHODS
LPARAMETERS toRegObj, toRegClass, tcMethods, taMethods, taCode, tnMethodCount
TRY
WITH THIS AS c_conversor_bin_a_prg OF 'FOXBIN2PRG.PRG'
.SortMethod( toRegObj.METHODS, @taMethods, @taCode, '', @tnMethodCount )
*-- Ubico los métodos protegidos y les cambio la definición.
*-- Los métodos se deben generar con la ruta completa, porque si no es imposible saber a que objeto corresponden,
*-- o si son de la clase.
IF tnMethodCount > 0 THEN
FOR I = 1 TO tnMethodCount
IF EMPTY(toRegObj.PARENT)
tcMethodName = toRegObj.OBJNAME + '.' + taMethods(I,1)
ELSE
DO CASE
CASE '.' $ toRegObj.PARENT
tcMethodName = SUBSTR(toRegObj.PARENT, AT('.', toRegObj.PARENT) + 1) + '.' + toRegObj.OBJNAME + '.' + taMethods(I,1)
CASE LEFT(toRegObj.PARENT + '.', LEN( toRegClass.OBJNAME + '.' ) ) == toRegClass.OBJNAME + '.'
tcMethodName = toRegObj.OBJNAME + '.' + taMethods(I,1)
OTHERWISE
tcMethodName = toRegObj.PARENT + '.' + toRegObj.OBJNAME + '.' + taMethods(I,1)
ENDCASE
ENDIF
*-- Genero el método SIN indentar, ya que se hace luego
*-- Sustituyo el TEXT/ENDTEXT aquí porque a veces quita espacios de la derecha, y eso es peligroso
tcMethods = tcMethods + CR_LF + 'PROCEDURE ' + tcMethodName
tcMethods = tcMethods + CR_LF + .IndentarMemo( taCode(taMethods(I,2)) )
tcMethods = tcMethods + CR_LF + 'ENDPROC'
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE get_NombresObjetosOLEPublic
LPARAMETERS ta_NombresObjsOle
*-- Obtengo los objetos "OLEPublic"
SELECT PADR(OBJNAME,100) OBJNAME ;
FROM TABLABIN ;
WHERE TABLABIN.PLATFORM = "COMMENT" AND TABLABIN.RESERVED2 == "OLEPublic" ;
ORDER BY 1 ;
INTO ARRAY ta_NombresObjsOle
ENDPROC
*******************************************************************************************************************
PROCEDURE get_PropsAndCommentsFrom_RESERVED3
*-- Sirve para el memo RESERVED3
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcMemo (v! IN ) Contenido de un campo MEMO
* tlSort (v? IN ) Indica si se deben ordenar alfabéticamente los nombres
* taPropsAndComments (@! OUT) Array con las propiedades y comentarios
* tnPropsAndComments_Count (@! OUT) Cantidad de propiedades
* tcSortedMemo (@? OUT) Contenido del campo memo ordenado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcMemo, tlSort, taPropsAndComments, tnPropsAndComments_Count, tcSortedMemo
EXTERNAL ARRAY taPropsAndComments
TRY
LOCAL laLines(1), I, lnPos, loEx AS EXCEPTION
tcSortedMemo = ''
tnPropsAndComments_Count = ALINES(laLines, tcMemo, 1+4)
IF tnPropsAndComments_Count <= 1 AND EMPTY(laLines)
tnPropsAndComments_Count = 0
EXIT
ENDIF
DIMENSION taPropsAndComments(tnPropsAndComments_Count,2)
FOR I = 1 TO tnPropsAndComments_Count
lnPos = AT(' ', laLines(I)) && Un espacio separa la propiedad de su comentario (si tiene)
IF lnPos = 0
taPropsAndComments(I,1) = laLines(I)
taPropsAndComments(I,2) = ''
ELSE
taPropsAndComments(I,1) = LEFT( laLines(I), lnPos - 1 )
taPropsAndComments(I,2) = SUBSTR( laLines(I), lnPos + 1 )
ENDIF
ENDFOR
IF tlSort AND THIS.l_PropSort_Enabled
ASORT( taPropsAndComments, 1, -1, 0, 1 )
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE get_PropsAndValuesFrom_PROPERTIES
*-- Sirve para el memo PROPERTIES
*---------------------------------------------------------------------------------------------------
* KNOWLEDGE BASE:
* 29/11/2013 FDBOZZO En un pageframe, si las props.nativas del mismo no están antes que las de
* los objetos contenidos, causa un error. Se deben ordenar primero las
* props.nativas (sin punto) y luego las de los objetos (con punto)
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcMemo (v! IN ) Contenido de un campo MEMO
* tnSort (v? IN ) Indica si se deben ordenar alfabéticamente los objetos y props (1), o no (0)
* taPropsAndValues (@! OUT) Array con las propiedades y comentarios
* tnPropsAndValues_Count (@! OUT) Cantidad de propiedades
* tcSortedMemo (@? OUT) Contenido del campo memo ordenado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcMemo, tnSort, taPropsAndValues, tnPropsAndValues_Count, tcSortedMemo
EXTERNAL ARRAY taPropsAndValues
TRY
LOCAL laItems(1), I, X, lnLenAcum, lnPosEQ, lcPropName, lnLenVal, lcValue, lcMethods
tcSortedMemo = ''
tnPropsAndValues_Count = 0
IF NOT EMPTY(m.tcMemo)
WITH THIS AS c_conversor_bin_a_prg OF 'FOXBIN2PRG.PRG'
lnItemCount = ALINES(laItems, m.tcMemo, 0, CR_LF) && Específicamente CR+LF para que no reconozca los CR o LF por separado
X = 0
IF lnItemCount <= 1 AND EMPTY(laItems)
lnItemCount = 0
EXIT
ENDIF
*-- 1) OBTENCIÓN Y SEPARACIÓN DE PROPIEDADES Y VALORES
*-- Crear un array con los valores especiales que pueden estar repartidos entre varias lineas
FOR I = 1 TO m.lnItemCount
IF EMPTY( laItems(I) )
LOOP
ENDIF
X = X + 1
DIMENSION taPropsAndValues(X,2)
IF C_MPROPHEADER $ laItems(I)
*-- Solo entrará por aquí cuando se evalúe una propiedad de PROPERTIES con un valor especial (largo)
lnLenAcum = 0
lnPosEQ = AT( '=', laItems(I) )
lcPropName = LEFT( laItems(I), lnPosEQ - 2 )
lnLenVal = INT( VAL( SUBSTR( laItems(I), lnPosEQ + 2 + 517, 8) ) )
lcValue = SUBSTR( laItems(I), lnPosEQ + 2 + 517 + 8 )
IF LEN( lcValue ) < lnLenVal
*-- Como el valor es multi-línea, debo agregarle los CR_LF que le quitó el ALINES()
FOR I = I + 1 TO m.lnItemCount
lcValue = lcValue + CR_LF + laItems(I)
IF LEN( lcValue ) >= lnLenVal
EXIT
ENDIF
ENDFOR
lcValue = C_FB2P_VALUE_I + CR_LF + lcValue + CR_LF + C_FB2P_VALUE_F
ELSE
lcValue = C_FB2P_VALUE_I + lcValue + C_FB2P_VALUE_F
ENDIF
*-- Es un valor especial, por lo que se encapsula en un marcador especial
taPropsAndValues(X,1) = lcPropName
taPropsAndValues(X,2) = .normalizarValorPropiedad( lcPropName, lcValue, '' )
ELSE
*-- Propiedad normal
*-- SI HACE FALTA QUE LOS MÉTODOS ESTÉN AL FINAL, DESCOMENTAR ESTO (Y EL DE MÁS ABAJO)
*IF LEFT(laItems(I), 1) == '*' && Only Reserved3 have this
* LOOP
*ENDIF
lnPosEQ = AT( '=', laItems(I) )
taPropsAndValues(X,1) = LEFT( laItems(I), lnPosEQ - 2 )
taPropsAndValues(X,2) = .normalizarValorPropiedad( taPropsAndValues(X,1), LTRIM( SUBSTR( laItems(I), lnPosEQ + 2 ) ), '' )
ENDIF
ENDFOR
tnPropsAndValues_Count = X
lcMethods = ''
*-- 2) SORT
.sortPropsAndValues( @taPropsAndValues, tnPropsAndValues_Count, tnSort )
*-- Agregar propiedades primero
FOR I = 1 TO m.tnPropsAndValues_Count
*-- SI HACE FALTA QUE LOS MÉTODOS ESTÉN AL FINAL, DESCOMENTAR ESTO (Y EL DE MÁS ARRIBA)
*IF LEFT(taPropsAndValues(I,1), 1) == '*' && Only Reserved3 have this
* lcMethods = m.lcMethods + m.taPropsAndValues(I,1) + ' = ' + m.taPropsAndValues(I,2) + CR_LF
* LOOP
*ENDIF
tcSortedMemo = m.tcSortedMemo + m.taPropsAndValues(I,1) + ' = ' + m.taPropsAndValues(I,2) + CR_LF
ENDFOR
*-- Agregar métodos al final
tcSortedMemo = m.tcSortedMemo + m.lcMethods
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE get_PropsFrom_PROTECTED
*-- Sirve para el memo PROTECTED
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcMemo (v! IN ) Contenido de un campo MEMO
* tlSort (v? IN ) Indica si se deben ordenar alfabéticamente los nombres
* taProtected (@! OUT) Array con las propiedades y comentarios
* tnProtected_Count (@! OUT) Cantidad de propiedades
* tcSortedMemo (@? OUT) Contenido del campo memo ordenado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcMemo, tlSort, taProtected, tnProtected_Count, tcSortedMemo
EXTERNAL ARRAY taProtected
tcSortedMemo = ''
tnProtected_Count = ALINES(taProtected, tcMemo, 1+4)
IF tnProtected_Count <= 1 AND EMPTY(taProtected)
tnProtected_Count = 0
ELSE
IF tlSort AND THIS.l_PropSort_Enabled
ASORT( taProtected, 1, -1, 0, 1 )
ENDIF
FOR I = 1 TO tnProtected_Count
tcSortedMemo = tcSortedMemo + taProtected(I) + CR_LF
ENDFOR
ENDIF
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE IndentarMemo
LPARAMETERS tcMethod, tcIndentation
*-- INDENTA EL CÓDIGO DE UN MÉTODO DADO Y QUITA LA CABECERA DE MÉTODO (PROCEDURE/ENDPROC) SI LA ENCUENTRA
TRY
LOCAL I, X, lcMethod, llProcedure, lnInicio, lnFin, laLineas(1)
lcMethod = ''
llProcedure = ( LEFT(tcMethod,10) == 'PROCEDURE ' ;
OR LEFT(tcMethod,17) == 'HIDDEN PROCEDURE ' ;
OR LEFT(tcMethod,20) == 'PROTECTED PROCEDURE ' )
lnInicio = 1
lnFin = ALINES(laLineas, tcMethod)
IF VARTYPE(tcIndentation) # 'C'
tcIndentation = ''
ENDIF
*-- Quito las líneas en blanco luego del final del ENDPROC
X = 0
FOR I = lnFin TO 1 STEP -1
IF NOT EMPTY(laLineas(I)) && Última línea de código
IF LEFT( laLineas(I), 10 ) <> C_ENDPROC
*ERROR 'Procedimiento sin cerrar. La última línea de código debe ser ENDPROC. [' + laLineas(1) + ']'
ERROR (TEXTMERGE(C_PROCEDURE_NOT_CLOSED_ON_LINE_LOC))
ENDIF
EXIT
ENDIF
X = X + 1
ENDFOR
IF X > 0
lnFin = lnFin - X
DIMENSION laLineas(lnFin)
ENDIF
*-- Si encuentra la cabecera de un PROCEDURE, la saltea
IF llProcedure
lnInicio = 2
lnFin = lnFin - 1
ENDIF
FOR I = lnInicio TO lnFin
*-- TEXT/ENDTEXT aquí da error 2044 de recursividad. No usar.
lcMethod = lcMethod + CR_LF + tcIndentation + laLineas(I)
ENDFOR
lcMethod = SUBSTR(lcMethod,3) && Quito el primer ENTER (CR+LF)
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcMethod
ENDPROC
*******************************************************************************************************************
PROCEDURE MemoInOneLine( tcMethod )
TRY
LOCAL lcLine, I
lcLine = ''
IF NOT EMPTY(tcMethod)
FOR I = 1 TO ALINES(laLines, m.tcMethod, 0)
lcLine = lcLine + ', ' + laLines(I)
ENDFOR
lcLine = SUBSTR(lcLine, 3)
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcLine
ENDPROC
*******************************************************************************************************************
PROCEDURE set_MultilineMemoWithAddObjectProperties
LPARAMETERS taPropsAndValues, tnPropCount, tcLeftIndentation, tlNormalizeLine
EXTERNAL ARRAY taPropsAndValues
TRY
LOCAL lcLine, I, lcComentarios, laLines(1), lcFinDeLinea_Coma_PuntoComa_CR
lcLine = ''
lcFinDeLinea = ', ;' + CR_LF
IF tnPropCount > 0
IF VARTYPE(tcLeftIndentation) # 'C'
tcLeftIndentation = ''
ENDIF
FOR I = 1 TO tnPropCount
lcLine = lcLine + tcLeftIndentation + taPropsAndValues(I,1) + ' = ' + taPropsAndValues(I,2) + lcFinDeLinea
ENDFOR
*-- Quito el ", ;<CRLF>" final
lcLine = tcLeftIndentation + SUBSTR(lcLine, 1 + LEN(tcLeftIndentation), LEN(lcLine) - LEN(tcLeftIndentation) - LEN(lcFinDeLinea))
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcLine
ENDPROC
*******************************************************************************************************************
PROCEDURE SortMethod
LPARAMETERS tcMethod, taMethods, taCode, tcSorted, tnMethodCount
*-- 29/10/2013 Fernando D. Bozzo
*-- Se tiene en cuenta la posibilidad de que haya un PROC/ENDPROC dentro de un TEXT/ENDTEXT
*-- cuando es usado en un generador de código o similar.
EXTERNAL ARRAY taMethods, taCode
*-- ESTRUCTURA DE LOS ARRAYS CREADOS:
*-- taMethods[1,3]
*-- Nombre Método
*-- Posición Original
*-- Tipo (HIDDEN/PROTECTED/NORMAL)
*-- taCode[1]
*-- Bloque de código del método en su posición original
TRY
LOCAL lnLineCount, laLine(1), I, lnTextNodes, tcSorted
LOCAL loEx AS EXCEPTION
DIMENSION taMethods(1,3)
STORE '' TO taMethods, m.tcSorted, taCode
tnMethodCount = 0
IF NOT EMPTY(m.tcMethod) AND LEFT(m.tcMethod,9) == "ENDPROC"+CHR(13)+CHR(10)
tcMethod = SUBSTR(m.tcMethod,10)
ENDIF
IF NOT EMPTY(m.tcMethod)
DIMENSION laLine(1), taMethods(1,3)
STORE '' TO laLine, taMethods, taCode
STORE 0 TO tnMethodCount, lnTextNodes
lnLineCount = ALINES(laLine, m.tcMethod) && NO aplicar nungún formato ni limpieza, que es el CÓDIGO FUENTE
*-- Delete beginning empty lines before first "PROCEDURE", that is the first not empty line.
FOR I = 1 TO lnLineCount
IF NOT EMPTY(laLine(I))
IF I > 1
FOR X = I-1 TO 1 STEP -1
ADEL(laLine, X)
ENDFOR
lnLineCount = lnLineCount - I + 1
DIMENSION laLine(lnLineCount)
ENDIF
EXIT
ENDIF
ENDFOR
*-- Delete ending empty lines after last "ENDPROC", that is the last not empty line.
FOR I = lnLineCount TO 1 STEP -1
IF EMPTY(laLine(I))
ADEL(laLine, I)
ELSE
IF I < lnLineCount
lnLineCount = I
DIMENSION laLine(lnLineCount)
ENDIF
EXIT
ENDIF
ENDFOR
*-- Analyze and count line methods, get method names and consolidate block code
FOR I = 1 TO lnLineCount
DO CASE
CASE LEFT(laLine(I), 4) == C_TEXT
lnTextNodes = lnTextNodes + 1
taCode(tnMethodCount) = taCode(tnMethodCount) + laLine(I) + CR_LF
CASE LEFT(laLine(I), 7) == C_ENDTEXT
lnTextNodes = lnTextNodes - 1
taCode(tnMethodCount) = taCode(tnMethodCount) + laLine(I) + CR_LF
CASE lnTextNodes = 0 AND LEFT(laLine(I), 10) == 'PROCEDURE '
tnMethodCount = tnMethodCount + 1
DIMENSION taMethods(tnMethodCount, 3), taCode(tnMethodCount)
taMethods(tnMethodCount, 1) = RTRIM( SUBSTR(laLine(I), 11) )
taMethods(tnMethodCount, 2) = tnMethodCount
taMethods(tnMethodCount, 3) = ''
taCode(tnMethodCount) = laLine(I) + CR_LF
CASE lnTextNodes = 0 AND LEFT(laLine(I), 17) == 'HIDDEN PROCEDURE '
tnMethodCount = tnMethodCount + 1
DIMENSION taMethods(tnMethodCount, 3), taCode(tnMethodCount)
taMethods(tnMethodCount, 1) = RTRIM( SUBSTR(laLine(I), 18) )
taMethods(tnMethodCount, 2) = tnMethodCount
taMethods(tnMethodCount, 3) = 'HIDDEN '
taCode(tnMethodCount) = laLine(I) + CR_LF
CASE lnTextNodes = 0 AND LEFT(laLine(I), 20) == 'PROTECTED PROCEDURE '
tnMethodCount = tnMethodCount + 1
DIMENSION taMethods(tnMethodCount, 3), taCode(tnMethodCount)
taMethods(tnMethodCount, 1) = RTRIM( SUBSTR(laLine(I), 21) )
taMethods(tnMethodCount, 2) = tnMethodCount
taMethods(tnMethodCount, 3) = 'PROTECTED '
taCode(tnMethodCount) = laLine(I) + CR_LF
CASE lnTextNodes = 0 AND LEFT(laLine(I), 7) == 'ENDPROC'
taCode(tnMethodCount) = taCode(tnMethodCount) + laLine(I) + CR_LF
CASE tnMethodCount = 0 && Skip empty lines before methods begin
OTHERWISE && Method Code
taCode(tnMethodCount) = taCode(tnMethodCount) + laLine(I) + CR_LF
ENDCASE
ENDFOR
*-- Alphabetical ordering of methods
IF THIS.l_MethodSort_Enabled
ASORT(taMethods,1,-1,0,1)
ENDIF
FOR I = 1 TO tnMethodCount
m.tcSorted = m.tcSorted + taCode(taMethods(I,2))
ENDFOR
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC && SordMethod
*******************************************************************************************************************
PROCEDURE write_ADD_OBJECTS_WithProperties
LPARAMETERS toRegObj
#IF .F.
LOCAL toRegObj AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lcMemo, laPropsAndValues(1,2), lnPropsAndValues_Count
*-- Defino los objetos a cargar
THIS.get_PropsAndValuesFrom_PROPERTIES( toRegObj.PROPERTIES, 1, @laPropsAndValues, @lnPropsAndValues_Count, @lcMemo )
lcMemo = THIS.set_MultilineMemoWithAddObjectProperties( @laPropsAndValues, @lnPropsAndValues_Count, C_TAB + C_TAB, .T. )
IF '.' $ toRegObj.PARENT
*-- Este caso: clase.objeto.objeto ==> se quita clase
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> ADD OBJECT '<<SUBSTR(toRegObj.Parent, AT('.', toRegObj.Parent)+1)>>.<<toRegObj.objName>>' AS <<ALLTRIM(toRegObj.Class)>> <<>>
ENDTEXT
ELSE
*-- Este caso: objeto
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> ADD OBJECT '<<toRegObj.objName>>' AS <<ALLTRIM(toRegObj.Class)>> <<>>
ENDTEXT
ENDIF
IF NOT EMPTY(lcMemo)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<C_WITH>> ;
<<lcMemo>>
ENDTEXT
ENDIF
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_TAB + C_TAB>><<C_END_OBJECT_I>> <<>>
ENDTEXT
IF NOT EMPTY(toRegObj.CLASSLOC)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
ClassLib="<<toRegObj.ClassLoc>>" <<>>
ENDTEXT
ENDIF
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2+4+8
BaseClass="<<toRegObj.Baseclass>>" <<>>
ENDTEXT
*-- Agrego metainformación para objetos OLE
IF toRegObj.BASECLASS == 'olecontrol'
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2+4+8
<<>> Nombre="<<IIF(EMPTY(toRegObj.Parent),'',toRegObj.Parent+'.') + toRegObj.objName>>"
Parent="<<toRegObj.Parent>>"
ObjName="<<toRegObj.objname>>"
OLEObject="<<STREXTRACT(toRegObj.ole2, 'OLEObject = ', CHR(13)+CHR(10), 1, 1+2)>>"
Value="<<STRCONV(toRegObj.ole,13)>>" <<>>
ENDTEXT
ENDIF
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<C_END_OBJECT_F>>
<<>>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE write_ALL_OBJECT_METHODS
LPARAMETERS tcMethods
*-- Finalmente, todos los métodos los ordeno y escribo juntos
LOCAL laMethods(1), laCode(1), lnMethodCount, I, lcMethods, lcMethods2
IF NOT EMPTY(tcMethods)
STORE '' TO lcMethods, lcMethods2
DIMENSION laMethods(1,3)
WITH THIS AS c_conversor_bin_a_prg OF 'FOXBIN2PRG.PRG'
.SortMethod( @tcMethods, @laMethods, @laCode, '', @lnMethodCount )
FOR I = 1 TO lnMethodCount
*-- Genero los métodos indentados
*-- Sustituyo el TEXT/ENDTEXT aquí porque a veces quita espacios de la derecha, y eso es peligroso
lcMethods = lcMethods + CR_LF + C_TAB + laMethods(I,3) + C_PROCEDURE + ' ' + laMethods(I,1)
lcMethods = lcMethods + CR_LF + .IndentarMemo( laCode(laMethods(I,2)), CHR(9) + CHR(9) )
lcMethods = lcMethods + CR_LF + C_TAB + C_ENDPROC
lcMethods = lcMethods + CR_LF
ENDFOR
ENDWITH && THIS
C_FB2PRG_CODE = C_FB2PRG_CODE + lcMethods
ENDIF
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE write_CLASS_METHODS
LPARAMETERS tnMethodCount, taMethods, taCode, taProtected, taPropsAndComments
*-- DEFINIR MÉTODOS DE LA CLASE
*-- Ubico los métodos protegidos y les cambio la definición
EXTERNAL ARRAY taMethods, taCode, taProtected, taPropsAndComments
TRY
LOCAL lcMethod, lnProtectedItem, lnCommentRow, lcProcDef, lcMethods, lcMethods2
STORE '' TO lcMethod, lcProcDef, lcMethods, lcMethods2
IF tnMethodCount > 0 THEN
WITH THIS AS c_conversor_bin_a_prg OF 'FOXBIN2PRG.PRG'
FOR I = 1 TO tnMethodCount
lcMethod = CHRTRAN( taMethods(I,1), '^', '' )
lnProtectedItem = ASCAN( taProtected, taMethods(I,1), 1, 0, 0, 1)
lnCommentRow = ASCAN( taPropsAndComments, '*' + lcMethod, 1, 0, 1, 1+8)
DO CASE
CASE lnProtectedItem = 0
*-- Método común
lcProcDef = 'PROCEDURE'
CASE taProtected(lnProtectedItem) == taMethods(I,1)
*-- Método protegido
lcProcDef = 'PROTECTED PROCEDURE'
CASE taProtected(lnProtectedItem) == taMethods(I,1) + '^'
*-- Método oculto
lcProcDef = 'HIDDEN PROCEDURE'
ENDCASE
*-- Nombre del método
TEXT TO lcMethods ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<lcProcDef>> <<taMethods(I,1)>>
ENDTEXT
*-- Comentarios del método (si tiene)
IF lnCommentRow > 0 AND NOT EMPTY(taPropsAndComments(lnCommentRow,2))
TEXT TO lcMethods ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<>> && <<taPropsAndComments(lnCommentRow,2)>>
ENDTEXT
ENDIF
*-- Código del método
*-- Sustituyo el TEXT/ENDTEXT aquí porque a veces quita espacios de la derecha, y eso es peligroso
lcMethods = lcMethods + CR_LF + .IndentarMemo( taCode(taMethods(I,2)), C_TAB + C_TAB )
lcMethods = lcMethods + CR_LF + C_TAB + 'ENDPROC'
lcMethods = lcMethods + CR_LF
ENDFOR
ENDWITH && THIS
C_FB2PRG_CODE = C_FB2PRG_CODE + C_TAB + lcMethods &&+ CR_LF
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE write_CLASS_PROPERTIES
LPARAMETERS toRegClass, taPropsAndValues, taPropsAndComments, taProtected
EXTERNAL ARRAY taPropsAndValues, taPropsAndComments
TRY
LOCAL lnPropsAndValues_Count, lcHiddenProp, lcProtectedProp, lcPropsMethodsDefd, lnPropsAndComments_Count, I ;
, lcPropName, lnProtectedItem, lcComentarios, lnProtected_Count
WITH THIS AS c_conversor_bin_a_prg OF 'FOXBIN2PRG.PRG'
*-- DEFINIR PROPIEDADES ( HIDDEN, PROTECTED, *DEFINED_PAM )
DIMENSION taProtected(1)
STORE '' TO lcHiddenProp, lcProtectedProp, lcPropsMethodsDefd
.get_PropsAndValuesFrom_PROPERTIES( toRegClass.PROPERTIES, 1, @taPropsAndValues, @lnPropsAndValues_Count, '' )
.get_PropsAndCommentsFrom_RESERVED3( toRegClass.RESERVED3, .T., @taPropsAndComments, @lnPropsAndComments_Count, '' )
.get_PropsFrom_PROTECTED( toRegClass.PROTECTED, .T., @taProtected, @lnProtected_Count, '' )
IF lnPropsAndValues_Count > 0 THEN
*-- Recorro las propiedades (campo Properties) para ir conformando
*-- las definiciones HIDDEN y PROTECTED
FOR I = 1 TO lnPropsAndValues_Count
IF EMPTY(taPropsAndValues(I,1))
LOOP
ENDIF
lnProtectedItem = ASCAN(taProtected, taPropsAndValues(I,1), 1, 0, 0, 1)
DO CASE
CASE lnProtectedItem = 0
*-- Propiedad común
CASE LOWER( taProtected(lnProtectedItem) ) == LOWER( taPropsAndValues(I,1) )
*-- Propiedad protegida
lcProtectedProp = lcProtectedProp + ',' + taPropsAndValues(I,1)
CASE LOWER( taProtected(lnProtectedItem) ) == LOWER( taPropsAndValues(I,1) + '^' )
*-- Propiedad oculta
lcHiddenProp = lcHiddenProp + ',' + taPropsAndValues(I,1)
ENDCASE
ENDFOR
*-- Segunda barrida para las propiedades Hidden/Protected que no estén definidas en Properties
FOR I = 1 TO lnProtected_Count
IF EMPTY(taProtected(I,1)) OR ASCAN(taPropsAndValues, CHRTRAN( taProtected(I), '^', '' ), 1, 0, 1, 1) > 0
LOOP
ENDIF
IF RIGHT( taProtected(I), 1 ) == '^'
*-- Propiedad oculta
lcHiddenProp = lcHiddenProp + ',' + CHRTRAN( taProtected(I), '^', '' )
ELSE
*-- Propiedad protegida
lcProtectedProp = lcProtectedProp + ',' + taProtected(I)
ENDIF
ENDFOR
.write_DEFINED_PAM( @taPropsAndComments, lnPropsAndComments_Count )
.write_HIDDEN_Properties( @lcHiddenProp )
.write_PROTECTED_Properties( @lcProtectedProp )
*-- Escribo las propiedades de la clase y sus comentarios (los comentarios aquí son redundantes)
FOR I = 1 TO ALEN(taPropsAndValues, 1)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<taPropsAndValues(I,1)>> = <<taPropsAndValues(I,2)>>
ENDTEXT
lnComment = ASCAN( taPropsAndComments, taPropsAndValues(I,1), 1, 0, 1, 1+8)
IF lnComment > 0 AND NOT EMPTY(taPropsAndComments(lnComment,2))
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<>> && <<taPropsAndComments(lnComment,2)>>
ENDTEXT
ENDIF
ENDFOR
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
ENDTEXT
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE write_DEFINED_PAM
*-- Escribo propiedades DEFINED (Reserved3) en este formato:
*<DefinedPropArrayMethod>
*m: *metodovacio_con_comentarios && Este método no tiene código, pero tiene comentarios. A ver que pasa!
*m: *mimetodo && Mi metodo
*p: prop1 && Mi prop 1
*p: prop_especial_cr &&
*a: ^array_1_d[1,0] && Array 1 dimensión (1)
*a: ^array_2_d[1,2] && Array una dimension (1,2)
*p: _memberdata && XML Metadata for customizable properties
*</DefinedPropArrayMethod>
LPARAMETERS taPropsAndComments, tnPropsAndComments_Count
IF tnPropsAndComments_Count > 0
LOCAL I, lcPropsMethodsDefd
lcPropsMethodsDefd = ''
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_DEFINED_PAM_I>>
ENDTEXT
FOR I = 1 TO tnPropsAndComments_Count
IF EMPTY(taPropsAndComments(I,1))
LOOP
ENDIF
lcType = LEFT( taPropsAndComments(I,1), 1 )
lcType = ICASE( lcType == '*', 'm' ;
, lcType == '^', 'a' ;
, 'p' )
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> *<<lcType>>: <<taPropsAndComments(I,1)>>
ENDTEXT
IF NOT EMPTY(taPropsAndComments(I,2))
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<>> <<'&'>><<'&'>> <<taPropsAndComments(I,2)>>
ENDTEXT
ENDIF
ENDFOR
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_DEFINED_PAM_F>>
ENDTEXT
C_FB2PRG_CODE = C_FB2PRG_CODE + CR_LF
ENDIF
ENDPROC
*******************************************************************************************************************
PROCEDURE write_DEFINE_CLASS
LPARAMETERS ta_NombresObjsOle, toRegClass
LOCAL lcOF_Classlib, llOleObject
lcOF_Classlib = ''
llOleObject = ( ASCAN( ta_NombresObjsOle, toRegClass.OBJNAME, 1, 0, 1, 1+8) > 0 )
IF NOT EMPTY(toRegClass.CLASSLOC)
lcOF_Classlib = 'OF "' + ALLTRIM(toRegClass.CLASSLOC) + '" '
ENDIF
*-- DEFINICIÓN DE LA CLASE ( DEFINE CLASS 'className' AS 'classType' [OF 'classLib'] [OLEPUBLIC] )
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<'DEFINE CLASS'>> <<ALLTRIM(toRegClass.ObjName)>> AS <<ALLTRIM(toRegClass.Class)>> <<lcOF_Classlib + IIF(llOleObject, 'OLEPUBLIC', '')>>
ENDTEXT
ENDPROC
*******************************************************************************************************************
PROCEDURE write_DEFINE_CLASS_COMMENTS
LPARAMETERS toRegClass
*-- Comentario de la clase
IF NOT EMPTY(toRegClass.RESERVED7) THEN
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
<<>> <<'&'+'&'>> <<toRegClass.Reserved7>>
ENDTEXT
ENDIF
ENDPROC
*******************************************************************************************************************
PROCEDURE write_ENDDEFINE_SiCorresponde
LPARAMETERS tnLastClass
IF tnLastClass = 1
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<'ENDDEFINE'>>
<<>>
ENDTEXT
ENDIF
ENDPROC
*******************************************************************************************************************
PROCEDURE write_INCLUDE
LPARAMETERS toReg
*-- #INCLUDE
IF NOT EMPTY(toReg.RESERVED8) THEN
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> #INCLUDE "<<toReg.Reserved8>>"
ENDTEXT
ENDIF
ENDPROC
*******************************************************************************************************************
PROCEDURE write_CLASSMETADATA
LPARAMETERS toRegClass
*-- Agrego Metadatos de la clase (Baseclass, Timestamp, Scale, Uniqueid)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2+4+8
<<>> <<C_CLASSDATA_I>>
Baseclass="<<toRegClass.Baseclass>>"
Timestamp="<<ALLTRIM(THIS.getTimeStamp(toRegClass.Timestamp))>>"
Scale="<<toRegClass.Reserved6>>"
Uniqueid="<<toRegClass.Uniqueid>>"
ENDTEXT
IF NOT EMPTY(toRegClass.OLE2)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2+4+8
<<>> Nombre="<<IIF(EMPTY(toRegClass.Parent),'',toRegClass.Parent+'.') + toRegClass.objName>>"
Parent="<<toRegClass.Parent>>"
ObjName="<<toRegClass.objname>>"
OLEObject="<<STREXTRACT(toRegClass.ole2, 'OLEObject = ', CHR(13)+CHR(10), 1, 1+2)>>"
Value="<<STRCONV(toRegClass.ole,13)>>"
ENDTEXT
ENDIF
IF NOT EMPTY(toRegClass.RESERVED5)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2+4+8
ProjectClassIcon="<<toRegClass.Reserved5>>"
ENDTEXT
ENDIF
IF NOT EMPTY(toRegClass.RESERVED4)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2+4+8
ClassIcon="<<toRegClass.Reserved4>>"
ENDTEXT
ENDIF
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2+4+8
<<C_CLASSDATA_F>>
ENDTEXT
C_FB2PRG_CODE = C_FB2PRG_CODE + CR_LF
ENDPROC
*******************************************************************************************************************
PROCEDURE write_OBJECTMETADATA
LPARAMETERS toRegObj
LOCAL lcNombre
*-- Agrego Metadatos de los objetos (Timestamp, UniqueID)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
ENDTEXT
IF '.' $ toRegObj.PARENT
*-- Este caso: clase.objeto.objeto ==> se quita clase
lcNombre = SUBSTR(toRegObj.PARENT, AT('.', toRegObj.PARENT)+1) + '.' + toRegObj.OBJNAME
ELSE
*-- Este caso: objeto
lcNombre = toRegObj.OBJNAME
ENDIF
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2+4+8
<<>> <<C_OBJECTDATA_I>>
ObjPath="<<lcNombre>>"
UniqueID="<<toRegObj.Uniqueid>>"
Timestamp="<<ALLTRIM(THIS.getTimeStamp(toRegObj.Timestamp))>>"
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2+4+8
<<C_OBJECTDATA_F>>
ENDTEXT
ENDPROC
*******************************************************************************************************************
PROCEDURE write_HIDDEN_Properties
*-- Escribo la definición HIDDEN de propiedades
LPARAMETERS tcHiddenProp
IF NOT EMPTY(tcHiddenProp)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> HIDDEN <<SUBSTR(tcHiddenProp,2)>>
ENDTEXT
ENDIF
ENDPROC
*******************************************************************************************************************
PROCEDURE write_PROTECTED_Properties
*-- Escribo la definición PROTECTED de propiedades
LPARAMETERS tcProtectedProp
IF NOT EMPTY(tcProtectedProp)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> PROTECTED <<SUBSTR(tcProtectedProp,2)>>
ENDTEXT
ENDIF
ENDPROC
*******************************************************************************************************************
PROCEDURE write_CABECERA_REPORTE
LPARAMETERS toReg
TRY
LOCAL lc_TAG_REPORTE, loEx AS EXCEPTION
lc_TAG_REPORTE_I = '<' + C_TAG_REPORTE + ' '
lc_TAG_REPORTE_F = '</' + C_TAG_REPORTE + '>'
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<lc_TAG_REPORTE_I>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> platform="WINDOWS " uniqueid="<<toReg.UniqueID>>" timestamp="<<toReg.TimeStamp>>" objtype="<<toReg.ObjType>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
objcode="<<toReg.ObjCode>>" name="<<toReg.Name>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
vpos="<<toReg.vpos>>" hpos="<<toReg.hpos>>" height="<<toReg.height>>" width="<<toReg.width>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
order="<<toReg.order>>" unique="<<toReg.unique>>" comment="<<toReg.comment>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
environ="<<toReg.environ>>" boxchar="<<toReg.boxchar>>" fillchar="<<toReg.fillchar>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
pengreen="<<toReg.pengreen>>" penblue="<<toReg.penblue>>" fillred="<<toReg.fillred>>" fillgreen="<<toReg.fillgreen>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
fillblue="<<toReg.fillblue>>" pensize="<<toReg.pensize>>" penpat="<<toReg.penpat>>" fillpat="<<toReg.fillpat>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
fontface="<<toReg.fontface>>" fontstyle="<<toReg.fontstyle>>" fontsize="<<toReg.fontsize>>" mode="<<toReg.mode>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
ruler="<<toReg.ruler>>" rulerlines="<<toReg.rulerlines>>" grid="<<toReg.grid>>" gridv="<<toReg.gridv>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
gridh="<<toReg.gridh>>" float="<<toReg.float>>" stretch="<<toReg.stretch>>" stretchtop="<<toReg.stretchtop>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
top="<<toReg.top>>" bottom="<<toReg.bottom>>" suptype="<<toReg.suptype>>" suprest="<<toReg.suprest>>" norepeat="<<toReg.norepeat>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
resetrpt="<<toReg.resetrpt>>" pagebreak="<<toReg.pagebreak>>" colbreak="<<toReg.colbreak>>" resetpage="<<toReg.resetpage>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
general="<<toReg.general>>" spacing="<<toReg.spacing>>" double="<<toReg.double>>" swapheader="<<toReg.swapheader>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
swapfooter="<<toReg.swapfooter>>" ejectbefor="<<toReg.ejectbefor>>" ejectafter="<<toReg.ejectafter>>" plain="<<toReg.plain>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
summary="<<toReg.summary>>" addalias="<<toReg.addalias>>" offset="<<toReg.offset>>" topmargin="<<toReg.topmargin>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
botmargin="<<toReg.botmargin>>" totaltype="<<toReg.totaltype>>" resettotal="<<toReg.resettotal>>" resoid="<<toReg.resoid>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
curpos="<<toReg.curpos>>" supalways="<<toReg.supalways>>" supovflow="<<toReg.supovflow>>" suprpcol="<<toReg.suprpcol>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
supgroup="<<toReg.supgroup>>" supvalchng="<<toReg.supvalchng>>" supexpr="<<toReg.supexpr>>" >
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <picture><![CDATA[<<toReg.picture>>]]>
<<>> <tag><![CDATA[<<THIS.encode_SpecialCodes_1_31( toReg.tag )>>]]>
<<>> <tag2><![CDATA[<<STRCONV( toReg.tag2,13 )>>]]>
<<>> <penred><![CDATA[<<toReg.penred>>]]>
<<>> <style><![CDATA[<<toReg.style>>]]>
<<>> <expr><![CDATA[<<toReg.expr>>]]>
<<>> <user><![CDATA[<<toReg.user>>]]>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<lc_TAG_REPORTE_F>>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE write_DETALLE_REPORTE
LPARAMETERS toReg
TRY
LOCAL lc_TAG_REPORTE, loEx AS EXCEPTION
lc_TAG_REPORTE_I = '<' + C_TAG_REPORTE + ' '
lc_TAG_REPORTE_F = '</' + C_TAG_REPORTE + '>'
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<lc_TAG_REPORTE_I>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> platform="WINDOWS " uniqueid="<<toReg.UniqueID>>" timestamp="<<toReg.TimeStamp>>" objtype="<<toReg.ObjType>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
objcode="<<toReg.ObjCode>>" name="<<toReg.Name>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
vpos="<<toReg.vpos>>" hpos="<<toReg.hpos>>" height="<<toReg.height>>" width="<<toReg.width>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
order="<<toReg.order>>" unique="<<toReg.unique>>" comment="<<toReg.comment>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
environ="<<toReg.environ>>" boxchar="<<toReg.boxchar>>" fillchar="<<toReg.fillchar>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
pengreen="<<toReg.pengreen>>" penblue="<<toReg.penblue>>" fillred="<<toReg.fillred>>" fillgreen="<<toReg.fillgreen>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
fillblue="<<toReg.fillblue>>" pensize="<<toReg.pensize>>" penpat="<<toReg.penpat>>" fillpat="<<toReg.fillpat>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
fontface="<<toReg.fontface>>" fontstyle="<<toReg.fontstyle>>" fontsize="<<toReg.fontsize>>" mode="<<toReg.mode>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
ruler="<<toReg.ruler>>" rulerlines="<<toReg.rulerlines>>" grid="<<toReg.grid>>" gridv="<<toReg.gridv>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
gridh="<<toReg.gridh>>" float="<<toReg.float>>" stretch="<<toReg.stretch>>" stretchtop="<<toReg.stretchtop>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
top="<<toReg.top>>" bottom="<<toReg.bottom>>" suptype="<<toReg.suptype>>" suprest="<<toReg.suprest>>" norepeat="<<toReg.norepeat>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
resetrpt="<<toReg.resetrpt>>" pagebreak="<<toReg.pagebreak>>" colbreak="<<toReg.colbreak>>" resetpage="<<toReg.resetpage>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
general="<<toReg.general>>" spacing="<<toReg.spacing>>" double="<<toReg.double>>" swapheader="<<toReg.swapheader>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
swapfooter="<<toReg.swapfooter>>" ejectbefor="<<toReg.ejectbefor>>" ejectafter="<<toReg.ejectafter>>" plain="<<toReg.plain>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
summary="<<toReg.summary>>" addalias="<<toReg.addalias>>" offset="<<toReg.offset>>" topmargin="<<toReg.topmargin>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
botmargin="<<toReg.botmargin>>" totaltype="<<toReg.totaltype>>" resettotal="<<toReg.resettotal>>" resoid="<<toReg.resoid>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
curpos="<<toReg.curpos>>" supalways="<<toReg.supalways>>" supovflow="<<toReg.supovflow>>" suprpcol="<<toReg.suprpcol>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
supgroup="<<toReg.supgroup>>" supvalchng="<<toReg.supvalchng>>" supexpr="<<toReg.supexpr>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <picture><![CDATA[<<toReg.picture>>]]>
<<>> <tag><![CDATA[<<THIS.encode_SpecialCodes_1_31( toReg.tag )>>]]>
<<>> <tag2><![CDATA[<<STRCONV( toReg.tag2,13 )>>]]>
<<>> <penred><![CDATA[<<toReg.penred>>]]>
<<>> <style><![CDATA[<<toReg.style>>]]>
<<>> <expr><![CDATA[<<toReg.expr>>]]>
<<>> <user><![CDATA[<<toReg.user>>]]>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<lc_TAG_REPORTE_F>>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE write_DATAENVIRONMENT_REPORTE
LPARAMETERS toReg
TRY
LOCAL lc_TAG_REPORTE, loEx AS EXCEPTION
lc_TAG_REPORTE_I = '<' + C_TAG_REPORTE + ' '
lc_TAG_REPORTE_F = '</' + C_TAG_REPORTE + '>'
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<lc_TAG_REPORTE_I>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> platform="WINDOWS " uniqueid="<<toReg.UniqueID>>" timestamp="<<toReg.TimeStamp>>" objtype="<<toReg.ObjType>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
objcode="<<toReg.ObjCode>>" name="<<toReg.Name>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
vpos="<<toReg.vpos>>" hpos="<<toReg.hpos>>" height="<<toReg.height>>" width="<<toReg.width>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
order="<<toReg.order>>" unique="<<toReg.unique>>" comment="<<toReg.comment>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
environ="<<toReg.environ>>" boxchar="<<toReg.boxchar>>" fillchar="<<toReg.fillchar>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
pengreen="<<toReg.pengreen>>" penblue="<<toReg.penblue>>" fillred="<<toReg.fillred>>" fillgreen="<<toReg.fillgreen>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
fillblue="<<toReg.fillblue>>" pensize="<<toReg.pensize>>" penpat="<<toReg.penpat>>" fillpat="<<toReg.fillpat>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
fontface="<<toReg.fontface>>" fontstyle="<<toReg.fontstyle>>" fontsize="<<toReg.fontsize>>" mode="<<toReg.mode>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
ruler="<<toReg.ruler>>" rulerlines="<<toReg.rulerlines>>" grid="<<toReg.grid>>" gridv="<<toReg.gridv>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
gridh="<<toReg.gridh>>" float="<<toReg.float>>" stretch="<<toReg.stretch>>" stretchtop="<<toReg.stretchtop>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
top="<<toReg.top>>" bottom="<<toReg.bottom>>" suptype="<<toReg.suptype>>" suprest="<<toReg.suprest>>" norepeat="<<toReg.norepeat>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
resetrpt="<<toReg.resetrpt>>" pagebreak="<<toReg.pagebreak>>" colbreak="<<toReg.colbreak>>" resetpage="<<toReg.resetpage>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
general="<<toReg.general>>" spacing="<<toReg.spacing>>" double="<<toReg.double>>" swapheader="<<toReg.swapheader>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
swapfooter="<<toReg.swapfooter>>" ejectbefor="<<toReg.ejectbefor>>" ejectafter="<<toReg.ejectafter>>" plain="<<toReg.plain>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
summary="<<toReg.summary>>" addalias="<<toReg.addalias>>" offset="<<toReg.offset>>" topmargin="<<toReg.topmargin>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
botmargin="<<toReg.botmargin>>" totaltype="<<toReg.totaltype>>" resettotal="<<toReg.resettotal>>" resoid="<<toReg.resoid>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
curpos="<<toReg.curpos>>" supalways="<<toReg.supalways>>" supovflow="<<toReg.supovflow>>" suprpcol="<<toReg.suprpcol>>" <<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2
supgroup="<<toReg.supgroup>>" supvalchng="<<toReg.supvalchng>>" supexpr="<<toReg.supexpr>>" <<>>
ENDTEXT
* NOTA: En el DataEnvironment el TAG2 es el TAG compilado, que se recompila con COMPILE REPORT <nombre>
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <picture><![CDATA[<<toReg.picture>>]]>
<<>> <tag><![CDATA[<<CR_LF>><<toReg.tag>>]]>
<<>> <tag2><![CDATA[]]>
<<>> <penred><![CDATA[<<toReg.penred>>]]>
<<>> <style><![CDATA[<<toReg.style>>]]>
<<>> <expr><![CDATA[<<toReg.expr>>]]>
<<>> <user><![CDATA[<<toReg.user>>]]>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<lc_TAG_REPORTE_F>>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE write_DefinicionObjetosOLE
*-- Crea la definición del tag *< OLE: /> con la información de todos los objetos OLE
LPARAMETERS toFoxBin2Prg
LOCAL lnOLECount, lcOLEChecksum, llOleExistente, loReg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
SELECT TABLABIN
SET ORDER TO PARENT_OBJ
lnOLECount = 0
SCAN ALL FOR TABLABIN.PLATFORM = "WINDOWS" AND BASECLASS = 'olecontrol'
SCATTER MEMO NAME loReg
IF toFoxBin2Prg.l_NoTimestamps
loReg.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loReg.UNIQUEID = ''
ENDIF
lcOLEChecksum = SYS(2007, loReg.OLE, 0, 1)
llOleExistente = .F.
IF lnOLECount > 0 AND ASCAN(laOLE, lcOLEChecksum, 1, 0, 0, 0) > 0
llOleExistente = .T.
ENDIF
lnOLECount = lnOLECount + 1
DIMENSION laOLE( lnOLECount )
laOLE( lnOLECount ) = lcOLEChecksum
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
ENDTEXT
ENDSCAN
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
*
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE FixOle2Fields
*******************************************************************************************************************
* (This method is taken from Open Source project TwoFox, from Christof Wallenhaupt - http://www.foxpert.com/downloads.htm)
* OLE2 contains the physical name of the OCX or DLL when a record refers to an ActiveX
* control. On different developer machines these controls can be located in different
* folders without affecting the code.
*
* When a control is stored outside the project directory, we assume that every developer
* is responsible for installing and registering the control. Therefore we only leave
* the file name which should be fixed. It's also sufficient for VFP to locate an OCX
* file when the control is not registered and the OCX file is stored in the current
* directory or the application path.
*--------------------------------------------------------------------------------------
* Project directory for comparision purposes
*--------------------------------------------------------------------------------------
LOCAL lcProjDir
lcProjDir = UPPER(ALLTRIM(THIS.cHomeDir))
IF RIGHT(m.lcProjDir,1) == "\"
lcProjDir = LEFT(m.lcProjDir, LEN(m.lcProjDir)-1)
ENDIF
*--------------------------------------------------------------------------------------
* Check all OLE2 fields
*--------------------------------------------------------------------------------------
LOCAL lcOcx
SCAN FOR NOT EMPTY(OLE2)
lcOcx = STREXTRACT (OLE2, "OLEObject = ", CHR(13), 1, 1+2)
IF THIS.OcxOutsideProjDir (m.lcOcx, m.lcProjDir)
THIS.TruncateOle2 (m.lcOcx)
ENDIF
ENDSCAN
ENDPROC
*******************************************************************************************************************
FUNCTION OcxOutsideProjDir
LPARAMETERS tcOcx, tcProjDir
*******************************************************************************************************************
* (This method is taken from Open Source project TwoFox, from Christof Wallenhaupt - http://www.foxpert.com/downloads.htm)
* Returns .T. when the OCX control resides outside the project directory
LOCAL lcOcxDir, llOutside
lcOcxDir = UPPER (JUSTPATH (m.tcOcx))
IF LEFT(m.lcOcxDir, LEN(m.tcProjDir)) == m.tcProjDir
llOutside = .F.
ELSE
llOutside = .T.
ENDIF
RETURN m.llOutside
*******************************************************************************************************************
* (This method is taken from Open Source project TwoFox, from Christof Wallenhaupt - http://www.foxpert.com/downloads.htm)
* Cambios de un campo OLE2 exclusivamente en el nombre del archivo
PROCEDURE TruncateOle2 (tcOcx)
REPLACE OLE2 WITH STRTRAN ( ;
OLE2 ;
,"OLEObject = " + m.tcOcx ;
,"OLEObject = " + JUSTFNAME(m.tcOcx) ;
)
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_vcx_a_prg AS c_conversor_bin_a_prg
#IF .F.
LOCAL THIS AS c_conversor_vcx_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase CL_MODULO con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
TRY
LOCAL lnCodError, loRegClass, loRegObj, lnMethodCount, laMethods(1), laCode(1), laProtected(1), lnLen, lnObjCount ;
, laPropsAndValues(1), laPropsAndComments(1), lnLastClass, lnRecno, lcMethods, lcObjName, la_NombresObjsOle(1) ;
, laObjs(1,3), I
STORE 0 TO lnCodError, lnLastClass, lnObjCount
STORE '' TO laMethods(1), laCode(1), laProtected(1), laPropsAndComments(1), laObjs(1)
STORE NULL TO loRegClass, loRegObj
WITH THIS AS c_conversor_vcx_a_prg OF 'FOXBIN2PRG.PRG'
USE (.c_InputFile) SHARED NOUPDATE ALIAS _TABLAORIG
SELECT * FROM _TABLAORIG INTO CURSOR TABLABIN
USE IN (SELECT("_TABLAORIG"))
INDEX ON PADR(LOWER(PLATFORM + IIF(EMPTY(PARENT),'',ALLTRIM(PARENT)+'.')+OBJNAME),240) TAG PARENT_OBJ OF TABLABIN ADDITIVE
SET ORDER TO 0 IN TABLABIN
C_FB2PRG_CODE = C_FB2PRG_CODE + toFoxBin2Prg.get_PROGRAM_HEADER()
.get_NombresObjetosOLEPublic( @la_NombresObjsOle )
.write_DefinicionObjetosOLE( toFoxBin2Prg )
*-- Escribo los métodos ordenados
lnLastClass = 0
*----------------------------------------------
*-- RECORRO LAS CLASES
*----------------------------------------------
SELECT TABLABIN
SET ORDER TO PARENT_OBJ
SCAN ALL FOR TABLABIN.PLATFORM = "WINDOWS" AND TABLABIN.RESERVED1=="Class"
SCATTER MEMO NAME loRegClass
IF toFoxBin2Prg.l_NoTimestamps
loRegClass.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegClass.UNIQUEID = ''
ELSE
loRegClass.UNIQUEID = ALLTRIM(loRegClass.UNIQUEID)
ENDIF
lcObjName = ALLTRIM(loRegClass.OBJNAME)
.write_ENDDEFINE_SiCorresponde( lnLastClass )
.write_DEFINE_CLASS( @la_NombresObjsOle, @loRegClass )
.write_DEFINE_CLASS_COMMENTS( @loRegClass )
.write_CLASSMETADATA( @loRegClass )
*-------------------------------------------------------------------------------
*-- RECORRO LOS OBJETOS DENTRO DE LA CLASE ACTUAL PARA EXPORTAR SU DEFINICIÓN
*-------------------------------------------------------------------------------
lnObjCount = 0
lnRecno = RECNO()
LOCATE FOR TABLABIN.PLATFORM = "WINDOWS" AND ALLTRIM(GETWORDNUM(TABLABIN.PARENT, 1, '.')) == lcObjName
SCAN REST WHILE TABLABIN.PLATFORM = "WINDOWS" AND ALLTRIM(GETWORDNUM(TABLABIN.PARENT, 1, '.')) == lcObjName
lnObjCount = lnObjCount + 1
DIMENSION laObjs(lnObjCount,3)
SCATTER MEMO NAME loRegObj
laObjs(lnObjCount,1) = loRegObj
laObjs(lnObjCount,2) = RECNO() && ZOrder
laObjs(lnObjCount,3) = lnObjCount && Alphabetic order
IF toFoxBin2Prg.l_NoTimestamps
loRegObj.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegObj.UNIQUEID = ''
ELSE
loRegObj.UNIQUEID = ALLTRIM(loRegObj.UNIQUEID)
ENDIF
loRegObj = NULL
ENDSCAN
GOTO RECORD (lnRecno)
ASORT(laObjs, 2, -1, 0, 0) && Orden por ZOrder
IF lnObjCount > 0
C_FB2PRG_CODE = C_FB2PRG_CODE + CR_LF + ' *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder '
FOR I = 1 TO lnObjCount
.write_OBJECTMETADATA( laObjs(I,1) )
ENDFOR
C_FB2PRG_CODE = C_FB2PRG_CODE + CR_LF
ENDIF
.write_INCLUDE( @loRegClass )
.write_CLASS_PROPERTIES( @loRegClass, @laPropsAndValues, @laPropsAndComments, @laProtected )
ASORT(laObjs, 3, -1, 0, 0) && Orden Alfabético (del SCAN original)
FOR I = 1 TO lnObjCount
.write_ADD_OBJECTS_WithProperties( laObjs(I,1) )
ENDFOR
*-- OBTENGO LOS MÉTODOS DE LA CLASE PARA POSTERIOR TRATAMIENTO
DIMENSION laMethods(1,3)
lcMethods = ''
.SortMethod( loRegClass.METHODS, @laMethods, @laCode, '', @lnMethodCount )
.write_CLASS_METHODS( @lnMethodCount, @laMethods, @laCode, @laProtected, @laPropsAndComments )
lnLastClass = 1
lcMethods = ''
*-- RECORRO LOS OBJETOS DENTRO DE LA CLASE ACTUAL PARA OBTENER SUS MÉTODOS
lnRecno = RECNO()
LOCATE FOR TABLABIN.PLATFORM = "WINDOWS" AND ALLTRIM(GETWORDNUM(TABLABIN.PARENT, 1, '.')) == lcObjName
SCAN REST ;
FOR TABLABIN.PLATFORM = "WINDOWS" AND NOT TABLABIN.RESERVED1=="Class" ;
WHILE ALLTRIM(GETWORDNUM(TABLABIN.PARENT, 1, '.')) == lcObjName
SCATTER MEMO NAME loRegObj
IF toFoxBin2Prg.l_NoTimestamps
loRegObj.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegObj.UNIQUEID = ''
ELSE
loRegObj.UNIQUEID = ALLTRIM(loRegObj.UNIQUEID)
ENDIF
.get_ADD_OBJECT_METHODS( @loRegObj, @loRegClass, @lcMethods )
ENDSCAN
.write_ALL_OBJECT_METHODS( @lcMethods )
GOTO RECORD (lnRecno)
ENDSCAN
.write_ENDDEFINE_SiCorresponde( lnLastClass )
*-- Genero el VC2
IF .l_Test
toModulo = C_FB2PRG_CODE
ELSE
lnLen = 1 &&LEN( toFoxBin2Prg.get_PROGRAM_HEADER() )
DO CASE
CASE FILE(.c_OutputFile) AND SUBSTR( FILETOSTR( .c_OutputFile ), lnLen ) == SUBSTR( C_FB2PRG_CODE, lnLen )
*.writeLog( 'El archivo de salida [' + .c_OutputFile + '] no se sobreescribe por ser igual al generado.' )
.writeLog( TEXTMERGE(C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC) )
CASE toFoxBin2Prg.doBackup( .F., .T., '', '', '' ) ;
AND toFoxBin2Prg.ChangeFileAttribute( .c_OutputFile, '-R' ) ;
AND STRTOFILE( C_FB2PRG_CODE, .c_OutputFile ) = 0
*ERROR 'No se puede generar el archivo [' + .c_OutputFile + '] porque es ReadOnly'
ERROR (TEXTMERGE(C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC))
ENDCASE
ENDIF
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_scx_a_prg AS c_conversor_bin_a_prg
#IF .F.
LOCAL THIS AS c_conversor_scx_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase CL_MODULO con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
DODEFAULT( @toModulo, @toEx )
#IF .F.
LOCAL toModulo AS CL_MODULO OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, loRegClass, loRegObj, lnMethodCount, laMethods(1), laCode(1), laProtected(1), lnLen, lnObjCount ;
, laPropsAndValues(1), laPropsAndComments(1), lnLastClass, lnRecno, lcMethods, lcObjName, la_NombresObjsOle(1) ;
, laObjs(1,3), I
STORE 0 TO lnCodError, lnLastClass, lnObjCount
STORE '' TO laMethods(1), laCode(1), laProtected(1), laPropsAndComments(1)
STORE NULL TO loRegClass, loRegObj
WITH THIS AS c_conversor_scx_a_prg OF 'FOXBIN2PRG.PRG'
USE (.c_InputFile) SHARED NOUPDATE ALIAS _TABLAORIG
SELECT * FROM _TABLAORIG INTO CURSOR TABLABIN
USE IN (SELECT("_TABLAORIG"))
INDEX ON PADR(LOWER(PLATFORM + IIF(EMPTY(PARENT),'',ALLTRIM(PARENT)+'.')+OBJNAME),240) TAG PARENT_OBJ OF TABLABIN ADDITIVE
SET ORDER TO 0 IN TABLABIN
C_FB2PRG_CODE = C_FB2PRG_CODE + toFoxBin2Prg.get_PROGRAM_HEADER()
.get_NombresObjetosOLEPublic( @la_NombresObjsOle )
.write_DefinicionObjetosOLE( toFoxBin2Prg )
*-- Escribo los métodos ordenados
lnLastObj = 0
lnLastClass = 0
*----------------------------------------------
*-- RECORRO LAS CLASES
*----------------------------------------------
SELECT TABLABIN
SET ORDER TO PARENT_OBJ
GOTO RECORD 1
SCATTER FIELDS RESERVED8 MEMO NAME loRegClass
IF NOT EMPTY(loRegClass.RESERVED8) THEN
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
#INCLUDE "<<loRegClass.Reserved8>>"
<<>>
ENDTEXT
ENDIF
SCAN ALL FOR TABLABIN.PLATFORM = "WINDOWS" ;
AND (EMPTY(TABLABIN.PARENT) ;
AND (TABLABIN.BASECLASS == 'dataenvironment' OR TABLABIN.BASECLASS == 'form' OR TABLABIN.BASECLASS == 'formset' ) )
loRegClass = NULL
SCATTER MEMO NAME loRegClass
IF toFoxBin2Prg.l_NoTimestamps
loRegClass.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegClass.UNIQUEID = ''
ELSE
loRegClass.UNIQUEID = ALLTRIM(loRegClass.UNIQUEID)
ENDIF
lcObjName = ALLTRIM(loRegClass.OBJNAME)
.write_ENDDEFINE_SiCorresponde( lnLastClass )
.write_DEFINE_CLASS( @la_NombresObjsOle, @loRegClass )
.write_DEFINE_CLASS_COMMENTS( @loRegClass )
.write_CLASSMETADATA( @loRegClass )
*-------------------------------------------------------------------------------
*-- RECORRO LOS OBJETOS DENTRO DE LA CLASE ACTUAL PARA EXPORTAR SU DEFINICIÓN
*-------------------------------------------------------------------------------
lnObjCount = 0
lnRecno = RECNO()
LOCATE FOR TABLABIN.PLATFORM = "WINDOWS" AND ALLTRIM(GETWORDNUM(TABLABIN.PARENT, 1, '.')) == lcObjName
SCAN REST WHILE TABLABIN.PLATFORM = "WINDOWS" AND ALLTRIM(GETWORDNUM(TABLABIN.PARENT, 1, '.')) == lcObjName
lnObjCount = lnObjCount + 1
DIMENSION laObjs(lnObjCount,3)
SCATTER MEMO NAME loRegObj
laObjs(lnObjCount,1) = loRegObj
laObjs(lnObjCount,2) = RECNO() && ZOrder
laObjs(lnObjCount,3) = lnObjCount && Orden alfabético
IF toFoxBin2Prg.l_NoTimestamps
loRegObj.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegObj.UNIQUEID = ''
ELSE
loRegObj.UNIQUEID = ALLTRIM(loRegObj.UNIQUEID)
ENDIF
loRegObj = NULL
ENDSCAN
GOTO RECORD (lnRecno)
ASORT(laObjs, 2, -1, 0, 0) && Orden por ZOrder
IF lnObjCount > 0
C_FB2PRG_CODE = C_FB2PRG_CODE + CR_LF + ' *-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder '
FOR I = 1 TO lnObjCount
.write_OBJECTMETADATA( laObjs(I,1) )
ENDFOR
C_FB2PRG_CODE = C_FB2PRG_CODE + CR_LF
ENDIF
.write_INCLUDE( @loRegClass )
.write_CLASS_PROPERTIES( @loRegClass, @laPropsAndValues, @laPropsAndComments, @laProtected )
ASORT(laObjs, 3, -1, 0, 0) && Orden Alfabético de objetos (del SCAN original)
FOR I = 1 TO lnObjCount
.write_ADD_OBJECTS_WithProperties( laObjs(I,1) )
ENDFOR
*-- OBTENGO LOS MÉTODOS DE LA CLASE PARA POSTERIOR TRATAMIENTO
DIMENSION laMethods(1,3)
lcMethods = ''
.SortMethod( loRegClass.METHODS, @laMethods, @laCode, '', @lnMethodCount )
.write_CLASS_METHODS( @lnMethodCount, @laMethods, @laCode, @laProtected, @laPropsAndComments )
lnLastClass = 1
lcMethods = ''
*-- RECORRO LOS OBJETOS DENTRO DE LA CLASE ACTUAL PARA OBTENER SUS MÉTODOS
lnRecno = RECNO()
LOCATE FOR TABLABIN.PLATFORM = "WINDOWS" AND ALLTRIM(GETWORDNUM(TABLABIN.PARENT, 1, '.')) == lcObjName
SCAN REST ;
FOR TABLABIN.PLATFORM = "WINDOWS" ;
AND NOT (EMPTY(TABLABIN.PARENT) ;
AND (TABLABIN.BASECLASS == 'dataenvironment' OR TABLABIN.BASECLASS == 'form' OR TABLABIN.BASECLASS == 'formset' ) ) ;
WHILE ALLTRIM(GETWORDNUM(TABLABIN.PARENT, 1, '.')) == lcObjName
SCATTER MEMO NAME loRegObj
IF toFoxBin2Prg.l_NoTimestamps
loRegObj.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegObj.UNIQUEID = ''
ELSE
loRegObj.UNIQUEID = ALLTRIM(loRegObj.UNIQUEID)
ENDIF
.get_ADD_OBJECT_METHODS( @loRegObj, @loRegClass, @lcMethods )
ENDSCAN
.write_ALL_OBJECT_METHODS( @lcMethods )
GOTO RECORD (lnRecno)
ENDSCAN
.write_ENDDEFINE_SiCorresponde( lnLastClass )
*-- Genero el SC2
IF .l_Test
toModulo = C_FB2PRG_CODE
ELSE
lnLen = 1 &&LEN( toFoxBin2Prg.get_PROGRAM_HEADER() )
DO CASE
CASE FILE(.c_OutputFile) AND SUBSTR( FILETOSTR( .c_OutputFile ), lnLen ) == SUBSTR( C_FB2PRG_CODE, lnLen )
*.writeLog( 'El archivo de salida [' + .c_OutputFile + '] no se sobreescribe por ser igual al generado.' )
.writeLog( TEXTMERGE(C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC) )
CASE toFoxBin2Prg.doBackup( .F., .T., '', '', '' ) ;
AND toFoxBin2Prg.ChangeFileAttribute( .c_OutputFile, '-R' ) ;
AND STRTOFILE( C_FB2PRG_CODE, .c_OutputFile ) = 0
*ERROR 'No se puede generar el archivo [' + .c_OutputFile + '] porque es ReadOnly'
ERROR (TEXTMERGE(C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC))
ENDCASE
ENDIF
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
loRegObj = NULL
loRegClass = NULL
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_pjx_a_prg AS c_conversor_bin_a_prg
#IF .F.
LOCAL THIS AS c_conversor_pjx_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase CL_PROJECT con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
TRY
LOCAL lnCodError, lcStr, lnPos, lnLen, lnServerCount, loReg, lcDevInfo, lnLen ;
, loEx AS EXCEPTION ;
, loProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG' ;
, loServerHead AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG' ;
, loServerData AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
STORE NULL TO loProject, loReg, loServerHead, loServerData
WITH THIS AS c_conversor_pjx_a_prg OF 'FOXBIN2PRG.PRG'
USE (.c_InputFile) SHARED NOUPDATE ALIAS _TABLAORIG
SELECT * FROM _TABLAORIG INTO CURSOR TABLABIN
USE IN (SELECT("_TABLAORIG"))
loServerHead = CREATEOBJECT('CL_PROJ_SRV_HEAD')
*-- Obtengo los archivos del proyecto
loProject = CREATEOBJECT('CL_PROJECT')
SCATTER MEMO NAME loReg
IF toFoxBin2Prg.l_NoTimestamps
loReg.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loReg.ID = 0
ENDIF
loProject._HomeDir = ['] + ALLTRIM( .get_ValueFromNullTerminatedValue( loReg.HOMEDIR ) ) + [']
loProject._ServerInfo = loReg.RESERVED2
loProject._Debug = loReg.DEBUG
loProject._Encrypted = loReg.ENCRYPT
lcDevInfo = loReg.DEVINFO
*--- Ubico el programa principal
LOCATE FOR MAINPROG
IF FOUND()
loProject._MainProg = LOWER( ALLTRIM( .get_ValueFromNullTerminatedValue( NAME ) ) )
ENDIF
*-- Ubico el Project Hook
LOCATE FOR TYPE == 'W'
IF FOUND()
loProject._ProjectHookLibrary = LOWER( ALLTRIM( .get_ValueFromNullTerminatedValue( NAME ) ) )
loProject._ProjectHookClass = LOWER( ALLTRIM( .get_ValueFromNullTerminatedValue( RESERVED1 ) ) )
ENDIF
*-- Ubico el icono del proyecto
LOCATE FOR TYPE == 'i'
IF FOUND()
loProject._Icon = LOWER( ALLTRIM( .get_ValueFromNullTerminatedValue( NAME ) ) )
ENDIF
*-- Escaneo el proyecto
SCAN ALL FOR NOT INLIST(TYPE, 'H','W','i' )
SCATTER FIELDS NAME,TYPE,EXCLUDE,COMMENTS,CPID,TIMESTAMP,ID,OBJREV MEMO NAME loReg
IF toFoxBin2Prg.l_NoTimestamps
loReg.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loReg.ID = 0
ENDIF
loReg.NAME = LOWER( ALLTRIM( .get_ValueFromNullTerminatedValue( loReg.NAME ) ) )
loReg.COMMENTS = ALLTRIM( .get_ValueFromNullTerminatedValue( loReg.COMMENTS ) )
*-- TIP: Si el "Name" del objeto está vacío, lo salteo
IF EMPTY(loReg.NAME)
LOOP
ENDIF
TRY
loProject.ADD( loReg, loReg.NAME )
CATCH TO loEx WHEN loEx.ERRORNO = 2062 && The specified key already exists ==> loProject.ADD( loReg, loReg.NAME )
*-- Saltear y no agregar el archivo duplicado / Bypass and not add the duplicated file
ENDTRY
ENDSCAN
C_FB2PRG_CODE = C_FB2PRG_CODE + toFoxBin2Prg.get_PROGRAM_HEADER()
*-- Directorio de inicio
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
LPARAMETERS tcDir
<<>>
lcCurdir = SYS(5)+CURDIR()
CD ( EVL( tcDir, JUSTPATH( SYS(16) ) ) )
<<>>
ENDTEXT
*-- Información del programa
loProject.parseDeviceInfo( lcDevInfo )
C_FB2PRG_CODE = C_FB2PRG_CODE + loProject.getFormattedDeviceInfoText() + CR_LF
*-- Información de los Servidores definidos
IF NOT EMPTY(loProject._ServerInfo)
loServerHead.parseServerInfo( loProject._ServerInfo )
C_FB2PRG_CODE = C_FB2PRG_CODE + loServerHead.getFormattedServerText() + CR_LF
loServerHead = NULL
ENDIF
*-- Generación del proyecto
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_BUILDPROJ_I>>
<<>>*<.HomeDir = <<loProject._HomeDir>> />
<<>>
FOR EACH loProject IN _VFP.Projects FOXOBJECT
<<>> loProject.Close()
ENDFOR
<<>>
STRTOFILE( '', '__newproject.f2b' )
BUILD PROJECT <<JUSTFNAME( EVL( .c_OriginalFileName, .c_InputFile ) )>> FROM '__newproject.f2b'
ENDTEXT
*-- Abro el proyecto
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
FOR EACH loProject IN _VFP.Projects FOXOBJECT
<<>> loProject.Close()
ENDFOR
<<>>
MODIFY PROJECT '<<JUSTFNAME( EVL( .c_OriginalFileName, .c_InputFile ) )>>' NOWAIT NOSHOW NOPROJECTHOOK
<<>>
loProject = _VFP.Projects('<<JUSTFNAME( EVL( .c_OriginalFileName, .c_InputFile ) )>>')
<<>>
WITH loProject.FILES
ENDTEXT
*-- Definir archivos del proyecto y metadata: CPID, Timestamp, ID, etc.
loProject.KEYSORT = 2
FOR EACH loReg IN loProject &&FOXOBJECT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .ADD('<<loReg.NAME>>')
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2+4+8
<<>> <<'&'>><<'&'>> <<C_FILE_META_I>>
Type="<<loReg.TYPE>>"
Cpid="<<INT( loReg.CPID )>>"
Timestamp="<<INT( loReg.TIMESTAMP )>>"
ID="<<INT( loReg.ID )>>"
ObjRev="<<INT( loReg.OBJREV )>>"
<<C_FILE_META_F>>
ENDTEXT
ENDFOR
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_BUILDPROJ_F>>
<<>>
<<>> .ITEM('__newproject.f2b').Remove()
<<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FILE_CMTS_I>>
ENDTEXT
*-- Agrego los comentarios
loProject.KEYSORT = 2
FOR EACH loReg IN loProject &&FOXOBJECT
IF NOT EMPTY(loReg.COMMENTS)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .ITEM(lcCurdir + '<<loReg.NAME>>').Description = '<<loReg.COMMENTS>>'
ENDTEXT
ENDIF
ENDFOR
*-- Exclusiones
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FILE_CMTS_F>>
<<>>
<<>> <<C_FILE_EXCL_I>>
ENDTEXT
loProject.KEYSORT = 2
FOR EACH loReg IN loProject &&FOXOBJECT
IF loReg.EXCLUDE
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .ITEM(lcCurdir + '<<loReg.NAME>>').Exclude = .T.
ENDTEXT
ENDIF
ENDFOR
*-- Tipos de archivos especiales
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FILE_EXCL_F>>
<<>>
<<>> <<C_FILE_TXT_I>>
ENDTEXT
loProject.KEYSORT = 2
FOR EACH loReg IN loProject &&FOXOBJECT
IF INLIST( UPPER( JUSTEXT( loReg.NAME ) ), 'H','FPW' )
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .ITEM(lcCurdir + '<<loReg.NAME>>').Type = 'T'
ENDTEXT
ENDIF
ENDFOR
*-- ProjectHook, Debug, Encrypt, Build y cierre
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FILE_TXT_F>>
<<C_ENDWITH>>
<<>>
<<C_WITH>> loProject
<<>> <<C_PROJPROPS_I>>
ENDTEXT
IF NOT EMPTY(loProject._MainProg)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .SetMain(lcCurdir + '<<loProject._MainProg>>')
ENDTEXT
ENDIF
IF NOT EMPTY(loProject._Icon)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .Icon = lcCurdir + '<<loProject._Icon>>'
ENDTEXT
ENDIF
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .Debug = <<loProject._Debug>>
<<>> .Encrypted = <<loProject._Encrypted>>
<<>> *<.CmntStyle = <<loProject._CmntStyle>> />
<<>> *<.NoLogo = <<loProject._NoLogo>> />
<<>> *<.SaveCode = <<loProject._SaveCode>> />
<<>> .ProjectHookLibrary = '<<loProject._ProjectHookLibrary>>'
<<>> .ProjectHookClass = '<<loProject._ProjectHookClass>>'
<<>> <<C_PROJPROPS_F>>
<<C_ENDWITH>>
<<>>
ENDTEXT
*-- Build y cierre
* _VFP.Projects('<<JUSTFNAME( .c_inputFile )>>').FILES('__newproject.f2b').Remove()
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
_VFP.Projects('<<JUSTFNAME( EVL( .c_OriginalFileName, .c_InputFile ) )>>').Close()
ENDTEXT
*-- Restauro Directorio de inicio
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
*ERASE '__newproject.f2b'
CD (lcCurdir)
RETURN
ENDTEXT
*-- Genero el PJ2
IF .l_Test
toModulo = C_FB2PRG_CODE
ELSE
lnLen = 1 &&LEN( toFoxBin2Prg.get_PROGRAM_HEADER() )
DO CASE
CASE FILE(.c_OutputFile) AND SUBSTR( FILETOSTR( .c_OutputFile ), lnLen ) == SUBSTR( C_FB2PRG_CODE, lnLen )
*.writeLog( 'El archivo de salida [' + .c_OutputFile + '] no se sobreescribe por ser igual al generado.' )
.writeLog( TEXTMERGE(C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC) )
CASE toFoxBin2Prg.doBackup( .F., .T., '', '', '' ) ;
AND toFoxBin2Prg.ChangeFileAttribute( .c_OutputFile, '-R' ) ;
AND STRTOFILE( C_FB2PRG_CODE, .c_OutputFile ) = 0
*ERROR 'No se puede generar el archivo [' + .c_OutputFile + '] porque es ReadOnly'
ERROR (TEXTMERGE(C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC))
ENDCASE
ENDIF
ENDWITH && THIS
CATCH TO toEx
lnCodError = toEx.ERRORNO
DO CASE
CASE lnCodError = 2062 && The specified key already exists ==> loProject.ADD( loReg, loReg.NAME )
*toEx.USERVALUE = 'Archivo duplicado: ' + loReg.NAME
toEx.USERVALUE = C_DUPLICATED_FILE_LOC + ': ' + loReg.NAME
ENDCASE
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
ENDDEFINE
DEFINE CLASS c_conversor_pjm_a_prg AS c_conversor_bin_a_prg
#IF .F.
LOCAL THIS AS c_conversor_pjm_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase CL_PROJECT con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
TRY
LOCAL lnCodError, lcStr, lnPos, lnLen, lnServerCount, loReg, lcDevInfo, lnLen ;
, lcStrPJM, laLines(1), laProps(1) ;
, loEx AS EXCEPTION ;
, loProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG' ;
, loServerHead AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG' ;
, loServerData AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
STORE NULL TO loProject, loReg, loServerHead, loServerData
lcStrPJM = FILETOSTR( THIS.c_InputFile )
loServerHead = CREATEOBJECT('CL_PROJ_SRV_HEAD')
*-- Obtengo los archivos del proyecto
loProject = CREATEOBJECT('CL_PROJECT')
WITH loProject AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
*-- Proj.Info
._CmntStyle = STREXTRACT( lcStrPJM, 'CommentStyle=', CR_LF )
._Debug = STREXTRACT( lcStrPJM, 'Debug=', CR_LF )
._Encrypted = STREXTRACT( lcStrPJM, 'Encrypt=', CR_LF )
._HomeDir = ['] + LOWER( JUSTPATH( SYS(5)+CURDIR() ) ) + [']
._ID = ''
._NoLogo = STREXTRACT( lcStrPJM, 'NoLogo=', CR_LF )
._ObjRev = 0
._ProjectHookClass = ''
._ProjectHookLibrary = ''
._SaveCode = STREXTRACT( lcStrPJM, 'SaveCode=', CR_LF )
._ServerHead = NULL
._ServerInfo = 'ServerData'
._SourceFile = ''
._TimeStamp = 0
._Version = STREXTRACT( lcStrPJM, 'Version=', CR_LF )
*-- Dev.info
._Author = STREXTRACT( lcStrPJM, 'Author=', CR_LF )
._Company = STREXTRACT( lcStrPJM, 'Company=', CR_LF )
._Address = STREXTRACT( lcStrPJM, 'Address=', CR_LF )
._City = STREXTRACT( lcStrPJM, 'City=', CR_LF )
._State = STREXTRACT( lcStrPJM, 'State=', CR_LF )
._PostalCode = STREXTRACT( lcStrPJM, 'Zip=', CR_LF )
._Country = STREXTRACT( lcStrPJM, 'Country=', CR_LF )
._Comments = STREXTRACT( lcStrPJM, 'Comments=', CR_LF )
._CompanyName = STREXTRACT( lcStrPJM, 'CompanyName=', CR_LF )
._FileDescription = STREXTRACT( lcStrPJM, 'FileDescription=', CR_LF )
._LegalCopyright = STREXTRACT( lcStrPJM, 'LegalCopyright=', CR_LF )
._LegalTrademark = STREXTRACT( lcStrPJM, 'LegalTrademarks=', CR_LF )
._ProductName = STREXTRACT( lcStrPJM, 'ProductName=', CR_LF )
._MajorVer = STREXTRACT( lcStrPJM, 'Major=', CR_LF )
._MinorVer = STREXTRACT( lcStrPJM, 'Minor=', CR_LF )
._Revision = STREXTRACT( lcStrPJM, 'Revision=', CR_LF )
._AutoIncrement = IIF( STREXTRACT( lcStrPJM, 'AutoIncrement=', CR_LF ) = '.T.', '1', '0' )
ENDWITH
FOR I = 1 TO ALINES( laLines, STREXTRACT( lcStrPJM, '[OLEServers]', '[OLEServersEnd]' ), 4 )
ALINES( laProps, laLines(I), 1, ',' )
IF I = 1
WITH loServerHead AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG'
._LibraryName = laProps(1)
._InternalName = laProps(2)
._ProjectName = laProps(3)
._TypeLibDesc = laProps(4)
._ServerType = PADL(laProps(5),4)
._TypeLib = laProps(6)
ENDWITH
ELSE
loServerData = CREATEOBJECT("CL_PROJ_SRV_DATA")
WITH loServerData AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
._HelpContextID = laProps(4)
._ServerName = laProps(3)
._Description = laProps(5)
._HelpFile = laProps(6)
._ServerClass = laProps(1)
._ClassLibrary = laProps(2)
._Instancing = laProps(7)
._CLSID = laProps(8)
._Interface = laProps(9)
ENDWITH
loServerHead.add_Server( loServerData )
loServerData = NULL
ENDIF
ENDFOR
*-- Escaneo el proyecto
FOR I = 1 TO ALINES( laLines, STREXTRACT( lcStrPJM, '[ProjectFiles]', '[EOF]' ), 4 )
ALINES( laProps, laLines(I) + ',', 1, ',' )
loReg = CREATEOBJECT("EMPTY")
ADDPROPERTY( loReg, 'ID', IIF( toFoxBin2Prg.l_ClearUniqueID, 0, VAL( laProps(1) ) ) )
ADDPROPERTY( loReg, 'TYPE', laProps(2) )
ADDPROPERTY( loReg, 'NAME', laProps(3) )
ADDPROPERTY( loReg, 'EXCLUDE', EVALUATE( laProps(4) ) )
ADDPROPERTY( loReg, 'MAINPROG', laProps(5) )
ADDPROPERTY( loReg, 'CPID', VAL( laProps(6) ) )
ADDPROPERTY( loReg, 'COMMENTS', laProps(9) )
ADDPROPERTY( loReg, 'TIMESTAMP', 0 )
ADDPROPERTY( loReg, 'OBJREV', 0 )
*-- TIP: Si el "Name" del objeto está vacío, lo salteo
IF EMPTY(loReg.NAME)
LOOP
ENDIF
TRY
DO CASE
CASE loReg.MAINPROG = '.T.'
loProject._MainProg = loReg.NAME
loProject.ADD( loReg, loReg.NAME )
CASE loReg.TYPE == 'W'
*
CASE loReg.TYPE == 'i'
loProject._Icon = loReg.NAME
OTHERWISE
loProject.ADD( loReg, loReg.NAME )
ENDCASE
CATCH TO loEx WHEN loEx.ERRORNO = 2062 && The specified key already exists ==> loProject.ADD( loReg, loReg.NAME )
*-- Saltear y no agregar el archivo duplicado / Bypass and not add the duplicated file
FINALLY
loReg = NULL
ENDTRY
ENDFOR
C_FB2PRG_CODE = C_FB2PRG_CODE + toFoxBin2Prg.get_PROGRAM_HEADER()
*-- Directorio de inicio
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
LPARAMETERS tcDir
<<>>
lcCurdir = SYS(5)+CURDIR()
CD ( EVL( tcDir, JUSTPATH( SYS(16) ) ) )
<<>>
ENDTEXT
*-- Información del programa
C_FB2PRG_CODE = C_FB2PRG_CODE + loProject.getFormattedDeviceInfoText() + CR_LF
*-- Información de los Servidores definidos
IF NOT EMPTY(loProject._ServerInfo)
C_FB2PRG_CODE = C_FB2PRG_CODE + loServerHead.getFormattedServerText() + CR_LF
loServerHead = NULL
ENDIF
WITH THIS AS c_conversor_pjm_a_prg OF 'FOXBIN2PRG.PRG'
*-- Generación del proyecto
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_BUILDPROJ_I>>
<<>>*<.HomeDir = <<loProject._HomeDir>> />
<<>>
FOR EACH loProject IN _VFP.Projects FOXOBJECT
<<>> loProject.Close()
ENDFOR
<<>>
STRTOFILE( '', '__newproject.f2b' )
BUILD PROJECT <<JUSTFNAME( EVL( .c_OriginalFileName, .c_InputFile ) )>> FROM '__newproject.f2b'
ENDTEXT
*-- Abro el proyecto
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
FOR EACH loProject IN _VFP.Projects FOXOBJECT
<<>> loProject.Close()
ENDFOR
<<>>
MODIFY PROJECT '<<JUSTFNAME( EVL( .c_OriginalFileName, .c_InputFile ) )>>' NOWAIT NOSHOW NOPROJECTHOOK
<<>>
loProject = _VFP.Projects('<<JUSTFNAME( EVL( .c_OriginalFileName, .c_InputFile ) )>>')
<<>>
WITH loProject.FILES
ENDTEXT
*-- Definir archivos del proyecto y metadata: CPID, Timestamp, ID, etc.
loProject.KEYSORT = 2
FOR EACH loReg IN loProject &&FOXOBJECT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .ADD('<<loReg.NAME>>')
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1 PRETEXT 1+2+4+8
<<>> <<'&'>><<'&'>> <<C_FILE_META_I>>
Type="<<loReg.TYPE>>"
Cpid="<<INT( loReg.CPID )>>"
Timestamp="<<INT( loReg.TIMESTAMP )>>"
ID="<<INT( loReg.ID )>>"
ObjRev="<<INT( loReg.OBJREV )>>"
<<C_FILE_META_F>>
ENDTEXT
ENDFOR
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_BUILDPROJ_F>>
<<>>
<<>> .ITEM('__newproject.f2b').Remove()
<<>>
ENDTEXT
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FILE_CMTS_I>>
ENDTEXT
*-- Agrego los comentarios
loProject.KEYSORT = 2
FOR EACH loReg IN loProject &&FOXOBJECT
IF NOT EMPTY(loReg.COMMENTS)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .ITEM(lcCurdir + '<<loReg.NAME>>').Description = '<<loReg.COMMENTS>>'
ENDTEXT
ENDIF
ENDFOR
*-- Exclusiones
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FILE_CMTS_F>>
<<>>
<<>> <<C_FILE_EXCL_I>>
ENDTEXT
loProject.KEYSORT = 2
FOR EACH loReg IN loProject &&FOXOBJECT
IF loReg.EXCLUDE
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .ITEM(lcCurdir + '<<loReg.NAME>>').Exclude = .T.
ENDTEXT
ENDIF
ENDFOR
*-- Tipos de archivos especiales
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FILE_EXCL_F>>
<<>>
<<>> <<C_FILE_TXT_I>>
ENDTEXT
loProject.KEYSORT = 2
FOR EACH loReg IN loProject &&FOXOBJECT
IF INLIST( UPPER( JUSTEXT( loReg.NAME ) ), 'H','FPW' )
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .ITEM(lcCurdir + '<<loReg.NAME>>').Type = 'T'
ENDTEXT
ENDIF
ENDFOR
*-- ProjectHook, Debug, Encrypt, Build y cierre
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FILE_TXT_F>>
<<C_ENDWITH>>
<<>>
<<C_WITH>> loProject
<<>> <<C_PROJPROPS_I>>
ENDTEXT
IF NOT EMPTY(loProject._MainProg)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .SetMain(lcCurdir + '<<loProject._MainProg>>')
ENDTEXT
ENDIF
IF NOT EMPTY(loProject._Icon)
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .Icon = lcCurdir + '<<loProject._Icon>>'
ENDTEXT
ENDIF
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> .Debug = <<loProject._Debug>>
<<>> .Encrypted = <<loProject._Encrypted>>
<<>> *<.CmntStyle = <<loProject._CmntStyle>> />
<<>> *<.NoLogo = <<loProject._NoLogo>> />
<<>> *<.SaveCode = <<loProject._SaveCode>> />
<<>> .ProjectHookLibrary = '<<loProject._ProjectHookLibrary>>'
<<>> .ProjectHookClass = '<<loProject._ProjectHookClass>>'
<<>> <<C_PROJPROPS_F>>
<<C_ENDWITH>>
<<>>
ENDTEXT
*-- Build y cierre
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
_VFP.Projects('<<JUSTFNAME( EVL( .c_OriginalFileName, .c_InputFile ) )>>').Close()
ENDTEXT
*-- Restauro Directorio de inicio
TEXT TO C_FB2PRG_CODE ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
*ERASE '__newproject.f2b'
CD (lcCurdir)
RETURN
ENDTEXT
*-- Genero el PJ2
IF .l_Test
toModulo = C_FB2PRG_CODE
ELSE
lnLen = 1 &&LEN( toFoxBin2Prg.get_PROGRAM_HEADER() )
DO CASE
CASE FILE(.c_OutputFile) AND SUBSTR( FILETOSTR( .c_OutputFile ), lnLen ) == SUBSTR( C_FB2PRG_CODE, lnLen )
*.writeLog( 'El archivo de salida [' + .c_OutputFile + '] no se sobreescribe por ser igual al generado.' )
.writeLog( TEXTMERGE(C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC) )
CASE toFoxBin2Prg.doBackup( .F., .T., '', '', '' ) ;
AND toFoxBin2Prg.ChangeFileAttribute( .c_OutputFile, '-R' ) ;
AND STRTOFILE( C_FB2PRG_CODE, .c_OutputFile ) = 0
*ERROR 'No se puede generar el archivo [' + .c_OutputFile + '] porque es ReadOnly'
ERROR (TEXTMERGE(C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC))
ENDCASE
ENDIF
ENDWITH && THIS
CATCH TO toEx
lnCodError = toEx.ERRORNO
DO CASE
CASE lnCodError = 2062 && The specified key already exists ==> loProject.ADD( loReg, loReg.NAME )
*toEx.USERVALUE = 'Archivo duplicado: ' + loReg.NAME
toEx.USERVALUE = C_DUPLICATED_FILE_LOC + ': ' + loReg.NAME
ENDCASE
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
*USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_frx_a_prg AS c_conversor_bin_a_prg
#IF .F.
LOCAL THIS AS c_conversor_frx_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
*_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="convertir" display="Convertir"/>] ;
+ [</VFPData>]
*******************************************************************************************************************
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Objeto generado de clase CL_PROJECT con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
TRY
LOCAL lnCodError, loRegCab, loRegDataEnv, loRegCur, loRegObj, lnMethodCount, laMethods(1), laCode(1), laProtected(1), lnLen ;
, laPropsAndValues(1), laPropsAndComments(1), lnLastClass, lnRecno, lcMethods, lcObjName, la_NombresObjsOle(1)
STORE 0 TO lnCodError, lnLastClass
STORE '' TO laMethods(1), laCode(1), laProtected(1), laPropsAndComments(1)
STORE NULL TO loRegObj, loRegCab, loRegDataEnv, loRegCur
WITH THIS AS c_conversor_pjm_a_prg OF 'FOXBIN2PRG.PRG'
USE (.c_InputFile) SHARED NOUPDATE ALIAS _TABLAORIG
SELECT * FROM _TABLAORIG INTO CURSOR TABLABIN_0
USE IN (SELECT("_TABLAORIG"))
*-- Header
LOCATE FOR ObjType = 1
IF FOUND()
SCATTER MEMO NAME loRegCab
IF toFoxBin2Prg.l_NoTimestamps
loRegCab.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegCab.UNIQUEID = ''
ENDIF
ENDIF
*-- Dataenvironment
LOCATE FOR ObjType = 25
IF FOUND()
SCATTER MEMO NAME loRegDataEnv
IF toFoxBin2Prg.l_NoTimestamps
loRegDataEnv.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegDataEnv.UNIQUEID = ''
ENDIF
ENDIF
*-- Cursor1 (¿puede haber más de 1 cursor?)
LOCATE FOR ObjType = 26
IF FOUND()
SCATTER MEMO NAME loRegCur
IF toFoxBin2Prg.l_NoTimestamps
loRegCur.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegCur.UNIQUEID = ''
ENDIF
ENDIF
IF .l_ReportSort_Enabled
*-- ORDENADO
SELECT * FROM TABLABIN_0 ;
WHERE ObjType NOT IN (1,25,26) ;
ORDER BY vpos,hpos ;
INTO CURSOR TABLABIN READWRITE
ELSE
*-- SIN ORDENAR (Sólo para poder comparar con el original)
SELECT * FROM TABLABIN_0 ;
WHERE ObjType NOT IN (1,25,26) ;
INTO CURSOR TABLABIN
ENDIF
loRegObj = NULL
USE IN (SELECT("TABLABIN_0"))
C_FB2PRG_CODE = C_FB2PRG_CODE + toFoxBin2Prg.get_PROGRAM_HEADER()
*-- Recorro los registros y genero el texto
IF VARTYPE(loRegCab) = "O"
.write_CABECERA_REPORTE( @loRegCab )
ENDIF
SELECT TABLABIN
GOTO TOP
SCAN ALL
SCATTER MEMO NAME loRegObj
IF toFoxBin2Prg.l_NoTimestamps
loRegObj.TIMESTAMP = 0
ENDIF
IF toFoxBin2Prg.l_ClearUniqueID
loRegObj.UNIQUEID = ''
ENDIF
.write_DETALLE_REPORTE( @loRegObj )
ENDSCAN
IF VARTYPE(loRegDataEnv) = "O"
.write_DATAENVIRONMENT_REPORTE( @loRegDataEnv )
ENDIF
IF VARTYPE(loRegCur) = "O"
.write_DETALLE_REPORTE( @loRegCur )
ENDIF
*-- Genero el FR2
IF .l_Test
toModulo = C_FB2PRG_CODE
ELSE
lnLen = 1 &&LEN( toFoxBin2Prg.get_PROGRAM_HEADER() )
DO CASE
CASE FILE(.c_OutputFile) AND SUBSTR( FILETOSTR( .c_OutputFile ), lnLen ) == SUBSTR( C_FB2PRG_CODE, lnLen )
*.writeLog( 'El archivo de salida [' + .c_OutputFile + '] no se sobreescribe por ser igual al generado.' )
.writeLog( TEXTMERGE(C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC) )
CASE toFoxBin2Prg.doBackup( .F., .T., '', '', '' ) ;
AND toFoxBin2Prg.ChangeFileAttribute( .c_OutputFile, '-R' ) ;
AND STRTOFILE( C_FB2PRG_CODE, .c_OutputFile ) = 0
*ERROR 'No se puede generar el archivo [' + .c_OutputFile + '] porque es ReadOnly'
ERROR (TEXTMERGE(C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC))
ENDCASE
ENDIF
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
USE IN (SELECT("TABLABIN_0"))
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_dbf_a_prg AS c_conversor_bin_a_prg
#IF .F.
LOCAL THIS AS c_conversor_dbf_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toModulo (@! OUT) Contenido del texto generado
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toModulo, toEx AS EXCEPTION, toFoxBin2Prg
#IF .F.
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
DODEFAULT( @toModulo, @toEx )
TRY
LOCAL lnCodError, laDatabases(1), lnDatabases_Count, laDatabases2(1), lnLen, lc_FileTypeDesc ;
, ln_HexFileType, ll_FileHasCDX, ll_FileHasMemo, ll_FileIsDBC, lc_DBC_Name
LOCAL loTable AS CL_DBF_TABLE OF 'FOXBIN2PRG.PRG'
LOCAL loDBFUtils AS CL_DBF_UTILS OF 'FOXBIN2PRG.PRG'
STORE 0 TO lnCodError
loDBFUtils = CREATEOBJECT('CL_DBF_UTILS')
WITH THIS AS c_conversor_dbf_a_prg OF 'FOXBIN2PRG.PRG'
loDBFUtils.getDBFmetadata( .c_InputFile, @ln_HexFileType, @ll_FileHasCDX, @ll_FileHasMemo, @ll_FileIsDBC, @lc_DBC_Name )
lc_FileTypeDesc = loDBFUtils.fileTypeDescription(ln_HexFileType)
lnDatabases_Count = ADATABASES(laDatabases)
USE (.c_InputFile) SHARED NOUPDATE ALIAS TABLABIN
C_FB2PRG_CODE = C_FB2PRG_CODE + toFoxBin2Prg.get_PROGRAM_HEADER()
*-- Header
loTable = CREATEOBJECT('CL_DBF_TABLE')
C_FB2PRG_CODE = C_FB2PRG_CODE + loTable.toText( ln_HexFileType, ll_FileHasCDX, ll_FileHasMemo, ll_FileIsDBC, lc_DBC_Name, .c_InputFile, lc_FileTypeDesc )
*-- Genero el DB2
IF .l_Test
toModulo = C_FB2PRG_CODE
ELSE
lnLen = 1 &&LEN( toFoxBin2Prg.get_PROGRAM_HEADER() )
DO CASE
CASE FILE(.c_OutputFile) AND SUBSTR( FILETOSTR( .c_OutputFile ), lnLen ) == SUBSTR( C_FB2PRG_CODE, lnLen )
*.writeLog( 'El archivo de salida [' + .c_OutputFile + '] no se sobreescribe por ser igual al generado.' )
.writeLog( TEXTMERGE(C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC) )
CASE toFoxBin2Prg.doBackup( .F., .T., '', '', '' ) ;
AND toFoxBin2Prg.ChangeFileAttribute( .c_OutputFile, '-R' ) ;
AND STRTOFILE( C_FB2PRG_CODE, .c_OutputFile ) = 0
*ERROR 'No se puede generar el archivo [' + .c_OutputFile + '] porque es ReadOnly'
ERROR (TEXTMERGE(C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC))
ENDCASE
ENDIF
ENDWITH && THIS
CATCH TO toEx
DO CASE
CASE toEx.ERRORNO = 13 && Alias not found
*toEx.USERVALUE = 'WARNING!!' + CR_LF ;
+ 'MAKE SURE YOU ARE NOT USING A TABLE ALIAS ON INDEX KEY EXPRESSIONS!! (ex: index on ' ;
+ UPPER(JUSTSTEM(THIS.c_InputFile)) + '.field tag keyname)' + CR_LF + CR_LF ;
+ '¡¡ATENCIÓN!!' + CR_LF ;
+ 'ASEGÚRESE DE QUE NO ESTÁ USANDO UN ALIAS DE TABLA EN LAS EXPRESIONES DE LOS ÍNDICES!! (ej: index on ' ;
+ UPPER(JUSTSTEM(THIS.c_InputFile)) + '.campo tag nombreclave)'
toEx.USERVALUE = TEXTMERGE(C_WARN_TABLE_ALIAS_ON_INDEX_EXPRESSION_LOC)
*!* CASE toEx.ErrorNo = 1976 && Cannot resolve backlink
*!* toEx.UserValue = 'WARNING!!' + CR_LF ;
*!* + "MAY BE DATABASE FIELDS DOESN'T" ;
*!* + UPPER(JUSTSTEM(THIS.c_InputFile)) + '.field tag keyname)' + CR_LF + CR_LF ;
*!* + '¡¡ATENCIÓN!!' + CR_LF ;
*!* + 'ASEGÚRESE DE QUE NO ESTÁ USANDO UN ALIAS DE TABLA EN LAS EXPRESIONES DE LOS ÍNDICES!! (ej: index on ' ;
*!* + UPPER(JUSTSTEM(THIS.c_InputFile)) + '.campo tag nombreclave)'
ENDCASE
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
*-- Cierro DBC
FOR I = 1 TO ADATABASES(laDatabases2)
IF ASCAN( laDatabases, laDatabases2(I) ) = 0
SET DATABASE TO (laDatabases2(I))
CLOSE DATABASES
EXIT
ENDIF
ENDFOR
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_dbc_a_prg AS c_conversor_bin_a_prg
#IF .F.
LOCAL THIS AS c_conversor_dbc_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toDatabase (@! OUT) Objeto generado de clase CL_DBC con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toDatabase, toEx AS EXCEPTION, toFoxBin2Prg
DODEFAULT( @toDatabase, @toEx )
#IF .F.
LOCAL toDatabase AS CL_DBC OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, laDatabases(1), lnDatabases_Count, lnLen
STORE 0 TO lnCodError
WITH THIS AS c_conversor_dbc_a_prg OF 'FOXBIN2PRG.PRG'
lnDatabases_Count = ADATABASES(laDatabases)
USE (.c_InputFile) SHARED NOUPDATE ALIAS TABLABIN
OPEN DATABASE (.c_InputFile) SHARED NOUPDATE
C_FB2PRG_CODE = C_FB2PRG_CODE + toFoxBin2Prg.get_PROGRAM_HEADER()
*-- Header
toDatabase = CREATEOBJECT('CL_DBC')
C_FB2PRG_CODE = C_FB2PRG_CODE + toDatabase.toText()
*-- Genero el DC2
IF .l_Test
toModulo = C_FB2PRG_CODE
ELSE
lnLen = 1 &&LEN( toFoxBin2Prg.get_PROGRAM_HEADER() )
DO CASE
CASE FILE(.c_OutputFile) AND SUBSTR( FILETOSTR( .c_OutputFile ), lnLen ) == SUBSTR( C_FB2PRG_CODE, lnLen )
*.writeLog( 'El archivo de salida [' + .c_OutputFile + '] no se sobreescribe por ser igual al generado.' )
.writeLog( TEXTMERGE(C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC) )
CASE toFoxBin2Prg.doBackup( .F., .T., '', '', '' ) ;
AND toFoxBin2Prg.ChangeFileAttribute( .c_OutputFile, '-R' ) ;
AND STRTOFILE( C_FB2PRG_CODE, .c_OutputFile ) = 0
*ERROR 'No se puede generar el archivo [' + .c_OutputFile + '] porque es ReadOnly'
ERROR (TEXTMERGE(C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC))
ENDCASE
ENDIF
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
CLOSE DATABASES
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS c_conversor_mnx_a_prg AS c_conversor_bin_a_prg
#IF .F.
LOCAL THIS AS c_conversor_mnx_a_prg OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE Convertir
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* totoMenu (@! OUT) Objeto generado de clase CL_MENU con la información leida del texto
* toEx (@! OUT) Objeto con información del error
* toFoxBin2Prg (v! IN ) Referencia al objeto principal
*---------------------------------------------------------------------------------------------------
LPARAMETERS toMenu, toEx AS EXCEPTION, toFoxBin2Prg
DODEFAULT( @toMenu, @toEx )
#IF .F.
LOCAL toMenu AS CL_MENU OF 'FOXBIN2PRG.PRG'
LOCAL toFoxBin2Prg AS c_foxbin2prg OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL lnCodError, lnLen
STORE 0 TO lnCodError
WITH THIS AS c_conversor_mnx_a_prg OF 'FOXBIN2PRG.PRG'
USE (.c_InputFile) SHARED NOUPDATE ALIAS _TABLAORIG
SELECT * FROM _TABLAORIG INTO CURSOR TABLABIN
USE IN (SELECT("_TABLAORIG"))
*-- Verificación de menú VFP 9
IF FCOUNT() < 25 OR EMPTY(FIELD("RESNAME")) OR EMPTY(FIELD("SYSRES"))
*ERROR 'Menu [' + (.c_InputFile) + '] is NOT VFP 9 Format! - Please convert to VFP 9 with MODIFY MENU ' + JUSTFNAME((.c_InputFile))
ERROR (TEXTMERGE(C_MENU_NOT_IN_VFP9_FORMAT_LOC))
ENDIF
*-- Header
C_FB2PRG_CODE = C_FB2PRG_CODE + toFoxBin2Prg.get_PROGRAM_HEADER()
toMenu = CREATEOBJECT('CL_MENU')
toMenu.get_DataFromTablabin()
C_FB2PRG_CODE = C_FB2PRG_CODE + toMenu.toText()
*-- Genero el MN2
IF .l_Test
toMenu = C_FB2PRG_CODE
ELSE
lnLen = 1 &&LEN( toFoxBin2Prg.get_PROGRAM_HEADER() )
DO CASE
CASE FILE(.c_OutputFile) AND SUBSTR( FILETOSTR( .c_OutputFile ), lnLen ) == SUBSTR( C_FB2PRG_CODE, lnLen )
*.writeLog( 'El archivo de salida [' + .c_OutputFile + '] no se sobreescribe por ser igual al generado.' )
.writeLog( TEXTMERGE(C_OUTPUT_FILE_IS_NOT_OVERWRITEN_LOC) )
CASE toFoxBin2Prg.doBackup( .F., .T., '', '', '' ) ;
AND toFoxBin2Prg.ChangeFileAttribute( .c_OutputFile, '-R' ) ;
AND STRTOFILE( C_FB2PRG_CODE, .c_OutputFile ) = 0
*ERROR 'No se puede generar el archivo [' + .c_OutputFile + '] porque es ReadOnly'
ERROR (TEXTMERGE(C_CANT_GENERATE_FILE_BECAUSE_IT_IS_READONLY_LOC))
ENDCASE
ENDIF
ENDWITH && THIS
CATCH TO toEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_CUS_BASE AS CUSTOM
*-- Propiedades (Se preservan: CONTROLCOUNT, CONTROLS, OBJECTS, PARENT, CLASS)
HIDDEN BASECLASS, TOP, WIDTH, CLASSLIB, CLASSLIBRARY, COMMENT ;
, HEIGHT, HELPCONTEXTID, LEFT, NAME ;
, PARENTCLASS, PICTURE, TAG, WHATSTHISHELPID
*-- Métodos (Se preservan: INIT, DESTROY, ERROR, ADDPROPERTY)
*HIDDEN ADDOBJECT, NEWOBJECT, READEXPRESSION, READMETHOD, REMOVEOBJECT ;
, RESETTODEFAULT, SAVEASCLASS, SHOWWHATSTHIS, WRITEEXPRESSION, WRITEMETHOD
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="l_debug" display="l_Debug"/>] ;
+ [<memberdata name="set_line" display="set_Line"/>] ;
+ [<memberdata name="analizarbloque" display="analizarBloque"/>] ;
+ [<memberdata name="filetypedescription" display="fileTypeDescription"/>] ;
+ [<memberdata name="totext" display="toText"/>] ;
+ [</VFPData>]
l_Debug = .F.
PROCEDURE INIT
SET DELETED ON
SET DATE YMD
SET HOURS TO 24
SET CENTURY ON
SET SAFETY OFF
SET TABLEPROMPT OFF
THIS.l_Debug = (_VFP.STARTMODE=0)
ENDPROC
PROCEDURE analizarBloque
ENDPROC
PROCEDURE set_Line
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (v! IN ) Número de línea en análisis
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I
tcLine = LTRIM( taCodeLines(I), 0, ' ', CHR(9) )
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_COL_BASE AS COLLECTION
#IF .F.
LOCAL THIS AS CL_COL_BASE OF 'FOXBIN2PRG.PRG'
#ENDIF
*-- Propiedades (Se preservan: COUNT, KEYSORT, NAME)
**HIDDEN BASECLASS, CLASS, CLASSLIBRARY, COUNT, COMMENT ;
, PARENT, PARENTCLASS, TAG
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="l_debug" display="l_Debug"/>] ;
+ [<memberdata name="analizarbloque" display="analizarBloque"/>] ;
+ [<memberdata name="set_line" display="set_Line"/>] ;
+ [<memberdata name="totext" display="toText"/>] ;
+ [</VFPData>]
l_Debug = .F.
PROCEDURE INIT
SET DELETED ON
SET DATE YMD
SET HOURS TO 24
SET CENTURY ON
SET SAFETY OFF
SET TABLEPROMPT OFF
THIS.l_Debug = (_VFP.STARTMODE=0)
ENDPROC
PROCEDURE analizarBloque
ENDPROC
PROCEDURE set_Line
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (v! IN ) Número de línea en análisis
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I
tcLine = LTRIM( taCodeLines(I), 0, ' ', CHR(9) )
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taArray (@? OUT) Array de conexiones
* tnArray_Count (@? OUT) Cantidad de conexiones
*---------------------------------------------------------------------------------------------------
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_MODULO AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_MODULO OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="add_ole" display="add_OLE"/>] ;
+ [<memberdata name="add_class" display="add_Class"/>] ;
+ [<memberdata name="existeobjetoole" display="existeObjetoOLE"/>] ;
+ [<memberdata name="_clases" display="_Clases"/>] ;
+ [<memberdata name="_clases_count" display="_Clases_Count"/>] ;
+ [<memberdata name="_includefile" display="_IncludeFile"/>] ;
+ [<memberdata name="_ole_objs" display="_Ole_Objs"/>] ;
+ [<memberdata name="_ole_obj_count" display="_Ole_Obj_Count"/>] ;
+ [<memberdata name="_sourcefile" display="_SourceFile"/>] ;
+ [<memberdata name="_version" display="_Version"/>] ;
+ [</VFPData>]
DIMENSION _Ole_Objs[1], _Clases[1]
_Version = 0
_SourceFile = ''
_Ole_Obj_count = 0
_Clases_Count = 0
_includeFile = ''
************************************************************************************************
PROCEDURE add_OLE
LPARAMETERS toOle
#IF .F.
LOCAL toOle AS CL_OLE OF 'FOXBIN2PRG.PRG'
#ENDIF
WITH THIS AS CL_MODULO OF 'FOXBIN2PRG.PRG'
._Ole_Obj_count = ._Ole_Obj_count + 1
DIMENSION ._Ole_Objs( ._Ole_Obj_count )
._Ole_Objs( ._Ole_Obj_count ) = toOle
ENDWITH && THIS
ENDPROC
************************************************************************************************
PROCEDURE add_Class
LPARAMETERS toClase
#IF .F.
LOCAL toClase AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
WITH THIS AS CL_MODULO OF 'FOXBIN2PRG.PRG'
._Clases_Count = ._Clases_Count + 1
DIMENSION ._Clases( ._Clases_Count )
._Clases( ._Clases_Count ) = toClase
ENDWITH && THIS
ENDPROC
************************************************************************************************
PROCEDURE existeObjetoOLE
*-- Ubico el objeto ole por su nombre (parent+objname), que no se repite.
LPARAMETERS tcNombre, X
LOCAL llExiste
WITH THIS AS CL_MODULO OF 'FOXBIN2PRG.PRG'
FOR X = 1 TO ._Ole_Obj_count
IF ._Ole_Objs(X)._Nombre == tcNombre
llExiste = .T.
EXIT
ENDIF
ENDFOR
ENDWITH && THIS
RETURN llExiste
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_OLE AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_OLE OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_checksum" display="_CheckSum"/>] ;
+ [<memberdata name="_nombre" display="_Nombre"/>] ;
+ [<memberdata name="_objname" display="_ObjName"/>] ;
+ [<memberdata name="_parent" display="_Parent"/>] ;
+ [<memberdata name="_value" display="_Value"/>] ;
+ [</VFPData>]
_Nombre = ''
_Parent = ''
_ObjName = ''
_CheckSum = ''
_Value = ''
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_CLASE AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_CLASE OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="add_procedure" display="add_Procedure"/>] ;
+ [<memberdata name="add_property" display="add_Property"/>] ;
+ [<memberdata name="add_object" display="add_Object"/>] ;
+ [<memberdata name="l_objectmetadatainheader" display="l_ObjectMetadataInHeader"/>] ;
+ [<memberdata name="_addobject_count" display="_AddObject_Count"/>] ;
+ [<memberdata name="_addobjects" display="_AddObjects"/>] ;
+ [<memberdata name="_baseclass" display="_BaseClass"/>] ;
+ [<memberdata name="_class" display="_Class"/>] ;
+ [<memberdata name="_classicon" display="_ClassIcon"/>] ;
+ [<memberdata name="_classloc" display="_ClassLoc"/>] ;
+ [<memberdata name="_comentario" display="_Comentario"/>] ;
+ [<memberdata name="_defined_pam" display="_Defined_PAM"/>] ;
+ [<memberdata name="_definicion" display="_Definicion"/>] ;
+ [<memberdata name="_fin" display="_Fin"/>] ;
+ [<memberdata name="_fin_cab" display="_Fin_Cab"/>] ;
+ [<memberdata name="_fin_cuerpo" display="_Fin_Cuerpo"/>] ;
+ [<memberdata name="_hiddenmethods" display="_HiddenMethods"/>] ;
+ [<memberdata name="_hiddenprops" display="_HiddenProps"/>] ;
+ [<memberdata name="_includefile" display="_IncludeFile"/>] ;
+ [<memberdata name="_inicio" display="_Inicio"/>] ;
+ [<memberdata name="_ini_cab" display="_Ini_Cab"/>] ;
+ [<memberdata name="_ini_cuerpo" display="_Ini_Cuerpo"/>] ;
+ [<memberdata name="_metadata" display="_MetaData"/>] ;
+ [<memberdata name="_nombre" display="_Nombre"/>] ;
+ [<memberdata name="_objname" display="_ObjName"/>] ;
+ [<memberdata name="_ole" display="_Ole"/>] ;
+ [<memberdata name="_ole2" display="_Ole2"/>] ;
+ [<memberdata name="_olepublic" display="_OlePublic"/>] ;
+ [<memberdata name="_parent" display="_Parent"/>] ;
+ [<memberdata name="_procedures" display="_Procedures"/>] ;
+ [<memberdata name="_procedure_count" display="_Procedure_Count"/>] ;
+ [<memberdata name="_projectclassicon" display="_ProjectClassIcon"/>] ;
+ [<memberdata name="_protectedmethods" display="_ProtectedMethods"/>] ;
+ [<memberdata name="_protectedprops" display="_ProtectedProps"/>] ;
+ [<memberdata name="_props" display="_Props"/>] ;
+ [<memberdata name="_prop_count" display="_Prop_Count"/>] ;
+ [<memberdata name="_scale" display="_Scale"/>] ;
+ [<memberdata name="_timestamp" display="_TimeStamp"/>] ;
+ [<memberdata name="_uniqueid" display="_UniqueID"/>] ;
+ [<memberdata name="_properties" display="_PROPERTIES"/>] ;
+ [<memberdata name="_protected" display="_PROTECTED"/>] ;
+ [<memberdata name="_methods" display="_METHODS"/>] ;
+ [<memberdata name="_reserved1" display="_RESERVED1"/>] ;
+ [<memberdata name="_reserved2" display="_RESERVED2"/>] ;
+ [<memberdata name="_reserved3" display="_RESERVED3"/>] ;
+ [<memberdata name="_reserved4" display="_RESERVED4"/>] ;
+ [<memberdata name="_reserved5" display="_RESERVED5"/>] ;
+ [<memberdata name="_reserved6" display="_RESERVED6"/>] ;
+ [<memberdata name="_reserved7" display="_RESERVED7"/>] ;
+ [<memberdata name="_reserved8" display="_RESERVED8"/>] ;
+ [<memberdata name="_user" display="_USER"/>] ;
+ [</VFPData>]
DIMENSION _Props[1,2], _AddObjects[1], _Procedures[1]
l_ObjectMetadataInHeader = .F.
_Nombre = ''
_ObjName = ''
_Parent = ''
_Definicion = ''
_Class = ''
_ClassLoc = ''
_OlePublic = ''
_Ole = ''
_Ole2 = ''
_UniqueID = ''
_Comentario = ''
_ClassIcon = ''
_ProjectClassIcon = ''
_Inicio = 0
_Fin = 0
_Ini_Cab = 0
_Fin_Cab = 0
_Ini_Cuerpo = 0
_Fin_Cuerpo = 0
_Prop_Count = 0
_HiddenProps = ''
_ProtectedProps = ''
_HiddenMethods = ''
_ProtectedMethods = ''
_MetaData = ''
_BaseClass = ''
_TimeStamp = 0
_Scale = ''
_Defined_PAM = ''
_includeFile = ''
_AddObject_Count = 0
_Procedure_Count = 0
_PROPERTIES = ''
_PROTECTED = ''
_METHODS = ''
_RESERVED1 = ''
_RESERVED2 = ''
_RESERVED3 = ''
_RESERVED4 = ''
_RESERVED5 = ''
_RESERVED6 = ''
_RESERVED7 = ''
_RESERVED8 = ''
_User = ''
************************************************************************************************
PROCEDURE add_Procedure
LPARAMETERS toProcedure
#IF .F.
LOCAL toProcedure AS CL_PROCEDURE OF 'FOXBIN2PRG.PRG'
#ENDIF
WITH THIS AS CL_CLASE OF 'FOXBIN2PRG.PRG'
._Procedure_Count = ._Procedure_Count + 1
DIMENSION ._Procedures( ._Procedure_Count )
._Procedures( ._Procedure_Count ) = toProcedure
ENDWITH && THIS
ENDPROC
************************************************************************************************
PROCEDURE add_Property
LPARAMETERS tcProperty AS STRING, tcValue AS STRING, tcComment AS STRING
WITH THIS AS CL_CLASE OF 'FOXBIN2PRG.PRG'
._Prop_Count = ._Prop_Count + 1
DIMENSION ._Props( ._Prop_Count, 3 )
._Props( ._Prop_Count, 1 ) = tcProperty
._Props( ._Prop_Count, 2 ) = tcValue
._Props( ._Prop_Count, 3 ) = tcComment
ENDWITH && THIS
ENDPROC
************************************************************************************************
PROCEDURE add_Object
LPARAMETERS toObjeto
#IF .F.
LOCAL toObjeto AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
#ENDIF
WITH THIS AS CL_CLASE OF 'FOXBIN2PRG.PRG'
._AddObject_Count = ._AddObject_Count + 1
DIMENSION ._AddObjects( ._AddObject_Count )
._AddObjects( ._AddObject_Count ) = toObjeto
ENDWITH && THIS
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_PROCEDURE AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_PROCEDURE OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="add_line" display="add_Line"/>] ;
+ [<memberdata name="_comentario" display="_Comentario"/>] ;
+ [<memberdata name="_nombre" display="_Nombre"/>] ;
+ [<memberdata name="_procline_count" display="_ProcLine_Count"/>] ;
+ [<memberdata name="_proclines" display="_ProcLines"/>] ;
+ [<memberdata name="_proctype" display="_ProcType"/>] ;
+ [</VFPData>]
DIMENSION _ProcLines[1]
_Nombre = ''
_ProcType = ''
_Comentario = ''
_ProcLine_Count = 0
************************************************************************************************
PROCEDURE add_Line
LPARAMETERS tcLine AS STRING
WITH THIS AS CL_CLASE OF 'FOXBIN2PRG.PRG'
._ProcLine_Count = ._ProcLine_Count + 1
DIMENSION ._ProcLines( ._ProcLine_Count )
._ProcLines( ._ProcLine_Count ) = tcLine
ENDWITH && THIS
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_OBJETO AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="add_procedure" display="add_Procedure"/>] ;
+ [<memberdata name="add_property" display="add_Property"/>] ;
+ [<memberdata name="_baseclass" display="_BaseClass"/>] ;
+ [<memberdata name="_class" display="_Class"/>] ;
+ [<memberdata name="_classlib" display="_ClassLib"/>] ;
+ [<memberdata name="_nombre" display="_Nombre"/>] ;
+ [<memberdata name="_objname" display="_ObjName"/>] ;
+ [<memberdata name="_ole" display="_Ole"/>] ;
+ [<memberdata name="_ole2" display="_Ole2"/>] ;
+ [<memberdata name="_parent" display="_Parent"/>] ;
+ [<memberdata name="_writeorder" display="_WriteOrder"/>] ;
+ [<memberdata name="_procedures" display="_Procedures"/>] ;
+ [<memberdata name="_procedure_count" display="_Procedure_Count"/>] ;
+ [<memberdata name="_props" display="_Props"/>] ;
+ [<memberdata name="_prop_count" display="_Prop_Count"/>] ;
+ [<memberdata name="_timestamp" display="_TimeStamp"/>] ;
+ [<memberdata name="_uniqueid" display="_UniqueID"/>] ;
+ [<memberdata name="_user" display="_User"/>] ;
+ [<memberdata name="_zorder" display="_ZOrder"/>] ;
+ [</VFPData>]
DIMENSION _Props[1,1], _Procedures[1]
_Nombre = ''
_ObjName = ''
_Parent = ''
_Class = ''
_ClassLib = ''
_BaseClass = ''
_UniqueID = ''
_TimeStamp = 0
_Ole = ''
_Ole2 = ''
_Prop_Count = 0
_Procedure_Count = 0
_User = ''
_WriteOrder = 0
_ZOrder = 0
************************************************************************************************
PROCEDURE add_Procedure
LPARAMETERS toProcedure
#IF .F.
LOCAL toProcedure AS CL_PROCEDURE OF 'FOXBIN2PRG.PRG'
#ENDIF
WITH THIS AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
IF '.' $ ._Nombre
toProcedure._Nombre = SUBSTR( toProcedure._Nombre, AT( '.', toProcedure._Nombre, OCCURS( '.', ._Nombre) ) + 1 )
ENDIF
._Procedure_Count = ._Procedure_Count + 1
DIMENSION ._Procedures( ._Procedure_Count )
._Procedures( ._Procedure_Count ) = toProcedure
ENDWITH && THIS
ENDPROC
************************************************************************************************
PROCEDURE add_Property
LPARAMETERS tcProperty AS STRING, tcValue AS STRING
WITH THIS AS CL_OBJETO OF 'FOXBIN2PRG.PRG'
._Prop_Count = ._Prop_Count + 1
DIMENSION ._Props( ._Prop_Count, 2 )
._Props( ._Prop_Count, 1 ) = tcProperty
._Props( ._Prop_Count, 2 ) = tcValue
ENDWITH && THIS
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_REPORT AS CL_COL_BASE
#IF .F.
LOCAL THIS AS CL_REPORT OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_timestamp" display="_TimeStamp"/>] ;
+ [<memberdata name="_version" display="_Version"/>] ;
+ [<memberdata name="_sourcefile" display="_SourceFile"/>] ;
+ [</VFPData>]
*-- Report.Info
_TimeStamp = 0
_Version = ''
_SourceFile = ''
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_PROJECT AS CL_COL_BASE
#IF .F.
LOCAL THIS AS CL_PROJECT OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_cmntstyle" display="_CmntStyle"/>] ;
+ [<memberdata name="_debug" display="_Debug"/>] ;
+ [<memberdata name="_encrypted" display="_Encrypted"/>] ;
+ [<memberdata name="_homedir" display="_HomeDir"/>] ;
+ [<memberdata name="_icon" display="_Icon"/>] ;
+ [<memberdata name="_mainprog" display="_MainProg"/>] ;
+ [<memberdata name="_nologo" display="_NoLogo"/>] ;
+ [<memberdata name="_objrev" display="_ObjRev"/>] ;
+ [<memberdata name="_projecthookclass" display="_ProjectHookClass"/>] ;
+ [<memberdata name="_projecthooklibrary" display="_ProjectHookLibrary"/>] ;
+ [<memberdata name="_savecode" display="_SaveCode"/>] ;
+ [<memberdata name="_serverinfo" display="_ServerInfo"/>] ;
+ [<memberdata name="_serverhead" display="_ServerHead"/>] ;
+ [<memberdata name="_sourcefile" display="_SourceFile"/>] ;
+ [<memberdata name="_timestamp" display="_TimeStamp"/>] ;
+ [<memberdata name="_version" display="_Version"/>] ;
+ [<memberdata name="_address" display="_Address"/>] ;
+ [<memberdata name="_author" display="_Author"/>] ;
+ [<memberdata name="_company" display="_Company"/>] ;
+ [<memberdata name="_city" display="_City"/>] ;
+ [<memberdata name="_state" display="_State"/>] ;
+ [<memberdata name="_postalcode" display="_PostalCode"/>] ;
+ [<memberdata name="_country" display="_Country"/>] ;
+ [<memberdata name="_comments" display="_Comments"/>] ;
+ [<memberdata name="_companyname" display="_CompanyName"/>] ;
+ [<memberdata name="_filedescription" display="_FileDescription"/>] ;
+ [<memberdata name="_legalcopyright" display="_LegalCopyright"/>] ;
+ [<memberdata name="_legaltrademark" display="_LegalTrademark"/>] ;
+ [<memberdata name="_productname" display="_ProductName"/>] ;
+ [<memberdata name="_majorver" display="_MajorVer"/>] ;
+ [<memberdata name="_minorver" display="_MinorVer"/>] ;
+ [<memberdata name="_revision" display="_Revision"/>] ;
+ [<memberdata name="_languageid" display="_LanguageID"/>] ;
+ [<memberdata name="_autoincrement" display="_AutoIncrement"/>] ;
+ [<memberdata name="getformatteddeviceinfotext" display="getFormattedDeviceInfoText"/>] ;
+ [<memberdata name="parsedeviceinfo" display="parseDeviceInfo"/>] ;
+ [<memberdata name="parsenullterminatedvalue" display="parseNullTerminatedValue"/>] ;
+ [<memberdata name="setparsedinfoline" display="setParsedInfoLine"/>] ;
+ [<memberdata name="setparsedprojinfoline" display="setParsedProjInfoLine"/>] ;
+ [<memberdata name="getrowdeviceinfo" display="getRowDeviceInfo"/>] ;
+ [</VFPData>]
*-- Proj.Info
_CmntStyle = 1
_Debug = .F.
_Encrypted = .F.
_HomeDir = ''
_Icon = ''
_ID = ''
_MainProg = ''
_NoLogo = .F.
_ObjRev = 0
_ProjectHookClass = ''
_ProjectHookLibrary = ''
_SaveCode = .T.
_ServerHead = NULL
_ServerInfo = ''
_SourceFile = ''
_TimeStamp = 0
_Version = ''
*-- Dev.info
_Author = ''
_Company = ''
_Address = ''
_City = ''
_State = ''
_PostalCode = ''
_Country = ''
_Comments = ''
_CompanyName = ''
_FileDescription = ''
_LegalCopyright = ''
_LegalTrademark = ''
_ProductName = ''
_MajorVer = ''
_MinorVer = ''
_Revision = ''
_LanguageID = ''
_AutoIncrement = ''
************************************************************************************************
PROCEDURE INIT
DODEFAULT()
THIS._ServerHead = CREATEOBJECT('CL_PROJ_SRV_HEAD')
ENDPROC
************************************************************************************************
PROCEDURE setParsedProjInfoLine
LPARAMETERS tcProjInfoLine
THIS.setParsedInfoLine( THIS, tcProjInfoLine )
ENDPROC
************************************************************************************************
PROCEDURE setParsedInfoLine
LPARAMETERS toObject, tcInfoLine
LOCAL lcAsignacion, lcCurDir
*lcCurDir = ADDBS(JUSTPATH(THIS._SourceFile))
lcCurDir = ADDBS(THIS._HomeDir)
IF LEFT(tcInfoLine,1) == '.'
lcAsignacion = 'toObject' + tcInfoLine
ELSE
lcAsignacion = 'toObject.' + tcInfoLine
ENDIF
&lcAsignacion.
ENDPROC
************************************************************************************************
PROCEDURE parseNullTerminatedValue
LPARAMETERS tcDevInfo, tnPos, tnLen
LOCAL lcValue, lnNullPos
lcStr = SUBSTR( tcDevInfo, tnPos, tnLen )
lnNullPos = AT(CHR(0), lcStr )
IF lnNullPos = 0
lcValue = CHRTRAN( LEFT( lcStr, tnLen ), ['], ["] )
ELSE
lcValue = CHRTRAN( LEFT( lcStr, MIN(tnLen, lnNullPos - 1 ) ), ['], ["] )
ENDIF
RETURN lcValue
ENDPROC
************************************************************************************************
PROCEDURE parseDeviceInfo
LPARAMETERS tcDevInfo
TRY
WITH THIS
._Author = .parseNullTerminatedValue( @tcDevInfo, 1, 45 )
._Company = .parseNullTerminatedValue( @tcDevInfo, 47, 45 )
._Address = .parseNullTerminatedValue( @tcDevInfo, 93, 45 )
._City = .parseNullTerminatedValue( @tcDevInfo, 139, 20 )
._State = .parseNullTerminatedValue( @tcDevInfo, 160, 5 )
._PostalCode = .parseNullTerminatedValue( @tcDevInfo, 166, 10 )
._Country = .parseNullTerminatedValue( @tcDevInfo, 177, 45 )
*--
._Comments = .parseNullTerminatedValue( @tcDevInfo, 223, 254 )
._CompanyName = .parseNullTerminatedValue( @tcDevInfo, 478, 254 )
._FileDescription = .parseNullTerminatedValue( @tcDevInfo, 733, 254 )
._LegalCopyright = .parseNullTerminatedValue( @tcDevInfo, 988, 254 )
._LegalTrademark = .parseNullTerminatedValue( @tcDevInfo, 1243, 254 )
._ProductName = .parseNullTerminatedValue( @tcDevInfo, 1498, 254 )
._MajorVer = .parseNullTerminatedValue( @tcDevInfo, 1753, 4 )
._MinorVer = .parseNullTerminatedValue( @tcDevInfo, 1758, 4 )
._Revision = .parseNullTerminatedValue( @tcDevInfo, 1763, 4 )
._LanguageID = .parseNullTerminatedValue( @tcDevInfo, 1768, 19 )
._AutoIncrement = IIF( SUBSTR( tcDevInfo, 1788, 1 ) = CHR(1), '1', '0' )
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
ENDPROC
************************************************************************************************
PROCEDURE getRowDeviceInfo
LPARAMETERS tcDevInfo
TRY
IF VARTYPE(tcDevInfo) # 'C' OR LEN(tcDevInfo) = 0
tcDevInfo = REPLICATE( CHR(0), 1795 )
ENDIF
WITH THIS
tcDevInfo = STUFF( tcDevInfo, 1, LEN(._Author), ._Author)
tcDevInfo = STUFF( tcDevInfo, 47, LEN(._Company), ._Company)
tcDevInfo = STUFF( tcDevInfo, 93, LEN(._Address), ._Address)
tcDevInfo = STUFF( tcDevInfo, 139, LEN(._City), ._City)
tcDevInfo = STUFF( tcDevInfo, 160, LEN(._State), ._State)
tcDevInfo = STUFF( tcDevInfo, 166, LEN(._PostalCode), ._PostalCode)
tcDevInfo = STUFF( tcDevInfo, 177, LEN(._Country), ._Country)
tcDevInfo = STUFF( tcDevInfo, 223, LEN(._Comments), ._Comments)
tcDevInfo = STUFF( tcDevInfo, 478, LEN(._CompanyName), ._CompanyName)
tcDevInfo = STUFF( tcDevInfo, 733, LEN(._FileDescription), ._FileDescription)
tcDevInfo = STUFF( tcDevInfo, 988, LEN(._LegalCopyright), ._LegalCopyright)
tcDevInfo = STUFF( tcDevInfo, 1243, LEN(._LegalTrademark), ._LegalTrademark)
tcDevInfo = STUFF( tcDevInfo, 1498, LEN(._ProductName), ._ProductName)
tcDevInfo = STUFF( tcDevInfo, 1753, LEN(._MajorVer), ._MajorVer)
tcDevInfo = STUFF( tcDevInfo, 1758, LEN(._MinorVer), ._MinorVer)
tcDevInfo = STUFF( tcDevInfo, 1763, LEN(._Revision), ._Revision)
tcDevInfo = STUFF( tcDevInfo, 1768, LEN(._LanguageID), ._LanguageID)
tcDevInfo = STUFF( tcDevInfo, 1788, 1, CHR(VAL(._AutoIncrement)))
tcDevInfo = STUFF( tcDevInfo, 1792, 1, CHR(1))
ENDWITH && THIS
CATCH TO loEx
lnCodError = loEx.ERRORNO
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN tcDevInfo
ENDPROC
************************************************************************************************
PROCEDURE getFormattedDeviceInfoText
TRY
LOCAL lcText
lcText = ''
WITH THIS
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_DEVINFO_I>>
_Author = "<<._Author>>"
_Company = "<<._Company>>"
_Address = "<<._Address>>"
_City = "<<._City>>"
_State = "<<._State>>"
_PostalCode = "<<._PostalCode>>"
_Country = "<<._Country>>"
*--
_Comments = "<<._Comments>>"
_CompanyName = "<<._CompanyName>>"
_FileDescription = "<<._FileDescription>>"
_LegalCopyright = "<<._LegalCopyright>>"
_LegalTrademark = "<<._LegalTrademark>>"
_ProductName = "<<._ProductName>>"
_MajorVer = "<<._MajorVer>>"
_MinorVer = "<<._MinorVer>>"
_Revision = "<<._Revision>>"
_LanguageID = "<<._LanguageID>>"
_AutoIncrement = "<<._AutoIncrement>>"
<<C_DEVINFO_F>>
<<>>
ENDTEXT
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_COL_BASE AS CL_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBC_COL_BASE OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="__objectid" display="__ObjectID"/>] ;
+ [<memberdata name="updatedbc" display="updateDBC"/>] ;
+ [</VFPData>]
__ObjectID = 0
_Name = ''
PROCEDURE updateDBC
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_OutputFile (v! IN ) Nombre del archivo de salida
* tnLastID (@! IN ) Último número de ID usado
* tnParentID (v! IN ) ID del objeto Padre
*---------------------------------------------------------------------------------------------------
LPARAMETERS tc_OutputFile, tnLastID, tnParentID
LOCAL loObject
FOR EACH loObject IN THIS FOXOBJECT
loObject.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
ENDFOR
RETURN
ENDPROC
PROCEDURE __ObjectID_ACCESS
RETURN THIS.PARENT.__ObjectID
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_BASE AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="add_property" display="Add_Property"/>] ;
+ [<memberdata name="analizarbloque_comment" display="analizarBloque_Comment"/>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="__objectid" display="__ObjectID"/>] ;
+ [<memberdata name="dbgetprop" display="DBGETPROP"/>] ;
+ [<memberdata name="dbsetprop" display="DBSETPROP"/>] ;
+ [<memberdata name="getallpropertiesfromobjectname" display="getAllPropertiesFromObjectname"/>] ;
+ [<memberdata name="getbinpropertydatarecord" display="getBinPropertyDataRecord"/>] ;
+ [<memberdata name="getcodememo" display="getCodeMemo"/>] ;
+ [<memberdata name="getdbcpropertyidbyname" display="getDBCPropertyIDByName"/>] ;
+ [<memberdata name="getdbcpropertynamebyid" display="getDBCPropertyNameByID"/>] ;
+ [<memberdata name="getdbcpropertyvaluetypebypropertyid" display="getDBCPropertyValueTypeByPropertyID"/>] ;
+ [<memberdata name="getid" display="getID"/>] ;
+ [<memberdata name="getobjecttype" display="getObjectType"/>] ;
+ [<memberdata name="getbinmemofromproperties" display="getBinMemoFromProperties"/>] ;
+ [<memberdata name="getreferentialintegrityinfo" display="getReferentialIntegrityInfo"/>] ;
+ [<memberdata name="getusermemo" display="getUserMemo"/>] ;
+ [<memberdata name="setnextid" display="setNextID"/>] ;
+ [<memberdata name="updatedbc" display="updateDBC"/>] ;
+ [</VFPData>]
__ObjectID = 0
_Name = ''
FUNCTION add_Property
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcPropertyName (v! IN ) Nombre de la propiedad a agregar o modificar
* teValue (v! IN ) Valor de la propiedad
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcPropertyName, teValue
LOCAL lnPropertyID, tcDataType, leValue, llRetorno, lnDataLen
WITH THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
lnPropertyID = .getDBCPropertyIDByName( SUBSTR(tcPropertyName,2) )
IF lnPropertyID = -1
IF PCOUNT()=1
llRetorno = .ADDPROPERTY( tcPropertyName )
ELSE
llRetorno = .ADDPROPERTY( tcPropertyName, teValue )
ENDIF
ELSE
tcDataType = .getDBCPropertyValueTypeByPropertyID( lnPropertyID )
lnDataLen = LEN(teValue)
DO CASE
CASE tcDataType = 'L'
IF lnDataLen = 0
leValue = .F.
ELSE
leValue = CAST( teValue AS (tcDataType) )
ENDIF
CASE INLIST(tcDataType, 'N', 'B')
IF lnDataLen = 0
leValue = 0
ELSE
leValue = CAST( teValue AS (tcDataType) (lnDataLen) )
ENDIF
OTHERWISE && Asumo 'C'
IF lnDataLen = 0
leValue = ''
ELSE
leValue = teValue
ENDIF
ENDCASE
llRetorno = .ADDPROPERTY( tcPropertyName, leValue )
ENDIF
ENDWITH && THIS
RETURN llRetorno
ENDFUNC
PROCEDURE analizarBloque_Comment
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
IF LEFT(tcLine, LEN('<Comment>')) == '<Comment>'
LOCAL lcValue
llBloqueEncontrado = .T.
lcValue = STREXTRACT( taCodeLines(I), '<Comment>', '</Comment>', 1, 2 )
WITH THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
IF NOT '</Comment>' $ tcLine THEN
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE '</Comment>' $ tcLine && Fin
lcValue = lcValue + CR_LF + LEFT( taCodeLines(I), AT( '</Comment>', taCodeLines(I) ) - 1 )
EXIT
OTHERWISE && Línea de Stored Procedure
lcValue = lcValue + CR_LF + taCodeLines(I)
ENDCASE
ENDFOR
ENDIF
.ADDPROPERTY( '_Comment', lcValue )
ENDWITH && THIS
ENDIF
ENDPROC
PROCEDURE getAllPropertiesFromObjectname
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcName (v! IN ) Nombre del objeto
* tcType (v! IN ) Tipo de objeto (Table, Index, Field, View, Relation)
* taProperties (@! OUT) Array con las propiedades encontradas y sus valores
* tnProperty_Count (@! OUT) Cantidad de propiedades encontradas
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcName, tcType, taProperties, tnProperty_Count
EXTERNAL ARRAY taProperties && STRUCTURE: PropName,RecordLen,DataIDLen,DataID,DataType,Data
TRY
LOCAL lcValue, leValue, lnSelect, laProperty(1,1), lnRecordLen, lcBinRecord, lnPropertyID ;
, lnLastPos, lnLenCCode, lcDataType, lcPropName, lcDBF, lnLenData, lnLenHeader
WITH THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
tnProperty_Count = 0
lnSelect = SELECT()
leValue = ''
tcName = PROPER(RTRIM(tcName))
tcType = PROPER(RTRIM(tcType))
tcProperty = PROPER(RTRIM(tcProperty))
lcDBF = DBF()
SELECT 0
USE (lcDBF) AGAIN SHARED NOUPDATE ALIAS C_TABLABIN2
IF INLIST( tcType, 'Index', 'Field' )
SELECT TB.Property FROM C_TABLABIN2 TB ;
INNER JOIN C_TABLABIN2 TB2 ON STR(TB.ParentID)+TB.ObjectType+LOWER(TB.objectName) = STR(TB2.ObjectID)+PADR(tcType,10)+PADR(LOWER(JUSTEXT(tcName)),128) ;
AND TB2.objectName = PADR(LOWER(JUSTSTEM(tcName)),128) ;
INTO ARRAY laProperty
ELSE
SELECT TB.Property FROM C_TABLABIN2 TB ;
INNER JOIN C_TABLABIN2 TB2 ON STR(TB.ParentID)+TB.ObjectType+LOWER(TB.objectName) = STR(TB2.ObjectID)+PADR(tcType,10)+PADR(LOWER(tcName),128) ;
INTO ARRAY laProperty
ENDIF
IF _TALLY > 0
IF EMPTY(laProperty(1,1))
EXIT
ENDIF
lnLastPos = 1
DO WHILE lnLastPos < LEN(laProperty(1,1))
tnProperty_Count = tnProperty_Count + 1
DIMENSION taProperties( tnProperty_Count,6 )
lnRecordLen = CTOBIN( SUBSTR(laProperty(1,1), lnLastPos, 4), "4RS" )
lcBinRecord = SUBSTR(laProperty(1,1), lnLastPos, lnRecordLen)
lnLenCCode = CTOBIN( SUBSTR(lcBinRecord, 4+1, 2), "2RS" )
lnPropertyID = ASC( SUBSTR(lcBinRecord, 4+2+1, lnLenCCode) )
lcPropName = .getDBCPropertyNameByID( lnPropertyID )
lcDataType = .getDBCPropertyValueTypeByPropertyID( lnPropertyID )
lnLenHeader = 4 + 2 + lnLenCCode
lcValue = SUBSTR(lcBinRecord, lnLenHeader + 1)
DO CASE
CASE lcDataType = 'B'
IF lnLenHeader = lnRecordLen
leValue = 0
ELSE
leValue = ASC( lcValue )
ENDIF
CASE lcDataType = 'L'
IF lnLenHeader = lnRecordLen
leValue = .F.
ELSE
leValue = ( CTOBIN( lcValue, "1S" ) = 1 )
ENDIF
CASE lcDataType = 'N'
IF lnLenHeader = lnRecordLen
leValue = 0
ELSE
leValue = CTOBIN( lcValue, "4S" )
ENDIF
OTHERWISE && Asume 'C'
IF lnLenHeader = lnRecordLen
leValue = ''
ELSE
leValue = LEFT( lcValue, AT( CHR(0), lcValue ) - 1 )
ENDIF
ENDCASE
taProperties( tnProperty_Count,1 ) = lcPropName
taProperties( tnProperty_Count,2 ) = lnRecordLen
taProperties( tnProperty_Count,3 ) = lnLenCCode
taProperties( tnProperty_Count,4 ) = lnPropertyID
taProperties( tnProperty_Count,5 ) = lcDataType
taProperties( tnProperty_Count,6 ) = leValue
lnLastPos = lnLastPos + lnRecordLen
ENDDO
ELSE
ERROR 1562, (tcName)
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("C_TABLABIN2"))
SELECT (lnSelect)
ENDTRY
RETURN leValue
ENDPROC
PROCEDURE getDBCPropertyIDByName
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcPropertyName (v! IN ) Nombre de la propiedad
* tlRethrowError (v? IN ) Indica si se debe relanzar el error o solo devolver -1
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcPropertyName, tlRethrowError
LOCAL lnPropertyID
tcPropertyName = LOWER(RTRIM(tcPropertyName))
DO CASE
CASE tcPropertyName == 'null'
lnPropertyID = 0
CASE tcPropertyName == 'path'
lnPropertyID = 1
CASE tcPropertyName == 'class'
lnPropertyID = 2
CASE tcPropertyName == 'comment'
lnPropertyID = 7
CASE tcPropertyName == 'ruleexpression'
lnPropertyID = 9
CASE tcPropertyName == 'ruletext'
lnPropertyID = 10
CASE tcPropertyName == 'defaultvalue'
lnPropertyID = 11
CASE tcPropertyName == 'parameterlist'
lnPropertyID = 12
CASE tcPropertyName == 'childtag'
lnPropertyID = 13
CASE tcPropertyName == 'inserttrigger'
lnPropertyID = 14
CASE tcPropertyName == 'updatetrigger'
lnPropertyID = 15
CASE tcPropertyName == 'deletetrigger'
lnPropertyID = 16
CASE tcPropertyName == 'isunique'
lnPropertyID = 17
CASE tcPropertyName == 'parenttable'
lnPropertyID = 18
CASE tcPropertyName == 'parenttag'
lnPropertyID = 19
CASE tcPropertyName == 'primarykey'
lnPropertyID = 20
CASE tcPropertyName == 'version'
lnPropertyID = 24
CASE tcPropertyName == 'batchupdatecount'
lnPropertyID = 28
CASE tcPropertyName == 'datasource'
lnPropertyID = 29
CASE tcPropertyName == 'connectname'
lnPropertyID = 32
CASE tcPropertyName == 'updatename'
lnPropertyID = 35
CASE tcPropertyName == 'fetchmemo'
lnPropertyID = 36
CASE tcPropertyName == 'fetchsize'
lnPropertyID = 37
CASE tcPropertyName == 'keyfield'
lnPropertyID = 38
CASE tcPropertyName == 'maxrecords'
lnPropertyID = 39
CASE tcPropertyName == 'shareconnection'
lnPropertyID = 40
CASE tcPropertyName == 'sourcetype'
lnPropertyID = 41
CASE tcPropertyName == 'sql'
lnPropertyID = 42
CASE tcPropertyName == 'tables'
lnPropertyID = 43
CASE tcPropertyName == 'sendupdates'
lnPropertyID = 44
CASE tcPropertyName == 'updatablefield' OR tcPropertyName == 'updatable'
lnPropertyID = 45
CASE tcPropertyName == 'updatetype'
lnPropertyID = 46
CASE tcPropertyName == 'usememosize'
lnPropertyID = 47
CASE tcPropertyName == 'wheretype'
lnPropertyID = 48
CASE tcPropertyName == 'displayclass' && Undocumented
lnPropertyID = 50
CASE tcPropertyName == 'displayclasslibrary' && Undocumented
lnPropertyID = 51
CASE tcPropertyName == 'inputmask' && Undocumented
lnPropertyID = 54
CASE tcPropertyName == 'format' && Undocumented
lnPropertyID = 55
CASE tcPropertyName == 'caption'
lnPropertyID = 56
CASE tcPropertyName == 'asynchronous'
lnPropertyID = 64
CASE tcPropertyName == 'batchmode'
lnPropertyID = 65
CASE tcPropertyName == 'connectstring'
lnPropertyID = 66
CASE tcPropertyName == 'connecttimeout'
lnPropertyID = 67
CASE tcPropertyName == 'displogin'
lnPropertyID = 68
CASE tcPropertyName == 'dispwarnings'
lnPropertyID = 69
CASE tcPropertyName == 'idletimeout'
lnPropertyID = 70
CASE tcPropertyName == 'querytimeout'
lnPropertyID = 71
CASE tcPropertyName == 'password'
lnPropertyID = 72
CASE tcPropertyName == 'transactions'
lnPropertyID = 73
CASE tcPropertyName == 'userid'
lnPropertyID = 74
CASE tcPropertyName == 'waittime'
lnPropertyID = 75
CASE tcPropertyName == 'timestamp'
lnPropertyID = 76
CASE tcPropertyName == 'datatype'
lnPropertyID = 77
CASE tcPropertyName == 'packetsize' && Undocumented
lnPropertyID = 78
CASE tcPropertyName == 'database' && Undocumented
lnPropertyID = 79
CASE tcPropertyName == 'prepared' && Undocumented
lnPropertyID = 80
CASE tcPropertyName == 'comparememo' && Undocumented
lnPropertyID = 81
CASE tcPropertyName == 'fetchasneeded' && Undocumented
lnPropertyID = 82
CASE tcPropertyName == 'offline' && Undocumented
lnPropertyID = 83
CASE tcPropertyName == 'recordcount' && Undocumented
lnPropertyID = 84
CASE tcPropertyName == 'undocumented_view_prop_85' && Undocumented
lnPropertyID = 85
CASE tcPropertyName == 'dbcevents' && Undocumented
lnPropertyID = 86
CASE tcPropertyName == 'dbceventfilename' && Undocumented
lnPropertyID = 87
CASE tcPropertyName == 'allowsimultaneousfetch' && Undocumented
lnPropertyID = 88
CASE tcPropertyName == 'disconnectrollback' && Undocumented
lnPropertyID = 89
OTHERWISE
IF tlRethrowError
ERROR 1559, (tcPropertyName)
ELSE
lnPropertyID = -1
ENDIF
ENDCASE
RETURN lnPropertyID
ENDPROC
PROCEDURE getDBCPropertyNameByID
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcPropertyID (v! IN ) Nombre de la propiedad
* tlRethrowError (v? IN ) Indica si se debe relanzar el error o solo devolver -1
*---------------------------------------------------------------------------------------------------
LPARAMETERS tnPropertyID, tlRethrowError
LOCAL lcPropertyName
DO CASE
CASE tnPropertyID = 0
lcPropertyName = 'null'
CASE tnPropertyID = 1
lcPropertyName = 'path'
CASE tnPropertyID = 2
lcPropertyName = 'class'
CASE tnPropertyID = 7
lcPropertyName = 'comment'
CASE tnPropertyID = 9
lcPropertyName = 'ruleexpression'
CASE tnPropertyID = 10
lcPropertyName = 'ruletext'
CASE tnPropertyID = 11
lcPropertyName = 'defaultvalue'
CASE tnPropertyID = 12
lcPropertyName = 'parameterlist'
CASE tnPropertyID = 13
lcPropertyName = 'childtag'
CASE tnPropertyID = 14
lcPropertyName = 'inserttrigger'
CASE tnPropertyID = 15
lcPropertyName = 'updatetrigger'
CASE tnPropertyID = 16
lcPropertyName = 'deletetrigger'
CASE tnPropertyID = 17
lcPropertyName = 'isunique'
CASE tnPropertyID = 18
lcPropertyName = 'parenttable'
CASE tnPropertyID = 19
lcPropertyName = 'parenttag'
CASE tnPropertyID = 20
lcPropertyName = 'primarykey'
CASE tnPropertyID = 24
lcPropertyName = 'version'
CASE tnPropertyID = 28
lcPropertyName = 'batchupdatecount'
CASE tnPropertyID = 29
lcPropertyName = 'datasource'
CASE tnPropertyID = 32
lcPropertyName = 'connectname'
CASE tnPropertyID = 35
lcPropertyName = 'updatename'
CASE tnPropertyID = 36
lcPropertyName = 'fetchmemo'
CASE tnPropertyID = 37
lcPropertyName = 'fetchsize'
CASE tnPropertyID = 38
lcPropertyName = 'keyfield'
CASE tnPropertyID = 39
lcPropertyName = 'maxrecords'
CASE tnPropertyID = 40
lcPropertyName = 'shareconnection'
CASE tnPropertyID = 41
lcPropertyName = 'sourcetype'
CASE tnPropertyID = 42
lcPropertyName = 'sql'
CASE tnPropertyID = 43
lcPropertyName = 'tables'
CASE tnPropertyID = 44
lcPropertyName = 'sendupdates'
CASE tnPropertyID = 45
lcPropertyName = 'updatablefield'
CASE tnPropertyID = 46
lcPropertyName = 'updatetype'
CASE tnPropertyID = 47
lcPropertyName = 'usememosize'
CASE tnPropertyID = 48
lcPropertyName = 'wheretype'
CASE tnPropertyID = 50
lcPropertyName = 'displayclass' && Undocumented
CASE tnPropertyID = 51
lcPropertyName = 'displayclasslibrary' && Undocumented
CASE tnPropertyID = 54
lcPropertyName = 'inputmask' && Undocumented
CASE tnPropertyID = 55
lcPropertyName = 'format' && Undocumented
CASE tnPropertyID = 56
lcPropertyName = 'caption'
CASE tnPropertyID = 64
lcPropertyName = 'asynchronous'
CASE tnPropertyID = 65
lcPropertyName = 'batchmode'
CASE tnPropertyID = 66
lcPropertyName = 'connectstring'
CASE tnPropertyID = 67
lcPropertyName = 'connecttimeout'
CASE tnPropertyID = 68
lcPropertyName = 'displogin'
CASE tnPropertyID = 69
lcPropertyName = 'dispwarnings'
CASE tnPropertyID = 70
lcPropertyName = 'idletimeout'
CASE tnPropertyID = 71
lcPropertyName = 'querytimeout'
CASE tnPropertyID = 72
lcPropertyName = 'password'
CASE tnPropertyID = 73
lcPropertyName = 'transactions'
CASE tnPropertyID = 74
lcPropertyName = 'userid'
CASE tnPropertyID = 75
lcPropertyName = 'waittime'
CASE tnPropertyID = 76
lcPropertyName = 'timestamp'
CASE tnPropertyID = 77
lcPropertyName = 'datatype'
CASE tnPropertyID = 78
lcPropertyName = 'packetsize' && Undocumented
CASE tnPropertyID = 79
lcPropertyName = 'database' && Undocumented
CASE tnPropertyID = 80
lcPropertyName = 'prepared' && Undocumented
CASE tnPropertyID = 81
lcPropertyName = 'comparememo' && Undocumented
CASE tnPropertyID = 82
lcPropertyName = 'fetchasneeded' && Undocumented
CASE tnPropertyID = 83
lcPropertyName = 'offline' && Undocumented
CASE tnPropertyID = 84
lcPropertyName = 'recordcount' && Undocumented
CASE tnPropertyID = 85
lcPropertyName = 'undocumented_view_prop_85' && Undocumented
CASE tnPropertyID = 86
lcPropertyName = 'dbcevents' && Undocumented
CASE tnPropertyID = 87
lcPropertyName = 'dbceventfilename' && Undocumented
CASE tnPropertyID = 88
lcPropertyName = 'allowsimultaneousfetch' && Undocumented
CASE tnPropertyID = 89
lcPropertyName = 'disconnectrollback' && Undocumented
OTHERWISE
IF tlRethrowError
ERROR 1559, (TRANSFORM(tnPropertyID))
ELSE
lcPropertyName = ''
ENDIF
ENDCASE
RETURN lcPropertyName
ENDPROC
PROCEDURE getDBCPropertyValueTypeByPropertyID
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tnPropertyID (v! IN ) ID de la Propiedad
*---------------------------------------------------------------------------------------------------
LPARAMETERS tnPropertyID
LOCAL lcValueType
lcValueType = ''
DO CASE
CASE INLIST(tnPropertyID,2,41,46,48,68,73)
lcValueType = 'B' && Byte
CASE INLIST(tnPropertyID,17,36,38,40,44,45,64,65,69,80,81,82,83,86,88,89)
lcValueType = 'L'
CASE INLIST(tnPropertyID,24,28,37,39,47,67,70,71,75,76,78,84,85)
lcValueType = 'N'
CASE INLIST(tnPropertyID,0,1,7,9,10,11,12,13,14,15,16,18,19,20,29,30,32,35) ;
OR INLIST(tnPropertyID,42,43,49,50,51,54,55,56,66,67,72,74,77,79,87)
lcValueType = 'C'
OTHERWISE
*ERROR 'Propiedad [' + TRANSFORM(tnPropertyID) + '] no reconocida.'
ERROR (TEXTMERGE(C_PROPERTY_NAME_NOT_RECOGNIZED_LOC))
ENDCASE
RETURN lcValueType
ENDPROC
PROCEDURE DBGETPROP
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcName (v! IN ) Nombre del objeto
* tcType (v! IN ) Tipo de objeto (Table, Index, Field, View, Relation)
* tcProperty (v! IN ) Nombre de la propiedad
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcName, tcType, tcProperty
TRY
LOCAL lcValue, leValue, lnSelect, laProperty(1,1), lnRecordLen, lcBinRecord, lnPropertyID ;
, lnLastPos, lnLenCCode, lcDataType, lnSerchedDataCC, lcDBF, lnLenData, lnLenHeader
WITH THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
lnSelect = SELECT()
leValue = ''
tcName = PROPER(RTRIM(tcName))
tcType = PROPER(RTRIM(tcType))
tcProperty = PROPER(RTRIM(tcProperty))
lcDBF = DBF()
SELECT 0
USE (lcDBF) AGAIN SHARED NOUPDATE ALIAS C_TABLABIN2
IF INLIST( tcType, 'Index', 'Field' )
SELECT TB.Property FROM C_TABLABIN2 TB ;
INNER JOIN C_TABLABIN2 TB2 ON STR(TB.ParentID)+TB.ObjectType+LOWER(TB.objectName) = STR(TB2.ObjectID)+PADR(tcType,10)+PADR(LOWER(JUSTEXT(tcName)),128) ;
AND TB2.objectName = PADR(LOWER(JUSTSTEM(tcName)),128) ;
INTO ARRAY laProperty
ELSE
SELECT TB.Property FROM C_TABLABIN2 TB ;
INNER JOIN C_TABLABIN2 TB2 ON STR(TB.ParentID)+TB.ObjectType+LOWER(TB.objectName) = STR(TB2.ObjectID)+PADR(tcType,10)+PADR(LOWER(tcName),128) ;
INTO ARRAY laProperty
ENDIF
IF _TALLY > 0
IF EMPTY(laProperty(1,1))
EXIT
ENDIF
lnLastPos = 1
lnSerchedDataCC = .getDBCPropertyIDByName( tcProperty, .T. )
DO WHILE lnLastPos < LEN(laProperty(1,1))
lnRecordLen = CTOBIN( SUBSTR(laProperty(1,1), lnLastPos, 4), "4RS" )
lcBinRecord = SUBSTR(laProperty(1,1), lnLastPos, lnRecordLen)
lnLenCCode = CTOBIN( SUBSTR(lcBinRecord, 4+1, 2), "2RS" )
lnPropertyID = ASC( SUBSTR(lcBinRecord, 4+2+1, lnLenCCode) )
IF lnPropertyID = lnSerchedDataCC
lcDataType = .getDBCPropertyValueTypeByPropertyID( lnPropertyID )
lnLenHeader = 4 + 2 + lnLenCCode
lcValue = SUBSTR(lcBinRecord, lnLenHeader + 1)
DO CASE
CASE lcDataType = 'B'
IF lnLenHeader = lnRecordLen
leValue = 0
ELSE
leValue = ASC( lcValue )
ENDIF
CASE lcDataType = 'L'
IF lnLenHeader = lnRecordLen
leValue = .F.
ELSE
leValue = ( CTOBIN( lcValue, "1S" ) = 1 )
ENDIF
CASE lcDataType = 'N'
IF lnLenHeader = lnRecordLen
leValue = 0
ELSE
leValue = CTOBIN( lcValue, "4S" )
ENDIF
OTHERWISE && Asume 'C'
IF lnLenHeader = lnRecordLen
leValue = ''
ELSE
leValue = LEFT( lcValue, AT( CHR(0), lcValue ) - 1 )
ENDIF
ENDCASE
EXIT
ENDIF
lnLastPos = lnLastPos + lnRecordLen
ENDDO
ELSE
ERROR 1562, (tcName)
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("C_TABLABIN2"))
SELECT (lnSelect)
ENDTRY
RETURN leValue
ENDPROC
PROCEDURE DBSETPROP
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcName (v! IN ) Nombre del objeto
* tcType (v! IN ) Tipo de objeto (Table, Index, Field, View, Relation)
* tcProperty (v! IN ) Nombre de la propiedad
* tePropertyValue (v! IN ) Valor de la propiedad
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcName, tcType, tcProperty, tePropertyValue
ENDPROC
PROCEDURE getBinPropertyDataRecord
LPARAMETERS teData, tnPropertyID
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* teData (v! IN ) Dato a codificar
* tnPropertyID (v! IN ) ID de la propiedad a la que pertenece
*---------------------------------------------------------------------------------------------------
TRY
LOCAL lcBinRecord, lnLen, lcDataType
lcBinRecord = ''
lcDataType = THIS.getDBCPropertyValueTypeByPropertyID( tnPropertyID )
DO CASE
CASE lcDataType = 'B'
teData = CHR(teData)
lnLen = 4 + 2 + 1 + 1
lcBinRecord = BINTOC( lnLen, "4RS" ) + BINTOC( 1, "2RS" ) + CHR(tnPropertyID) + teData
CASE lcDataType = 'L'
teData = BINTOC( IIF(teData,1,0), "1S" )
lnLen = 4 + 2 + 1 + 1
lcBinRecord = BINTOC( lnLen, "4RS" ) + BINTOC( 1, "2RS" ) + CHR(tnPropertyID) + teData
CASE lcDataType = 'N'
teData = BINTOC( teData, "4S" )
lnLen = 4 + 2 + 1 + 4
lcBinRecord = BINTOC( lnLen, "4RS" ) + BINTOC( 1, "2RS" ) + CHR(tnPropertyID) + teData
OTHERWISE && Asume 'C'
IF EMPTY(teData)
EXIT
ENDIF
lnLen = 4 + 2 + 1 + LEN(teData) + 1
lcBinRecord = BINTOC( lnLen, "4RS" ) + BINTOC( 1, "2RS" ) + CHR(tnPropertyID) + teData + CHR(0)
ENDCASE
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcBinRecord
ENDPROC
PROCEDURE getID
RETURN THIS.__ObjectID
ENDPROC
PROCEDURE getCodeMemo
RETURN ''
ENDPROC
PROCEDURE getUserMemo
RETURN ''
ENDPROC
PROCEDURE getBinMemoFromProperties
RETURN ''
ENDPROC
PROCEDURE getReferentialIntegrityInfo
RETURN ''
ENDPROC
PROCEDURE getObjectType
LOCAL lcType
WITH THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
DO CASE
CASE .CLASS == 'Cl_dbc'
lcType = 'Database'
CASE .CLASS == 'Cl_dbc_connection'
lcType = 'Connection'
CASE .CLASS == 'Cl_dbc_table'
lcType = 'Table'
CASE .CLASS == 'Cl_dbc_view'
lcType = 'View'
CASE .CLASS == 'Cl_dbc_index_db' OR .CLASS == 'Cl_dbc_index_vw'
lcType = 'Index'
CASE .CLASS == 'Cl_dbc_relation'
lcType = 'Relation'
CASE .CLASS == 'Cl_dbc_field_db' OR .CLASS == 'Cl_dbc_field_vw'
lcType = 'Field'
OTHERWISE
*ERROR 'Clase [' + .CLASS + '] desconocida'
ERROR (TEXTMERGE(C_UNKNOWN_CLASS_NAME_LOC))
ENDCASE
ENDWITH && THIS
RETURN lcType
ENDPROC
PROCEDURE setNextID
LPARAMETERS tnLastID
tnLastID = tnLastID + 1
THIS.__ObjectID = tnLastID
ENDPROC
PROCEDURE updateDBC
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_OutputFile (v! IN ) Nombre del archivo de salida
* tnLastID (@! IN ) Último número de ID usado
* tnParentID (v! IN ) ID del objeto Padre
*---------------------------------------------------------------------------------------------------
LPARAMETERS tc_OutputFile, tnLastID, tnParentID
TRY
LOCAL lcMemoWithProperties, lcCodeMemo, lcObjectType, lcRI_Info, lcUserMemo, lcID
WITH THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
.setNextID( @tnLastID )
lcMemoWithProperties = .getBinMemoFromProperties()
lcCodeMemo = .getCodeMemo()
lcObjectType = .getObjectType()
lcRI_Info = .getReferentialIntegrityInfo()
lcUserMemo = .getUserMemo()
lcID = .getID()
INSERT INTO TABLABIN ;
( ObjectID ;
, ParentID ;
, ObjectType ;
, objectName ;
, Property ;
, CODE ;
, RIInfo ;
, USER ) ;
VALUES ;
( lcID ;
, tnParentID ;
, lcObjectType ;
, LOWER(._Name) ;
, lcMemoWithProperties ;
, lcCodeMemo ;
, lcRI_Info ;
, lcUserMemo )
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC AS CL_DBC_BASE
#IF .F.
LOCAL THIS AS CL_DBC OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="analizarbloque_sp" display="analizarBloque_SP"/>] ;
+ [<memberdata name="_comment" display="_Comment"/>] ;
+ [<memberdata name="_version" display="_Version"/>] ;
+ [<memberdata name="_dbcevents" display="_DBCEvents"/>] ;
+ [<memberdata name="_dbceventfilename" display="_DBCEventFilename"/>] ;
+ [<memberdata name="_connections" display="_Connections"/>] ;
+ [<memberdata name="_tables" display="_Tables"/>] ;
+ [<memberdata name="_views" display="_Views"/>] ;
+ [<memberdata name="_relations" display="_Relations"/>] ;
+ [<memberdata name="_sourcefile" display="_SourceFile"/>] ;
+ [<memberdata name="_storedprocedures" display="_StoredProcedures"/>] ;
+ [<memberdata name="_version" display="_Version"/>] ;
+ [</VFPData>]
*-- Modulo
_Version = 0
_SourceFile = ''
*-- Database Info
_Name = ''
_Comment = ''
_Version = 0
_DBCEvents = .F.
_DBCEventFilename = ''
_StoredProcedures = ''
PROCEDURE INIT
DODEFAULT()
*--
WITH THIS AS CL_DBC OF 'FOXBIN2PRG.PRG'
.ADDOBJECT("_Connections", "CL_DBC_CONNECTIONS")
.ADDOBJECT("_Tables", "CL_DBC_TABLES")
.ADDOBJECT("_Views", "CL_DBC_VIEWS")
ENDWITH && THIS
ENDPROC
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loConnections AS CL_DBC_CONNECTIONS OF 'FOXBIN2PRG.PRG'
LOCAL loTables AS CL_DBC_TABLES OF 'FOXBIN2PRG.PRG'
LOCAL loViews AS CL_DBC_VIEWS OF 'FOXBIN2PRG.PRG'
LOCAL loRelations AS CL_DBC_RELATIONS OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_DATABASE_I)) == C_DATABASE_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_DATABASE_F $ tcLine && Fin
EXIT
CASE C_CONNECTIONS_I $ tcLine
loConnections = ._Connections
loConnections.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE C_TABLES_I $ tcLine
loTables = ._Tables
loTables.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE C_VIEWS_I $ tcLine
loViews = ._Views
loViews.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE C_STORED_PROC_I $ tcLine
.analizarBloque_SP( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE '<Comment>' $ tcLine
.analizarBloque_Comment( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Otro valor
*-- Estructura a reconocer:
* <tagname>ID<tagname>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.add_Property( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE analizarBloque_SP
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
IF LEFT(tcLine, LEN(C_STORED_PROC_I)) == C_STORED_PROC_I
LOCAL lcValue
lcValue = ''
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE C_STORED_PROC_F $ tcLine && Fin
EXIT
OTHERWISE && Línea de Stored Procedure
lcValue = lcValue + CR_LF + taCodeLines(I)
ENDCASE
ENDFOR
.ADDPROPERTY( '_StoredProcedures', SUBSTR(lcValue,3) )
ENDWITH && THIS
ENDIF
ENDPROC
PROCEDURE updateDBC
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_OutputFile (v! IN ) Nombre del archivo de salida
* tnLastID (@! IN ) Último número de ID usado
* tnParentID (v! IN ) ID del objeto Padre
*---------------------------------------------------------------------------------------------------
LPARAMETERS tc_OutputFile, tnLastID, tnParentID
TRY
LOCAL loTables AS CL_DBC_TABLES OF 'FOXBIN2PRG.PRG'
LOCAL loConnections AS CL_DBC_CONNECTIONS OF 'FOXBIN2PRG.PRG'
LOCAL loViews AS CL_DBC_VIEWS OF 'FOXBIN2PRG.PRG'
WITH THIS AS CL_DBC_BASE OF 'FOXBIN2PRG.PRG'
loTables = ._Tables
loConnections = ._Connections
loViews = ._Views
ERASE (tc_OutputFile)
CREATE DATABASE (tc_OutputFile)
CLOSE DATABASES
OPEN DATABASE (tc_OutputFile) SHARED
USE (tc_OutputFile) SHARED AGAIN ALIAS TABLABIN
tnLastID = 5
.setNextID(0)
tnParentID = .__ObjectID
lcMemoWithProperties = .getBinMemoFromProperties()
UPDATE TABLABIN ;
SET Property = lcMemoWithProperties ;
WHERE STR(ParentID) + ObjectType + LOWER(objectName) = STR(1) + PADR('Database',10) + PADR(LOWER('Database'),128)
IF NOT EMPTY(._StoredProcedures)
UPDATE TABLABIN ;
SET CODE = THIS._StoredProcedures ;
WHERE STR(ParentID) + ObjectType + LOWER(objectName) = STR(1) + PADR('Database',10) + PADR(LOWER('StoredProceduresSource'),128)
ENDIF
loTables.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
loViews.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
loConnections.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
CLOSE DATABASES
USE IN (SELECT("TABLABIN"))
ENDTRY
RETURN
ENDPROC
*******************************************************************************************************************
PROCEDURE toText
TRY
LOCAL I, lcText, lcDBC, laCode(1,1), loEx AS EXCEPTION
LOCAL loConnections AS CL_DBC_CONNECTIONS OF 'FOXBIN2PRG.PRG'
LOCAL loTables AS CL_DBC_TABLES OF 'FOXBIN2PRG.PRG'
LOCAL loViews AS CL_DBC_VIEWS OF 'FOXBIN2PRG.PRG'
LOCAL loRelations AS CL_DBC_RELATIONS OF 'FOXBIN2PRG.PRG'
WITH THIS AS CL_DBC OF 'FOXBIN2PRG.PRG'
lcText = ''
lcDBC = JUSTSTEM(DBC())
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<DATABASE>
<<>> <Name><<lcDBC>></Name>
<<>> <Comment><<DBGETPROP(lcDBC,"DATABASE","Comment")>></Comment>
<<>> <Version><<DBGETPROP(lcDBC,"DATABASE","Version")>></Version>
<<>> <DBCEvents><<DBGETPROP(lcDBC,"DATABASE","DBCEvents")>></DBCEvents>
<<>> <DBCEventFilename><<DBGETPROP(lcDBC,"DATABASE","DBCEventFilename")>></DBCEventFilename>
ENDTEXT
*-- Connections
loConnections = ._Connections
lcText = lcText + loConnections.toText()
*-- Tables
loTables = ._Tables
lcText = lcText + loTables.toText()
*-- Views
loViews = ._Views
lcText = lcText + loViews.toText()
SELECT CODE ;
FROM TABLABIN ;
WHERE STR(ParentID) + ObjectType + LOWER(objectName) = STR(1) + PADR('Database',10) + PADR(LOWER('StoredProceduresSource'),128) ;
INTO ARRAY laCode
._StoredProcedures = laCode(1,1)
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <<C_STORED_PROC_I>>
<<._StoredProcedures>>
<<>> <<C_STORED_PROC_F>>
</DATABASE>
ENDTEXT
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE getBinMemoFromProperties
LOCAL lcBinData
lcBinData = ''
WITH THIS AS CL_DBC OF 'FOXBIN2PRG.PRG'
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Version, .getDBCPropertyIDByName('Version', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Comment, .getDBCPropertyIDByName('Comment', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DBCEvents, .getDBCPropertyIDByName('DBCEvents', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DBCEventFilename, .getDBCPropertyIDByName('DBCEventFilename', .T.) )
ENDWITH && THIS
RETURN lcBinData
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_CONNECTIONS AS CL_DBC_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBC_CONNECTIONS OF 'FOXBIN2PRG.PRG'
#ENDIF
*******************************************************************************************************************
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loConnection AS CL_DBC_CONNECTION OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_CONNECTIONS_I)) == C_CONNECTIONS_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_CONNECTIONS OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_CONNECTIONS_F $ tcLine && Fin
EXIT
CASE C_CONNECTION_I $ tcLine
loConnection = CREATEOBJECT("CL_DBC_CONNECTION")
loConnection.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loConnection, loConnection._Name )
CASE '<Comment>' $ tcLine
.analizarBloque_Comment( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taConnections (@? OUT) Array de conexiones
* tnConnection_Count (@? OUT) Cantidad de conexiones
*---------------------------------------------------------------------------------------------------
LPARAMETERS taConnections, tnConnection_Count
TRY
LOCAL I, lcText, loEx AS EXCEPTION
LOCAL loConnection AS CL_DBC_CONNECTION OF 'FOXBIN2PRG.PRG'
lcText = ''
DIMENSION taConnections(1)
tnConnection_Count = ADBOBJECTS( taConnections,"CONNECTION" )
IF tnConnection_Count > 0
ASORT( taConnections, 1, -1, 0, 1 )
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <CONNECTIONS>
ENDTEXT
loConnection = CREATEOBJECT('CL_DBC_CONNECTION')
FOR I = 1 TO tnConnection_Count
lcText = lcText + loConnection.toText( taConnections(I) )
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </CONNECTIONS>
<<>>
ENDTEXT
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_CONNECTION AS CL_DBC_BASE
#IF .F.
LOCAL THIS AS CL_DBC_CONNECTION OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="_comment" display="_Comment"/>] ;
+ [<memberdata name="_datasource" display="_DataSource"/>] ;
+ [<memberdata name="_database" display="_Database"/>] ;
+ [<memberdata name="_connectstring" display="_ConnectString"/>] ;
+ [<memberdata name="_asynchronous" display="_Asynchronous"/>] ;
+ [<memberdata name="_batchmode" display="_BatchMode"/>] ;
+ [<memberdata name="_connecttimeout" display="_ConnectTimeout"/>] ;
+ [<memberdata name="_disconnectrollback" display="_DisconnectRollback"/>] ;
+ [<memberdata name="_displogin" display="_DispLogin"/>] ;
+ [<memberdata name="_dispwarnings" display="_DispWarnings"/>] ;
+ [<memberdata name="_idletimeout" display="_IdleTimeout"/>] ;
+ [<memberdata name="_packetsize" display="_PacketSize"/>] ;
+ [<memberdata name="_password" display="_PassWord"/>] ;
+ [<memberdata name="_querytimeout" display="_QueryTimeout"/>] ;
+ [<memberdata name="_transactions" display="_Transactions"/>] ;
+ [<memberdata name="_userid" display="_UserId"/>] ;
+ [<memberdata name="_waittime" display="_WaitTime"/>] ;
+ [</VFPData>]
*-- Info
_Name = ''
_Comment = ''
_DataSource = ''
_Database = ''
_ConnectString = ''
_Asynchronous = .F.
_BatchMode = .F.
_ConnectTimeout = 0
_DisconnectRollback = .F.
_DispLogin = 0
_DispWarnings = .F.
_IdleTimeout = 0
_PacketSize = 0
_PassWord = ''
_QueryTimeout = 0
_Transactions = ''
_UserId = ''
_WaitTime = 0
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_CONNECTION_I)) == C_CONNECTION_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_CONNECTION OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_CONNECTION_F $ tcLine && Fin
EXIT
CASE '<Comment>' $ tcLine
.analizarBloque_Comment( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Propiedad de CONNECTION
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.add_Property( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcConnection (v! IN ) Nombre de la Conexión
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcConnection
TRY
LOCAL lcText, loEx AS EXCEPTION
TEXT TO lcText TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <CONNECTION>
<<>> <Name><<tcConnection>></Name>
<<>> <Comment><<DBGETPROP(tcConnection,"CONNECTION","Comment")>></Comment>
<<>> <DataSource><<DBGETPROP(tcConnection,"CONNECTION","DataSource")>></DataSource>
<<>> <Database><<DBGETPROP(tcConnection,"CONNECTION","Database")>></Database>
<<>> <ConnectString><<DBGETPROP(tcConnection,"CONNECTION","ConnectString")>></ConnectString>
<<>> <Asynchronous><<DBGETPROP(tcConnection,"CONNECTION","Asynchronous")>></Asynchronous>
<<>> <BatchMode><<DBGETPROP(tcConnection,"CONNECTION","BatchMode")>></BatchMode>
<<>> <ConnectTimeout><<DBGETPROP(tcConnection,"CONNECTION","ConnectTimeout")>></ConnectTimeout>
<<>> <DisconnectRollback><<DBGETPROP(tcConnection,"CONNECTION","DisconnectRollback")>></DisconnectRollback>
<<>> <DispLogin><<DBGETPROP(tcConnection,"CONNECTION","DispLogin")>></DispLogin>
<<>> <DispWarnings><<DBGETPROP(tcConnection,"CONNECTION","DispWarnings")>></DispWarnings>
<<>> <IdleTimeout><<DBGETPROP(tcConnection,"CONNECTION","IdleTimeout")>></IdleTimeout>
<<>> <PacketSize><<DBGETPROP(tcConnection,"CONNECTION","PacketSize")>></PacketSize>
<<>> <PassWord><<DBGETPROP(tcConnection,"CONNECTION","PassWord")>></PassWord>
<<>> <QueryTimeout><<DBGETPROP(tcConnection,"CONNECTION","QueryTimeout")>></QueryTimeout>
<<>> <Transactions><<DBGETPROP(tcConnection,"CONNECTION","Transactions")>></Transactions>
<<>> <UserId><<DBGETPROP(tcConnection,"CONNECTION","UserId")>></UserId>
<<>> <WaitTime><<DBGETPROP(tcConnection,"CONNECTION","WaitTime")>></WaitTime>
<<>> </CONNECTION>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE getBinMemoFromProperties
LOCAL lcBinData
lcBinData = ''
WITH THIS AS CL_DBC_CONNECTION OF 'FOXBIN2PRG.PRG'
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Asynchronous, .getDBCPropertyIDByName('Asynchronous', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._BatchMode, .getDBCPropertyIDByName('BatchMode', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DispWarnings, .getDBCPropertyIDByName('DispWarnings') )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DispLogin, .getDBCPropertyIDByName('DispLogin', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Transactions, .getDBCPropertyIDByName('Transactions', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DisconnectRollback, .getDBCPropertyIDByName('DisconnectRollback', .T.) ) && Undocumented
lcBinData = lcBinData + .getBinPropertyDataRecord( ._ConnectTimeout , .getDBCPropertyIDByName('ConnectTimeout', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._QueryTimeout, .getDBCPropertyIDByName('QueryTimeout', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._IdleTimeout, .getDBCPropertyIDByName('IdleTimeout', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._WaitTime, .getDBCPropertyIDByName('WaitTime', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._PacketSize, .getDBCPropertyIDByName('PacketSize', .T.) ) && Undocumented
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DataSource, .getDBCPropertyIDByName('DataSource', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._UserId, .getDBCPropertyIDByName('UserId', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._PassWord, .getDBCPropertyIDByName('PassWord', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Database, .getDBCPropertyIDByName('Database', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._ConnectString, .getDBCPropertyIDByName('ConnectString', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Comment, .getDBCPropertyIDByName('Comment', .T.) )
ENDWITH
RETURN lcBinData
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_TABLES AS CL_DBC_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBC_TABLES OF 'FOXBIN2PRG.PRG'
#ENDIF
*******************************************************************************************************************
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loTable AS CL_DBC_TABLE OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_TABLES_I)) == C_TABLES_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_TABLES OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_TABLES_F $ tcLine && Fin
EXIT
CASE C_TABLE_I $ tcLine
loTable = CREATEOBJECT("CL_DBC_TABLE")
loTable.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loTable, loTable._Name )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taTables (@? OUT) Array de conexiones
* lnTable_Count (@? OUT) Cantidad de conexiones
*---------------------------------------------------------------------------------------------------
LPARAMETERS taTables, tnTable_Count
EXTERNAL ARRAY taTables
TRY
LOCAL I, lcText, loEx AS EXCEPTION
LOCAL loTable AS CL_DBC_TABLE OF 'FOXBIN2PRG.PRG'
STORE 0 TO I, tnTable_Count
lcText = ''
DIMENSION taTables(1)
tnTable_Count = ADBOBJECTS( taTables,"TABLE" )
IF tnTable_Count > 0
ASORT( taTables, 1, -1, 0, 1 )
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <TABLES>
ENDTEXT
loTable = CREATEOBJECT('CL_DBC_TABLE')
FOR I = 1 TO tnTable_Count
lcText = lcText + loTable.toText( taTables(I) )
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </TABLES>
<<>>
ENDTEXT
ENDIF
CATCH TO loEx
IF BETWEEN(I, 1, tnTable_Count)
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "taTables(" + TRANSFORM(I) + ") = " + RTRIM(TRANSFORM(taTables(I)))
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_TABLE AS CL_DBC_BASE
#IF .F.
LOCAL THIS AS CL_DBC_TABLE OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="_comment" display="_Comment"/>] ;
+ [<memberdata name="_path" display="_Path"/>] ;
+ [<memberdata name="_deletetrigger" display="_DeleteTrigger"/>] ;
+ [<memberdata name="_inserttrigger" display="_InsertTrigger"/>] ;
+ [<memberdata name="_updatetrigger" display="_UpdateTrigger"/>] ;
+ [<memberdata name="_primarykey" display="_PrimaryKey"/>] ;
+ [<memberdata name="_ruleexpression" display="_RuleExpression"/>] ;
+ [<memberdata name="_ruletext" display="_RuleText"/>] ;
+ [<memberdata name="_fields" display="_Fields"/>] ;
+ [<memberdata name="_indexes" display="_Indexes"/>] ;
+ [</VFPData>]
*-- Info
_Name = ''
_Comment = ''
_Path = ''
_DeleteTrigger = ''
_InsertTrigger = ''
_UpdateTrigger = ''
_PrimaryKey = ''
_RuleExpression = ''
_RuleText = ''
*-- Sub-objects
*_Fields = NULL
*_Indexes = NULL
PROCEDURE INIT
DODEFAULT()
*--
WITH THIS AS CL_DBC_TABLE OF 'FOXBIN2PRG.PRG'
.ADDOBJECT("_Fields", "CL_DBC_FIELDS_DB")
.ADDOBJECT("_Indexes", "CL_DBC_INDEXES_DB")
.ADDOBJECT("_Relations", "CL_DBC_RELATIONS")
ENDWITH && THIS
ENDPROC
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
LOCAL loFields AS CL_DBC_FIELDS_DB OF 'FOXBIN2PRG.PRG'
LOCAL loIndexes AS CL_DBC_INDEXES_DB OF 'FOXBIN2PRG.PRG'
LOCAL loRelations AS CL_DBC_RELATIONS OF 'FOXBIN2PRG.PRG'
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_TABLE_I)) == C_TABLE_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_TABLE OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_TABLE_F $ tcLine && Fin
EXIT
CASE C_FIELDS_I $ tcLine
loFields = ._Fields
loFields.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE C_INDEXES_I $ tcLine
loIndexes = ._Indexes
loIndexes.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE C_RELATIONS_I $ tcLine
loRelations = ._Relations
loRelations.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE '<Comment>' $ tcLine
.analizarBloque_Comment( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Propiedad de TABLE
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.add_Property( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcTable (v! IN ) Nombre de la Tabla
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcTable
TRY
LOCAL lcText, loEx AS EXCEPTION
LOCAL loIndexes AS CL_DBC_INDEXES_DB OF 'FOXBIN2PRG.PRG'
LOCAL loFields AS CL_DBC_FIELDS_DB OF 'FOXBIN2PRG.PRG'
LOCAL loRelations AS CL_DBC_RELATIONS OF 'FOXBIN2PRG.PRG'
lcText = ''
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <TABLE>
<<>> <Name><<tcTable>></Name>
<<>> <Comment><<DBGETPROP(tcTable,"TABLE","Comment")>></Comment>
<<>> <Path><<DBGETPROP(tcTable,"TABLE","Path")>></Path>
<<>> <DeleteTrigger><<DBGETPROP(tcTable,"TABLE","DeleteTrigger")>></DeleteTrigger>
<<>> <InsertTrigger><<DBGETPROP(tcTable,"TABLE","InsertTrigger")>></InsertTrigger>
<<>> <UpdateTrigger><<DBGETPROP(tcTable,"TABLE","UpdateTrigger")>></UpdateTrigger>
<<>> <PrimaryKey><<DBGETPROP(tcTable,"TABLE","PrimaryKey")>></PrimaryKey>
<<>> <RuleExpression><<DBGETPROP(tcTable,"TABLE","RuleExpression")>></RuleExpression>
<<>> <RuleText><<DBGETPROP(tcTable,"TABLE","RuleText")>></RuleText>
ENDTEXT
loFields = CREATEOBJECT('CL_DBC_FIELDS_DB')
lcText = lcText + loFields.toText( tcTable )
loIndexes = CREATEOBJECT('CL_DBC_INDEXES_DB')
lcText = lcText + loIndexes.toText( tcTable )
loRelations = CREATEOBJECT('CL_DBC_RELATIONS')
lcText = lcText + loRelations.toText( tcTable )
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </TABLE>
ENDTEXT
CATCH TO loEx
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "tcTable = " + RTRIM(TRANSFORM(tcTable))
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE updateDBC
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_OutputFile (v! IN ) Nombre del archivo de salida
* tnLastID (@! IN ) Último número de ID usado
* tnParentID (v! IN ) ID del objeto Padre
*---------------------------------------------------------------------------------------------------
LPARAMETERS tc_OutputFile, tnLastID, tnParentID
DODEFAULT( tc_OutputFile, @tnLastID, tnParentID)
WITH THIS AS CL_DBC_TABLE OF 'FOXBIN2PRG.PRG'
tnParentID = .__ObjectID
._Fields.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
._Indexes.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
._Relations.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
ENDWITH && THIS
ENDPROC
PROCEDURE getBinMemoFromProperties
LOCAL lcBinData
lcBinData = ''
WITH THIS AS CL_DBC_TABLE OF 'FOXBIN2PRG.PRG'
lcBinData = lcBinData + .getBinPropertyDataRecord( 1, .getDBCPropertyIDByName('Class', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Path, .getDBCPropertyIDByName('Path', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._PrimaryKey, .getDBCPropertyIDByName('PrimaryKey', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RuleExpression, .getDBCPropertyIDByName('RuleExpression', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RuleText, .getDBCPropertyIDByName('RuleText', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Comment, .getDBCPropertyIDByName('Comment', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._InsertTrigger, .getDBCPropertyIDByName('InsertTrigger', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._UpdateTrigger, .getDBCPropertyIDByName('UpdateTrigger', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DeleteTrigger, .getDBCPropertyIDByName('DeleteTrigger', .T.) )
ENDWITH && THIS
RETURN lcBinData
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_FIELDS_DB AS CL_DBC_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBC_FIELDS_DB OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loField AS CL_DBC_FIELD_DB OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_FIELDS_I)) == C_FIELDS_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_FIELDS_DB OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_FIELDS_F $ tcLine && Fin
EXIT
CASE C_FIELD_I $ tcLine
loField = CREATEOBJECT("CL_DBC_FIELD_DB")
loField.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loField, loField._Name )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcTable (v! IN ) Nombre de la Tabla
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcTable
TRY
LOCAL X, lcText, lnField_Count, laFields(1), loEx AS EXCEPTION
LOCAL loField AS CL_DBC_FIELD_DB OF 'FOXBIN2PRG.PRG'
STORE 0 TO X, lnField_Count
lcText = ''
_TALLY = 0
SELECT LOWER(TB.objectName) FROM TABLABIN TB ;
INNER JOIN TABLABIN TB2 ON STR(TB.ParentID)+TB.ObjectType = STR(TB2.ObjectID)+PADR('Field',10) ;
AND TB2.objectName = PADR(LOWER(tcTable),128) ;
INTO ARRAY laFields
lnField_Count = _TALLY
IF lnField_Count > 0
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <FIELDS>
ENDTEXT
loField = CREATEOBJECT('CL_DBC_FIELD_DB')
FOR X = 1 TO lnField_Count
lcText = lcText + loField.toText( tcTable, laFields(X) )
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </FIELDS>
ENDTEXT
ENDIF
CATCH TO loEx
IF BETWEEN(X, 1, lnField_Count)
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "tcTable = " + RTRIM(TRANSFORM(tcTable)) + ", laFields(" + TRANSFORM(X) + ") = " + RTRIM(TRANSFORM(laFields(X)))
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TB"))
USE IN (SELECT("TB2"))
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_FIELD_DB AS CL_DBC_BASE
#IF .F.
LOCAL THIS AS CL_DBC_FIELD_DB OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="_caption" display="_Caption"/>] ;
+ [<memberdata name="_comment" display="_Comment"/>] ;
+ [<memberdata name="_defaultvalue" display="_DefaultValue"/>] ;
+ [<memberdata name="_displayclass" display="_DisplayClass"/>] ;
+ [<memberdata name="_displayclasslibrary" display="_DisplayClassLibrary"/>] ;
+ [<memberdata name="_format" display="_Format"/>] ;
+ [<memberdata name="_inputmask" display="_InputMask"/>] ;
+ [<memberdata name="_ruleexpression" display="_RuleExpression"/>] ;
+ [<memberdata name="_ruletext" display="_RuleText"/>] ;
+ [</VFPData>]
*-- Info
_Name = ''
_Caption = ''
_Comment = ''
_DefaultValue = ''
_DisplayClass = ''
_DisplayClassLibrary = ''
_Format = ''
_InputMask = ''
_RuleExpression = ''
_RuleText = ''
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_FIELD_I)) == C_FIELD_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_FIELD_DB OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_FIELD_F $ tcLine && Fin
EXIT
CASE '<Comment>' $ tcLine
.analizarBloque_Comment( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Propiedad de FIELD
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.add_Property( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcTable (v! IN ) Nombre de la Tabla
* tcField (v! IN ) Nombre del campo
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcTable, tcField
TRY
LOCAL lcText, loEx AS EXCEPTION
lcText = ''
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <FIELD>
<<>> <Name><<RTRIM(tcField)>></Name>
<<>> <Caption><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","Caption")>></Caption>
<<>> <Comment><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","Comment")>></Comment>
<<>> <DefaultValue><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","DefaultValue")>></DefaultValue>
<<>> <DisplayClass><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","DisplayClass")>></DisplayClass>
<<>> <DisplayClassLibrary><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","DisplayClassLibrary")>></DisplayClassLibrary>
<<>> <Format><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","Format")>></Format>
<<>> <InputMask><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","InputMask")>></InputMask>
<<>> <RuleExpression><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","RuleExpression")>></RuleExpression>
<<>> <RuleText><<DBGETPROP( RTRIM(tcTable) + '.' + RTRIM(tcField),"FIELD","RuleText")>></RuleText>
<<>> </FIELD>
ENDTEXT
CATCH TO loEx
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "tcTable = " + RTRIM(TRANSFORM(tcTable)) + ", tcField = " + RTRIM(TRANSFORM(tcField))
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE getBinMemoFromProperties
LOCAL lcBinData
lcBinData = ''
WITH THIS AS CL_DBC_FIELD_DB OF 'FOXBIN2PRG.PRG'
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Comment, .getDBCPropertyIDByName('Comment', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DefaultValue, .getDBCPropertyIDByName('DefaultValue', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DisplayClass, .getDBCPropertyIDByName('DisplayClass', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DisplayClassLibrary, .getDBCPropertyIDByName('DisplayClassLibrary', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Caption, .getDBCPropertyIDByName('Caption', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Format, .getDBCPropertyIDByName('Format', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._InputMask, .getDBCPropertyIDByName('InputMask', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RuleExpression, .getDBCPropertyIDByName('RuleExpression', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RuleText, .getDBCPropertyIDByName('RuleText', .T.) )
ENDWITH && THIS
RETURN lcBinData
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_INDEXES_DB AS CL_DBC_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBC_INDEXES_DB OF 'FOXBIN2PRG.PRG'
#ENDIF
*-- Info
_Name = ''
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loIndex AS CL_DBC_INDEX_DB OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_INDEXES_I)) == C_INDEXES_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_INDEXES_DB OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_INDEXES_F $ tcLine && Fin
EXIT
CASE C_INDEX_I $ tcLine
loIndex = CREATEOBJECT("CL_DBC_INDEX_DB")
loIndex.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loIndex, loIndex._Name )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcTable (v! IN ) Nombre de la Tabla
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcTable
TRY
LOCAL X, lcText, lnIndex_Count, laIndexes(1), loEx AS EXCEPTION
LOCAL loIndex AS CL_DBC_INDEX_DB OF 'FOXBIN2PRG.PRG'
STORE 0 TO X, lnIndex_Count
lcText = ''
_TALLY = 0
SELECT LOWER(TB.objectName) FROM TABLABIN TB ;
INNER JOIN TABLABIN TB2 ON STR(TB.ParentID)+TB.ObjectType = STR(TB2.ObjectID)+PADR('Index',10) ;
AND TB2.objectName = PADR(LOWER(tcTable),128) ;
INTO ARRAY laIndexes
lnIndex_Count = _TALLY
IF lnIndex_Count > 0
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <INDEXES>
ENDTEXT
loIndex = CREATEOBJECT('CL_DBC_INDEX_DB')
FOR X = 1 TO lnIndex_Count
lcText = lcText + loIndex.toText( tcTable + '.' + laIndexes(X) )
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </INDEXES>
ENDTEXT
ENDIF
CATCH TO loEx
IF BETWEEN(X, 1, lnField_Count)
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "laIndexes(" + TRANSFORM(X) + ") = " + RTRIM(laIndexes(X))
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TB"))
USE IN (SELECT("TB2"))
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_INDEX_DB AS CL_DBC_BASE
#IF .F.
LOCAL THIS AS CL_DBC_INDEX_DB OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="_isunique" display="_IsUnique"/>] ;
+ [<memberdata name="_comment" display="_Comment"/>] ;
+ [</VFPData>]
*-- Info
_Name = ''
_IsUnique = .F.
_Comment = ''
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_INDEX_I)) == C_INDEX_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_INDEX_DB OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_INDEX_F $ tcLine && Fin
EXIT
CASE '<Comment>' $ tcLine
.analizarBloque_Comment( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Propiedad de FIELD
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.add_Property( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcIndex (v! IN ) Nombre del índice en la forma "tabla.indice"
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcIndex
TRY
LOCAL lcText, loEx AS EXCEPTION
lcText = ''
WITH THIS AS CL_DBC_INDEX_DB OF 'FOXBIN2PRG.PRG'
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <INDEX>
<<>> <Name><<RTRIM(JUSTEXT(tcIndex))>></Name>
<<>> <Comment><<RTRIM( .DBGETPROP(tcIndex,'Index','Comment') )>></Comment>
<<>> <IsUnique><<.DBGETPROP(tcIndex,'Index','IsUnique')>></IsUnique>
<<>> </INDEX>
ENDTEXT
ENDWITH && THIS
CATCH TO loEx
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "tcIndex = " + RTRIM(TRANSFORM(tcIndex))
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE getBinMemoFromProperties
LOCAL lcBinData
lcBinData = ''
WITH THIS AS CL_DBC_INDEX_DB OF 'FOXBIN2PRG.PRG'
lcBinData = lcBinData + .getBinPropertyDataRecord( ._IsUnique, .getDBCPropertyIDByName('IsUnique', .T.) )
ENDWITH && THIS
RETURN lcBinData
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_INDEXES_VW AS CL_DBC_INDEXES_DB
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_INDEX_VW AS CL_DBC_INDEX_DB
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_VIEWS AS CL_DBC_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBC_VIEWS OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loView AS CL_DBC_VIEW OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_VIEWS_I)) == C_VIEWS_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_VIEWS OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_VIEWS_F $ tcLine && Fin
EXIT
CASE C_VIEW_I $ tcLine
loView = CREATEOBJECT("CL_DBC_VIEW")
loView.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loView, loView._Name )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taViews (@? OUT) Array de vistas
* tnView_Count (@? OUT) Cantidad de vistas
*---------------------------------------------------------------------------------------------------
LPARAMETERS taViews, tnView_Count
EXTERNAL ARRAY taViews
TRY
LOCAL I, lcText, lcDBC, lnField_Count, laFields(1), loEx AS EXCEPTION
LOCAL loView AS CL_DBC_VIEW OF 'FOXBIN2PRG.PRG'
STORE 0 TO I, X, tnView_Count, lnField_Count
lcText = ''
lcDBC = JUSTSTEM(DBC())
DIMENSION taViews(1)
tnView_Count = ADBOBJECTS( taViews,"VIEW" )
IF tnView_Count > 0
ASORT( taViews, 1, -1, 0, 1 )
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <VIEWS>
ENDTEXT
loView = CREATEOBJECT('CL_DBC_VIEW')
FOR I = 1 TO tnView_Count
lcText = lcText + loView.toText( taViews(I) )
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </VIEWS>
<<>>
ENDTEXT
ENDIF
CATCH TO loEx
IF BETWEEN(I, 1, tnTable_Count)
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "taViews(" + TRANSFORM(I) + ") = " + RTRIM(taViews(I))
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_VIEW AS CL_DBC_BASE
#IF .F.
LOCAL THIS AS CL_DBC_VIEW OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="_comment" display="_Comment"/>] ;
+ [<memberdata name="_tables" display="_Tables"/>] ;
+ [<memberdata name="_sql" display="_SQL"/>] ;
+ [<memberdata name="_allowsimultaneousfetch" display="_AllowSimultaneousFetch"/>] ;
+ [<memberdata name="_batchupdatecount" display="_BatchUpdateCount"/>] ;
+ [<memberdata name="_comparememo" display="_CompareMemo"/>] ;
+ [<memberdata name="_connectname" display="_ConnectName"/>] ;
+ [<memberdata name="_fetchasneeded" display="_FetchAsNeeded"/>] ;
+ [<memberdata name="_fetchmemo" display="_FetchMemo"/>] ;
+ [<memberdata name="_fetchsize" display="_FetchSize"/>] ;
+ [<memberdata name="_maxrecords" display="_MaxRecords"/>] ;
+ [<memberdata name="_offline" display="_Offline"/>] ;
+ [<memberdata name="_recordcount" display="_RecordCount"/>] ;
+ [<memberdata name="_path" display="_Path"/>] ;
+ [<memberdata name="_parameterlist" display="_ParameterList"/>] ;
+ [<memberdata name="_prepared" display="_Prepared"/>] ;
+ [<memberdata name="_ruleexpression" display="_RuleExpression"/>] ;
+ [<memberdata name="_ruletext" display="_RuleText"/>] ;
+ [<memberdata name="_sendupdates" display="_SendUpdates"/>] ;
+ [<memberdata name="_shareconnection" display="_ShareConnection"/>] ;
+ [<memberdata name="_sourcetype" display="_SourceType"/>] ;
+ [<memberdata name="_updatetype" display="_UpdateType"/>] ;
+ [<memberdata name="_usememosize" display="_UseMemoSize"/>] ;
+ [<memberdata name="_wheretype" display="_WhereType"/>] ;
+ [<memberdata name="_fields" display="_Fields"/>] ;
+ [<memberdata name="_indexes" display="_Indexes"/>] ;
+ [</VFPData>]
*-- Info
_Name = ''
_Comment = ''
_Tables = ''
_SQL = ''
_AllowSimultaneousFetch = .F.
_BatchUpdateCount = 0
_CompareMemo = .F.
_ConnectName = ''
_FetchAsNeeded = .F.
_FetchMemo = .F.
_FetchSize = 0
_MaxRecords = 0
_Offline = .F.
_RecordCount = 0
_Path = ''
_ParameterList = ''
_Prepared = .F.
_RuleExpression = ''
_RuleText = ''
_SendUpdates = .F.
_ShareConnection = .F.
_SourceType = 0
_UpdateType = 0
_UseMemoSize = 0
_WhereType = 0
*-- Sub-objects
*_Fields = NULL
*_Indexes = NULL
PROCEDURE INIT
DODEFAULT()
*--
WITH THIS AS CL_DBC_VIEW OF 'FOXBIN2PRG.PRG'
.ADDOBJECT("_Fields", "CL_DBC_FIELDS_VW")
.ADDOBJECT("_Indexes", "CL_DBC_INDEXES_VW")
.ADDOBJECT("_Relations", "CL_DBC_RELATIONS")
ENDWITH && THIS
ENDPROC
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
LOCAL loFields AS CL_DBC_FIELDS_VW OF 'FOXBIN2PRG.PRG'
LOCAL loIndexes AS CL_DBC_INDEXES_VW OF 'FOXBIN2PRG.PRG'
LOCAL loRelations AS CL_DBC_RELATIONS OF 'FOXBIN2PRG.PRG'
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_VIEW_I)) == C_VIEW_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_VIEW OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_VIEW_F $ tcLine && Fin
EXIT
CASE C_FIELDS_I $ tcLine
loFields = ._Fields
loFields.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE C_INDEXES_I $ tcLine
loIndexes = ._Indexes
loIndexes.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE C_RELATIONS_I $ tcLine
loRelations = ._Relations
loRelations.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE '<Comment>' $ tcLine
.analizarBloque_Comment( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Propiedad de VIEW
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.add_Property( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcView (v! IN ) Vista en evaluación
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcView
TRY
LOCAL I, lcText, lcDBC, lnField_Count, laFields(1), loEx AS EXCEPTION
LOCAL loFields AS CL_DBC_FIELDS_VW OF 'FOXBIN2PRG.PRG'
LOCAL loIndexes AS CL_DBC_INDEXES_VW OF 'FOXBIN2PRG.PRG'
LOCAL loRelations AS CL_DBC_RELATIONS OF 'FOXBIN2PRG.PRG'
lcText = ''
WITH THIS AS CL_DBC_VIEW OF 'FOXBIN2PRG.PRG'
TEXT TO lcText TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <VIEW>
<<>> <Name><<tcView>></Name>
<<>> <Comment><<DBGETPROP(tcView,"VIEW","Comment")>></Comment>
<<>> <Tables><<DBGETPROP(tcView,"VIEW","Tables")>></Tables>
<<>> <SQL><<DBGETPROP(tcView,"VIEW","SQL")>></SQL>
<<>> <AllowSimultaneousFetch><<DBGETPROP(tcView,"VIEW","AllowSimultaneousFetch")>></AllowSimultaneousFetch>
<<>> <BatchUpdateCount><<DBGETPROP(tcView,"VIEW","BatchUpdateCount")>></BatchUpdateCount>
<<>> <CompareMemo><<DBGETPROP(tcView,"VIEW","CompareMemo")>></CompareMemo>
<<>> <ConnectName><<DBGETPROP(tcView,"VIEW","ConnectName")>></ConnectName>
<<>> <FetchAsNeeded><<DBGETPROP(tcView,"VIEW","FetchAsNeeded")>></FetchAsNeeded>
<<>> <FetchMemo><<DBGETPROP(tcView,"VIEW","FetchMemo")>></FetchMemo>
<<>> <FetchSize><<DBGETPROP(tcView,"VIEW","FetchSize")>></FetchSize>
<<>> <MaxRecords><<DBGETPROP(tcView,"VIEW","MaxRecords")>></MaxRecords>
<<>> <Offline><<DBGETPROP(tcView,"VIEW","Offline")>></Offline>
<<>> <ParameterList><<DBGETPROP(tcView,"VIEW","ParameterList")>></ParameterList>
<<>> <Prepared><<DBGETPROP(tcView,"VIEW","Prepared")>></Prepared>
<<>> <RuleExpression><<DBGETPROP(tcView,"VIEW","RuleExpression")>></RuleExpression>
<<>> <RuleText><<DBGETPROP(tcView,"VIEW","RuleText")>></RuleText>
<<>> <SendUpdates><<DBGETPROP(tcView,"VIEW","SendUpdates")>></SendUpdates>
<<>> <ShareConnection><<DBGETPROP(tcView,"VIEW","ShareConnection")>></ShareConnection>
<<>> <SourceType><<DBGETPROP(tcView,"VIEW","SourceType")>></SourceType>
<<>> <UpdateType><<DBGETPROP(tcView,"VIEW","UpdateType")>></UpdateType>
<<>> <UseMemoSize><<DBGETPROP(tcView,"VIEW","UseMemoSize")>></UseMemoSize>
<<>> <WhereType><<DBGETPROP(tcView,"VIEW","WhereType")>></WhereType>
ENDTEXT
*-- ALGUNOS VALORES QUE EL DBGETPROP OFICIAL NO DEVUELVE
*-- Path
*-- OfflineRecordCount
IF NOT EMPTY(._Offline) AND EVALUATE(._Offline)
TEXT TO lcText TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <Path><<.DBGETPROP(tcView,"VIEW","Path")>></Path>
<<>> <RecordCount><<.DBGETPROP(tcView,"VIEW","RecordCount")>></RecordCount>
ENDTEXT
ENDIF
*--
loFields = ._Fields
lcText = lcText + loFields.toText( tcView )
loIndexes = ._Indexes
lcText = lcText + loIndexes.toText( tcView )
loRelations = CREATEOBJECT('CL_DBC_RELATIONS')
lcText = lcText + loRelations.toText( tcView )
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </VIEW>
ENDTEXT
ENDWITH && THIS
CATCH TO loEx
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "tcView = " + RTRIM(TRANSFORM(tcView))
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE updateDBC
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_OutputFile (v! IN ) Nombre del archivo de salida
* tnLastID (@! IN ) Último número de ID usado
* tnParentID (v! IN ) ID del objeto Padre
*---------------------------------------------------------------------------------------------------
LPARAMETERS tc_OutputFile, tnLastID, tnParentID
DODEFAULT( tc_OutputFile, @tnLastID, tnParentID)
WITH THIS AS CL_DBC_VIEW OF 'FOXBIN2PRG.PRG'
tnParentID = .__ObjectID
._Fields.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
._Indexes.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
._Relations.updateDBC( tc_OutputFile, @tnLastID, tnParentID )
ENDWITH && THIS
ENDPROC
PROCEDURE getBinMemoFromProperties
LOCAL lcBinData
lcBinData = ''
WITH THIS AS CL_DBC_VIEW OF 'FOXBIN2PRG.PRG'
IF ._SourceType = 1
lcBinData = lcBinData + .getBinPropertyDataRecord( 6, .getDBCPropertyIDByName('Class', .T.) )
ELSE
lcBinData = lcBinData + .getBinPropertyDataRecord( 7, .getDBCPropertyIDByName('Class', .T.) )
ENDIF
lcBinData = lcBinData + .getBinPropertyDataRecord( ._UpdateType, .getDBCPropertyIDByName('UpdateType', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._WhereType, .getDBCPropertyIDByName('WhereType', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._FetchMemo, .getDBCPropertyIDByName('FetchMemo', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._ShareConnection, .getDBCPropertyIDByName('ShareConnection', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._AllowSimultaneousFetch, .getDBCPropertyIDByName('AllowSimultaneousFetch', .T.) ) && Undocumented
lcBinData = lcBinData + .getBinPropertyDataRecord( ._SendUpdates, .getDBCPropertyIDByName('SendUpdates', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Prepared, .getDBCPropertyIDByName('Prepared', .T.) ) && Undocumented
lcBinData = lcBinData + .getBinPropertyDataRecord( ._CompareMemo, .getDBCPropertyIDByName('CompareMemo', .T.) ) && Undocumented
lcBinData = lcBinData + .getBinPropertyDataRecord( ._FetchAsNeeded, .getDBCPropertyIDByName('FetchAsNeeded', .T.) ) && Undocumented
lcBinData = lcBinData + .getBinPropertyDataRecord( ._FetchSize, .getDBCPropertyIDByName('FetchSize', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._MaxRecords, .getDBCPropertyIDByName('MaxRecords', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Tables, .getDBCPropertyIDByName('Tables', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._SQL, .getDBCPropertyIDByName('SQL', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._SourceType, .getDBCPropertyIDByName('SourceType', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._BatchUpdateCount, .getDBCPropertyIDByName('BatchUpdateCount', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Comment, .getDBCPropertyIDByName('Comment', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RuleExpression, .getDBCPropertyIDByName('RuleExpression', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RuleText, .getDBCPropertyIDByName('RuleText', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._ParameterList, .getDBCPropertyIDByName('ParameterList', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._ConnectName, .getDBCPropertyIDByName('ConnectName', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._UseMemoSize, .getDBCPropertyIDByName('UseMemoSize', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Offline, .getDBCPropertyIDByName('Offline', .T.) ) && Undocumented
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RecordCount, .getDBCPropertyIDByName('RecordCount', .T.) ) && Undocumented
lcBinData = lcBinData + .getBinPropertyDataRecord( 0, .getDBCPropertyIDByName('undocumented_view_prop_85', .T.) ) && Undocumented
ENDWITH && THIS
RETURN lcBinData
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_FIELDS_VW AS CL_DBC_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBC_FIELDS_VW OF 'FOXBIN2PRG.PRG'
#ENDIF
*******************************************************************************************************************
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loField AS CL_DBC_FIELD_VW OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_FIELDS_I)) == C_FIELDS_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_FIELDS_VW OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_FIELDS_F $ tcLine && Fin
EXIT
CASE C_FIELD_I $ tcLine
loField = CREATEOBJECT("CL_DBC_FIELD_VW")
loField.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loField, loField._Name )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
*******************************************************************************************************************
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcView (v! IN ) Nombre de la Vista
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcView
TRY
LOCAL X, lcText, lnField_Count, laFields(1), loEx AS EXCEPTION
LOCAL loField AS CL_DBC_FIELD_VW OF 'FOXBIN2PRG.PRG'
STORE 0 TO X, tnTable_Count, lnField_Count
lcText = ''
_TALLY = 0
SELECT LOWER(TB.objectName) FROM TABLABIN TB ;
INNER JOIN TABLABIN TB2 ON STR(TB.ParentID)+TB.ObjectType = STR(TB2.ObjectID)+PADR('Field',10) ;
AND TB2.objectName = PADR(LOWER(tcView),128) ;
INTO ARRAY laFields
lnField_Count = _TALLY
IF lnField_Count > 0
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <FIELDS>
ENDTEXT
loField = CREATEOBJECT("CL_DBC_FIELD_VW")
FOR X = 1 TO lnField_Count
lcText = lcText + loField.toText( tcView, laFields(X) )
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </FIELDS>
ENDTEXT
ENDIF
CATCH TO loEx
IF BETWEEN(X, 1, lnField_Count)
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "laFields(" + TRANSFORM(X) + ") = " + RTRIM(laFields(X))
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
USE IN (SELECT("TB"))
USE IN (SELECT("TB2"))
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_FIELD_VW AS CL_DBC_BASE
#IF .F.
LOCAL THIS AS CL_DBC_FIELD_VW OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="_caption" display="_Caption"/>] ;
+ [<memberdata name="_comment" display="_Comment"/>] ;
+ [<memberdata name="_datatype" display="_DataType"/>] ;
+ [<memberdata name="_defaultvalue" display="_DefaultValue"/>] ;
+ [<memberdata name="_displayclass" display="_DisplayClass"/>] ;
+ [<memberdata name="_displayclasslibrary" display="_DisplayClassLibrary"/>] ;
+ [<memberdata name="_format" display="_Format"/>] ;
+ [<memberdata name="_inputmask" display="_InputMask"/>] ;
+ [<memberdata name="_keyfield" display="_KeyField"/>] ;
+ [<memberdata name="_ruleexpression" display="_RuleExpression"/>] ;
+ [<memberdata name="_ruletext" display="_RuleText"/>] ;
+ [<memberdata name="_updatable" display="_Updatable"/>] ;
+ [<memberdata name="_updatename" display="_UpdateName"/>] ;
+ [</VFPData>]
*-- Info
_Name = ''
_Caption = ''
_Comment = ''
_DataType = ''
_DefaultValue = ''
_DisplayClass = ''
_DisplayClassLibrary = ''
_Format = ''
_InputMask = ''
_KeyField = .F.
_RuleExpression = ''
_RuleText = ''
_Updatable = .F.
_UpdateName = ''
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_FIELD_I)) == C_FIELD_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_FIELD_VW OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_FIELD_F $ tcLine && Fin
EXIT
CASE '<Comment>' $ tcLine
.analizarBloque_Comment( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Propiedad de FIELD
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.add_Property( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcView (v! IN ) Nombre de la Vista
* tcField (v! IN ) Nombre del campo
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcView, tcField
TRY
LOCAL lcText, loEx AS EXCEPTION
lcText = ''
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <FIELD>
<<>> <Name><<RTRIM(tcField)>></Name>
<<>> <Caption><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","Caption")>></Caption>
<<>> <Comment><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","Comment")>></Comment>
<<>> <DataType><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","DataType")>></DataType>
<<>> <DefaultValue><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","DefaultValue")>></DefaultValue>
<<>> <DisplayClass><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","DefaultValue")>></DisplayClass>
<<>> <DisplayClassLibrary><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","DefaultValue")>></DisplayClassLibrary>
<<>> <Format><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","Format")>></Format>
<<>> <InputMask><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","InputMask")>></InputMask>
<<>> <KeyField><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","KeyField")>></KeyField>
<<>> <RuleExpression><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","RuleExpression")>></RuleExpression>
<<>> <RuleText><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","RuleText")>></RuleText>
<<>> <Updatable><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","Updatable")>></Updatable>
<<>> <UpdateName><<DBGETPROP( RTRIM(tcView) + '.' + RTRIM(tcField),"FIELD","UpdateName")>></UpdateName>
<<>> </FIELD>
ENDTEXT
CATCH TO loEx
loEx.USERVALUE = loEx.USERVALUE + CR_LF + "tcField = " + RTRIM(TRANSFORM(tcField))
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE getBinMemoFromProperties
LOCAL lcBinData
lcBinData = ''
WITH THIS AS CL_DBC_FIELD_VW OF 'FOXBIN2PRG.PRG'
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Comment, .getDBCPropertyIDByName('Comment', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DataType, .getDBCPropertyIDByName('DataType', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._KeyField, .getDBCPropertyIDByName('KeyField', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Updatable, .getDBCPropertyIDByName('UpdatableField', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._UpdateName, .getDBCPropertyIDByName('UpdateName', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DefaultValue, .getDBCPropertyIDByName('DefaultValue', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DisplayClass, .getDBCPropertyIDByName('DisplayClass', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._DisplayClassLibrary, .getDBCPropertyIDByName('DisplayClassLibrary', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Caption, .getDBCPropertyIDByName('Caption', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._Format, .getDBCPropertyIDByName('Format', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._InputMask, .getDBCPropertyIDByName('InputMask', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RuleExpression, .getDBCPropertyIDByName('RuleExpression', .T.) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._RuleText, .getDBCPropertyIDByName('RuleText', .T.) )
ENDWITH && THIS
RETURN lcBinData
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_RELATIONS AS CL_DBC_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBC_RELATIONS OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loRelation AS CL_DBC_RELATION OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_RELATIONS_I)) == C_RELATIONS_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_RELATIONS OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_RELATIONS_F $ tcLine && Fin
EXIT
CASE C_RELATION_I $ tcLine
loRelation = CREATEOBJECT("CL_DBC_RELATION")
loRelation.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loRelation, loRelation._ChildTable + loRelation._ParentTable )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcTable (v! IN ) Tabla de la que obtener las relaciones
* taRelations (@? OUT) Array de relaciones
* tnRelation_Count (@? OUT) Cantidad de relaciones
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcTable, taRelations, tnRelation_Count
EXTERNAL ARRAY taRelations
TRY
LOCAL I, X, lcText, loEx AS EXCEPTION
LOCAL loRelation AS CL_DBC_RELATION OF 'FOXBIN2PRG.PRG'
lcText = ''
X = 0
DIMENSION taRelations(1,5)
tnRelation_Count = ADBOBJECTS( taRelations,"RELATION" )
IF tnRelation_Count > 0
ASORT( taRelations, 2, -1, 0, 1 )
ASORT( taRelations, 1, -1, 0, 1 )
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <RELATIONS>
ENDTEXT
loRelation = CREATEOBJECT('CL_DBC_RELATION')
FOR I = 1 TO tnRelation_Count
IF taRelations(I,1) == UPPER( RTRIM( tcTable ) )
lcText = lcText + loRelation.toText( @taRelations, I )
ENDIF
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> </RELATIONS>
<<>>
ENDTEXT
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBC_RELATION AS CL_DBC_BASE
#IF .F.
LOCAL THIS AS CL_DBC_RELATION OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_childtable" display="_ChildTable"/>] ;
+ [<memberdata name="_parenttable" display="_ParentTable"/>] ;
+ [<memberdata name="_childindex" display="_ChildIndex"/>] ;
+ [<memberdata name="_parentindex" display="_ParentIndex"/>] ;
+ [<memberdata name="_refintegrity" display="_RefIntegrity"/>] ;
+ [</VFPData>]
*-- Info
_ChildTable = ''
_ParentTable = ''
_ChildIndex = ''
_ParentIndex = ''
_RefIntegrity = ''
*******************************************************************************************************************
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_RELATION_I)) == C_RELATION_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBC_RELATION OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_RELATION_F $ tcLine && Fin
EXIT
OTHERWISE && Propiedad de RELATION
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.add_Property( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taRelations (@! IN ) Array de relaciones
* I (@! IN ) Número de relación evaluado
*---------------------------------------------------------------------------------------------------
LPARAMETERS taRelations, I
TRY
LOCAL lcText, loEx AS EXCEPTION
lcText = ''
TEXT TO lcText TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <RELATION>
<<>> <Name><<'Relation ' + TRANSFORM(I)>></Name>
<<>> <ChildTable><<ALLTRIM(taRelations(I,1))>></ChildTable>
<<>> <ParentTable><<ALLTRIM(taRelations(I,2))>></ParentTable>
<<>> <ChildIndex><<ALLTRIM(taRelations(I,3))>></ChildIndex>
<<>> <ParentIndex><<ALLTRIM(taRelations(I,4))>></ParentIndex>
<<>> <RefIntegrity><<ALLTRIM(taRelations(I,5))>></RefIntegrity>
<<>> </RELATION>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE getReferentialIntegrityInfo
RETURN THIS._RefIntegrity
ENDPROC
PROCEDURE getBinMemoFromProperties
LOCAL lcBinData
lcBinData = ''
WITH THIS AS CL_DBC_RELATION OF 'FOXBIN2PRG.PRG'
lcBinData = lcBinData + .getBinPropertyDataRecord( ._ChildIndex, .getDBCPropertyIDByName( 'ChildTag', .T. ) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._ParentTable, .getDBCPropertyIDByName( 'ParentTable', .T. ) )
lcBinData = lcBinData + .getBinPropertyDataRecord( ._ParentIndex, .getDBCPropertyIDByName( 'ParentTag', .T. ) )
*_ChildTable is used to link the name of the related table.
ENDWITH && THIS
RETURN lcBinData
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBF_TABLE AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_DBF_TABLE OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_codepage" display="_CodePage"/>] ;
+ [<memberdata name="_database" display="_Database"/>] ;
+ [<memberdata name="_filetype" display="_FileType"/>] ;
+ [<memberdata name="_filetype_descrip" display="_FileType_Descrip"/>] ;
+ [<memberdata name="_indexfile" display="_IndexFile"/>] ;
+ [<memberdata name="_memofile" display="_MemoFile"/>] ;
+ [<memberdata name="_lastupdate" display="_LastUpdate"/>] ;
+ [<memberdata name="_fields" display="_Fields"/>] ;
+ [<memberdata name="_indexes" display="_Indexes"/>] ;
+ [<memberdata name="_sourcefile" display="_SourceFile"/>] ;
+ [<memberdata name="_version" display="_Version"/>] ;
+ [<memberdata name="_fields" display="_Fields"/>] ;
+ [<memberdata name="_indexes" display="_Indexes"/>] ;
+ [</VFPData>]
*-- Modulo
_Version = 0
_SourceFile = ''
*-- Table Info
_CodePage = 0
_Database = ''
_FileType = ''
_FileType_Descrip = ''
_IndexFile = ''
_MemoFile = ''
_LastUpdate = {}
*-- Fields and Indexes
*_Fields = NULL
*_Indexes = NULL
PROCEDURE INIT
DODEFAULT()
*--
THIS.ADDOBJECT("_Fields", "CL_DBF_FIELDS")
THIS.ADDOBJECT("_Indexes", "CL_DBF_INDEXES")
ENDPROC
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loFields AS CL_DBF_FIELDS OF 'FOXBIN2PRG.PRG'
LOCAL loIndexes AS CL_DBF_INDEXES OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_TABLE_I)) == C_TABLE_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBF_TABLE OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_TABLE_F $ tcLine && Fin
EXIT
CASE C_FIELDS_I $ tcLine
loFields = ._Fields
loFields.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
CASE C_INDEXES_I $ tcLine
loIndexes = ._Indexes
loIndexes.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
OTHERWISE && Otro valor
*-- Estructura a reconocer:
* <tagname>ID<tagname>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.ADDPROPERTY( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_FileTypeDesc (v! IN ) Tipo de archivo (en Hex)
* tl_FileHasCDX (v! IN ) Indica si el archivo tiene CDX asociado
* tl_FileHasMemo (v! IN ) Indica si el archivo tiene MEMO (FPT) asociado
* tl_FileIsDBC (v! IN ) Indica si el archivo es un DBC
* tc_DBC_Name (v! IN ) Nombre del DBC (si tiene)
* tc_InputFile (v! IN ) Nombre del archivo de salida
* tc_FileTypeDesc (v! IN ) Descripción del Tipo de archivo
*---------------------------------------------------------------------------------------------------
LPARAMETERS tn_HexFileType, tl_FileHasCDX, tl_FileHasMemo, tl_FileIsDBC, tc_DBC_Name, tc_InputFile, tc_FileTypeDesc
TRY
LOCAL lcText, loEx AS EXCEPTION
LOCAL loFields AS CL_DBF_FIELDS OF 'FOXBIN2PRG.PRG'
LOCAL loIndexes AS CL_DBF_INDEXES OF 'FOXBIN2PRG.PRG'
lcText = ''
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<C_TABLE_I>>
<<>> <MemoFile><<IIF( tl_FileHasMemo, FORCEEXT(tc_InputFile, 'FPT'), '' )>></MemoFile>
<<>> <CodePage><<CPDBF('TABLABIN')>></CodePage>
<<>> <LastUpdate><<LUPDATE('TABLABIN')>></LastUpdate>
<<>> <Database><<tc_DBC_Name>></Database>
<<>> <FileType><<TRANSFORM(tn_HexFileType, '@0')>></FileType>
<<>> <FileType_Descrip><<tc_FileTypeDesc>></FileType_Descrip>
ENDTEXT
*-- Fields
loFields = THIS._Fields
lcText = lcText + loFields.toText()
*-- Indexes
loIndexes = THIS._Indexes
lcText = lcText + loIndexes.toText()
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_TABLE_F>>
<<>>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBF_FIELDS AS CL_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBF_FIELDS OF 'FOXBIN2PRG.PRG'
#ENDIF
*******************************************************************************************************************
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loField AS CL_DBF_FIELD OF 'FOXBIN2PRG.PRG'
LOCAL loIndex AS CL_DBF_INDEX OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_FIELDS_I)) == C_FIELDS_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBF_FIELDS OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_FIELDS_F $ tcLine && Fin
EXIT
CASE C_FIELD_I $ tcLine
loField = CREATEOBJECT("CL_DBF_FIELD")
loField.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loField, loField._Name )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taFields (@? OUT) Array de información de campos
* tnField_Count (@? OUT) Cantidad de campos
*---------------------------------------------------------------------------------------------------
LPARAMETERS taFields, tnField_Count
EXTERNAL ARRAY taFields
TRY
LOCAL I, lcText, loEx AS EXCEPTION
LOCAL loField AS CL_DBF_FIELD OF 'FOXBIN2PRG.PRG'
lcText = ''
DIMENSION taFields(1,18)
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <<C_FIELDS_I>>
ENDTEXT
tnField_Count = AFIELDS(taFields)
loField = CREATEOBJECT('CL_DBF_FIELD')
FOR I = 1 TO tnField_Count
lcText = lcText + loField.toText( @taFields, I )
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FIELDS_F>>
<<>>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBF_FIELD AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_DBF_FIELD OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="_type" display="_Type"/>] ;
+ [<memberdata name="_width" display="_Width"/>] ;
+ [<memberdata name="_decimals" display="_Decimals"/>] ;
+ [<memberdata name="_null" display="_Null"/>] ;
+ [<memberdata name="_nocptran" display="_NoCPTran"/>] ;
+ [<memberdata name="_field_valid_exp" display="_Field_Valid_Exp"/>] ;
+ [<memberdata name="_field_valid_text" display="_Field_Valid_Text"/>] ;
+ [<memberdata name="_field_default_value" display="_Field_Default_Value"/>] ;
+ [<memberdata name="_table_valid_exp" display="_Table_Valid_Exp"/>] ;
+ [<memberdata name="_table_valid_text" display="_Table_Valid_Text"/>] ;
+ [<memberdata name="_longtablename" display="_LongTableName"/>] ;
+ [<memberdata name="_ins_trig_exp" display="_Ins_Trig_Exp"/>] ;
+ [<memberdata name="_upd_trig_exp" display="_Upd_Trig_Exp"/>] ;
+ [<memberdata name="_del_trig_exp" display="_Del_Trig_Exp"/>] ;
+ [<memberdata name="_tablecomment" display="_TableComment"/>] ;
+ [<memberdata name="_autoinc_nextval" display="_AutoInc_NextVal"/>] ;
+ [<memberdata name="_autoinc_step" display="_AutoInc_Step"/>] ;
+ [</VFPData>]
*-- Field Info
_Name = '' && 1
_Type = '' && 2
_Width = 0 && 3
_Decimals = 0 && 4
_Null = .F. && 5
_NoCPTran = .F. && 6
_Field_Valid_Exp = '' && 7 - DBC
_Field_Valid_Text = '' && 8 - DBC
_Field_Default_Value = '' && 9 - DBC
_Table_Valid_Exp = '' && 10 - DBC
_Table_Valid_Text = '' && 11 - DBC
_LongTableName = '' && 12 - DBC
_Ins_Trig_Exp = '' && 13 - DBC
_Upd_Trig_Exp = '' && 14 - DBC
_Del_Trig_Exp = '' && 15 - DBC
_TableComment = '' && 16 - DBC
_AutoInc_NextVal = 0 && 17
_AutoInc_Step = 0 && 18
*******************************************************************************************************************
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_FIELD_I)) == C_FIELD_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBF_FIELD OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_FIELD_F $ tcLine && Fin
EXIT
OTHERWISE && Propiedad de FIELD
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.ADDPROPERTY( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taFields (@! IN ) Array de información de campos
* I (@! IN ) Campo en evaluación
*---------------------------------------------------------------------------------------------------
LPARAMETERS taFields, I
EXTERNAL ARRAY taFields
TRY
LOCAL I, lcText, loEx AS EXCEPTION
lcText = ''
TEXT TO lcText TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_FIELD_I>>
<<>> <Name><<taFields(I,1)>></Name>
<<>> <Type><<taFields(I,2)>></Type>
<<>> <Width><<taFields(I,3)>></Width>
<<>> <Decimals><<taFields(I,4)>></Decimals>
<<>> <Null><<taFields(I,5)>></Null>
<<>> <NoCPTran><<taFields(I,6)>></NoCPTran>
<<>> <Field_Valid_Exp><<taFields(I,7)>></Field_Valid_Exp>
<<>> <Field_Valid_Text><<taFields(I,8)>></Field_Valid_Text>
<<>> <Field_Default_Value><<taFields(I,9)>></Field_Default_Value>
<<>> <Table_Valid_Exp><<taFields(I,10)>></Table_Valid_Exp>
<<>> <Table_Valid_Text><<taFields(I,11)>></Table_Valid_Text>
<<>> <LongTableName><<taFields(I,12)>></LongTableName>
<<>> <Ins_Trig_Exp><<taFields(I,13)>></Ins_Trig_Exp>
<<>> <Upd_Trig_Exp><<taFields(I,14)>></Upd_Trig_Exp>
<<>> <Del_Trig_Exp><<taFields(I,15)>></Del_Trig_Exp>
<<>> <TableComment><<taFields(I,16)>></TableComment>
<<>> <Autoinc_Nextval><<taFields(I,17)>></Autoinc_Nextval>
<<>> <Autoinc_Step><<taFields(I,18)>></Autoinc_Step>
<<>> <<C_FIELD_F>>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBF_INDEXES AS CL_COL_BASE
#IF .F.
LOCAL THIS AS CL_DBF_INDEXES OF 'FOXBIN2PRG.PRG'
#ENDIF
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL loIndex AS CL_DBF_INDEX OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_INDEXES_I)) == C_INDEXES_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBF_INDEXES OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_INDEXES_F $ tcLine && Fin
EXIT
CASE C_INDEX_I $ tcLine
loIndex = CREATEOBJECT("CL_DBF_INDEX")
loIndex.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines )
.ADD( loIndex, loIndex._TagName )
OTHERWISE && Otro valor
*-- No hay otros valores
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine)
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taTagInfo (@? OUT) Array de información de indices
* tnTagInfo_Count (@? OUT) Cantidad de índices
*---------------------------------------------------------------------------------------------------
LPARAMETERS taTagInfo, tnTagInfo_Count
EXTERNAL ARRAY taTagInfo
TRY
LOCAL I, lcText, loEx AS EXCEPTION
LOCAL loIndex AS CL_DBF_INDEX OF 'FOXBIN2PRG.PRG'
lcText = ''
DIMENSION taTagInfo(1,6)
IF TAGCOUNT() > 0
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<>> <<C_CDX_I>><<CDX(1)>><<C_CDX_F>>
<<>>
<<>> <<C_INDEXES_I>>
ENDTEXT
tnTagInfo_Count = ATAGINFO( taTagInfo )
loIndex = CREATEOBJECT("CL_DBF_INDEX")
FOR I = 1 TO tnTagInfo_Count
lcText = lcText + loIndex.toText( @taTagInfo, I )
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <<C_INDEXES_F>>
<<>>
ENDTEXT
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_DBF_INDEX AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_DBF_INDEX OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_tagname" display="_TagName"/>] ;
+ [<memberdata name="_tagtype" display="_TagType"/>] ;
+ [<memberdata name="_key" display="_Key"/>] ;
+ [<memberdata name="_filter" display="_Filter"/>] ;
+ [<memberdata name="_order" display="_Order"/>] ;
+ [<memberdata name="_collate" display="_Collate"/>] ;
+ [</VFPData>]
*-- Index Info
_TagName = ''
_TagType = ''
_Key = ''
_Filter = ''
_Order = ''
_Collate = ''
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines
TRY
LOCAL llBloqueEncontrado, lcPropName, lcValue, loEx AS EXCEPTION
STORE '' TO lcPropName, lcValue
IF LEFT(tcLine, LEN(C_INDEX_I)) == C_INDEX_I
llBloqueEncontrado = .T.
WITH THIS AS CL_DBF_INDEX OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE C_INDEX_F $ tcLine && Fin
EXIT
OTHERWISE && Propiedad de INDEX
*-- Estructura a reconocer:
* <name>NOMBRE</name>
lcPropName = STREXTRACT( tcLine, '<', '>', 1, 0 )
lcValue = STREXTRACT( tcLine, '<' + lcPropName + '>', '</' + lcPropName + '>', 1, 0 )
.ADDPROPERTY( '_' + lcPropName, lcValue )
ENDCASE
ENDFOR
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF loEx.ERRORNO = 1470 && Incorrect property name.
loEx.USERVALUE = 'I=' + TRANSFORM(I) + ', tcLine=' + TRANSFORM(tcLine) + ', PropName=[' + TRANSFORM(lcPropName) + '], Value=[' + TRANSFORM(lcValue) + ']'
ENDIF
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* taTagInfo (@? IN ) Array de información de indices
* I (@? IN ) Indice en evaluación
*---------------------------------------------------------------------------------------------------
LPARAMETERS taTagInfo, I
EXTERNAL ARRAY taTagInfo
TRY
LOCAL I, lcText, loEx AS EXCEPTION
lcText = ''
TEXT TO lcText TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>> <INDEX>
<<>> <TagName><<taTagInfo(I,1)>></TagName>
<<>> <TagType><<ICASE(LEFT(taTagInfo(I,2),3)='BIN','BINARY',PRIMARY(I),'PRIMARY',CANDIDATE(I),'CANDIDATE',UNIQUE(I),'UNIQUE','REGULAR'))>></TagType>
<<>> <Key><<taTagInfo(I,3)>></Key>
<<>> <Filter><<taTagInfo(I,4)>></Filter>
<<>> <Order><<IIF(DESCENDING(I), 'DESCENDING', 'ASCENDING')>></Order>
<<>> <Collate><<taTagInfo(I,6)>></Collate>
<<>> </INDEX>
ENDTEXT
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_PROJ_SRV_HEAD AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_internalname" display="_InternalName"/>] ;
+ [<memberdata name="_libraryname" display="_LibraryName"/>] ;
+ [<memberdata name="_projectname" display="_ProjectName"/>] ;
+ [<memberdata name="_servercount" display="_ServerCount"/>] ;
+ [<memberdata name="_servers" display="_Servers"/>] ;
+ [<memberdata name="_servertype" display="_ServerType"/>] ;
+ [<memberdata name="_typelib" display="_TypeLib"/>] ;
+ [<memberdata name="_typelibdesc" display="_TypeLibDesc"/>] ;
+ [<memberdata name="add_server" display="add_Server"/>] ;
+ [<memberdata name="getdatafrompair_lendata_structure" display="getDataFromPair_LenData_Structure"/>] ;
+ [<memberdata name="getformattedservertext" display="getFormattedServerText"/>] ;
+ [<memberdata name="getrowserverinfo" display="getRowServerInfo"/>] ;
+ [<memberdata name="getserverdataobject" display="getServerDataObject"/>] ;
+ [<memberdata name="parseserverinfo" display="parseServerInfo"/>] ;
+ [<memberdata name="setparsedheadinfoline" display="setParsedHeadInfoLine"/>] ;
+ [<memberdata name="setparsedinfoline" display="setParsedInfoLine"/>] ;
+ [</VFPData>]
*-- Información interesante sobre Servidores OLE y corrupción de IDs: http://www.west-wind.com/wconnect/weblog/ShowEntry.blog?id=880
*-- Server Head info
DIMENSION _Servers[1]
_ServerCount = 0
_LibraryName = ''
_InternalName = ''
_ProjectName = ''
_TypeLibDesc = ''
_ServerType = ''
_TypeLib = ''
************************************************************************************************
PROCEDURE setParsedHeadInfoLine
LPARAMETERS tcHeadInfoLine
THIS.setParsedInfoLine( THIS, tcHeadInfoLine )
ENDPROC
************************************************************************************************
PROCEDURE setParsedInfoLine
LPARAMETERS toObject, tcInfoLine
LOCAL lcAsignacion, lcCurDir
IF LEFT(tcInfoLine,1) == '.'
lcAsignacion = 'toObject' + tcInfoLine
ELSE
lcAsignacion = 'toObject.' + tcInfoLine
ENDIF
&lcAsignacion.
ENDPROC
************************************************************************************************
PROCEDURE add_Server
LPARAMETERS toServerData
#IF .F.
LOCAL toServerData AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
#ENDIF
WITH THIS AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG'
._ServerCount = ._ServerCount + 1
DIMENSION ._Servers( ._ServerCount )
._Servers( ._ServerCount ) = toServerData
ENDWITH && THIS
ENDPROC
************************************************************************************************
PROCEDURE getDataFromPair_LenData_Structure
LPARAMETERS tcData, tnPos, tnLen
LOCAL lcData, lnLen
tnPos = tnPos + 4 + tnLen
tnLen = INT( VAL( SUBSTR( tcData, tnPos, 4 ) ) )
lcData = SUBSTR( tcData, tnPos + 4, tnLen )
RETURN lcData
ENDPROC
PROCEDURE getServerDataObject
RETURN CREATEOBJECT('CL_PROJ_SRV_DATA')
ENDPROC
************************************************************************************************
PROCEDURE parseServerInfo
LPARAMETERS tcServerInfo
IF NOT EMPTY(tcServerInfo)
TRY
LOCAL loServerData AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
WITH THIS AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG'
lcStr = ''
lnPos = 1
lnLen = 4
lnServerCount = INT( VAL( .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen ) ) )
._LibraryName = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
._InternalName = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
._ProjectName = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
._TypeLibDesc = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
._ServerType = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
._TypeLib = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
*-- Información de los servidores
FOR I = 1 TO lnServerCount
loServerData = NULL
loServerData = .getServerDataObject()
loServerData._HelpContextID = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
loServerData._ServerName = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
loServerData._Description = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
loServerData._HelpFile = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
loServerData._ServerClass = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
loServerData._ClassLibrary = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
loServerData._Instancing = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
loServerData._CLSID = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
loServerData._Interface = .getDataFromPair_LenData_Structure( @tcServerInfo, @lnPos, @lnLen )
.add_Server( loServerData )
ENDFOR
ENDWITH && THIS
loServerData = NULL
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
ENDIF
ENDPROC
************************************************************************************************
PROCEDURE getRowServerInfo
TRY
LOCAL lcStr, lnLenH, lnLen, lnPos ;
, loServerData AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
lcStr = ''
WITH THIS AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG'
IF ._ServerCount > 0
lnPos = 1
lnLen = 4
lnLenH = 103 && Al final es una constante fija :( 4 + 8 + 4 + LEN(._LibraryName) + 4 + LEN(._InternalName) + 4 + LEN(._ProjectName) + 4 + LEN(._TypeLibDesc) - 1
*-- Header
lcStr = lcStr + PADL( 4, 4, ' ' ) + PADL( lnLenH, 4, ' ' )
lcStr = lcStr + PADL( 4, 4, ' ' ) + PADL( ._ServerCount, 4, ' ' )
lcStr = lcStr + PADL( LEN(._LibraryName), 4, ' ' ) + ._LibraryName
lcStr = lcStr + PADL( LEN(._InternalName), 4, ' ' ) + ._InternalName
lcStr = lcStr + PADL( LEN(._ProjectName), 4, ' ' ) + ._ProjectName
lcStr = lcStr + PADL( LEN(._TypeLibDesc), 4, ' ' ) + ._TypeLibDesc
lcStr = lcStr + PADL( LEN(._ServerType), 4, ' ' ) + ._ServerType
lcStr = lcStr + PADL( LEN(._TypeLib), 4, ' ' ) + ._TypeLib
FOR I = 1 TO ._ServerCount
loServerData = ._Servers(I)
lcStr = lcStr + loServerData.getRowServerInfo()
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcStr
ENDPROC
************************************************************************************************
PROCEDURE getFormattedServerText
TRY
LOCAL lcText ;
, loServerData AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
lcText = ''
WITH THIS AS CL_PROJ_SRV_HEAD OF 'FOXBIN2PRG.PRG'
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_SRV_HEAD_I>>
_LibraryName = '<<._LibraryName>>'
_InternalName = '<<._InternalName>>'
_ProjectName = '<<._ProjectName>>'
_TypeLibDesc = '<<._TypeLibDesc>>'
_ServerType = '<<._ServerType>>'
_TypeLib = '<<._TypeLib>>'
<<C_SRV_HEAD_F>>
ENDTEXT
*-- Recorro los servidores
FOR I = 1 TO ._ServerCount
loServerData = ._Servers(I)
lcText = lcText + loServerData.getFormattedServerText()
loServerData = NULL
ENDFOR
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_PROJ_SRV_DATA AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_PROJ_SRV_DATA OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_classlibrary" display="_ClassLibrary"/>] ;
+ [<memberdata name="_clsid" display="_CLSID"/>] ;
+ [<memberdata name="_description" display="_Description"/>] ;
+ [<memberdata name="_helpcontextid" display="_HelpContextID"/>] ;
+ [<memberdata name="_helpfile" display="_HelpFile"/>] ;
+ [<memberdata name="_interface" display="_Interface"/>] ;
+ [<memberdata name="_instancing" display="_Instancing"/>] ;
+ [<memberdata name="_serverclass" display="_ServerClass"/>] ;
+ [<memberdata name="_servername" display="_ServerName"/>] ;
+ [<memberdata name="getformattedservertext" display="getFormattedServerText"/>] ;
+ [<memberdata name="getrowserverinfo" display="getRowServerInfo"/>] ;
+ [</VFPData>]
_HelpContextID = 0
_ServerName = ''
_Description = ''
_HelpFile = ''
_ServerClass = ''
_ClassLibrary = ''
_Instancing = 0
_CLSID = ''
_Interface = ''
************************************************************************************************
PROCEDURE getRowServerInfo
TRY
LOCAL lcStr, lnLen, lnPos
lcStr = ''
WITH THIS
IF NOT EMPTY(._ServerName)
lnPos = 1
lnLen = 4
*-- Data
lcStr = lcStr + PADL( LEN(._HelpContextID), 4, ' ' ) + ._HelpContextID
lcStr = lcStr + PADL( LEN(._ServerName), 4, ' ' ) + ._ServerName
lcStr = lcStr + PADL( LEN(._Description), 4, ' ' ) + ._Description
lcStr = lcStr + PADL( LEN(._HelpFile), 4, ' ' ) + ._HelpFile
lcStr = lcStr + PADL( LEN(._ServerClass), 4, ' ' ) + ._ServerClass
lcStr = lcStr + PADL( LEN(._ClassLibrary), 4, ' ' ) + ._ClassLibrary
lcStr = lcStr + PADL( LEN(._Instancing), 4, ' ' ) + ._Instancing
lcStr = lcStr + PADL( LEN(._CLSID), 4, ' ' ) + ._CLSID
lcStr = lcStr + PADL( LEN(._Interface), 4, ' ' ) + ._Interface
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcStr
ENDPROC
************************************************************************************************
PROCEDURE getFormattedServerText
TRY
LOCAL lcText
lcText = ''
WITH THIS
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_SRV_DATA_I>>
_HelpContextID = '<<._HelpContextID>>'
_ServerName = '<<._ServerName>>'
_Description = '<<._Description>>'
_HelpFile = '<<._HelpFile>>'
_ServerClass = '<<._ServerClass>>'
_ClassLibrary = '<<._ClassLibrary>>'
_Instancing = '<<._Instancing>>'
_CLSID = '<<._CLSID>>'
_Interface = '<<._Interface>>'
<<C_SRV_DATA_F>>
ENDTEXT
ENDWITH
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_PROJ_FILE AS CL_CUS_BASE
#IF .F.
LOCAL THIS AS CL_PROJ_FILE OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="_comments" display="_Comments"/>] ;
+ [<memberdata name="_cpid" display="_CPID"/>] ;
+ [<memberdata name="_exclude" display="_Exclude"/>] ;
+ [<memberdata name="_id" display="_ID"/>] ;
+ [<memberdata name="_name" display="_Name"/>] ;
+ [<memberdata name="_objrev" display="_ObjRev"/>] ;
+ [<memberdata name="_timestamp" display="_Timestamp"/>] ;
+ [<memberdata name="_type" display="_Type"/>] ;
+ [</VFPData>]
_Name = ''
_Type = ''
_Exclude = .F.
_Comments = ''
_CPID = 0
_ID = 0
_ObjRev = 0
_TimeStamp = 0
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_MENU_COL_BASE AS CL_COL_BASE
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="oreg" display="oReg"/>] ;
+ [<memberdata name="analizarsiexpresionescomandooprocedimiento" display="AnalizarSiExpresionEsComandoOProcedimiento"/>] ;
+ [<memberdata name="get_datafromtablabin" display="get_DataFromTablabin"/>] ;
+ [<memberdata name="updatemenu" display="updateMENU"/>] ;
+ [</VFPData>]
#IF .F.
LOCAL THIS AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
#ENDIF
oReg = NULL
PROCEDURE get_DataFromTablabin
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toReg (v! IN ) Objeto de datos del registro
* toCol_LastLevelName (v! IN ) Objeto collection con la pila de niveles analizados
*---------------------------------------------------------------------------------------------------
LPARAMETERS toReg, toCol_LastLevelName AS COLLECTION
TRY
LOCAL I, lcLevelName, lnLastKey, llRetorno, llHayDatos, loReg ;
, loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG' ;
, loOption AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
WITH THIS AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
lnLastKey = 0
.oReg = toReg
lcLevelName = toReg.LevelName
lnLastKey = IIF( toCol_LastLevelName.COUNT=0, 0, toCol_LastLevelName.GETKEY(toReg.LevelName ) )
IF lnLastKey = 0
toCol_LastLevelName.ADD( toReg.LevelName, toReg.LevelName )
ENDIF
DO WHILE NOT EOF()
loReg = NULL
SKIP 1
IF EOF()
EXIT
ENDIF
SCATTER MEMO NAME loReg
lnLastKey = toCol_LastLevelName.GETKEY(loReg.LevelName)
DO CASE
CASE EOF()
llRetorno = .T.
EXIT
CASE lnLastKey > 0 AND lnLastKey < toCol_LastLevelName.COUNT
*-- El nombre del analizado actual ya existe y no es el último,
*-- así que corresponde a un nivel superior.
SKIP -1
llRetorno = .F.
EXIT
CASE loReg.ObjType = 3 AND toReg.ObjType = 3 OR loReg.ObjType = 2 AND toReg.ObjType = 2
*-- Un objeto Option no puede anidar a otro Option,
*-- y un objeto Bar/Popup no puede anidar a otro Bar/Popup
SKIP -1
llRetorno = .F.
EXIT
CASE loReg.ObjType = 2 && Bar or Popup
loBarPop = CREATEOBJECT('CL_MENU_BARPOP')
llHayDatos = loBarPop.get_DataFromTablabin( loReg, toCol_LastLevelName )
llRetorno = .T.
llRetorno = llHayDatos
.ADD( loBarPop )
loBarPop = NULL
IF NOT llHayDatos AND toReg.ObjType = 3
EXIT
ENDIF
CASE loReg.ObjType = 3 && Option
loOption = CREATEOBJECT('CL_MENU_OPTION')
llHayDatos = loOption.get_DataFromTablabin( loReg, toCol_LastLevelName )
llRetorno = llHayDatos
.ADD( loOption )
loOption = NULL
IF NOT llHayDatos AND toReg.ObjType = 3
EXIT
ENDIF
OTHERWISE
llRetorno = .T.
EXIT
ENDCASE
ENDDO
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
STORE NULL TO loBarPop, loOption
IF toReg.ObjType = 2
lnLastKey = toCol_LastLevelName.GETKEY(toReg.LevelName)
IF lnLastKey > 0
toCol_LastLevelName.REMOVE(lnLastKey)
ENDIF
ENDIF
ENDTRY
RETURN llRetorno
ENDPROC
PROCEDURE updateMENU
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS toConversor
ENDPROC
PROCEDURE AnalizarSiExpresionEsComandoOProcedimiento
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcExpr (v! IN ) Expresión a analizar (puede ser una línea o un Procedure)
* tcProcName (@! OUT) Nombre del Procedimiento, si se encuentra uno
* tcProcCode (@! OUT) Código del Procedimiento, si se encuentra uno
* tcSourceCode (@? IN ) Si se indica, se buscará el nombre de Procedure para obtener su código
* tnIndentation (v? IN ) En caso de devolver código, indica si se debe indentar o quitar indentación
* tlAddProcEndproc (v? IN ) En caso de devolver código, indica si se debe encerrar con PROCEDURE/ENDPROC
*---------------------------------------------------------------------------------------------------
* DETALLE: Los menus guardan en los primeros registros los Comandos o Procedimientos en el campo PROCEDURE,
* y luego al generar el código lo muestran como Comando si es una sola línea, y si no como Procedure.
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcExpr, tcProcName, tcProcCode, tcSourceCode, tnIndentation, tlAddProcEndproc
LOCAL laProcLines(1), lnLine_Count, I
tcProcName = ''
tcProcCode = ''
tnIndentation = EVL(tnIndentation,0)
lnLine_Count = ALINES( laProcLines, tcExpr )
IF lnLine_Count > 1
*-- ES UN PROCEDIMIENTO
tcProcCode = tcExpr
FOR I = 1 TO lnLine_Count
*-- Si existe el snippet #NAME, lo usa
IF EMPTY(tcProcName) AND UPPER( LEFT( ALLTRIM(laProcLines(I)), 6 ) ) == '#NAME '
tcProcName = ALLTRIM( SUBSTR( ALLTRIM(laProcLines(I)), 7 ) )
EXIT
ENDIF
ENDFOR
ELSE
*-- ES UN COMANDO, PERO PODRÍA REFERENCIAR A UN PROCEDURE DEL MENU, SE VERIFICA.
IF NOT EMPTY(tcSourceCode)
IF LEFT( tcExpr, 3 ) == 'DO '
*-- Parece un Procedimiento, vamos a confirmarlo.
tcProcName = ALLTRIM( STREXTRACT( tcExpr, 'DO ', '&'+'&', 1, 2 ) )
tcProcCode = STREXTRACT( tcSourceCode, 'PROCEDURE ' + tcProcName + CR_LF, CR_LF + 'ENDPROC &'+'& ' + tcProcName )
IF EMPTY(tcProcCode)
*-- Era un Command al final, o un Procedure externo,
*-- que para el caso es lo mismo porque no es del Menu.
tcProcName = ''
ENDIF
ENDIF
ENDIF
ENDIF
*-- Si se indicó indentación, se reprocesa el código del procedimiento
IF NOT EMPTY(tcProcCode) AND (tnIndentation <> 0 OR tlAddProcEndproc)
lnLine_Count = ALINES( laProcLines, tcProcCode )
tcProcCode = ''
IF tlAddProcEndproc
*tcProcCode = '*' + REPLICATE('-',34) + CR_LF + 'PROCEDURE <<ProcName>>' + CR_LF
tcProcCode = 'PROCEDURE <<ProcName>>' + CR_LF
ENDIF
DO CASE
CASE tnIndentation = 0
FOR I = 1 TO lnLine_Count
*-- No Indentar
tcProcCode = tcProcCode + laProcLines(I) + CR_LF
ENDFOR
CASE tnIndentation > 0
FOR I = 1 TO lnLine_Count
*-- Indentar
tcProcCode = tcProcCode + C_TAB + laProcLines(I) + CR_LF
ENDFOR
OTHERWISE
FOR I = 1 TO lnLine_Count
*-- Quitar indentación
IF INLIST( LEFT(laProcLines(I),1), SPACE(1), C_TAB )
tcProcCode = tcProcCode + SUBSTR( laProcLines(I), 2 ) + CR_LF
ELSE
tcProcCode = tcProcCode + laProcLines(I) + CR_LF
ENDIF
ENDFOR
ENDCASE
IF tlAddProcEndproc
tcProcCode = tcProcCode + 'ENDPROC &' + '& <<ProcName>>' + CR_LF
ENDIF
ENDIF
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_MENU AS CL_MENU_COL_BASE
#IF .F.
LOCAL THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
#ENDIF
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="analizarbloque_cleanupcode" display="analizarBloque_CleanupCode"/>] ;
+ [<memberdata name="analizarbloque_menucode" display="analizarBloque_MenuCode"/>] ;
+ [<memberdata name="analizarbloque_procedure" display="analizarBloque_PROCEDURE"/>] ;
+ [<memberdata name="analizarbloque_setupcode" display="analizarBloque_SetupCode"/>] ;
+ [<memberdata name="updatemenu_recursivo" display="UpdateMenu_Recursivo"/>] ;
+ [<memberdata name="_sourcefile" display="_SourceFile"/>] ;
+ [<memberdata name="_version" display="_Version"/>] ;
+ [</VFPData>]
*-- Modulo
_Version = 0
_SourceFile = ''
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL loOptions AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
LOCAL loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, loReg, lcComment, lcExpr, lcProcName, lcProcCode, loEx AS EXCEPTION ;
, llBloque_SetupCode_Analizado, llBloque_CleanupCode_Analizado, llBloque_MenuCode_Analizado ;
, llBloque_MenuType_Analizado, llBloque_Procedure_Analizado, llBloque_MenuLocation_Analizado
STORE '' TO lcComment
llBloqueEncontrado = .T.
WITH THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
*-- CABECERA DEL MENU
.oReg = toConversor.emptyRecord()
loReg = .oReg
FOR I = I + 0 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE toConversor.lineIsOnlyCommentAndNoMetadata( @tcLine, @lcComment )
LOOP && Saltear comentarios
CASE NOT llBloque_MenuType_Analizado AND LEFT( tcLine, LEN(C_MENUTYPE_I) ) == C_MENUTYPE_I
toConversor.n_MenuType = INT( VAL( STREXTRACT( tcLine, C_MENUTYPE_I, C_MENUTYPE_F ) ) )
loReg.ObjType = toConversor.n_MenuType
llBloque_MenuType_Analizado = .T.
CASE NOT llBloque_MenuLocation_Analizado AND LEFT( tcLine, LEN(C_MENULOCATION_I) ) == C_MENULOCATION_I
toConversor.c_MenuLocation = STREXTRACT( tcLine, C_MENULOCATION_I, C_MENULOCATION_F )
DO CASE
CASE toConversor.c_MenuLocation == 'REPLACE'
loReg.Location = 0
CASE toConversor.c_MenuLocation == 'APPEND'
loReg.Location = 1
OTHERWISE
IF LEFT(toConversor.c_MenuLocation,7) == 'BEFORE'
loReg.Location = 2
ELSE
loReg.Location = 3
ENDIF
loReg.NAME = GETWORDNUM(toConversor.c_MenuLocation,2)
ENDCASE
llBloque_MenuLocation_Analizado = .T.
CASE NOT llBloque_SetupCode_Analizado AND .analizarBloque_SetupCode( @tcLine, @taCodeLines, @I, tnCodeLines, toConversor )
llBloque_SetupCode_Analizado = .T.
CASE NOT llBloque_MenuCode_Analizado AND .analizarBloque_MenuCode( @tcLine, @taCodeLines, @I, tnCodeLines, toConversor )
llBloque_MenuCode_Analizado = .T.
CASE NOT llBloque_CleanupCode_Analizado AND .analizarBloque_CleanupCode( @tcLine, @taCodeLines, @I, tnCodeLines, toConversor )
llBloque_CleanupCode_Analizado = .T.
CASE NOT llBloque_Procedure_Analizado AND .analizarBloque_PROCEDURE( @tcLine, @taCodeLines, @I, tnCodeLines, toConversor )
llBloque_Procedure_Analizado = .T.
OTHERWISE && Otro valor
*EXIT
ENDCASE
ENDFOR
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE analizarBloque_SetupCode
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcText, lcComment, loEx AS EXCEPTION
STORE '' TO lcText, lcComment
IF LEFT(tcLine, LEN(C_SETUPCODE_I)) == C_SETUPCODE_I
llBloqueEncontrado = .T.
WITH THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE C_SETUPCODE_F $ tcLine && Fin
I = I + 1
EXIT
OTHERWISE && Líneas de procedure
lcText = lcText + CR_LF + taCodeLines(I)
ENDCASE
ENDFOR
I = I - 1
.oReg.SETUP = SUBSTR( lcText, 3 ) && Quito el primer CR_LF
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE analizarBloque_CleanupCode
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcText, lcComment, loEx AS EXCEPTION
STORE '' TO lcText, lcComment
IF LEFT(tcLine, LEN(C_CLEANUPCODE_I)) == C_CLEANUPCODE_I
llBloqueEncontrado = .T.
WITH THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE C_CLEANUPCODE_F $ tcLine && Fin
I = I + 1
EXIT
OTHERWISE && Líneas de procedure
lcText = lcText + CR_LF + taCodeLines(I)
ENDCASE
ENDFOR
I = I - 1
.oReg.Cleanup = SUBSTR( lcText, 3 ) && Quito el primer CR_LF
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE analizarBloque_MenuCode
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL loOptions AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
LOCAL loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcExpr, lcProcName, lcProcCode, lcComment, loReg, loEx AS EXCEPTION ;
, llBloque_SetupCode_Analizado
STORE '' TO lcExpr, lcProcName, lcProcCode, lcComment
WITH THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
loReg = .oReg
IF LEFT(tcLine, LEN(C_MENUCODE_I)) == C_MENUCODE_I
llBloqueEncontrado = .T.
FOR I = I + 0 TO tnCodeLines
STORE '' TO lcExpr, lcProcName, lcProcCode
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE toConversor.lineIsOnlyCommentAndNoMetadata( @tcLine, @lcComment )
LOOP && Saltear comentarios
CASE LEFT( tcLine, LEN(C_MENUCODE_F) ) == C_MENUCODE_F
EXIT
CASE LEFT( tcLine, LEN(C_MENUCODE_I) ) == C_MENUCODE_I
CASE LEFT( tcLine, 12 ) == 'DEFINE MENU '
loReg.OBJCODE = 22
loReg.PROCTYPE = 1
loReg.MARK = CHR(4)
loReg.SETUPTYPE = 1
loReg.CLEANTYPE = 1
loReg.ITEMNUM = STR(0,3)
lcMenuType = ALLTRIM( GETWORDNUM( tcLine, 3 ) )
*loReg.ObjType = IIF( UPPER(lcMenuType) = '_MSYSMENU', 1, 5 )
lcExpr = ALLTRIM( STREXTRACT( C_FB2PRG_CODE, 'ON SELECTION MENU _MSYSMENU ', CR_LF ) )
IF NOT EMPTY(lcExpr)
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, @C_FB2PRG_CODE, -1, .F. )
IF EMPTY(lcProcCode)
*-- Comando
loReg.PROCEDURE = lcExpr
ELSE
*-- Procedure
lcProcCode = STRTRAN( lcProcCode, '<<ProcName>>', lcProcName )
loReg.PROCEDURE = lcProcCode
ENDIF
ENDIF
loBarPop = CREATEOBJECT('CL_MENU_BARPOP')
loBarPop.c_ParentName = ''
loBarPop.n_ParentCode = .oReg.OBJCODE
loBarPop.n_ParentType = .oReg.ObjType
loBarPop.analizarBloque( @tcLine, @taCodeLines, @I, @tnCodeLines, toConversor )
.ADD( loBarPop )
EXIT
CASE LEFT( tcLine, 13 ) == 'DEFINE POPUP '
loReg.OBJCODE = 22
loReg.PROCTYPE = 1
loReg.MARK = CHR(4)
loReg.SETUPTYPE = 1
loReg.CLEANTYPE = 1
loReg.ITEMNUM = STR(0,3)
loReg.SCHEME = 0
lcExpr = ALLTRIM( STREXTRACT( C_FB2PRG_CODE, 'ON SELECTION POPUP ALL ', CR_LF ) )
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, @C_FB2PRG_CODE, -1, .F. )
IF EMPTY(lcProcCode)
*-- Comando
loReg.PROCEDURE = lcExpr
ELSE
*-- Procedure
lcProcCode = STRTRAN( lcProcCode, '<<ProcName>>', lcProcName )
loReg.PROCEDURE = lcProcCode
ENDIF
loBarPop = CREATEOBJECT('CL_MENU_BARPOP')
loBarPop.c_ParentName = ''
loBarPop.n_ParentCode = .oReg.OBJCODE
loBarPop.n_ParentType = .oReg.ObjType
loBarPop.analizarBloque( @tcLine, @taCodeLines, @I, @tnCodeLines, toConversor )
.ADD( loBarPop )
*-- Creo option
loOption = CREATEOBJECT("CL_MENU_OPTION")
loOption.oReg = toConversor.emptyRecord()
WITH loOption.oReg
.ObjType = 3
.OBJCODE = 77
.MARK = CHR(0)
.PROMPT = '\<Shortcut'
.LevelName = '_MSYSMENU'
loBarPop.ADD( loOption )
loBarPop.oReg.NUMITEMS = loBarPop.COUNT
.ITEMNUM = STR(loBarPop.COUNT,3)
.SCHEME = 0
loBarPop = NULL
ENDWITH
*-- Creo BarPop
loBarPop = CREATEOBJECT('CL_MENU_BARPOP')
loBarPop.c_ParentName = ''
loBarPop.n_ParentCode = loOption.oReg.OBJCODE
loBarPop.n_ParentType = loOption.oReg.ObjType
loBarPop.analizarBloque( @tcLine, @taCodeLines, @I, @tnCodeLines, toConversor )
loOption.ADD( loBarPop )
loBarPop = NULL
loOption = NULL
EXIT
OTHERWISE && Otro valor
I = I - 1
EXIT
ENDCASE
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
loBarPop = NULL
loReg = NULL
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE analizarBloque_PROCEDURE
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcText, lcComment, lcProcName, loEx AS EXCEPTION
STORE '' TO lcText, lcComment
IF LEFT(tcLine, LEN(C_PROC_CODE_I)) == C_PROC_CODE_I
llBloqueEncontrado = .T.
WITH THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE C_PROC_CODE_F $ tcLine && Fin
I = I + 1
EXIT
OTHERWISE && Líneas de procedure
*-- Las saltea
ENDCASE
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
*---------------------------------------------------------------------------------------------------
TRY
LOCAL lcText, loReg, loHeader, lnNivel, lcEndProcedures, lcExpr, lcProcName, lcProcCode, lcLocation ;
, loEx AS EXCEPTION ;
, loCol_LastLevelName AS COLLECTION ;
, loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG' ;
, loOption AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
STORE '' TO lcText, lcEndProcedures
WITH THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
loReg = .oReg
loHeader = loReg
loBarPop = .ITEM(1).oReg
lnNivel = 0
DO CASE
CASE loReg.Location = 0
lcLocation = 'REPLACE'
CASE loReg.Location = 1
lcLocation = 'APPEND'
CASE loReg.Location = 2
lcLocation = 'BEFORE ' + loReg.NAME
CASE loReg.Location = 3
lcLocation = 'AFTER ' + loReg.NAME
ENDCASE
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_MENUTYPE_I>><<loReg.ObjType>><<C_MENUTYPE_F>>
<<C_MENULOCATION_I>><<lcLocation>><<C_MENULOCATION_F>>
ENDTEXT
IF NOT EMPTY(loReg.SETUP)
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<C_SETUPCODE_I>>
<<loReg.Setup>>
<<C_SETUPCODE_F>>
ENDTEXT
ENDIF
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<C_MENUCODE_I>>
ENDTEXT
DO CASE
CASE loHeader.ObjType = 1 && Menu Bar (Sistema)
lcText = lcText + CR_LF + 'DEFINE MENU ' + loBarPop.NAME + ' BAR'
CASE loHeader.ObjType = 5 && Menu Bar (On top)
lcText = lcText + CR_LF + 'DEFINE MENU ' + loBarPop.NAME + ' BAR'
CASE loHeader.ObjType = 4 && Shortcut
lcText = lcText + CR_LF + 'DEFINE POPUP ' + .ITEM(1).ITEM(1).ITEM(1).oReg.NAME + ' SHORTCUT RELATIVE FROM MROW(),MCOL()'
ENDCASE
*-- Bars and Popups
IF .COUNT > 0
FOR EACH loBarPop IN THIS FOXOBJECT
lcText = lcText + loBarPop.toText(loReg, lnNivel+0, @lcEndProcedures, loHeader)
ENDFOR
ENDIF
loBarPop = .ITEM(1).oReg
DO CASE
CASE loHeader.ObjType = 1 OR loHeader.ObjType = 5
*-- Propecimiento principal de _MSYSMENU (ObjType:1, ObjCode:22)
IF NOT EMPTY(loHeader.PROCEDURE)
lcExpr = loHeader.PROCEDURE
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, '', 1, .T. )
IF EMPTY(lcProcCode)
*-- Comando
lcText = lcText + 'ON SELECTION MENU ' + loBarPop.NAME + ' ' + lcExpr + CR_LF
ELSE
*-- Procedure
lcProcName = EVL( lcProcName, CHRTRAN('SELECTION MENU ' + loBarPop.NAME, ' ', '_') + '_FB2P' )
lcText = lcText + 'ON SELECTION MENU ' + loBarPop.NAME + ' DO ' + lcProcName + CR_LF
lcProcCode = STRTRAN( lcProcCode, '<<ProcName>>', lcProcName )
lcEndProcedures = lcEndProcedures + lcProcCode + CR_LF
ENDIF
ENDIF
CASE loHeader.ObjType = 4
IF NOT EMPTY(loHeader.PROCEDURE)
lcExpr = loHeader.PROCEDURE
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, '', 1, .T. )
IF EMPTY(lcProcCode)
*-- Comando
lcText = lcText + 'ON SELECTION POPUP ALL ' + lcExpr + CR_LF
ELSE
*-- Procedure
lcText = lcText + 'ON SELECTION POPUP ALL ' + loBarPop.NAME + ' DO ' + lcProcName + CR_LF
lcProcCode = STRTRAN( lcProcCode, '<<ProcName>>', lcProcName )
lcEndProcedures = lcEndProcedures + lcProcCode + CR_LF
ENDIF
ENDIF
lcText = lcText + 'ACTIVATE POPUP ' + .ITEM(1).ITEM(1).ITEM(1).oReg.NAME + CR_LF
ENDCASE
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<C_MENUCODE_F>>
ENDTEXT
*-- Procedimientos finales
IF NOT EMPTY(lcEndProcedures)
lcText = lcText + CR_LF + CR_LF ;
+ C_PROC_CODE_I + CR_LF ;
+ lcEndProcedures ;
+ C_PROC_CODE_F + CR_LF
ENDIF
IF NOT EMPTY(loReg.Cleanup)
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<>>
<<C_CLEANUPCODE_I>>
<<loReg.Cleanup>>
<<C_CLEANUPCODE_F>>
ENDTEXT
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE get_DataFromTablabin
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
*---------------------------------------------------------------------------------------------------
LOCAL loReg, loCol_LastLevelName AS COLLECTION
GO TOP
SCATTER MEMO NAME loReg
loCol_LastLevelName = CREATEOBJECT('COLLECTION')
CL_MENU_COL_BASE::get_DataFromTablabin( loReg, loCol_LastLevelName )
STORE NULL TO loReg, loCol_LastLevelName
ENDPROC
PROCEDURE updateMENU
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
SELECT TABLABIN
WITH THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
IF .l_Debug
toConversor.writeLog( '' )
toConversor.writeLog( REPLICATE('-',80) )
ENDIF
.UpdateMenu_Recursivo( THIS, 0, @toConversor )
IF .l_Debug
toConversor.writeLog( REPLICATE('-',80) )
ENDIF
ENDWITH && THIS
ENDPROC
PROCEDURE UpdateMenu_Recursivo
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toObj (v! IN ) Referencia del objeto CL_MENU_BARPOP o CL_MENU_OPTION
* tnNivel (v! IN ) Nivel de indentación (solo para debug)
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS toObj AS COLLECTION, tnNivel, toConversor
LOCAL loReg, loEx AS EXCEPTION
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
WITH THIS AS CL_MENU OF 'FOXBIN2PRG.PRG'
IF VARTYPE( toObj.oReg ) = 'O'
loReg = toObj.oReg
INSERT INTO TABLABIN FROM NAME loReg
IF .l_Debug
toConversor.writeLog( REPLICATE(C_TAB,tnNivel) ;
+ 'ObjType=' + TRANSFORM(loReg.ObjType) ;
+ ', ObjCode=' + TRANSFORM(loReg.OBJCODE) ;
+ ', Name=' + TRANSFORM(loReg.NAME) ;
+ ', LevelName=' + TRANSFORM(loReg.LevelName) ;
+ ', ItemNum=' + TRANSFORM(loReg.ITEMNUM) ;
+ ', Location=' + TRANSFORM(loReg.Location) ;
+ ', Prompt=' + TRANSFORM(loReg.PROMPT) ;
+ ', Message=' + TRANSFORM(loReg.MESSAGE) ;
+ ', KeyName=' + TRANSFORM(loReg.KEYNAME) ;
+ ', KeyLabel=' + TRANSFORM(loReg.KeyLabel) ;
+ ', Comment=' + TRANSFORM(loReg.COMMENT) ;
+ ', SkipFor=' + TRANSFORM(loReg.SKIPFOR) )
ENDIF
ELSE
IF .l_Debug
*toConversor.writeLog( REPLICATE(C_TAB,tnNivel) ;
+ 'Objeto [' + toObj.CLASS + '] no contiene el objeto oReg (nivel ' + TRANSFORM(tnNivel) + ')' )
toConversor.writeLog( REPLICATE(C_TAB,tnNivel) + TEXTMERGE(C_OBJECT_NAME_WITHOUT_OBJECT_OREG_LOC) )
ENDIF
ENDIF
IF toObj.COUNT > 0 THEN
FOR EACH loReg IN toObj FOXOBJECT
.UpdateMenu_Recursivo( loReg, tnNivel + 1, @toConversor )
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
ENDPROC
ENDDEFINE
*******************************************************************************************************************
DEFINE CLASS CL_MENU_BARPOP AS CL_MENU_COL_BASE
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="analizarbloque_definepopup" display="analizarBloque_DefinePOPUP"/>] ;
+ [<memberdata name="updatemenu" display="updateMENU"/>] ;
+ [<memberdata name="c_parentname" display="c_ParentName"/>] ;
+ [<memberdata name="n_parentcode" display="n_ParentCode"/>] ;
+ [<memberdata name="n_parenttype" display="n_ParentType"/>] ;
+ [</VFPData>]
#IF .F.
LOCAL THIS AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
#ENDIF
c_ParentName = ''
n_ParentCode = 0
n_ParentType = 0
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL loOption AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcSubName, lcComment, lnLast_I, loReg, lcExpr, lcProcName, lcProcCode, lcMenuType ;
, loEx AS EXCEPTION
STORE '' TO lcSubName, lcComment, lcExpr, lcProcName, lcProcCode
WITH THIS AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
.oReg = toConversor.emptyRecord()
loReg = .oReg
loReg.ObjType = 2
loReg.PROCTYPE = 1
loReg.MARK = CHR(0)
loReg.ITEMNUM = STR(0,3)
llBloqueEncontrado = .T.
FOR I = I + 0 TO tnCodeLines
STORE '' TO lcExpr, lcProcName, lcProcCode
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE toConversor.lineIsOnlyCommentAndNoMetadata( @tcLine, @lcComment )
LOOP && Saltear comentarios
CASE LEFT( tcLine, LEN(C_MENUCODE_F) ) == C_MENUCODE_F
EXIT
CASE LEFT( tcLine, LEN('ON SELECTION POPUP ' + loReg.NAME) ) == 'ON SELECTION POPUP ' + loReg.NAME
EXIT
CASE LEFT( tcLine, 12 ) == 'DEFINE MENU '
loReg.OBJCODE = 1
loReg.NAME = STREXTRACT( tcLine, 'DEFINE MENU ', ' BAR' )
*loReg.NAME = '_MSYSMENU'
loReg.LevelName = loReg.NAME
loReg.SCHEME = IIF( loReg.OBJCODE = 1, 3, 4 )
lcExpr = STREXTRACT( C_FB2PRG_CODE, 'ON SELECTION POPUP ALL ', CR_LF )
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, @C_FB2PRG_CODE, -1 )
loReg.PROCEDURE = EVL(lcProcCode, lcExpr)
CASE LEFT( tcLine, 13 ) == 'DEFINE POPUP '
IF .n_ParentCode = 22
loReg.OBJCODE = 1
loReg.NAME = '_MSYSMENU'
loReg.LevelName = loReg.NAME
loReg.SCHEME = 3
IF .n_ParentType = 4
EXIT
ENDIF
ELSE
loReg.OBJCODE = 0
loReg.SCHEME = 4
loReg.NAME = ALLTRIM( GETWORDNUM( tcLine, 3 ) )
IF RIGHT(loReg.NAME,5) == '_FB2P' && Originalmente era vacío y se la había puesto un nombre temporal.
loReg.NAME = ''
ENDIF
loReg.LevelName = loReg.NAME
lcExpr = ALLTRIM( STREXTRACT( C_FB2PRG_CODE, 'ON SELECTION POPUP ' + loReg.NAME + ' ', CR_LF ) )
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, @C_FB2PRG_CODE, -1 )
loReg.PROCEDURE = EVL(lcProcCode, lcExpr)
ENDIF
CASE LEFT( tcLine, 11 ) == 'DEFINE PAD ' OR LEFT( tcLine, 11 ) == 'DEFINE BAR '
loOption = CREATEOBJECT("CL_MENU_OPTION")
lnLast_I = I
loOption.c_ParentName = loReg.LevelName
loOption.n_ParentCode = loReg.OBJCODE
loOption.n_ParentType = loReg.ObjType
IF NOT loOption.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines, toConversor )
I = lnLast_I
llBloqueEncontrado = .F.
EXIT
ENDIF
.ADD( loOption )
loOption.oReg.ITEMNUM = STR(.COUNT,3)
loReg.NUMITEMS = .COUNT
loReg.SCHEME = IIF( loReg.OBJCODE = 1, 3, 4 )
loOption = NULL
OTHERWISE && Otro valor
I = I - 1
EXIT
ENDCASE
ENDFOR
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
loOption = NULL
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toParentReg (v! IN ) Objeto registro Padre
* tnNivel (v! IN ) Nivel para indentar
* tcEndProcedures (@! OUT) Agregar aquí los procedimientos que irán al final
* toHeader (v! IN ) Objeto Registro de cabecera del menu
*---------------------------------------------------------------------------------------------------
LPARAMETERS toParentReg, tnNivel, tcEndProcedures, toHeader
TRY
LOCAL loReg, I, lcText, lcTab, lcExpr, lcProcName, lcProcCode, loEx AS EXCEPTION ;
, loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG' ;
, loOption AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
STORE '' TO lcText, lcExpr, lcProcName, lcProcCode
loReg = THIS.oReg
lcTab = REPLICATE(CHR(9),tnNivel)
*-- Menu Bar or Popup (ObjType:2, ObjCode:0 ó 1)
IF loReg.OBJCODE = 0 && (Menu Pad)
IF toHeader.ObjType = 4
*-- Shortcut
IF NOT PEMSTATUS(toHeader,'_MenuInicializado', 5) && Header
ADDPROPERTY(toHeader,'_MenuInicializado', .T.)
ELSE && Rest
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<lcTab>>*----------------------------------
<<lcTab>>DEFINE POPUP <<loReg.Name>> SHORTCUT RELATIVE
ENDTEXT
ENDIF
ELSE && ObjType = 1 ó 5
*-- Menu
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<lcTab>>*----------------------------------
<<lcTab>>DEFINE POPUP <<loReg.Name>> MARGIN RELATIVE SHADOW COLOR SCHEME <<loReg.Scheme>>
ENDTEXT
ENDIF
ENDIF
*-- Options (ObjType:3)
IF THIS.COUNT > 0
FOR EACH loOption IN THIS FOXOBJECT
lcText = lcText + loOption.toText(loReg, tnNivel+0, @tcEndProcedures, toHeader)
ENDFOR
ENDIF
*-- Procedure del POPUP o MENU
IF NOT EMPTY(loReg.PROCEDURE)
lcExpr = loReg.PROCEDURE
THIS.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, '', 1, .T. )
IF EMPTY(lcProcName)
lcText = lcText + lcTab + 'ON SELECTION POPUP ' + IIF( loReg.OBJCODE = 0, loReg.NAME, 'ALL' ) + ' ' + lcExpr + CR_LF
ELSE
lcText = lcText + lcTab + 'ON SELECTION POPUP ' + IIF( loReg.OBJCODE = 0, loReg.NAME, 'ALL' ) + ' DO ' + lcProcName + CR_LF
tcEndProcedures = tcEndProcedures + STRTRAN( lcProcCode, '<<ProcName>>', lcProcName ) + CR_LF
ENDIF
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE updateMENU
ENDPROC
ENDDEFINE
DEFINE CLASS CL_MENU_OPTION AS CL_MENU_COL_BASE
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="analizarbloque_definebar" display="analizarBloque_DefineBAR"/>] ;
+ [<memberdata name="analizarbloque_definepad" display="analizarBloque_DefinePAD"/>] ;
+ [<memberdata name="get_definebartext" display="get_DefineBarText"/>] ;
+ [<memberdata name="get_definepadtext" display="get_DefinePadText"/>] ;
+ [<memberdata name="get_procnamefromsnippet" display="get_ProcNameFromSnippet"/>] ;
+ [<memberdata name="c_parentname" display="c_ParentName"/>] ;
+ [<memberdata name="n_parentcode" display="n_ParentCode"/>] ;
+ [<memberdata name="n_parenttype" display="n_ParentType"/>] ;
+ [</VFPData>]
#IF .F.
LOCAL THIS AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
#ENDIF
c_ParentName = ''
n_ParentCode = 0
n_ParentType = 0
PROCEDURE analizarBloque
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
LOCAL llBloqueEncontrado, lcComment, loReg, lnLast_I, loEx AS EXCEPTION ;
, llPadOBar_Analizado
STORE '' TO lcComment
WITH THIS AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
.oReg = toConversor.emptyRecord()
loReg = .oReg
loReg.MARK = CHR(0)
loReg.ITEMNUM = STR(0,3)
llBloqueEncontrado = .T.
FOR I = I + 0 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE toConversor.lineIsOnlyCommentAndNoMetadata( @tcLine, @lcComment )
LOOP && Saltear comentarios
CASE LEFT( tcLine, LEN(C_MENUCODE_F) ) == C_MENUCODE_F
EXIT
CASE LEFT( tcLine, LEN(C_MENUCODE_I) ) == C_MENUCODE_I
loReg.ObjType = 2
loReg.OBJCODE = 1
CASE .analizarBloque_DefinePAD( @tcLine, @taCodeLines, @I, tnCodeLines, toConversor )
IF EMPTY(loReg.PROMPT)
*-- Esta opción no corresponde a este nivel. Debe subir.
llBloqueEncontrado = .F.
EXIT
ENDIF
IF loReg.OBJCODE <> 77
EXIT
ENDIF
CASE .analizarBloque_DefineBAR( @tcLine, @taCodeLines, @I, tnCodeLines, toConversor )
IF EMPTY(loReg.PROMPT)
*-- Esta opción no corresponde a este nivel. Debe subir.
llBloqueEncontrado = .F.
EXIT
ENDIF
IF loReg.OBJCODE <> 77
EXIT
ENDIF
CASE LEFT( tcLine, 13 ) == 'DEFINE POPUP '
loBarPop = CREATEOBJECT("CL_MENU_BARPOP")
lnLast_I = I
loBarPop.c_ParentName = loReg.LevelName
loBarPop.n_ParentCode = loReg.OBJCODE
loBarPop.n_ParentType = loReg.ObjType
.ADD( loBarPop )
IF NOT loBarPop.analizarBloque( @tcLine, @taCodeLines, @I, tnCodeLines, toConversor )
I = I - 1
ENDIF
loBarPop = NULL
EXIT
OTHERWISE && Otro valor
I = I - 1
EXIT
ENDCASE
ENDFOR
ENDWITH && THIS
CATCH TO loEx WHEN loEx.MESSAGE = 'Nivel_Anterior'
*-- OK. Volver a evaluar en el nivel anterior
llBloqueEncontrado = .F.
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
loBarPop = NULL
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE analizarBloque_DefinePAD
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcText, loReg, lnPos, lcPadName, lcExpr, lcComment, lcProcName, lcProcCode, loEx AS EXCEPTION ;
, lnNegContainer, lnNegObject
STORE '' TO lcText, lcComment, lcPadName
* Estructura ejemplo a analizar:
*--------------------------------
* DEFINE PAD _3YM1DR90Z OF _MSYSMENU PROMPT "Opción A con submenú" COLOR SCHEME 3 ;
* NEGOTIATE NONE, LEFT ;
* KEY DEL, "Pulsar <DEL>" ;
* SKIP FOR SKIP_FOR() ;
* MESSAGE "Mensaje para Opción A con submenú" && Comentario
*
* ON PAD _3YM1DR90Z OF _MSYSMENU ACTIVATE POPUP OpciónA_CS
*--------------------------------
IF LEFT( tcLine, 11 ) == 'DEFINE PAD '
llBloqueEncontrado = .T.
WITH THIS AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
loReg = .oReg
loReg.ObjType = 3
lcPadName = ALLTRIM( STREXTRACT( tcLine, 'PAD ' , ' OF' ) )
loReg.NAME = lcPadName
loReg.LevelName = ALLTRIM( STREXTRACT( tcLine, ' OF ', ' PROMPT ' ) )
IF UPPER(loReg.LevelName) # UPPER(.c_ParentName)
EXIT
ENDIF
loReg.PROMPT = CHRTRAN( ALLTRIM( STREXTRACT( tcLine, ' PROMPT ', ' COLOR ' ) ), '"', '' )
*-- ANALISIS DEL "DEFINE PAD"
IF ';' $ tcLine
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
IF EMPTY(loReg.COMMENT) && No volver a buscar el comentario si ya existe
lnPos = AT( '&'+'&', tcLine )
IF lnPos > 0
*-- Busco si tiene comentario
loReg.COMMENT = SUBSTR( tcLine, lnPos + 3 )
tcLine = LEFT( tcLine, lnPos - 1 )
lnPos = 0
ENDIF
ENDIF
DO CASE
CASE LEFT( tcLine, 10 ) == 'NEGOTIATE '
lcExpr = ALLTRIM( STREXTRACT( tcLine, 'NEGOTIATE ', ';', 1, 2 ) )
lnNegContainer = INT( AT( ',' + PADR( ALLTRIM(GETWORDNUM( lcExpr, 1, ',' )), 6, '_' ) ;
, '______,NONE__,LEFT__,MIDDLE,RIGHT_' ) / 7 - 1 )
lnNegObject = INT( AT( ',' + PADR( ALLTRIM(GETWORDNUM( lcExpr, 2, ',' )), 6, '_' ) ;
, '______,NONE__,LEFT__,MIDDLE,RIGHT_' ) / 7 - 1 )
loReg.Location = lnNegContainer + lnNegObject * 2^4
CASE LEFT( tcLine, 4 ) == 'KEY '
lcExpr = ALLTRIM( STREXTRACT( tcLine, 'KEY ', ';', 1, 2 ) )
lnPos = AT( ',', lcExpr )
loReg.KEYNAME = ALLTRIM( LEFT( lcExpr, lnPos-1 ) )
loReg.KeyLabel = ALLTRIM( STREXTRACT( lcExpr, '"', '"' ) )
CASE LEFT( tcLine, 9 ) == 'SKIP FOR '
loReg.SKIPFOR = ALLTRIM( STREXTRACT( tcLine, 'SKIP FOR ', ';', 1, 2 ) )
CASE LEFT( tcLine, 8 ) == 'MESSAGE '
loReg.MESSAGE = ALLTRIM( STREXTRACT( tcLine, '"', '"', 1, 4 ) )
CASE LEFT( tcLine, 8 ) == 'PICTURE '
loReg.RESNAME = ALLTRIM( STREXTRACT( tcLine, '"', '"' ) )
CASE LEFT( tcLine, 8 ) == 'PICTRES '
loReg.RESNAME = ALLTRIM( STREXTRACT( tcLine, 'PICTRES ', ';', 1, 2 ) )
loReg.SYSRES = 1
OTHERWISE
* Nada
ENDCASE
IF NOT ';' $ tcLine && Fin
EXIT
ENDIF
ENDFOR
ENDIF && ';' $ tcLine
* Estructuras ejemplo a analizar:
*--------------------------------
* ON PAD _3YM1DR90Z OF _MSYSMENU ACTIVATE POPUP OpciónA_CS
* ON PAD _3YM1DR90Z OF _MSYSMENU wait window "algo"
* ON PAD _3YM1DR90Z OF _MSYSMENU DO Menu1_Opción_A_2_Sub_SNIPPET
*--------------------------------
*-- ANALISIS DEL "ON PAD" u "ON SELECTION PAD"
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE LEFT( tcLine, 7 ) == 'ON PAD '
loReg.OBJCODE = 77 && Submenu
I = I + 1
EXIT
CASE LEFT( tcLine, 17 ) == 'ON SELECTION PAD '
lcExpr = ALLTRIM( STREXTRACT( tcLine, ' OF ' + loReg.LevelName + ' ', '', 1, 2 ) )
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, @C_FB2PRG_CODE, -1, .F. )
DO CASE
CASE EMPTY(lcProcCode)
loReg.OBJCODE = 67
loReg.COMMAND = lcExpr
OTHERWISE
loReg.PROCEDURE = STRTRAN( lcProcCode, '<<ProcName>>', lcProcName )
IF EMPTY( loReg.PROCEDURE )
loReg.OBJCODE = 67
loReg.COMMAND = lcExpr
ELSE
loReg.OBJCODE = 80
loReg.PROCTYPE = 1
ENDIF
ENDCASE
I = I + 1
EXIT
OTHERWISE
* Nada
ENDCASE
IF NOT ';' $ tcLine && Fin
I = I + 1
EXIT
ENDIF
ENDFOR
I = I - 1
ENDWITH && THIS
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE analizarBloque_DefineBAR
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tcLine (@! IN/OUT) Contenido de la línea en análisis
* taCodeLines (@! IN ) Array de líneas del programa analizado
* I (@! IN/OUT) Número de línea en análisis
* tnCodeLines (@! IN ) Cantidad de líneas del programa analizado
* toConversor (v! IN ) Referencia al conversor para poder usar sus métodos
*---------------------------------------------------------------------------------------------------
LPARAMETERS tcLine, taCodeLines, I, tnCodeLines, toConversor
#IF .F.
LOCAL toConversor AS c_conversor_prg_a_mnx OF 'FOXBIN2PRG.PRG'
#ENDIF
TRY
LOCAL llBloqueEncontrado, lcText, loReg, lnPos, lcBarName, lcExpr, lcComment, lcProcName, lcProcCode, loEx AS EXCEPTION ;
, lnNegContainer, lnNegObject
STORE '' TO lcText, lcComment, lcBarName
* Estructura ejemplo a analizar:
*--------------------------------
* DEFINE BAR _3YM1DR90Z OF _MSYSMENU PROMPT "Opción A con submenú" COLOR SCHEME 3 ;
* NEGOTIATE NONE, LEFT ;
* KEY DEL, "Pulsar <DEL>" ;
* SKIP FOR SKIP_FOR() ;
* MESSAGE "Mensaje para Opción A con submenú" && Comentario
*
* ON BAR _3YM1DR90Z OF _MSYSMENU ACTIVATE POPUP OpciónA_CS
*
* DEFINE BAR 1 OF _MSYSMENU PROMPT "Opción A con submenú" ;
* NEGOTIATE NONE, LEFT ;
* KEY DEL, "Pulsar <DEL>" ;
* SKIP FOR SKIP_FOR() ;
* MESSAGE "Mensaje para Opción A con submenú" && Comentario
*
* ON BAR 1 OF _MSYSMENU ACTIVATE POPUP OpciónA_CS
*--------------------------------
IF LEFT( tcLine, 11 ) == 'DEFINE BAR '
llBloqueEncontrado = .T.
WITH THIS AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
loReg = .oReg
loReg.ObjType = 3
lcBarName = ALLTRIM( STREXTRACT( tcLine, 'BAR ' , ' OF' ) )
IF NOT ISDIGIT(lcBarName)
*-- Es un BAR del sistema
loReg.NAME = lcBarName
ENDIF
loReg.LevelName = ALLTRIM( STREXTRACT( tcLine, ' OF ', ' PROMPT ' ) )
IF UPPER(loReg.LevelName) # UPPER(.c_ParentName)
EXIT
ENDIF
loReg.PROMPT = CHRTRAN( ALLTRIM( STREXTRACT( tcLine, ' PROMPT ', ';', 1, 2 ) ), '"', '' )
*-- ANALISIS DEL "DEFINE BAR"
IF ';' $ tcLine
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
IF EMPTY(loReg.COMMENT) && No volver a buscar el comentario si ya existe
lnPos = AT( '&'+'&', tcLine )
IF lnPos > 0
*-- Busco si tiene comentario
loReg.COMMENT = SUBSTR( tcLine, lnPos + 3 )
tcLine = LEFT( tcLine, lnPos - 1 )
lnPos = 0
ENDIF
ENDIF
DO CASE
CASE LEFT( tcLine, 10 ) == 'NEGOTIATE '
lcExpr = ALLTRIM( STREXTRACT( tcLine, 'NEGOTIATE ', ';', 1, 2 ) )
lnNegContainer = INT( AT( ',' + PADR( ALLTRIM(GETWORDNUM( lcExpr, 1, ',' )), 6, '_' ) ;
, '______,NONE__,LEFT__,MIDDLE,RIGHT_' ) / 7 - 1 )
lnNegObject = INT( AT( ',' + PADR( ALLTRIM(GETWORDNUM( lcExpr, 2, ',' )), 6, '_' ) ;
, '______,NONE__,LEFT__,MIDDLE,RIGHT_' ) / 7 - 1 )
loReg.Location = lnNegContainer + lnNegObject * 2^4
CASE LEFT( tcLine, 4 ) == 'KEY '
lcExpr = ALLTRIM( STREXTRACT( tcLine, 'KEY ', ';', 1, 2 ) )
lnPos = AT( ',', lcExpr )
loReg.KEYNAME = ALLTRIM( LEFT( lcExpr, lnPos-1 ) )
loReg.KeyLabel = ALLTRIM( STREXTRACT( lcExpr, '"', '"' ) )
CASE LEFT( tcLine, 9 ) == 'SKIP FOR '
loReg.SKIPFOR = ALLTRIM( STREXTRACT( tcLine, 'SKIP FOR ', ';', 1, 2 ) )
CASE LEFT( tcLine, 8 ) == 'MESSAGE '
loReg.MESSAGE = ALLTRIM( STREXTRACT( tcLine, '"', '"', 1, 4 ) )
CASE LEFT( tcLine, 8 ) == 'PICTURE '
loReg.RESNAME = ALLTRIM( STREXTRACT( tcLine, '"', '"' ) )
CASE LEFT( tcLine, 8 ) == 'PICTRES '
loReg.RESNAME = ALLTRIM( STREXTRACT( tcLine, 'PICTRES ', ';', 1, 2 ) )
loReg.SYSRES = 1
OTHERWISE
* Nada
ENDCASE
IF NOT ';' $ tcLine && Fin
EXIT
ENDIF
ENDFOR
ENDIF && ';' $ tcLine
IF LEFT(lcBarName,1) == '_'
*-- Es un BAR del Sistema, así que no tiene ON BAR ni nada más.
loReg.OBJCODE = 78 && Bar#
I = I + 1
EXIT
ENDIF
* Estructuras ejemplo a analizar:
*--------------------------------
* ON BAR _3YM1DR90Z OF _MSYSMENU ACTIVATE POPUP OpciónA_CS
* ON BAR _3YM1DR90Z OF _MSYSMENU wait window "algo"
* ON BAR _3YM1DR90Z OF _MSYSMENU DO Menu1_Opción_A_2_Sub_SNIPPET
*--------------------------------
*-- ANALISIS DEL "ON BAR" u "ON SELECTION BAR"
FOR I = I + 1 TO tnCodeLines
.set_Line( @tcLine, @taCodeLines, I )
DO CASE
CASE EMPTY( tcLine )
LOOP
CASE LEFT( tcLine, 7 ) == 'ON BAR '
loReg.OBJCODE = 77 && Submenu
I = I + 1
EXIT
CASE LEFT( tcLine, 17 ) == 'ON SELECTION BAR '
lcExpr = ALLTRIM( STREXTRACT( tcLine, ' OF ' + loReg.LevelName + ' ', '', 1, 2 ) )
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, @C_FB2PRG_CODE, -1, .F. )
DO CASE
CASE NOT EMPTY(lcProcCode)
loReg.PROCEDURE = STRTRAN( lcProcCode, '<<ProcName>>', lcProcName )
IF EMPTY( loReg.PROCEDURE )
loReg.OBJCODE = 67
loReg.COMMAND = lcExpr
ELSE
loReg.OBJCODE = 80
loReg.PROCTYPE = 1
ENDIF
OTHERWISE
loReg.OBJCODE = 67 && Command
loReg.COMMAND = lcExpr
ENDCASE
I = I + 1
EXIT
OTHERWISE
* Nada
ENDCASE
IF NOT ';' $ tcLine && Fin
I = I + 1
EXIT
ENDIF
ENDFOR
ENDWITH && THIS
I = I - 1
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN llBloqueEncontrado
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toParentReg (v? IN ) Objeto registro Padre
* tnNivel (v? IN ) Nivel para indentar
* tcEndProcedures (@! OUT) Agregar aquí los procedimientos que irán al final
* toHeader (v! IN ) Objeto Registro de cabecera del menu
*---------------------------------------------------------------------------------------------------
LPARAMETERS toParentReg, tnNivel, tcEndProcedures, toHeader
TRY
LOCAL loReg, I, lcText, lcTab, lcExpr, lcProcName, lcProcCode, loEx AS EXCEPTION ;
, loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG' ;
, loOption AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
lcText = ''
lcProcName = ''
WITH THIS AS CL_MENU_OPTION OF 'FOXBIN2PRG.PRG'
loReg = .oReg
lcTab = REPLICATE(CHR(9),tnNivel)
loBarPop = toParentReg
*-- Options (ObjType:3)
DO CASE
CASE toParentReg.ObjType = 2 AND toParentReg.OBJCODE = 0
*-- Define Bar
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<.get_DefineBarText(loReg, loBarPop, tnNivel, toHeader)>>
ENDTEXT
CASE toParentReg.ObjType = 2 AND toParentReg.OBJCODE = 1 AND (toHeader.ObjType = 1 OR toHeader.ObjType = 5)
*-- Define Pad
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
<<.get_DefinePadText(loReg, loBarPop, tnNivel, toHeader)>>
ENDTEXT
ENDCASE
IF loReg.OBJCODE = 80 && Procedure de BAR o PAD
*-- Reemplazo el nombre definitivo
lcExpr = loReg.PROCEDURE
.AnalizarSiExpresionEsComandoOProcedimiento( lcExpr, @lcProcName, @lcProcCode, '', 1, .T. )
IF EMPTY(lcProcName)
lcProcName = CHRTRAN( ALLTRIM( STREXTRACT( lcText, 'DEFINE ', 'PROMPT ' ) ), ' ', '_' ) + '_FB2P'
ENDIF
lcText = STRTRAN( lcText, '<<ProcName>>', lcProcName )
tcEndProcedures = tcEndProcedures + STRTRAN( lcProcCode, '<<ProcName>>', lcProcName ) + CR_LF
ENDIF
*-- Menu Bar or Popup (ObjType:2, ObjCode:0 ó 1)
IF .COUNT > 0
FOR EACH loBarPop IN THIS FOXOBJECT
IF toParentReg.ObjType = 2 AND toParentReg.OBJCODE = 1 AND toHeader.ObjType = 4
*-- Shortcut
lcText = lcText + loBarPop.toText(loReg, tnNivel + 0, @tcEndProcedures, toHeader)
ELSE
*-- Menu
lcText = lcText + loBarPop.toText(loReg, tnNivel + 1, @tcEndProcedures, toHeader)
ENDIF
ENDFOR
ENDIF
ENDWITH && THIS
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE get_DefineBarText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toReg (v? IN ) Objeto registro
* toBarPop (v? IN ) Bar o Popup hijo
* tnNivel (v? IN ) Nivel para indentar
* toHeader (v! IN ) Objeto Registro de cabecera del menu
*---------------------------------------------------------------------------------------------------
LPARAMETERS toReg, toBarPop, tnNivel, toHeader
TRY
LOCAL lcText, lcTab, loEx AS EXCEPTION ;
, loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
lcTab = REPLICATE(CHR(9),tnNivel)
lcText = ''
*-- DEFINE BAR
*lcText = lcTab + '*----------------------------------' + CR_LF
lcText = lcText + lcTab + 'DEFINE BAR ' + ALLTRIM( EVL( toReg.NAME, toReg.ITEMNUM ) ) + ' OF ' + ALLTRIM(toReg.LevelName) ;
+ ' PROMPT "' + toReg.PROMPT + '"'
IF NOT EMPTY(toReg.KEYNAME)
lcText = lcText + ' ;' + CR_LF + lcTab + ' KEY ' + toReg.KEYNAME + ', "' + toReg.KeyLabel + '"'
ENDIF
IF NOT EMPTY(toReg.SKIPFOR)
lcText = lcText + ' ;' + CR_LF + lcTab + ' SKIP FOR ' + toReg.SKIPFOR
ENDIF
IF NOT EMPTY(toReg.RESNAME)
IF toReg.SYSRES = 1
lcText = lcText + ' ;' + CR_LF + lcTab + ' PICTRES ' + toReg.RESNAME
ELSE
lcText = lcText + ' ;' + CR_LF + lcTab + ' PICTURE "' + toReg.RESNAME + '"'
ENDIF
ENDIF
IF NOT EMPTY(toReg.MESSAGE)
lcText = lcText + ' ;' + CR_LF + lcTab + ' MESSAGE ' + toReg.MESSAGE
ENDIF
IF NOT EMPTY(toReg.COMMENT)
lcText = lcText + ' &' + '& ' + toReg.COMMENT
ENDIF
*-- ON BAR
IF toReg.OBJCODE <> 78 && Bar#
lcText = lcText + CR_LF
IF toReg.OBJCODE = 77 && Submenu
loBarPop = THIS.ITEM(1).oReg
lcText = lcText + lcTab + 'ON BAR ' + ALLTRIM( EVL( toReg.NAME, toReg.ITEMNUM ) ) + ' OF ' + ALLTRIM(toReg.LevelName) ;
+ ' ACTIVATE POPUP ' + ALLTRIM(loBarPop.NAME)
ELSE
lcText = lcText + lcTab + 'ON SELECTION BAR ' + ALLTRIM( EVL( toReg.NAME, toReg.ITEMNUM ) ) + ' OF ' + ALLTRIM(toReg.LevelName)
DO CASE
CASE toReg.OBJCODE = 67 && Command
IF NOT EMPTY(toReg.COMMAND)
lcText = lcText + ' ' + ALLTRIM(toReg.COMMAND)
ENDIF
CASE toReg.OBJCODE = 80 && Procedure
IF NOT EMPTY(toReg.PROCEDURE)
lcText = lcText + ' DO <<ProcName>>'
ENDIF
ENDCASE
ENDIF
ENDIF
lcText = lcText + CR_LF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE get_DefinePadText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* toReg (v? IN ) Objeto registro
* toBarPop (v? IN ) Bar o Popup hijo
* tnNivel (v? IN ) Nivel para indentar
* toHeader (v! IN ) Objeto Registro de cabecera del menu
*---------------------------------------------------------------------------------------------------
LPARAMETERS toReg, toBarPop, tnNivel, toHeader
TRY
LOCAL lcText, lcTab, lnContainer, lnObject, loEx AS EXCEPTION ;
, loBarPop AS CL_MENU_BARPOP OF 'FOXBIN2PRG.PRG'
lcTab = REPLICATE(CHR(9),tnNivel)
toReg.NAME = EVL(toReg.NAME,SYS(2015))
lcText = ''
*-- DEFINE PAD
*lcText = lcTab + '*----------------------------------' + CR_LF
lcText = lcText + lcTab + 'DEFINE PAD ' + ALLTRIM(toReg.NAME) + ' OF ' + ALLTRIM(toReg.LevelName) ;
+ ' PROMPT "' + toReg.PROMPT + '"' ;
+ ' COLOR SCHEME ' + TRANSFORM(toBarPop.SCHEME)
IF NOT EMPTY(toReg.Location)
lnContainer = toReg.Location % 2^4
lnObject = INT( (toReg.Location - lnContainer) / 2^4 )
lcText = lcText + ' ;' + CR_LF + lcTab + ' NEGOTIATE ' + GETWORDNUM('NONE,LEFT,MIDDLE,RIGHT',lnContainer+1,',') ;
+ ', ' + GETWORDNUM('NONE,LEFT,MIDDLE,RIGHT',lnObject+1,',')
ENDIF
IF NOT EMPTY(toReg.KEYNAME)
lcText = lcText + ' ;' + CR_LF + lcTab + ' KEY ' + toReg.KEYNAME + ', "' + toReg.KeyLabel + '"'
ENDIF
IF NOT EMPTY(toReg.SKIPFOR)
lcText = lcText + ' ;' + CR_LF + lcTab + ' SKIP FOR ' + toReg.SKIPFOR
ENDIF
IF NOT EMPTY(toReg.RESNAME)
IF toReg.SYSRES = 1
lcText = lcText + ' ;' + CR_LF + lcTab + ' PICTRES ' + toReg.RESNAME
ELSE
lcText = lcText + ' ;' + CR_LF + lcTab + ' PICTURE "' + toReg.RESNAME + '"'
ENDIF
ENDIF
IF NOT EMPTY(toReg.MESSAGE)
lcText = lcText + ' ;' + CR_LF + lcTab + ' MESSAGE ' + toReg.MESSAGE
ENDIF
IF NOT EMPTY(toReg.COMMENT)
lcText = lcText + ' &' + '& ' + toReg.COMMENT
ENDIF
lcText = lcText + CR_LF
*-- ON PAD
IF toReg.OBJCODE <> 78 && Bar#
lcText = lcText + CR_LF
IF toReg.OBJCODE = 77 && Submenu
loBarPop = THIS.ITEM(1).oReg
lcText = lcText + lcTab + 'ON PAD ' + ALLTRIM(toReg.NAME) + ' OF ' + ALLTRIM(toReg.LevelName) ;
+ ' ACTIVATE POPUP ' + ALLTRIM(loBarPop.NAME)
ELSE
lcText = lcText + lcTab + 'ON SELECTION PAD ' + ALLTRIM(toReg.NAME) + ' OF ' + ALLTRIM(toReg.LevelName)
DO CASE
CASE toReg.OBJCODE = 67 && Command
IF NOT EMPTY(toReg.COMMAND)
lcText = lcText + ' ' + ALLTRIM(toReg.COMMAND)
ENDIF
CASE toReg.OBJCODE = 80 && Procedure
IF NOT EMPTY(toReg.PROCEDURE)
lcText = lcText + ' DO <<ProcName>>'
ENDIF
ENDCASE
ENDIF
ENDIF
lcText = lcText + CR_LF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
ENDTRY
RETURN lcText
ENDPROC
PROCEDURE updateMENU
ENDPROC
ENDDEFINE
DEFINE CLASS CL_DBF_UTILS AS SESSION
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="fields" display="Fields"/>] ;
+ [<memberdata name="c_backlink_dbc_name" display="c_Backlink_DBC_Name"/>] ;
+ [<memberdata name="c_filename" display="c_FileName"/>] ;
+ [<memberdata name="n_headersize" display="n_HeaderSize"/>] ;
+ [<memberdata name="n_filesize" display="n_FileSize"/>] ;
+ [<memberdata name="c_lastupdate" display="c_LastUpdate"/>] ;
+ [<memberdata name="l_debug" display="l_Debug"/>] ;
+ [<memberdata name="l_filehascdx" display="l_FileHasCDX"/>] ;
+ [<memberdata name="l_fileisdbc" display="l_FileIsDBC"/>] ;
+ [<memberdata name="l_filehasmemo" display="l_FileHasMemo"/>] ;
+ [<memberdata name="n_codepage" display="n_CodePage"/>] ;
+ [<memberdata name="c_codepagedesc" display="c_CodePageDesc"/>] ;
+ [<memberdata name="n_datarecordlength" display="n_DataRecordLength"/>] ;
+ [<memberdata name="n_fieldcount" display="n_FieldCount"/>] ;
+ [<memberdata name="n_hexfiletype" display="n_HexFileType"/>] ;
+ [<memberdata name="n_numberofrecords" display="n_NumberOfRecords"/>] ;
+ [<memberdata name="n_numberofrecordsreal" display="n_NumberOfRecordsReal"/>] ;
+ [<memberdata name="n_posoffirstdatarecord" display="n_PosOfFirstDataRecord"/>] ;
+ [<memberdata name="filetypedescription" display="fileTypeDescription"/>] ;
+ [<memberdata name="getcodepageinfo" display="getCodePageInfo"/>] ;
+ [<memberdata name="getdbfmetadata" display="getDBFmetadata"/>] ;
+ [<memberdata name="totext" display="toText"/>] ;
+ [<memberdata name="write_dbc_backlink" display="write_DBC_BackLink"/>] ;
+ [</VFPData>]
#IF .F.
LOCAL THIS AS CL_DBF_UTILS OF 'FOXBIN2PRG.PRG'
#ENDIF
l_Debug = .F.
c_Backlink_DBC_Name = ''
c_FileName = ''
n_FileSize = 0
n_HeaderSize = 0
c_LastUpdate = ''
l_FileHasCDX = .F.
l_FileIsDBC = .F.
l_FileHasMemo = .F.
n_CodePage = 0
c_CodePageDesc = ''
n_DataRecordLength = 0
n_HexFileType = 0
n_FieldCount = 0
n_NumberOfRecords = 0
n_NumberOfRecordsReal = 0
n_PosOfFirstDataRecord = 0
FIELDS = NULL
PROCEDURE INIT
THIS.FIELDS = CREATEOBJECT("COLLECTION")
ENDPROC
PROCEDURE getDBFmetadata
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_FileName (v! IN ) Nombre del DBF a analizar
* tn_HexFileType (@? OUT) Tipo de archivo en hexadecimal (Está detallado en la ayuda de Fox)
* tl_FileHasCDX (@? OUT) Indica si el archivo tiene CDX asociado
* tl_FileHasMemo (@? OUT) Indica si el archivo tiene archivo MEMO asociado
* tl_FileIsDBC (@? OUT) Indica si el archivo es un DBC (base de datos)
* tcDBC_Name (@? OUT) Si tiene DBC, contiene el nombre del DBC asociado
*---------------------------------------------------------------------------------------------------
LPARAMETERS tc_FileName, tn_HexFileType, tl_FileHasCDX, tl_FileHasMemo, tl_FileIsDBC, tcDBC_Name
TRY
LOCAL lnHandle, lcStr, lnDataPos, lnFieldCount, lnVal, I, loEx AS EXCEPTION ;
, lnCodePage, lcCodePageDesc ;
, loField AS CL_DBF_UTILS_FIELD OF 'FOXBIN2PRG.PRG'
tn_HexFileType = 0
tcDBC_Name = ''
lnHandle = FOPEN(tc_FileName,0)
IF lnHandle = -1
EXIT
ENDIF
* Bytes Description
*------------------------------------------------------ ----------- ------------------------------------------
WITH THIS AS CL_DBF_UTILS OF 'FOXBIN2PRG.PRG'
.c_FileName = tc_FileName
lcStr = FREAD(lnHandle,1) && 0 File type
tn_HexFileType = EVALUATE( TRANSFORM(ASC(lcStr),'@0') )
.n_HexFileType = tn_HexFileType
lcStr = FREAD(lnHandle,3) && 1-3 Last update (YYMMDD)
.c_LastUpdate = PADL(ASC(LEFT(lcStr,1)),2,'0') + '/' + PADL(ASC(SUBSTR(lcStr,2,1)),2,'0') + '/' + PADL(ASC(RIGHT(lcStr,1)),2,'0')
lcStr = FREAD(lnHandle,4) && 4-7 Number of records in file
.n_NumberOfRecords = CTOBIN(lcStr,"4RS")
lcStr = FREAD(lnHandle,2) && 8-9 Position of first data record
.n_PosOfFirstDataRecord = CTOBIN(lcStr,"2RS")
.n_HeaderSize = INT(.n_PosOfFirstDataRecord + 1)
IF INLIST(tn_HexFileType, 0x30, 0x31, 0x32) THEN
.n_FieldCount = INT( (.n_PosOfFirstDataRecord - 296) / 32 ) && Visual FoxPro
ELSE
.n_FieldCount = INT( (.n_PosOfFirstDataRecord - 33) / 32 )
ENDIF
lcStr = FREAD(lnHandle,2) && 10-11 Length of one data record, including delete flag
.n_DataRecordLength = CTOBIN(lcStr,"2RS")
lcStr = FREAD(lnHandle,16) && 16-27 Reserved
lcStr = FREAD(lnHandle,1) && 28 Table flags: 0x01=Has CDX, 0x02=Has Memo, 0x04=Id DBC (flags acumulativos)
.l_FileHasCDX = ( BITAND( EVALUATE(TRANSFORM(ASC(lcStr),'@0')), 0x01 ) > 0 )
.l_FileHasMemo = ( BITAND( EVALUATE(TRANSFORM(ASC(lcStr),'@0')), 0x02 ) > 0 )
.l_FileIsDBC = ( BITAND( EVALUATE(TRANSFORM(ASC(lcStr),'@0')), 0x04 ) > 0 )
lcStr = FREAD(lnHandle,1) && 29 Code page mark (0=, 2=850,3=1252)
lnVal = EVALUATE( TRANSFORM(ASC(lcStr),'@0') )
.getCodePageInfo( lnVal, @lnCodePage, @lcCodePageDesc )
.n_CodePage = lnCodePage
.c_CodePageDesc = lcCodePageDesc
lcStr = FREAD(lnHandle,2) && 30-31 Reserved, contains 0x00
*lcStr = FREAD(lnHandle,32 * lnFieldCount) && 32-n Field subrecords (los salteo)
*---
FOR I = 1 TO .n_FieldCount
loField = CREATEOBJECT("CL_DBF_UTILS_FIELD")
WITH loField AS CL_DBF_UTILS_FIELD OF 'FOXBIN2PRG.PRG'
lcStr = FREAD(lnHandle,11)
.FieldName = RTRIM( lcStr, 0, CHR(0), ' ' )
lcStr = FREAD(lnHandle,1)
.FieldType = lcStr
lcStr = FREAD(lnHandle,4)
.FieldDisplacementInRecord = CTOBIN(lcStr,"4RS")
lcStr = FREAD(lnHandle,1)
.FieldWidth = ASC(lcStr)
lcStr = FREAD(lnHandle,1)
.FieldDecimals = ASC(lcStr)
lcStr = FREAD(lnHandle,1)
.FieldFlags = ASC(lcStr)
lcStr = FREAD(lnHandle,4)
.NextValueForAutoInc = CTOBIN(lcStr,"4RS")
lcStr = FREAD(lnHandle,1)
.StepForAutoInc = ASC(lcStr)
lcStr = FREAD(lnHandle,8)
ENDWITH
.FIELDS.ADD(loField)
loField = NULL
ENDFOR
*---
lcStr = FREAD(lnHandle,1) && n+1 Header Record Terminator (0x0D)
IF INLIST(tn_HexFileType, 0x30, 0x31, 0x32) THEN
lcStr = FREAD(lnHandle,263) && n+2 to n+264 Backlink (relative path of an associated database (.dbc) file)
tcDBC_Name = RTRIM(lcStr,0,CHR(0)) && DBC Name (si tiene)
.c_Backlink_DBC_Name = tcDBC_Name
ENDIF
.n_FileSize = FSEEK(lnHandle, 0, 2)
.n_NumberOfRecordsReal = INT( (.n_FileSize - .n_HeaderSize) / .n_DataRecordLength )
ENDWITH
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
FCLOSE(lnHandle)
ENDTRY
RETURN lnHandle
ENDPROC
PROCEDURE fileTypeDescription
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tn_HexFileType (@? IN ) Tipo de archivo en hexadecimal (Está detallado en la ayuda de Fox)
*---------------------------------------------------------------------------------------------------
LPARAMETERS tn_HexFileType
LOCAL lcFileType
DO CASE
CASE tn_HexFileType = 0x02
lcFileType = 'FoxBASE / dBase II'
CASE tn_HexFileType = 0x03
lcFileType = 'FoxBASE+ / FoxPro /dBase III PLUS / dBase IV, no memo'
CASE tn_HexFileType = 0x30
lcFileType = 'Visual FoxPro'
CASE tn_HexFileType = 0x31
lcFileType = 'Visual FoxPro, autoincrement enabled'
CASE tn_HexFileType = 0x32
lcFileType = 'Visual FoxPro, Varchar, Varbinary, or Blob-enabled'
CASE tn_HexFileType = 0x43
lcFileType = 'dBASE IV SQL table files, no memo'
CASE tn_HexFileType = 0x63
lcFileType = 'dBASE IV SQL system files, no memo'
CASE tn_HexFileType = 0x83
lcFileType = 'FoxBASE+/dBASE III PLUS, with memo'
CASE tn_HexFileType = 0x8B
lcFileType = 'dBASE IV with memo'
CASE tn_HexFileType = 0xCB
lcFileType = 'dBASE IV SQL table files, with memo'
CASE tn_HexFileType = 0xF5
lcFileType = 'FoxPro 2.x (or earlier) with memo'
CASE tn_HexFileType = 0xFB
lcFileType = 'FoxBASE (?)'
OTHERWISE
lcFileType = 'Unknown'
ENDCASE
RETURN lcFileType
ENDPROC
PROCEDURE getCodePageInfo
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tnHexCodePage (v! IN ) Código de página en hexadecimal (Está detallado en la ayuda de Fox)
* tnCodePage (@? OUT) Código de página normal
* tcDescrip (@? OUT) Descripción del código de página
*---------------------------------------------------------------------------------------------------
LPARAMETERS tnHexCodePage, tnCodePage, tcDescrip
LOCAL laCodePage(27,3), lnPos
*Code page Platform Code page identifier
laCodePage( 1,1) = 437
laCodePage( 1,2) = 'U.S. MS-DOS'
laCodePage( 1,3) = 0x01
laCodePage( 2,1) = 620
laCodePage( 2,2) = 'Mazovia (Polish) MS-DOS'
laCodePage( 2,3) = 0x69
laCodePage( 3,1) = 737
laCodePage( 3,2) = 'Greek MS-DOS (437G)'
laCodePage( 3,3) = 0x6A
laCodePage( 4,1) = 850
laCodePage( 4,2) = 'International MS-DOS'
laCodePage( 4,3) = 0x02
laCodePage( 5,1) = 852
laCodePage( 5,2) = 'Eastern European MS-DOS'
laCodePage( 5,3) = 0x64
laCodePage( 6,1) = 857
laCodePage( 6,2) = 'Turkish MS-DOS'
laCodePage( 6,3) = 0x6B
laCodePage( 7,1) = 861
laCodePage( 7,2) = 'Icelandic MS-DOS'
laCodePage( 7,3) = 0x67
laCodePage( 8,1) = 865
laCodePage( 8,2) = 'Nordic MS-DOS'
laCodePage( 8,3) = 0x66
laCodePage( 9,1) = 866
laCodePage( 9,2) = 'Russian MS-DOS'
laCodePage( 9,3) = 0x65
laCodePage(10,1) = 874
laCodePage(10,2) = 'Thai Windows'
laCodePage(10,3) = 0x7C
laCodePage(12,1) = 895
laCodePage(12,2) = 'Kamenicky (Czech) MS-DOS'
laCodePage(12,3) = 0x68
laCodePage(13,1) = 932
laCodePage(13,2) = 'Japanese Windows'
laCodePage(13,3) = 0x7B
laCodePage(14,1) = 936
laCodePage(14,2) = 'Chinese Simplified (PRC, Singapore) Windows'
laCodePage(14,3) = 0x7A
laCodePage(15,1) = 949
laCodePage(15,2) = 'Korean Windows'
laCodePage(15,3) = 0x79
laCodePage(16,1) = 950
laCodePage(16,2) = 'Traditional Chinese (Hong Kong SAR, Taiwan) Windows'
laCodePage(16,3) = 0x78
laCodePage(17,1) = 1250
laCodePage(17,2) = 'Eastern European Windows'
laCodePage(17,3) = 0xC8
laCodePage(18,1) = 1251
laCodePage(18,2) = 'Russian Windows'
laCodePage(18,3) = 0xC9
laCodePage(19,1) = 1252
laCodePage(19,2) = 'Windows ANSI'
laCodePage(19,3) = 0x03
laCodePage(20,1) = 1253
laCodePage(20,2) = 'Greek Windows'
laCodePage(20,3) = 0xCB
laCodePage(21,1) = 1254
laCodePage(21,2) = 'Turkish Windows'
laCodePage(21,3) = 0xCA
laCodePage(22,1) = 1255
laCodePage(22,2) = 'Hebrew Windows'
laCodePage(22,3) = 0x7D
laCodePage(23,1) = 1256
laCodePage(23,2) = 'Arabic Windows'
laCodePage(23,3) = 0x7E
laCodePage(24,1) = 10000
laCodePage(24,2) = 'Standard Macintosh'
laCodePage(24,3) = 0x04
laCodePage(25,1) = 10006
laCodePage(25,2) = 'Greek Macintosh'
laCodePage(25,3) = 0x98
laCodePage(26,1) = 10007
laCodePage(26,2) = 'Russian Macintosh'
laCodePage(26,3) = 0x96
laCodePage(27,1) = 10029
laCodePage(27,2) = 'Macintosh EE'
laCodePage(27,3) = 0x97
lnPos = ASCAN( laCodePage, tnHexCodePage, 1, -1, 3, 8 )
IF lnPos > 0
tnCodePage = laCodePage(lnPos,1)
tcDescrip = laCodePage(lnPos,2)
ELSE
tnCodePage = 0
tcDescrip = ''
ENDIF
RETURN
ENDPROC
PROCEDURE toText
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
*---------------------------------------------------------------------------------------------------
LOCAL lcText, loField AS CL_DBF_UTILS_FIELD OF 'FOXBIN2PRG.PRG'
lcText = ''
WITH THIS AS CL_DBF_UTILS OF 'FOXBIN2PRG.PRG'
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
---------------------------------------------------
FileName : <<JUSTFNAME(.c_FileName)>>
---------------------------------------------------
Backlink_DBC_Name : <<.c_Backlink_DBC_Name>>
HexFileType : <<TRANSFORM(.n_HexFileType, '@0')>> - <<.fileTypeDescription(.n_HexFileType)>>
FileSize : <<.n_FileSize>> bytes
LastUpdate : <<.c_LastUpdate>>
NumberOfRecords : <<.n_NumberOfRecords>> - REAL: <<.n_NumberOfRecordsReal>>
PosOfFirstDataRecord : <<.n_PosOfFirstDataRecord>>
FieldCount : <<.n_FieldCount>>
DataRecordLength : <<.n_DataRecordLength>>
FileHasCDX : <<.l_FileHasCDX>>
FileHasMemo : <<.l_FileHasMemo>>
FileIsDBC : <<.l_FileIsDBC>>
CodePage : <<.n_CodePage>> - <<.c_CodePageDesc>>
---------------------------------------------------
ENDTEXT
*-- Fields
loField = THIS.FIELDS.ITEM(1)
lcText = lcText + CR_LF + loField.toText(.T.)
FOR EACH loField AS CL_DBF_UTILS_FIELD OF 'FOXBIN2PRG.PRG' IN THIS.FIELDS
lcText = lcText + CR_LF + loField.toText()
ENDFOR
TEXT TO lcText ADDITIVE TEXTMERGE NOSHOW FLAGS 1+2 PRETEXT 1+2
---------------------------------------------------
Field flags Reference:
0x01 System Column (not visible to user)
0x02 Column can store null values
0x04 Binary column (for CHAR and MEMO only)
0x06 (0x02+0x04) When a field is NULL and binary (Integer, Currency, and Character/Memo fields)
0x0C Column is autoincrementing
ENDTEXT
ENDWITH
RETURN lcText
ENDPROC
PROCEDURE write_DBC_BackLink
*---------------------------------------------------------------------------------------------------
* PARÁMETROS: (!=Obligatorio | ?=Opcional) (@=Pasar por referencia | v=Pasar por valor) (IN/OUT)
* tc_FileName (v! IN ) Nombre del DBF a analizar
* tcDBC_Name (v! IN ) Nombre del DBC a asociar
* tdLastUpdate (v! IN ) Fecha de última actualización
*---------------------------------------------------------------------------------------------------
LPARAMETERS tc_FileName, tcDBC_Name, tdLastUpdate
TRY
LOCAL lnHandle, ln_HexFileType, lcStr, lnDataPos, lnFieldCount, loEx AS EXCEPTION
IF NOT EMPTY(tcDBC_Name)
ln_HexFileType = 0
lnHandle = FOPEN(tc_FileName,2)
IF lnHandle = -1
EXIT
ENDIF
lcStr = FREAD(lnHandle,1) && File type
ln_HexFileType = EVALUATE( TRANSFORM(ASC(lcStr),'@0') )
IF EMPTY(tdLastUpdate)
lcStr = FREAD(lnHandle,3) && Last update (YYMMDD)
ELSE
lcStr = CHR( VAL( RIGHT( PADL( YEAR( tdLastUpdate ),4,'0'), 2 ) ) ) ;
+ CHR( VAL( PADL( MONTH( tdLastUpdate ),2,'0' ) ) ) ;
+ CHR( VAL( PADL( DAY( tdLastUpdate ),2,'0' ) ) ) && Last update (YYMMDD)
=FWRITE( lnHandle, PADR(lcStr,3,CHR(0)) )
ENDIF
=FREAD(lnHandle,4) && Number of records in file
lcStr = FREAD(lnHandle,2) && Position of first data record
lnDataPos = CTOBIN(lcStr,"2RS")
IF INLIST(ln_HexFileType, 0x30, 0x31, 0x32) THEN
lnFieldCount = (lnDataPos - 296) / 32
ELSE
EXIT && No DBC BackLink on older versions!
ENDIF
=FREAD(lnHandle,2) && Length of one data record, including delete flag
=FREAD(lnHandle,16) && Reserved
=FREAD(lnHandle,1) && Table flags: 0x01=Has CDX, 0x02=Has Memo, 0x04=Id DBC (flags acumulativos)
=FREAD(lnHandle,1) && Code page mark
=FREAD(lnHandle,2) && Reserved, contains 0x00
=FREAD(lnHandle,32 * lnFieldCount) && Field subrecords (los salteo)
=FREAD(lnHandle,1) && Header Record Terminator (0x0D)
IF INLIST(ln_HexFileType, 0x30, 0x31, 0x32) THEN
IF FWRITE( lnHandle, PADR(tcDBC_Name,263,CHR(0)) ) = 0
*-- No se pudo actualizar el backlink [] de la tabla []
ERROR C_BACKLINK_CANT_UPDATE_BL_LOC + ' [' + tcDBC_Name + '] ' + C_BACKLINK_OF_TABLE_LOC + ' [' + tc_FileName + ']'
ENDIF
ENDIF
ENDIF
CATCH TO loEx
IF THIS.l_Debug AND _VFP.STARTMODE = 0
SET STEP ON
ENDIF
THROW
FINALLY
FCLOSE(lnHandle)
ENDTRY
RETURN lnHandle
ENDPROC
ENDDEFINE
DEFINE CLASS CL_DBF_UTILS_FIELD AS CUSTOM
_MEMBERDATA = [<VFPData>] ;
+ [<memberdata name="fieldname" display="FieldName"/>] ;
+ [<memberdata name="fieldtype" display="FieldType"/>] ;
+ [<memberdata name="fieldwidth" display="FieldWidth"/>] ;
+ [<memberdata name="fielddecimals" display="FieldDecimals"/>] ;
+ [<memberdata name="fieldflags" display="FieldFlags"/>] ;
+ [<memberdata name="fielddisplacementinrecord" display="FieldDisplacementInRecord"/>] ;
+ [<memberdata name="allownulls" display="AllowNulls"/>] ;
+ [<memberdata name="nocodepagetranslation" display="NoCodePageTranslation"/>] ;
+ [<memberdata name="fieldvalidationexpression" display="FieldValidationExpression"/>] ;
+ [<memberdata name="fieldvalidationtext" display="FieldValidationText"/>] ;
+ [<memberdata name="fielddefaultvalue" display="FieldDefaultValue"/>] ;
+ [<memberdata name="tablevalidationexpression" display="TableValidationExpression"/>] ;
+ [<memberdata name="longtablename" display="LongTableName"/>] ;
+ [<memberdata name="tablevalidationtext" display="TableValidationText"/>] ;
+ [<memberdata name="inserttriggerexpression" display="InsertTriggerExpression"/>] ;
+ [<memberdata name="updatetriggerexpression" display="UpdateTriggerExpression"/>] ;
+ [<memberdata name="deletetriggerexpression" display="DeleteTriggerExpression"/>] ;
+ [<memberdata name="tablecomment" display="TableComment"/>] ;
+ [<memberdata name="nextvalueforautoinc" display="NextValueForAutoInc"/>] ;
+ [<memberdata name="stepforautoinc" display="StepForAutoInc"/>] ;
+ [<memberdata name="totext" display="toText"/>] ;
+ [</VFPData>]
#IF .F.
LOCAL THIS AS CL_DBF_UTILS_FIELD OF 'FOXBIN2PRG.PRG'
#ENDIF
FieldName = ''
FieldType = ''
FieldWidth = 0
FieldDecimals = 0
FieldFlags = 0
FieldDisplacementInRecord = 0
AllowNulls = .F.
NoCodePageTranslation = .F.
FieldValidationExpression = ''
FieldValidationText = ''
FieldDefaultValue = ''
TableValidationExpression = ''
TableValidationText = ''
LongTableName = ''
InsertTriggerExpression = ''
UpdateTriggerExpression = ''
DeleteTriggerExpression = ''
TableComment = ''
NextValueForAutoInc = 0
StepForAutoInc = ''
PROCEDURE toText
LPARAMETERS tlHeader
LOCAL lcText
lcText = ''
IF tlHeader
lcText = lcText + PADR('FieldName',10) + ' ' + PADR('Type',4) + ' ' + PADR('Len',3) + ' ' ;
+ PADR('Dec',3) + ' ' + PADR('Flg',3) + ' ' + PADL('FDiR',4)
lcText = lcText + CR_LF + REPLICATE('-',10) + ' ' + REPLICATE('-',4) + ' ' + REPLICATE('-',3) + ' ' ;
+ REPLICATE('-',3) + ' ' + REPLICATE('-',3) + ' ' + REPLICATE('-',4)
ELSE
WITH THIS AS CL_DBF_UTILS_FIELD OF 'FOXBIN2PRG.PRG'
lcText = lcText + PADR(.FieldName,10) + ' ' + PADC(.FieldType,4) + ' ' + PADL(.FieldWidth,3) + ' ' ;
+ PADL(.FieldDecimals,3) + ' ' + PADC(.FieldFlags,3) + ' ' + PADL(.FieldDisplacementInRecord,4)
ENDWITH
ENDIF
RETURN lcText
ENDPROC
ENDDEFINE
Reference in New Issue View Git Blame Copy Permalink